From 58f16f4f4c9b1d3d1236833d54978de45e19647b Mon Sep 17 00:00:00 2001 From: Anton Kholomiov Date: Sat, 11 Nov 2023 10:46:57 +0300 Subject: [PATCH 1/6] Add generic interfaces for logger and db --- Makefile | 2 +- mig-tools/.gitignore | 2 + mig-tools/LICENSE | 30 +++++++++ mig-tools/README.md | 1 + mig-tools/Setup.hs | 3 + mig-tools/mig-tools.cabal | 79 +++++++++++++++++++++++ mig-tools/package.yaml | 63 +++++++++++++++++++ mig-tools/src/Mig/Tool/Base.hs | 76 ++++++++++++++++++++++ mig-tools/src/Mig/Tool/Db.hs | 41 ++++++++++++ mig-tools/src/Mig/Tool/Log.hs | 111 +++++++++++++++++++++++++++++++++ mig-tools/test/Spec.hs | 2 + stack.yaml | 1 + 12 files changed, 410 insertions(+), 1 deletion(-) create mode 100644 mig-tools/.gitignore create mode 100644 mig-tools/LICENSE create mode 100644 mig-tools/README.md create mode 100644 mig-tools/Setup.hs create mode 100644 mig-tools/mig-tools.cabal create mode 100644 mig-tools/package.yaml create mode 100644 mig-tools/src/Mig/Tool/Base.hs create mode 100644 mig-tools/src/Mig/Tool/Db.hs create mode 100644 mig-tools/src/Mig/Tool/Log.hs create mode 100644 mig-tools/test/Spec.hs diff --git a/Makefile b/Makefile index 4d1086f..2fa022d 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ .PHONY: build test run docs build: - stack build + stack build mig-tools test: stack test 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..46c4bc6 --- /dev/null +++ b/mig-tools/mig-tools.cabal @@ -0,0 +1,79 @@ +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 + CHANGELOG.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 + 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 + 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 + 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 + default-language: GHC2021 diff --git a/mig-tools/package.yaml b/mig-tools/package.yaml new file mode 100644 index 0000000..9e6445b --- /dev/null +++ b/mig-tools/package.yaml @@ -0,0 +1,63 @@ +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 +- 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 + +dependencies: +- base >= 4.7 && < 5 +- aeson +- text +- mtl +- 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 + +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..9c6d18b --- /dev/null +++ b/mig-tools/src/Mig/Tool/Base.hs @@ -0,0 +1,76 @@ +-- | Basic interfaces +module Mig.Tool.Base ( + Query (..), + queryToSet, + queryToGet, + QueryOr (..), + Get (..), + Set (..), + GetOr (..), + Proc (..), + 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 () + } + +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 (liftA2 (<*>) 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 ()) diff --git a/mig-tools/src/Mig/Tool/Db.hs b/mig-tools/src/Mig/Tool/Db.hs new file mode 100644 index 0000000..e500370 --- /dev/null +++ b/mig-tools/src/Mig/Tool/Db.hs @@ -0,0 +1,41 @@ +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 = Db + { query :: Query Sql SqlResult + , 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..444d2f4 --- /dev/null +++ b/mig-tools/src/Mig/Tool/Log.hs @@ -0,0 +1,111 @@ +-- | Logger interface +module Mig.Tool.Log ( + Log (..), + addLogNamespace, + setLogLevel, + LogLevel (..), + LogNamespace (..), + LogItem (..), + + -- * functions + logInfo, + logWarn, + logError, + logDebug, + + -- * augment interfaces with logger + logQuery, + logSet, + logGet, + logQuerySet, + logQueryGet, + logProc, +) where + +import Data.Aeson qualified as Json +import Data.Text (Text) +import Mig.Tool.Base + +data LogLevel = LogDebug | LogInfo | LogWarn | LogError + +newtype LogNamespace = LogNamespace [Text] + deriving newtype (Semigroup, Monoid) + +data LogItem = LogItem + { level :: LogLevel + , namespace :: LogNamespace + , message :: Json.Value + } + +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) + +------------------------------------------------------------------------------------- +-- log functions + +logByLevel :: (Json.ToJSON a) => LogLevel -> Log -> a -> IO () +logByLevel level logger message = + logger.log.set $ + LogItem + { level + , namespace = LogNamespace [] + , message = Json.toJSON message + } + +logInfo :: (Json.ToJSON a) => Log -> a -> IO () +logInfo = logByLevel LogInfo + +logDebug :: (Json.ToJSON a) => Log -> a -> IO () +logDebug = logByLevel LogDebug + +logWarn :: (Json.ToJSON a) => Log -> a -> IO () +logWarn = logByLevel LogWarn + +logError :: (Json.ToJSON a) => Log -> a -> IO () +logError = logByLevel LogError + +logSet :: (Json.ToJSON a) => Log -> Text -> Set a -> Set a +logSet env name (Set act) = Set $ \a -> do + env.log.set $ + LogItem LogInfo mempty $ + 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} + +addLogNamespaceItem :: LogNamespace -> LogItem -> LogItem +addLogNamespaceItem ns item = item{namespace = mappend ns item.namespace} + +setLogLevelItem :: LogLevel -> LogItem -> LogItem +setLogLevelItem level item = item{level} 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..04c5e9d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -10,3 +10,4 @@ packages: - mig-swagger-ui - mig-wai - mig-rio +- mig-tools From eb81d468a1dd90d8390423f04ca64e3014a9482b Mon Sep 17 00:00:00 2001 From: Anton Kholomiov Date: Sat, 11 Nov 2023 11:47:43 +0300 Subject: [PATCH 2/6] Implement fast-logger tool --- Makefile | 2 +- mig-tools/mig-tools.cabal | 5 +- mig-tools/package.yaml | 3 +- mig-tools/src/Mig/Tool/Base.hs | 4 ++ mig-tools/src/Mig/Tool/Log.hs | 71 ++++++++++++++++--- stack.yaml | 1 + tools/mig-fast-logger/.gitignore | 2 + tools/mig-fast-logger/CHANGELOG.md | 11 +++ tools/mig-fast-logger/LICENSE | 30 ++++++++ tools/mig-fast-logger/README.md | 1 + tools/mig-fast-logger/Setup.hs | 3 + tools/mig-fast-logger/mig-fast-logger.cabal | 50 +++++++++++++ tools/mig-fast-logger/package.yaml | 52 ++++++++++++++ .../mig-fast-logger/src/Mig/Tool/Log/Fast.hs | 35 +++++++++ 14 files changed, 257 insertions(+), 13 deletions(-) create mode 100644 tools/mig-fast-logger/.gitignore create mode 100644 tools/mig-fast-logger/CHANGELOG.md create mode 100644 tools/mig-fast-logger/LICENSE create mode 100644 tools/mig-fast-logger/README.md create mode 100644 tools/mig-fast-logger/Setup.hs create mode 100644 tools/mig-fast-logger/mig-fast-logger.cabal create mode 100644 tools/mig-fast-logger/package.yaml create mode 100644 tools/mig-fast-logger/src/Mig/Tool/Log/Fast.hs diff --git a/Makefile b/Makefile index 2fa022d..2db99e9 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ .PHONY: build test run docs build: - stack build mig-tools + stack build mig-fast-logger test: stack test diff --git a/mig-tools/mig-tools.cabal b/mig-tools/mig-tools.cabal index 46c4bc6..bd37611 100644 --- a/mig-tools/mig-tools.cabal +++ b/mig-tools/mig-tools.cabal @@ -17,7 +17,6 @@ license-file: LICENSE build-type: Simple extra-source-files: README.md - CHANGELOG.md source-repository head type: git @@ -42,6 +41,7 @@ library 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 @@ -49,6 +49,7 @@ library , bytestring , mtl , text + , time default-language: GHC2021 test-suite mig-tools-test @@ -68,6 +69,7 @@ test-suite mig-tools-test 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 @@ -76,4 +78,5 @@ test-suite mig-tools-test , mig-tools , mtl , text + , time default-language: GHC2021 diff --git a/mig-tools/package.yaml b/mig-tools/package.yaml index 9e6445b..6ddf29a 100644 --- a/mig-tools/package.yaml +++ b/mig-tools/package.yaml @@ -8,7 +8,6 @@ copyright: "2023 Author name here" extra-source-files: - README.md -- CHANGELOG.md # Metadata used when publishing your package # synopsis: Short description of your package @@ -29,6 +28,7 @@ default-extensions: - DerivingStrategies - StrictData - AllowAmbiguousTypes + - DeriveAnyClass dependencies: - base >= 4.7 && < 5 @@ -36,6 +36,7 @@ dependencies: - text - mtl - bytestring +- time ghc-options: - -Wall diff --git a/mig-tools/src/Mig/Tool/Base.hs b/mig-tools/src/Mig/Tool/Base.hs index 9c6d18b..5d502d1 100644 --- a/mig-tools/src/Mig/Tool/Base.hs +++ b/mig-tools/src/Mig/Tool/Base.hs @@ -6,6 +6,7 @@ module Mig.Tool.Base ( QueryOr (..), Get (..), Set (..), + filterSet, GetOr (..), Proc (..), module X, @@ -33,6 +34,9 @@ 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) diff --git a/mig-tools/src/Mig/Tool/Log.hs b/mig-tools/src/Mig/Tool/Log.hs index 444d2f4..16ef3f3 100644 --- a/mig-tools/src/Mig/Tool/Log.hs +++ b/mig-tools/src/Mig/Tool/Log.hs @@ -1,11 +1,12 @@ -- | Logger interface module Mig.Tool.Log ( Log (..), - addLogNamespace, - setLogLevel, LogLevel (..), LogNamespace (..), LogItem (..), + addLogNamespace, + setLogLevel, + trackLogTime, -- * functions logInfo, @@ -22,20 +23,49 @@ module Mig.Tool.Log ( logProc, ) where +import Control.Monad import Data.Aeson qualified as Json +import Data.Aeson.Types qualified as Json import Data.Text (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) + deriving newtype (Semigroup, Monoid, Show, Eq, Json.ToJSON) 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 @@ -48,14 +78,22 @@ 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 = +logByLevel level logger message = do + now <- getCurrentTime logger.log.set $ LogItem { level + , time = Just now , namespace = LogNamespace [] , message = Json.toJSON message } @@ -72,14 +110,16 @@ logWarn = logByLevel LogWarn logError :: (Json.ToJSON a) => Log -> a -> IO () logError = logByLevel LogError +------------------------------------------------------------------------------------- +-- add logger to interface + logSet :: (Json.ToJSON a) => Log -> Text -> Set a -> Set a logSet env name (Set act) = Set $ \a -> do - env.log.set $ - LogItem LogInfo mempty $ - Json.object - [ "call" Json..= name - , "argument" Json..= a - ] + logInfo env $ + Json.object + [ "call" Json..= name + , "argument" Json..= a + ] act a logGet :: (Json.ToJSON a) => Log -> Text -> Get a -> Get a @@ -104,8 +144,19 @@ 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/stack.yaml b/stack.yaml index 04c5e9d..6f313de 100644 --- a/stack.yaml +++ b/stack.yaml @@ -11,3 +11,4 @@ packages: - mig-wai - mig-rio - mig-tools +- tools/mig-fast-logger 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..fa70840 --- /dev/null +++ b/tools/mig-fast-logger/src/Mig/Tool/Log/Fast.hs @@ -0,0 +1,35 @@ +-- | Init fast-logger +module Mig.Tool.Log.Fast ( + 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 +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 $ + 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) From 8d4dd4a843e16c56a5fc09c675543747760c175f Mon Sep 17 00:00:00 2001 From: Anton Kholomiov Date: Sat, 11 Nov 2023 12:51:32 +0300 Subject: [PATCH 3/6] Use logger in the example --- examples/mig-example-apps/JsonApi/Init.hs | 42 +++---------------- .../mig-example-apps/JsonApi/Interface.hs | 32 ++++---------- examples/mig-example-apps/JsonApi/Server.hs | 21 +++++++--- .../mig-example-apps/mig-example-apps.cabal | 3 +- examples/mig-example-apps/package.yaml | 3 +- examples/mig-example-apps/stack.yaml | 2 + mig-tools/src/Mig/Tool/Base.hs | 2 +- mig-tools/src/Mig/Tool/Log.hs | 39 ++++++++++------- .../mig-fast-logger/src/Mig/Tool/Log/Fast.hs | 12 +++--- 9 files changed, 66 insertions(+), 90 deletions(-) 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/src/Mig/Tool/Base.hs b/mig-tools/src/Mig/Tool/Base.hs index 5d502d1..e4b4b84 100644 --- a/mig-tools/src/Mig/Tool/Base.hs +++ b/mig-tools/src/Mig/Tool/Base.hs @@ -58,7 +58,7 @@ newtype GetOr err a = GetOr instance Applicative (GetOr err) where pure = GetOr . pure . pure - (<*>) (GetOr fa) (GetOr fb) = GetOr (liftA2 (<*>) fa fb) + (<*>) (GetOr fa) (GetOr fb) = GetOr ((<*>) <$> fa <*> fb) instance Monad (GetOr err) where (GetOr ma) >>= mf = GetOr $ do diff --git a/mig-tools/src/Mig/Tool/Log.hs b/mig-tools/src/Mig/Tool/Log.hs index 16ef3f3..13968df 100644 --- a/mig-tools/src/Mig/Tool/Log.hs +++ b/mig-tools/src/Mig/Tool/Log.hs @@ -9,10 +9,9 @@ module Mig.Tool.Log ( trackLogTime, -- * functions - logInfo, - logWarn, - logError, - logDebug, + LogFuns (..), + logFuns, + logByLevel, -- * augment interfaces with logger logQuery, @@ -24,9 +23,12 @@ module Mig.Tool.Log ( ) 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 @@ -43,6 +45,9 @@ instance Json.ToJSON LogLevel where 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 @@ -98,24 +103,28 @@ logByLevel level logger message = do , message = Json.toJSON message } -logInfo :: (Json.ToJSON a) => Log -> a -> IO () -logInfo = logByLevel LogInfo - -logDebug :: (Json.ToJSON a) => Log -> a -> IO () -logDebug = logByLevel LogDebug - -logWarn :: (Json.ToJSON a) => Log -> a -> IO () -logWarn = logByLevel LogWarn +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 () + } -logError :: (Json.ToJSON a) => Log -> a -> IO () -logError = logByLevel LogError +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 - logInfo env $ + logByLevel LogInfo env $ Json.object [ "call" Json..= name , "argument" Json..= a diff --git a/tools/mig-fast-logger/src/Mig/Tool/Log/Fast.hs b/tools/mig-fast-logger/src/Mig/Tool/Log/Fast.hs index fa70840..1c803bf 100644 --- a/tools/mig-fast-logger/src/Mig/Tool/Log/Fast.hs +++ b/tools/mig-fast-logger/src/Mig/Tool/Log/Fast.hs @@ -1,5 +1,6 @@ -- | Init fast-logger module Mig.Tool.Log.Fast ( + LogCodec (..), newLogger, newLoggerStdout, module X, @@ -8,7 +9,7 @@ module Mig.Tool.Log.Fast ( import Data.Aeson qualified as Json import Data.ByteString.Lazy (ByteString, fromStrict) import Data.Yaml qualified as Yaml -import Mig.Tool.Base +import Mig.Tool.Base as X import Mig.Tool.Log as X import System.Log.FastLogger qualified as FastLogger @@ -18,10 +19,11 @@ newLogger :: LogCodec -> FastLogger.LogType -> IO Log newLogger codec config = do (writeLog, closeLogger) <- FastLogger.newFastLogger config pure $ - Log - { log = Set (writeLog . toLogStr) - , close = Proc closeLogger - } + trackLogTime $ + Log + { log = Set (writeLog . toLogStr) + , close = Proc closeLogger + } where toLogStr :: LogItem -> FastLogger.LogStr toLogStr = FastLogger.toLogStr . toByteString From 44ec3950faa7ee27598741af5e7746694d374c6b Mon Sep 17 00:00:00 2001 From: Anton Kholomiov Date: Sat, 11 Nov 2023 20:30:01 +0300 Subject: [PATCH 4/6] Adds React tool --- mig-tools/src/Mig/Tool/Base.hs | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/mig-tools/src/Mig/Tool/Base.hs b/mig-tools/src/Mig/Tool/Base.hs index e4b4b84..17bf0db 100644 --- a/mig-tools/src/Mig/Tool/Base.hs +++ b/mig-tools/src/Mig/Tool/Base.hs @@ -9,6 +9,8 @@ module Mig.Tool.Base ( filterSet, GetOr (..), Proc (..), + React (..), + filterReact, module X, ) where @@ -78,3 +80,29 @@ instance Semigroup Proc where 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) + +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) From 1f71d0ac0464324cfb44a424a9037e3201f903c0 Mon Sep 17 00:00:00 2001 From: Anton Kholomiov Date: Sat, 11 Nov 2023 22:12:21 +0300 Subject: [PATCH 5/6] Fix build wip --- mig-tools/src/Mig/Tool/Base.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/mig-tools/src/Mig/Tool/Base.hs b/mig-tools/src/Mig/Tool/Base.hs index 17bf0db..87b64f2 100644 --- a/mig-tools/src/Mig/Tool/Base.hs +++ b/mig-tools/src/Mig/Tool/Base.hs @@ -93,10 +93,12 @@ instance Functor React where 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 From 7228a62573cd1d145b11d4b2fd0df5ac9a73507e Mon Sep 17 00:00:00 2001 From: Anton Kholomiov Date: Thu, 16 Nov 2023 23:06:47 +0300 Subject: [PATCH 6/6] Adds postgresql-simple tool --- Makefile | 2 +- mig-tools/src/Mig/Tool/Db.hs | 25 +-- stack.yaml | 1 + tools/mig-postgresql-simple/.gitignore | 2 + tools/mig-postgresql-simple/CHANGELOG.md | 11 ++ tools/mig-postgresql-simple/LICENSE | 30 ++++ tools/mig-postgresql-simple/README.md | 1 + tools/mig-postgresql-simple/Setup.hs | 3 + .../mig-postgresql-simple.cabal | 52 ++++++ tools/mig-postgresql-simple/package.yaml | 54 ++++++ .../src/Mig/Tool/Db/PostgreSQL/Simple.hs | 156 ++++++++++++++++++ 11 files changed, 325 insertions(+), 12 deletions(-) create mode 100644 tools/mig-postgresql-simple/.gitignore create mode 100644 tools/mig-postgresql-simple/CHANGELOG.md create mode 100644 tools/mig-postgresql-simple/LICENSE create mode 100644 tools/mig-postgresql-simple/README.md create mode 100644 tools/mig-postgresql-simple/Setup.hs create mode 100644 tools/mig-postgresql-simple/mig-postgresql-simple.cabal create mode 100644 tools/mig-postgresql-simple/package.yaml create mode 100644 tools/mig-postgresql-simple/src/Mig/Tool/Db/PostgreSQL/Simple.hs diff --git a/Makefile b/Makefile index 2db99e9..8d3f95d 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ .PHONY: build test run docs build: - stack build mig-fast-logger + stack build mig-postgresql-simple test: stack test diff --git a/mig-tools/src/Mig/Tool/Db.hs b/mig-tools/src/Mig/Tool/Db.hs index e500370..0bcc18f 100644 --- a/mig-tools/src/Mig/Tool/Db.hs +++ b/mig-tools/src/Mig/Tool/Db.hs @@ -1,23 +1,25 @@ module Mig.Tool.Db ( Db (..), - Sql (..), - SqlResult (..), - SqlRow, - logDb, + -- 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 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 = Db - { query :: Query Sql SqlResult +-- 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 = @@ -39,3 +41,4 @@ newtype SqlResult = SqlResult } type SqlRow = [ByteString] +-} diff --git a/stack.yaml b/stack.yaml index 6f313de..27ff92b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -12,3 +12,4 @@ packages: - mig-rio - mig-tools - tools/mig-fast-logger +- tools/mig-postgresql-simple 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