diff --git a/Makefile b/Makefile index 4d1086f..8d3f95d 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ .PHONY: build test run docs build: - stack build + stack build mig-postgresql-simple test: stack test diff --git a/examples/mig-example-apps/JsonApi/Init.hs b/examples/mig-example-apps/JsonApi/Init.hs index e473f6c..15533c7 100644 --- a/examples/mig-example-apps/JsonApi/Init.hs +++ b/examples/mig-example-apps/JsonApi/Init.hs @@ -4,8 +4,6 @@ module Init ( ) where import Control.Monad -import Data.Aeson ((.=)) -import Data.Aeson qualified as Json import Data.IORef import Data.List qualified as List import Data.Map.Strict qualified as Map @@ -13,8 +11,7 @@ import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as Text import Data.Time -import Data.Yaml qualified as Yaml -import System.Log.FastLogger +import Mig.Tool.Log.Fast qualified as Log import System.Random import Interface @@ -38,18 +35,15 @@ initEnv port = do initProc :: Int -> IO Proc initProc port = do - (writeLog, closeLogger) <- newFastLogger (LogStdout defaultBufSize) - let logger = initLogger writeLog - - logMessage :: Text -> IO () - logMessage msg = logger.info $ Json.toJSON msg + logger <- Log.newLoggerStdout Log.LogYaml + let Log.LogFuns{..} = Log.logFuns logger pure $ Proc { logger = logger - , startup = logMessage $ ("App starts on port: " <> Text.pack (show port)) + , startup = logInfo @Text $ ("App starts on port: " <> Text.pack (show port)) , cleanup = do - logMessage "App shutdown" - closeLogger + logInfo @Text "App shutdown" + logger.close.run } initAuth :: St -> Auth @@ -82,30 +76,6 @@ toDaySpan day (DayInterval count) = List.unfoldr go (day, count) | n <= 0 = Nothing | otherwise = Just (succ d, (succ d, n - 1)) -initLogger :: (LogStr -> IO ()) -> Logger -initLogger writeLog = - Logger - { error = logBy "ERROR" - , info = logBy "INFO" - , debug = logBy "DEBUG" - } - where - logBy :: Text -> LogFun - logBy level msg = do - now <- getCurrentTime - writeLog $ - toLogStr $ - (<> "\n") $ - Yaml.encode $ - Json.object - [ "log" - .= Json.object - [ "message" .= msg - , "level" .= level - , "time" .= now - ] - ] - initStateConfig :: IO InitSt initStateConfig = do now <- (.utctDay) <$> getCurrentTime diff --git a/examples/mig-example-apps/JsonApi/Interface.hs b/examples/mig-example-apps/JsonApi/Interface.hs index e3ad8dc..0a19eb9 100644 --- a/examples/mig-example-apps/JsonApi/Interface.hs +++ b/examples/mig-example-apps/JsonApi/Interface.hs @@ -1,18 +1,18 @@ module Interface ( Env (..), - LogFun, Proc (..), - Logger (..), - logInfo, - logDebug, - logError, Auth (..), Weather (..), + getLogger, + module X, ) where -import Data.Aeson (ToJSON (..), Value) +import Mig.Tool.Log as X (Log, LogFuns (..), LogNamespace, addLogNamespace, logFuns) import Types +getLogger :: Env -> LogNamespace -> LogFuns +getLogger env ns = logFuns (addLogNamespace ns env.proc.logger) + -- | Site's environment. It contains all interfaces data Env = Env { weather :: Weather @@ -24,25 +24,7 @@ data Env = Env data Proc = Proc { startup :: IO () , cleanup :: IO () - , logger :: Logger - } - -type LogFun = Value -> IO () - -logInfo :: (ToJSON a) => Env -> a -> IO () -logInfo env = env.proc.logger.info . toJSON - -logDebug :: (ToJSON a) => Env -> a -> IO () -logDebug env = env.proc.logger.debug . toJSON - -logError :: (ToJSON a) => Env -> a -> IO () -logError env = env.proc.logger.error . toJSON - --- logger interface -data Logger = Logger - { info :: LogFun - , debug :: LogFun - , error :: LogFun + , logger :: Log } -- authorization interface diff --git a/examples/mig-example-apps/JsonApi/Server.hs b/examples/mig-example-apps/JsonApi/Server.hs index 5ba2ad9..50ddff2 100644 --- a/examples/mig-example-apps/JsonApi/Server.hs +++ b/examples/mig-example-apps/JsonApi/Server.hs @@ -32,7 +32,9 @@ server env = , "update" /. updateWeather env ] - withTrace = applyPlugin (Trace.logHttpBy (logInfo env) Trace.V2) + withTrace = applyPlugin (Trace.logHttpBy logInfo Trace.V2) + + LogFuns{..} = getLogger env "http" ------------------------------------------------------------------------------------- -- application handlers @@ -44,26 +46,30 @@ getWeather :: Capture "day-interval" DayInterval -> Get (RespOr Text (Timed WeatherData)) getWeather env (Capture location) (Capture fromDay) (Capture interval) = Send $ do - logInfo @Text env "get the weather forecast" + logInfo @Text "get the weather forecast" mResult <- env.weather.get location fromDay interval pure $ case mResult of Just result -> ok result Nothing -> bad status400 "No data" + where + LogFuns{..} = getLogger env "getWeather" updateWeather :: Env -> Body UpdateData -> Post (RespOr Text ()) updateWeather env (Body updateData) = Send $ do - logInfo @Text env "update the weather data" + logInfo @Text "update the weather data" ok <$> env.weather.update updateData + where + LogFuns{..} = getLogger env "updateWeather" ------------------------------------------------------------------------------------- -- authorization requestAuthToken :: Env -> Body User -> Post (RespOr Text AuthToken) requestAuthToken env (Body user) = Send $ do - logInfo env ("get new auth token for: " <> user.name) + logInfo ("get new auth token for: " <> user.name) isValid <- env.auth.validUser user if isValid then do @@ -71,9 +77,11 @@ requestAuthToken env (Body user) = Send $ do void $ forkIO $ setExpireTimer token pure $ ok token else do - logError env $ Text.unwords ["User", user.name, "does not have access to the service"] + logError $ Text.unwords ["User", user.name, "does not have access to the service"] pure $ bad unauthorized401 "User is not valid" where + LogFuns{..} = getLogger env "requestAuthToken" + setExpireTimer :: AuthToken -> IO () setExpireTimer token = do threadDelay (1_000_000 * 60 * 10) -- 10 minutes @@ -85,7 +93,8 @@ withAuth env (Header token) = processResponse $ \getResp -> do if isOk then getResp else do - logError env errMessage + logError errMessage pure $ Just (bad status500 $ Text.encodeUtf8 errMessage) where errMessage = "Token is invalid" + LogFuns{..} = getLogger env "auth" diff --git a/examples/mig-example-apps/mig-example-apps.cabal b/examples/mig-example-apps/mig-example-apps.cabal index 12b3dac..44a19a9 100644 --- a/examples/mig-example-apps/mig-example-apps.cabal +++ b/examples/mig-example-apps/mig-example-apps.cabal @@ -306,13 +306,14 @@ executable json-api-mig-example-app , bytestring , containers , derive-topdown - , fast-logger , http-types , mig , mig-client , mig-extra + , mig-fast-logger , mig-server , mig-swagger-ui + , mig-tools , openapi3 , pretty-simple , random diff --git a/examples/mig-example-apps/package.yaml b/examples/mig-example-apps/package.yaml index c8cfaf3..7d984f2 100644 --- a/examples/mig-example-apps/package.yaml +++ b/examples/mig-example-apps/package.yaml @@ -119,7 +119,8 @@ executables: - -with-rtsopts=-N dependencies: - containers - - fast-logger + - mig-tools + - mig-fast-logger - yaml counter-mig-example-app: diff --git a/examples/mig-example-apps/stack.yaml b/examples/mig-example-apps/stack.yaml index 9f0d5c5..fe304c8 100644 --- a/examples/mig-example-apps/stack.yaml +++ b/examples/mig-example-apps/stack.yaml @@ -11,3 +11,5 @@ extra-deps: - ../../mig-swagger-ui - ../../mig-wai - ../../mig-extra + - ../../mig-tools + - ../../tools/mig-fast-logger diff --git a/mig-tools/.gitignore b/mig-tools/.gitignore new file mode 100644 index 0000000..c368d45 --- /dev/null +++ b/mig-tools/.gitignore @@ -0,0 +1,2 @@ +.stack-work/ +*~ \ No newline at end of file diff --git a/mig-tools/LICENSE b/mig-tools/LICENSE new file mode 100644 index 0000000..c5b6c16 --- /dev/null +++ b/mig-tools/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2023 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/mig-tools/README.md b/mig-tools/README.md new file mode 100644 index 0000000..bd5a2ac --- /dev/null +++ b/mig-tools/README.md @@ -0,0 +1 @@ +# mig-tools diff --git a/mig-tools/Setup.hs b/mig-tools/Setup.hs new file mode 100644 index 0000000..e8ef27d --- /dev/null +++ b/mig-tools/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/mig-tools/mig-tools.cabal b/mig-tools/mig-tools.cabal new file mode 100644 index 0000000..bd37611 --- /dev/null +++ b/mig-tools/mig-tools.cabal @@ -0,0 +1,82 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.35.2. +-- +-- see: https://github.com/sol/hpack + +name: mig-tools +version: 0.1.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/githubuser/mig-tools#readme +bug-reports: https://github.com/githubuser/mig-tools/issues +author: Author name here +maintainer: example@example.com +copyright: 2023 Author name here +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/githubuser/mig-tools + +library + exposed-modules: + Mig.Tool.Base + Mig.Tool.Db + Mig.Tool.Log + other-modules: + Paths_mig_tools + autogen-modules: + Paths_mig_tools + hs-source-dirs: + src + default-extensions: + OverloadedStrings + OverloadedRecordDot + DuplicateRecordFields + LambdaCase + DerivingStrategies + StrictData + AllowAmbiguousTypes + DeriveAnyClass + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + aeson + , base >=4.7 && <5 + , bytestring + , mtl + , text + , time + default-language: GHC2021 + +test-suite mig-tools-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_mig_tools + autogen-modules: + Paths_mig_tools + hs-source-dirs: + test + default-extensions: + OverloadedStrings + OverloadedRecordDot + DuplicateRecordFields + LambdaCase + DerivingStrategies + StrictData + AllowAmbiguousTypes + DeriveAnyClass + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base >=4.7 && <5 + , bytestring + , mig-tools + , mtl + , text + , time + default-language: GHC2021 diff --git a/mig-tools/package.yaml b/mig-tools/package.yaml new file mode 100644 index 0000000..6ddf29a --- /dev/null +++ b/mig-tools/package.yaml @@ -0,0 +1,64 @@ +name: mig-tools +version: 0.1.0.0 +github: "githubuser/mig-tools" +license: BSD-3-Clause +author: "Author name here" +maintainer: "example@example.com" +copyright: "2023 Author name here" + +extra-source-files: +- README.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +language: GHC2021 + +default-extensions: + - OverloadedStrings + - OverloadedRecordDot + - DuplicateRecordFields + - LambdaCase + - DerivingStrategies + - StrictData + - AllowAmbiguousTypes + - DeriveAnyClass + +dependencies: +- base >= 4.7 && < 5 +- aeson +- text +- mtl +- bytestring +- time + +ghc-options: +- -Wall +- -Wcompat +- -Widentities +- -Wincomplete-record-updates +- -Wincomplete-uni-patterns +- -Wmissing-export-lists +- -Wmissing-home-modules +- -Wpartial-fields +- -Wredundant-constraints + +library: + source-dirs: src + +tests: + mig-tools-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - mig-tools diff --git a/mig-tools/src/Mig/Tool/Base.hs b/mig-tools/src/Mig/Tool/Base.hs new file mode 100644 index 0000000..87b64f2 --- /dev/null +++ b/mig-tools/src/Mig/Tool/Base.hs @@ -0,0 +1,110 @@ +-- | Basic interfaces +module Mig.Tool.Base ( + Query (..), + queryToSet, + queryToGet, + QueryOr (..), + Get (..), + Set (..), + filterSet, + GetOr (..), + Proc (..), + React (..), + filterReact, + module X, +) where + +import Control.Monad +import Control.Monad.IO.Class +import Data.Functor.Contravariant as X + +newtype Query a b = Query + { query :: a -> IO b + } + +queryToSet :: Query a b -> Set a +queryToSet (Query f) = Set (void . f) + +queryToGet :: a -> Query a b -> Get b +queryToGet val (Query f) = Get (f val) + +newtype QueryOr a err b = QueryOr + { query :: a -> IO (Either err b) + } + +newtype Set a = Set + { set :: a -> IO () + } + +filterSet :: (a -> Bool) -> Set a -> Set a +filterSet f (Set g) = Set $ \a -> when (f a) (g a) + +instance Contravariant Set where + contramap f (Set a) = Set (a . f) + +instance Semigroup (Set a) where + (<>) (Set a) (Set b) = Set $ \x -> a x >> b x + +instance Monoid (Set a) where + mempty = Set $ const (pure ()) + +newtype Get a = Get + { get :: IO a + } + deriving newtype (Functor, Applicative, Monad, MonadIO) + +newtype GetOr err a = GetOr + { get :: IO (Either err a) + } + deriving (Functor) + +instance Applicative (GetOr err) where + pure = GetOr . pure . pure + (<*>) (GetOr fa) (GetOr fb) = GetOr ((<*>) <$> fa <*> fb) + +instance Monad (GetOr err) where + (GetOr ma) >>= mf = GetOr $ do + a <- ma + case a of + Right res -> do + let GetOr mb = mf res + mb + Left err -> pure (Left err) + +newtype Proc = Proc + { run :: IO () + } + +instance Semigroup Proc where + (<>) (Proc a) (Proc b) = Proc (a >> b) + +instance Monoid Proc where + mempty = Proc (pure ()) + +{-| Process that runs forked background process which accepts a callback. +It returns a procedure to close the process. +-} +newtype React a = React + {react :: Set a -> IO Proc} + +instance Functor React where + fmap f (React a) = React (a . contramap f) + +filterReact :: (a -> Bool) -> React a -> React a +filterReact f (React a) = React (a . filterSet f) + +{- todo +accumReact :: (b -> a -> b) -> b -> React a -> React b +accumReact go initVal (React x) = React $ \call -> do + ref <- newIORef initVal + call +-} + +instance Semigroup (React a) where + (<>) (React a) (React b) = React $ \f -> do + finA <- a f + finB <- b f + pure (finA <> finB) + +instance Monoid (React a) where + mempty = React (const $ pure mempty) diff --git a/mig-tools/src/Mig/Tool/Db.hs b/mig-tools/src/Mig/Tool/Db.hs new file mode 100644 index 0000000..0bcc18f --- /dev/null +++ b/mig-tools/src/Mig/Tool/Db.hs @@ -0,0 +1,44 @@ +module Mig.Tool.Db ( + Db (..), + -- Sql (..), + -- SqlResult (..), + -- SqlRow, + -- logDb, +) where + +-- import Data.Aeson (ToJSON (..)) +-- import Data.ByteString (ByteString) +-- import Data.Text qualified as Text +-- import Data.Text.Encoding qualified as Text +import Mig.Tool.Base + +-- import Mig.Tool.Log + +data Db conn = Db + { run :: forall a. (conn -> IO a) -> IO a + , close :: Proc + } + +{- +-- | Adds logging to all DB functions +logDb :: Log -> Db -> Db +logDb logger db = + Db + { query = logQuerySet logger "sqlQuery" db.query + , close = logProc logger "dbClose" db.close + } + +newtype Sql = Sql ByteString + +instance ToJSON Sql where + toJSON (Sql expr) = + case Text.decodeUtf8' expr of + Right res -> toJSON res + Left err -> toJSON (Text.unwords ["Failed to deocde SQL as text:", Text.pack (show err)]) + +newtype SqlResult = SqlResult + { result :: Maybe [SqlRow] + } + +type SqlRow = [ByteString] +-} diff --git a/mig-tools/src/Mig/Tool/Log.hs b/mig-tools/src/Mig/Tool/Log.hs new file mode 100644 index 0000000..13968df --- /dev/null +++ b/mig-tools/src/Mig/Tool/Log.hs @@ -0,0 +1,171 @@ +-- | Logger interface +module Mig.Tool.Log ( + Log (..), + LogLevel (..), + LogNamespace (..), + LogItem (..), + addLogNamespace, + setLogLevel, + trackLogTime, + + -- * functions + LogFuns (..), + logFuns, + logByLevel, + + -- * augment interfaces with logger + logQuery, + logSet, + logGet, + logQuerySet, + logQueryGet, + logProc, +) where + +import Control.Monad +import Data.Aeson (ToJSON) +import Data.Aeson qualified as Json +import Data.Aeson.Types qualified as Json +import Data.String +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Time +import Mig.Tool.Base + +data LogLevel = LogDebug | LogInfo | LogWarn | LogError + deriving (Show, Eq, Ord) + +instance Json.ToJSON LogLevel where + toJSON = \case + LogDebug -> Json.toJSON @Text "debug" + LogInfo -> Json.toJSON @Text "info" + LogWarn -> Json.toJSON @Text "warn" + LogError -> Json.toJSON @Text "error" + +newtype LogNamespace = LogNamespace [Text] + deriving newtype (Semigroup, Monoid, Show, Eq, Json.ToJSON) + +instance IsString LogNamespace where + fromString = LogNamespace . Text.splitOn "." . fromString + +data LogItem = LogItem + { level :: LogLevel + , time :: Maybe UTCTime + , namespace :: LogNamespace + , message :: Json.Value + } + deriving (Show, Eq) + +instance Json.ToJSON LogItem where + toJSON item = + Json.object + [ "log" + Json..= ( Json.object $ + maybe id addTime item.time $ + [ "level" Json..= item.level + , "namespace" Json..= item.namespace + , "message" Json..= item.message + ] + ) + ] + where + addTime :: UTCTime -> [Json.Pair] -> [Json.Pair] + addTime t fields = ("time" Json..= t) : fields + +data Log = Log + { log :: Set LogItem + , close :: Proc + } + +addLogNamespace :: LogNamespace -> Log -> Log +addLogNamespace namespace = mapLogItem (addLogNamespaceItem namespace) + +setLogLevel :: LogLevel -> Log -> Log +setLogLevel level = mapLogItem (setLogLevelItem level) + +trackLogTime :: Log -> Log +trackLogTime = mapLogItemIO setLogTimeItem + +silentLogLevel :: LogLevel -> Log -> Log +silentLogLevel noLevel logger = logger{log = filterSet ((/= noLevel) . (.level)) logger.log} + +------------------------------------------------------------------------------------- +-- log functions + +logByLevel :: (Json.ToJSON a) => LogLevel -> Log -> a -> IO () +logByLevel level logger message = do + now <- getCurrentTime + logger.log.set $ + LogItem + { level + , time = Just now + , namespace = LogNamespace [] + , message = Json.toJSON message + } + +data LogFuns = LogFuns + { logInfo :: forall a. (ToJSON a) => a -> IO () + , logDebug :: forall a. (ToJSON a) => a -> IO () + , logWarn :: forall a. (ToJSON a) => a -> IO () + , logError :: forall a. (ToJSON a) => a -> IO () + } + +logFuns :: Log -> LogFuns +logFuns log = + LogFuns + { logInfo = logByLevel LogInfo log + , logDebug = logByLevel LogDebug log + , logWarn = logByLevel LogWarn log + , logError = logByLevel LogError log + } + +------------------------------------------------------------------------------------- +-- add logger to interface + +logSet :: (Json.ToJSON a) => Log -> Text -> Set a -> Set a +logSet env name (Set act) = Set $ \a -> do + logByLevel LogInfo env $ + Json.object + [ "call" Json..= name + , "argument" Json..= a + ] + act a + +logGet :: (Json.ToJSON a) => Log -> Text -> Get a -> Get a +logGet = undefined + +logQuery :: (Json.ToJSON a, Json.ToJSON b) => Log -> Text -> Query a b -> Query a b +logQuery = undefined + +logQuerySet :: (Json.ToJSON a) => Log -> Text -> Query a b -> Query a b +logQuerySet = undefined + +logQueryGet :: (Json.ToJSON b) => Log -> Text -> Query a b -> Query a b +logQueryGet = undefined + +logProc :: Log -> Text -> Proc -> Proc +logProc = undefined + +------------------------------------------------------------------------------------- +-- item transformations + +mapLogItem :: (LogItem -> LogItem) -> Log -> Log +mapLogItem f logger = + logger{log = contramap f logger.log} + +mapLogItemIO :: (LogItem -> IO LogItem) -> Log -> Log +mapLogItemIO f logger = + logger{log = updateSet logger.log} + where + updateSet (Set s) = (Set (s <=< f)) + +addLogNamespaceItem :: LogNamespace -> LogItem -> LogItem +addLogNamespaceItem ns item = item{namespace = mappend ns item.namespace} + +setLogLevelItem :: LogLevel -> LogItem -> LogItem +setLogLevelItem level item = item{level} + +setLogTimeItem :: LogItem -> IO LogItem +setLogTimeItem item = case item.time of + Nothing -> (\now -> item{time = Just now}) <$> getCurrentTime + Just _ -> pure item diff --git a/mig-tools/test/Spec.hs b/mig-tools/test/Spec.hs new file mode 100644 index 0000000..cd4753f --- /dev/null +++ b/mig-tools/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented" diff --git a/stack.yaml b/stack.yaml index 7cc2e41..27ff92b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -10,3 +10,6 @@ packages: - mig-swagger-ui - mig-wai - mig-rio +- mig-tools +- tools/mig-fast-logger +- tools/mig-postgresql-simple diff --git a/tools/mig-fast-logger/.gitignore b/tools/mig-fast-logger/.gitignore new file mode 100644 index 0000000..c368d45 --- /dev/null +++ b/tools/mig-fast-logger/.gitignore @@ -0,0 +1,2 @@ +.stack-work/ +*~ \ No newline at end of file diff --git a/tools/mig-fast-logger/CHANGELOG.md b/tools/mig-fast-logger/CHANGELOG.md new file mode 100644 index 0000000..8210700 --- /dev/null +++ b/tools/mig-fast-logger/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `mig-fast-logger` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - YYYY-MM-DD diff --git a/tools/mig-fast-logger/LICENSE b/tools/mig-fast-logger/LICENSE new file mode 100644 index 0000000..c5b6c16 --- /dev/null +++ b/tools/mig-fast-logger/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2023 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/tools/mig-fast-logger/README.md b/tools/mig-fast-logger/README.md new file mode 100644 index 0000000..b582a48 --- /dev/null +++ b/tools/mig-fast-logger/README.md @@ -0,0 +1 @@ +# mig-fast-logger diff --git a/tools/mig-fast-logger/Setup.hs b/tools/mig-fast-logger/Setup.hs new file mode 100644 index 0000000..e8ef27d --- /dev/null +++ b/tools/mig-fast-logger/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/tools/mig-fast-logger/mig-fast-logger.cabal b/tools/mig-fast-logger/mig-fast-logger.cabal new file mode 100644 index 0000000..4d11f89 --- /dev/null +++ b/tools/mig-fast-logger/mig-fast-logger.cabal @@ -0,0 +1,50 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.35.2. +-- +-- see: https://github.com/sol/hpack + +name: mig-fast-logger +version: 0.1.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/githubuser/mig-fast-logger#readme +bug-reports: https://github.com/githubuser/mig-fast-logger/issues +author: Author name here +maintainer: example@example.com +copyright: 2023 Author name here +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/githubuser/mig-fast-logger + +library + exposed-modules: + Mig.Tool.Log.Fast + other-modules: + Paths_mig_fast_logger + autogen-modules: + Paths_mig_fast_logger + hs-source-dirs: + src + default-extensions: + OverloadedStrings + OverloadedRecordDot + DuplicateRecordFields + LambdaCase + DerivingStrategies + StrictData + AllowAmbiguousTypes + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + aeson + , base >=4.7 && <5 + , bytestring + , fast-logger + , mig-tools + , yaml + default-language: GHC2021 diff --git a/tools/mig-fast-logger/package.yaml b/tools/mig-fast-logger/package.yaml new file mode 100644 index 0000000..58aa3cc --- /dev/null +++ b/tools/mig-fast-logger/package.yaml @@ -0,0 +1,52 @@ +name: mig-fast-logger +version: 0.1.0.0 +github: "githubuser/mig-fast-logger" +license: BSD-3-Clause +author: "Author name here" +maintainer: "example@example.com" +copyright: "2023 Author name here" + +extra-source-files: +- README.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +language: GHC2021 + +default-extensions: + - OverloadedStrings + - OverloadedRecordDot + - DuplicateRecordFields + - LambdaCase + - DerivingStrategies + - StrictData + - AllowAmbiguousTypes + +dependencies: +- base >= 4.7 && < 5 +- fast-logger +- mig-tools +- aeson +- yaml +- bytestring + +ghc-options: +- -Wall +- -Wcompat +- -Widentities +- -Wincomplete-record-updates +- -Wincomplete-uni-patterns +- -Wmissing-export-lists +- -Wmissing-home-modules +- -Wpartial-fields +- -Wredundant-constraints + +library: + source-dirs: src diff --git a/tools/mig-fast-logger/src/Mig/Tool/Log/Fast.hs b/tools/mig-fast-logger/src/Mig/Tool/Log/Fast.hs new file mode 100644 index 0000000..1c803bf --- /dev/null +++ b/tools/mig-fast-logger/src/Mig/Tool/Log/Fast.hs @@ -0,0 +1,37 @@ +-- | Init fast-logger +module Mig.Tool.Log.Fast ( + LogCodec (..), + newLogger, + newLoggerStdout, + module X, +) where + +import Data.Aeson qualified as Json +import Data.ByteString.Lazy (ByteString, fromStrict) +import Data.Yaml qualified as Yaml +import Mig.Tool.Base as X +import Mig.Tool.Log as X +import System.Log.FastLogger qualified as FastLogger + +data LogCodec = LogJson | LogYaml + +newLogger :: LogCodec -> FastLogger.LogType -> IO Log +newLogger codec config = do + (writeLog, closeLogger) <- FastLogger.newFastLogger config + pure $ + trackLogTime $ + Log + { log = Set (writeLog . toLogStr) + , close = Proc closeLogger + } + where + toLogStr :: LogItem -> FastLogger.LogStr + toLogStr = FastLogger.toLogStr . toByteString + + toByteString :: LogItem -> ByteString + toByteString = case codec of + LogJson -> Json.encode + LogYaml -> fromStrict . Yaml.encode + +newLoggerStdout :: LogCodec -> IO Log +newLoggerStdout codec = newLogger codec (FastLogger.LogStdout FastLogger.defaultBufSize) diff --git a/tools/mig-postgresql-simple/.gitignore b/tools/mig-postgresql-simple/.gitignore new file mode 100644 index 0000000..c368d45 --- /dev/null +++ b/tools/mig-postgresql-simple/.gitignore @@ -0,0 +1,2 @@ +.stack-work/ +*~ \ No newline at end of file diff --git a/tools/mig-postgresql-simple/CHANGELOG.md b/tools/mig-postgresql-simple/CHANGELOG.md new file mode 100644 index 0000000..8599780 --- /dev/null +++ b/tools/mig-postgresql-simple/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `mig-postgresql-simple` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - YYYY-MM-DD diff --git a/tools/mig-postgresql-simple/LICENSE b/tools/mig-postgresql-simple/LICENSE new file mode 100644 index 0000000..c5b6c16 --- /dev/null +++ b/tools/mig-postgresql-simple/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2023 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/tools/mig-postgresql-simple/README.md b/tools/mig-postgresql-simple/README.md new file mode 100644 index 0000000..55be150 --- /dev/null +++ b/tools/mig-postgresql-simple/README.md @@ -0,0 +1 @@ +# mig-postgresql-simple diff --git a/tools/mig-postgresql-simple/Setup.hs b/tools/mig-postgresql-simple/Setup.hs new file mode 100644 index 0000000..e8ef27d --- /dev/null +++ b/tools/mig-postgresql-simple/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/tools/mig-postgresql-simple/mig-postgresql-simple.cabal b/tools/mig-postgresql-simple/mig-postgresql-simple.cabal new file mode 100644 index 0000000..a1bc3ea --- /dev/null +++ b/tools/mig-postgresql-simple/mig-postgresql-simple.cabal @@ -0,0 +1,52 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.35.2. +-- +-- see: https://github.com/sol/hpack + +name: mig-postgresql-simple +version: 0.1.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/githubuser/mig-postgresql-simple#readme +bug-reports: https://github.com/githubuser/mig-postgresql-simple/issues +author: Author name here +maintainer: example@example.com +copyright: 2023 Author name here +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/githubuser/mig-postgresql-simple + +library + exposed-modules: + Mig.Tool.Db.PostgreSQL.Simple + other-modules: + Paths_mig_postgresql_simple + autogen-modules: + Paths_mig_postgresql_simple + hs-source-dirs: + src + default-extensions: + OverloadedStrings + OverloadedRecordDot + DuplicateRecordFields + LambdaCase + DerivingStrategies + StrictData + AllowAmbiguousTypes + RecordWildCards + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + aeson + , base >=4.7 && <5 + , bytestring + , mig-tools + , postgresql-simple + , text + default-language: GHC2021 diff --git a/tools/mig-postgresql-simple/package.yaml b/tools/mig-postgresql-simple/package.yaml new file mode 100644 index 0000000..d6d7c2b --- /dev/null +++ b/tools/mig-postgresql-simple/package.yaml @@ -0,0 +1,54 @@ +name: mig-postgresql-simple +version: 0.1.0.0 +github: "githubuser/mig-postgresql-simple" +license: BSD-3-Clause +author: "Author name here" +maintainer: "example@example.com" +copyright: "2023 Author name here" + +extra-source-files: +- README.md +- CHANGELOG.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +language: GHC2021 + +default-extensions: + - OverloadedStrings + - OverloadedRecordDot + - DuplicateRecordFields + - LambdaCase + - DerivingStrategies + - StrictData + - AllowAmbiguousTypes + - RecordWildCards + +dependencies: +- base >= 4.7 && < 5 +- postgresql-simple +- mig-tools +- bytestring +- aeson +- text + +ghc-options: +- -Wall +- -Wcompat +- -Widentities +- -Wincomplete-record-updates +- -Wincomplete-uni-patterns +- -Wmissing-export-lists +- -Wmissing-home-modules +- -Wpartial-fields +- -Wredundant-constraints + +library: + source-dirs: src diff --git a/tools/mig-postgresql-simple/src/Mig/Tool/Db/PostgreSQL/Simple.hs b/tools/mig-postgresql-simple/src/Mig/Tool/Db/PostgreSQL/Simple.hs new file mode 100644 index 0000000..1c483d0 --- /dev/null +++ b/tools/mig-postgresql-simple/src/Mig/Tool/Db/PostgreSQL/Simple.hs @@ -0,0 +1,156 @@ +module Mig.Tool.Db.PostgreSQL.Simple ( + DbConnection (..), + Db (..), + newDbConnection, + newDbConnectionPool, + toDb, + logDb, + timedLogDb, + module X, +) where + +import Data.Aeson qualified as Json +import Data.ByteString (ByteString) +import Data.Int as X (Int64) +import Data.Text (Text) +import Data.Text.Encoding qualified as Text +import Database.PostgreSQL.Simple as X (FromRow, In (..), Only (..), Query, ToRow) +import Database.PostgreSQL.Simple qualified as PostgreSQL +import Database.PostgreSQL.Simple.FromField as X (FromField (..)) +import Database.PostgreSQL.Simple.ToField as X (ToField (..)) +import Mig.Tool.Base hiding (Query) +import Mig.Tool.Log + +data DbConnection = DbConnection + { run :: forall a. (PostgreSQL.Connection -> IO a) -> IO a + , close :: Proc + } + +data Db = Db + { query :: forall q r. (ToRow q, FromRow r) => Query -> q -> IO [r] + , query_ :: forall r. (FromRow r) => Query -> IO [r] + , execute :: forall q. (ToRow q) => Query -> q -> IO Int64 + , execute_ :: Query -> IO Int64 + , executeMany :: forall q. (ToRow q) => Query -> [q] -> IO Int64 + , withTransaction :: forall a. IO a -> IO a + , formatMany :: forall q. (ToRow q) => Query -> [q] -> IO ByteString + , formatQuery :: forall q. (ToRow q) => Query -> q -> IO ByteString + } + +-- | Logs with SQL-query durations +timedLogDb :: Log -> Db -> Db +timedLogDb = undefined -- TODO + +-- | Add logs to DB +logDb :: Log -> Db -> Db +logDb logger (Db query query_ execute execute_ executeMany withTransaction formatMany formatQuery) = + Db + { query = runQuery + , query_ = runQuery_ + , execute = runExecute + , execute_ = runExecute_ + , executeMany = runExecuteMany + , withTransaction = runWithTransaction + , formatMany + , formatQuery + } + where + LogFuns{..} = logFuns $ addLogNamespace "db" logger + + runQuery :: forall q r. (ToRow q, FromRow r) => Query -> q -> IO [r] + runQuery expr q = do + logDebug =<< (toQueryParamLogItem expr q) + query expr q + + runQuery_ :: forall r. (FromRow r) => Query -> IO [r] + runQuery_ expr = do + logDebug =<< (toQueryParamLogItem expr ()) + query_ expr + + runExecute :: forall q. (ToRow q) => Query -> q -> IO Int64 + runExecute expr q = do + logDebug =<< (toQueryParamLogItem expr q) + execute expr q + + runExecute_ :: Query -> IO Int64 + runExecute_ expr = do + logDebug =<< (toQueryParamLogItem expr ()) + execute_ expr + + runExecuteMany :: forall q. (ToRow q) => Query -> [q] -> IO Int64 + runExecuteMany expr q = do + logDebug =<< (toManyLogItem expr q) + executeMany expr q + + runWithTransaction :: forall a. IO a -> IO a + runWithTransaction act = do + logDebug $ sqlObject "begin transaction" + res <- withTransaction act + logDebug $ sqlObject "end transaction" + pure res + + toQueryParamLogItem :: (ToRow q) => Query -> q -> IO Json.Value + toQueryParamLogItem expr q = do + eExpr <- Text.decodeUtf8' <$> formatQuery expr q + pure $ case eExpr of + Right res -> sqlObject res + Left _err -> sqlObject "Failed to decode SQL expr to UTF-8 text" + + toManyLogItem :: (ToRow q) => Query -> [q] -> IO Json.Value + toManyLogItem expr qs = do + eExpr <- Text.decodeUtf8' <$> formatMany expr qs + pure $ case eExpr of + Right res -> sqlObject res + Left _err -> sqlObject "Failed to decode SQL expr to UTF-8 text" + + sqlObject :: Text -> Json.Value + sqlObject val = Json.object ["sql" Json..= val] + +toDb :: DbConnection -> Db +toDb (DbConnection run _) = + Db + { query = runQuery + , query_ = runQuery_ + , execute = runExecute + , execute_ = runExecute_ + , executeMany = runExecuteMany + , withTransaction = runWithTransaction + , formatMany = runFormatMany + , formatQuery = runFormatQuery + } + where + runQuery :: forall q r. (ToRow q, FromRow r) => Query -> q -> IO [r] + runQuery expr q = run (\conn -> PostgreSQL.query @q @r conn expr q) + + runQuery_ :: forall r. (FromRow r) => Query -> IO [r] + runQuery_ expr = run (\conn -> PostgreSQL.query_ @r conn expr) + + runExecute :: forall q. (ToRow q) => Query -> q -> IO Int64 + runExecute expr q = run (\conn -> PostgreSQL.execute conn expr q) + + runExecute_ :: Query -> IO Int64 + runExecute_ expr = run (\conn -> PostgreSQL.execute_ conn expr) + + runExecuteMany :: forall q. (ToRow q) => Query -> [q] -> IO Int64 + runExecuteMany expr qs = run (\conn -> PostgreSQL.executeMany conn expr qs) + + runWithTransaction :: forall a. IO a -> IO a + runWithTransaction act = run (\conn -> PostgreSQL.withTransaction conn act) + + runFormatMany :: forall q. (ToRow q) => Query -> [q] -> IO ByteString + runFormatMany expr qs = run (\conn -> PostgreSQL.formatMany conn expr qs) + + runFormatQuery :: forall q. (ToRow q) => Query -> q -> IO ByteString + runFormatQuery expr q = run (\conn -> PostgreSQL.formatQuery conn expr q) + +newDbConnection :: ByteString -> IO DbConnection +newDbConnection connStr = do + connection <- PostgreSQL.connectPostgreSQL connStr + pure $ + DbConnection + { run = \f -> f connection + , close = Proc (PostgreSQL.close connection) + } + +newDbConnectionPool :: ByteString -> IO DbConnection +newDbConnectionPool = undefined