From f4de83a39a602bdb8942a57f06df2f00b321ddfe Mon Sep 17 00:00:00 2001 From: Hemant Mangla Date: Mon, 11 Jul 2022 15:04:53 +0530 Subject: [PATCH] Update euler-hs to make beckn compatible --- UPGRADE.md | 65 ++ euler-hs.cabal | 75 +-- src/EulerHS/CachedSqlDBQuery.hs | 435 +++++++++++++ src/EulerHS/Core/Api.hs | 115 ++-- src/EulerHS/Core/Interpreters.hs | 13 - src/EulerHS/Core/KVDB/Entries.hs | 311 --------- src/EulerHS/Core/KVDB/Interpreter.hs | 183 +++--- src/EulerHS/Core/KVDB/Language.hs | 102 ++- src/EulerHS/Core/Language.hs | 14 - src/EulerHS/Core/Logger/Entries.hs | 31 - src/EulerHS/Core/Logger/Impl/TinyLogger.hs | 28 +- src/EulerHS/Core/Logger/Interpreter.hs | 34 +- src/EulerHS/Core/Masking.hs | 90 +++ src/EulerHS/Core/Playback/Entries.hs | 354 ----------- src/EulerHS/Core/Playback/Machine.hs | 221 ------- src/EulerHS/Core/PubSub/Entries.hs | 61 -- src/EulerHS/Core/PubSub/Interpreter.hs | 20 +- src/EulerHS/Core/PubSub/Language.hs | 26 +- src/EulerHS/Core/Runtime.hs | 109 ++-- src/EulerHS/Core/SqlDB/Interpreter.hs | 6 + src/EulerHS/Core/SqlDB/Language.hs | 52 +- src/EulerHS/Core/Types.hs | 15 +- src/EulerHS/Core/Types/BinaryString.hs | 4 + src/EulerHS/Core/Types/Common.hs | 43 +- src/EulerHS/Core/Types/DB.hs | 585 +++++++---------- src/EulerHS/Core/Types/Exceptions.hs | 25 +- src/EulerHS/Core/Types/HttpAPI.hs | 83 ++- src/EulerHS/Core/Types/KVDB.hs | 254 +++----- src/EulerHS/Core/Types/Logger.hs | 194 ++---- src/EulerHS/Core/Types/MySQL.hs | 122 ++-- src/EulerHS/Core/Types/Options.hs | 24 +- src/EulerHS/Core/Types/Playback.hs | 246 -------- src/EulerHS/Core/Types/Postgres.hs | 17 +- src/EulerHS/Core/Types/Serializable.hs | 3 +- src/EulerHS/Extra/Aeson.hs | 13 +- src/EulerHS/Extra/AltValidation.hs | 21 +- src/EulerHS/Extra/Language.hs | 302 ++++----- src/EulerHS/Extra/Test.hs | 50 +- src/EulerHS/Extra/Validation.hs | 15 +- src/EulerHS/Framework/Flow/Interpreter.hs | 325 +++------- src/EulerHS/Framework/Flow/Language.hs | 234 +++---- src/EulerHS/Framework/Interpreters.hs | 13 - src/EulerHS/Framework/Language.hs | 14 - src/EulerHS/Framework/Runtime.hs | 87 +-- src/EulerHS/Interpreters.hs | 28 - src/EulerHS/Language.hs | 58 -- src/EulerHS/Prelude.hs | 19 +- src/EulerHS/Runtime.hs | 35 -- src/EulerHS/Types.hs | 33 - stack.yaml | 25 +- stack.yaml.lock | 59 +- test/EulerHS/TestData/API/Client.hs | 54 +- test/EulerHS/TestData/Scenarios/Scenario1.hs | 42 +- test/EulerHS/TestData/Types.hs | 44 +- test/EulerHS/Testing/Flow/Interpreter.hs | 68 +- test/EulerHS/Testing/Flow/Runtime.hs | 28 +- test/EulerHS/Testing/Types.hs | 3 +- test/EulerHS/Tests/Framework/ArtSpec.hs | 623 +++++++++---------- test/EulerHS/Tests/Framework/CachedDBSpec.hs | 174 ++++++ test/EulerHS/Tests/Framework/Common.hs | 293 ++++----- test/EulerHS/Tests/Framework/DBSetup.hs | 47 +- test/EulerHS/Tests/Framework/FlowSpec.hs | 333 +++++----- test/EulerHS/Tests/Framework/KVDBArtSpec.hs | 335 +++++----- test/EulerHS/Tests/Framework/MaskingSpec.hs | 58 ++ test/EulerHS/Tests/Framework/PubSubSpec.hs | 234 ++++--- test/EulerHS/Tests/Framework/SQLArtSpec.hs | 354 ++++++----- test/Main.hs | 100 ++- testDB/KVDB/KVDBSpec.hs | 98 ++- testDB/Main.hs | 14 +- testDB/SQLDB/TestData/Connections.hs | 2 + testDB/SQLDB/TestData/Scenarios/MySQL.hs | 35 +- testDB/SQLDB/TestData/Scenarios/Postgres.hs | 13 +- testDB/SQLDB/TestData/Scenarios/SQLite.hs | 6 +- testDB/SQLDB/TestData/Types.hs | 15 +- testDB/SQLDB/Tests/MySQLDBSpec.hs | 17 +- testDB/SQLDB/Tests/PostgresDBSpec.hs | 36 +- testDB/SQLDB/Tests/SQLiteDBSpec.hs | 22 +- update.sh | 94 +++ 78 files changed, 3775 insertions(+), 4658 deletions(-) create mode 100644 UPGRADE.md create mode 100644 src/EulerHS/CachedSqlDBQuery.hs delete mode 100644 src/EulerHS/Core/KVDB/Entries.hs delete mode 100644 src/EulerHS/Core/Logger/Entries.hs create mode 100644 src/EulerHS/Core/Masking.hs delete mode 100644 src/EulerHS/Core/Playback/Entries.hs delete mode 100644 src/EulerHS/Core/Playback/Machine.hs delete mode 100644 src/EulerHS/Core/PubSub/Entries.hs delete mode 100644 src/EulerHS/Core/Types/Playback.hs create mode 100644 test/EulerHS/Tests/Framework/CachedDBSpec.hs create mode 100644 test/EulerHS/Tests/Framework/MaskingSpec.hs create mode 100755 update.sh diff --git a/UPGRADE.md b/UPGRADE.md new file mode 100644 index 00000000..c716a9b5 --- /dev/null +++ b/UPGRADE.md @@ -0,0 +1,65 @@ +# How to update to a new version of euler-hs +## 1.10.0.0 +This contains significant changes to the nix build structure, so it's important to read the section for nix users. + +For stack users there are no big changes, mostly some of the `extra-deps` need to be changed and in order for stack builds to work on NixOS (or if you don't want to mysql and other packages to your system and want to rely on nix) you should add a `nix` attribute to `stack.yaml` as described in the "For stack users" section. + +We use forked versions of + + - `beam` + - `beam-mysql` + - for more info about `beam-*` changes [see BEAM_NOTES.md](BEAM_NOTES.md). + - `hedis` for redis clustering support (the work on upstreaming was ongoing but looks like currently is frozen INSERT LINK TO PR) + +#### For nix users +It would be helpful to read [BUILD.md](BUILD.md) first to familiarise yourself with the `eulerBuild` and existing overlays. + +Use nixpkgs with a GHC version 8.8.3+. +You can copy nixpkgs used currently by all euler-hs libraries from [default.nix](default.nix). + +To see how to import libraries, see the working examples from projects using: + + - https://bitbucket.org/juspay/euler-api-gateway/src/master/default.nix + - https://bitbucket.org/juspay/euler-api-order/src/master/default.nix + +Also replace your `shell.nix` with a `(import ./default.nix {}).mkShell` text and see examples above and [BUILD.md](BUILD.md) on how to configure and use it. + +We use a tag `EulerHS-1.10.0.0` for all libraries. +So fetch a repo with `ref = "EulerHS-1.10.0.0"`. + +For explanation of `ref` and `rev` attributes [see BUILD.md section "Fetching deps with git"](BUILD.md). + +If you want to use `eulerBuild` the minimum that you need to fetch is `euler-hs` repository which contains `eulerBuild` implementation (it may be moved to a separate repo, but no definite plans yet). + +To see how to add your package, add your overlay, see what overlays different libraries provide please refer to [BUILD.md](BUILD.md). + +As usual working examples should be in: + +- https://bitbucket.org/juspay/euler-api-gateway/src/master/nix +- https://bitbucket.org/juspay/euler-api-order/src/master/nix + +###### Important note about certain overrides +Please see a [BUILD.md](BUILD.md) section "Important note about overrides". +The brief version is that if you use a package that depends on `haskell-src-exts` you may get a cabal mismatched deps error. See the linked doc for into on how to fix that. + +#### For stack users +1. We are now using GHC 8.8 and resolver 15.15. +2. If you are using `juspay/beam-mysql2` you can go back to `juspay/beam-mysql` as `beam-mysql2` will be deleted in the near future. +3. Look at `stack.yaml` files of libraries that you want to use and copy `extra-deps` used. +4. These repos use a lot of euler libraries and should usually have up to date stack files: + + - https://bitbucket.org/juspay/euler-api-order/src/master/stack.yaml + - https://bitbucket.org/juspay/euler-api-gateway/src/master/stack.yaml + +5. Some of the libraries used by `euler-hs` require presence of mysql, postgres, openssl and zlib packages in order to build. You can either install it globally via your package manage, or rely on nix and use stack-nix integration the following to your `stack.yaml`: +```yaml +nix: + enable: false + packages: [mysql57, openssl, zlib, postgresql] +``` + +After that you can do `stack --nix build` and get a working build (`stack --nix test` for test, etc.). + +If you are using euler libraries that are fetched remotely (like in the `euler-api-gateway` example) then in order to update you should take a look at what commit does `EulerHS-1.10.0.0` tag refer to (https://bitbucket.org/juspay/euler-hs/commits/tag/EulerHS-1.10.0.0) and change your stack file with that hash. + +Alternatively fetch a git repo and do a `git show EulerHS-1.10.0.0` this way you'll also get the required commit hash. diff --git a/euler-hs.cabal b/euler-hs.cabal index 922b41cb..08e32567 100644 --- a/euler-hs.cabal +++ b/euler-hs.cabal @@ -1,15 +1,20 @@ cabal-version: 3.0 name: euler-hs -version: 2.6.0.0 -synopsis: The Flow framework for web backends -license: Apache-2.0 +version: 2.0.4.4 +synopsis: The Flow framework for Euler. +homepage: https://bitbucket.org/juspay/euler-hs +license: author: Juspay Technologies Pvt Ltd -maintainer: opensource@juspay.in -copyright: (C) Juspay Technologies Pvt Ltd 2019-2021 +maintainer: koz.ross@juspay.in +copyright: (C) Juspay Technologies Pvt Ltd 2019-2020 category: Euler build-type: Simple tested-with: GHC ==8.8.3 +source-repository head + type: git + location: https://bitbucket.org/juspay/euler-hs + common common-lang ghc-options: -Wall -Wcompat -Wincomplete-record-updates @@ -50,6 +55,7 @@ common common-lang library import: common-lang exposed-modules: + EulerHS.CachedSqlDBQuery EulerHS.Extra.AltValidation EulerHS.Extra.Test EulerHS.Extra.Validation @@ -62,17 +68,13 @@ library other-modules: EulerHS.Core.Api EulerHS.Core.Interpreters - EulerHS.Core.KVDB.Entries EulerHS.Core.KVDB.Interpreter EulerHS.Core.KVDB.Language EulerHS.Core.Language - EulerHS.Core.Logger.Entries EulerHS.Core.Logger.Impl.TinyLogger EulerHS.Core.Logger.Interpreter EulerHS.Core.Logger.Language - EulerHS.Core.Playback.Entries - EulerHS.Core.Playback.Machine - EulerHS.Core.PubSub.Entries + EulerHS.Core.Masking EulerHS.Core.PubSub.Interpreter EulerHS.Core.PubSub.Language EulerHS.Core.Runtime @@ -88,7 +90,6 @@ library EulerHS.Core.Types.Logger EulerHS.Core.Types.MySQL EulerHS.Core.Types.Options - EulerHS.Core.Types.Playback EulerHS.Core.Types.Postgres EulerHS.Core.Types.Serializable EulerHS.Extra.Aeson @@ -126,16 +127,17 @@ library , http-media , http-types , lens + , mason , mysql-haskell ^>=0.8.4.2 + , named , newtype-generics , postgresql-simple , process , profunctors , resource-pool - , servant-client - , servant-client-core - -- , servant-client ^>=0.18.1 - -- , servant-client-core ^>=0.18.1 + , sequelize ^>=1.1.0.0 + , servant-client ^>=0.18.1 + , servant-client-core ^>=0.18.1 , sqlite-simple , stm , string-conversions @@ -161,17 +163,13 @@ test-suite language other-modules: EulerHS.Core.Api EulerHS.Core.Interpreters - EulerHS.Core.KVDB.Entries EulerHS.Core.KVDB.Interpreter EulerHS.Core.KVDB.Language EulerHS.Core.Language - EulerHS.Core.Logger.Entries EulerHS.Core.Logger.Impl.TinyLogger EulerHS.Core.Logger.Interpreter EulerHS.Core.Logger.Language - EulerHS.Core.Playback.Entries - EulerHS.Core.Playback.Machine - EulerHS.Core.PubSub.Entries + EulerHS.Core.Masking EulerHS.Core.PubSub.Interpreter EulerHS.Core.PubSub.Language EulerHS.Core.Runtime @@ -187,7 +185,6 @@ test-suite language EulerHS.Core.Types.Logger EulerHS.Core.Types.MySQL EulerHS.Core.Types.Options - EulerHS.Core.Types.Playback EulerHS.Core.Types.Postgres EulerHS.Core.Types.Serializable EulerHS.Extra.Aeson @@ -214,54 +211,59 @@ test-suite language EulerHS.Tests.Framework.PubSubSpec EulerHS.Tests.Framework.SQLArtSpec EulerHS.Types + EulerHS.Tests.Framework.CachedDBSpec + EulerHS.Tests.Framework.MaskingSpec build-depends: , aeson , aeson-pretty + , async , base64-bytestring , base64-bytestring-type - , beam-core ^>=0.9.0.0 + , beam-core , beam-mysql ^>=1.2.1.0 , beam-postgres ^>=0.5.0.0 - , beam-sqlite ^>=0.5.0.0 - , binary + , beam-sqlite , bytestring , case-insensitive , cereal , connection , containers , data-default + , directory , dlist , euler-hs , exceptions , extra + , filepath , fmt , free + , generic-arbitrary , generic-lens - , hedis ^>=0.12.8.1 + , hedis , hspec , http-client , http-client-tls , http-media , http-types , lens - , mysql-haskell ^>=0.8.4.2 + , named , newtype-generics + , mysql-haskell ^>=0.8.4.2 , postgresql-simple , process , profunctors , QuickCheck + , quickcheck-instances + , random , resource-pool - , servant - , servant-client - , servant-client-core - , servant-mock - , servant-server - -- , servant ^>=0.18.1 - -- , servant-client ^>=0.18.1 - -- , servant-client-core ^>=0.18.1 - -- , servant-mock ^>=0.8.7 - -- , servant-server ^>=0.18.1 + , safe-exceptions + , sequelize + , servant ^>=0.18.1 + , servant-client ^>=0.18.1 + , servant-client-core ^>=0.18.1 + , servant-mock ^>=0.8.7 + , servant-server ^>=0.18.1 , sqlite-simple , stm , string-conversions @@ -270,6 +272,7 @@ test-suite language , tinylog , tls , transformers + , typed-process , unagi-chan , universum , unordered-containers diff --git a/src/EulerHS/CachedSqlDBQuery.hs b/src/EulerHS/CachedSqlDBQuery.hs new file mode 100644 index 00000000..8ffbd7a3 --- /dev/null +++ b/src/EulerHS/CachedSqlDBQuery.hs @@ -0,0 +1,435 @@ +{-# LANGUAGE OverloadedStrings #-} + +module EulerHS.CachedSqlDBQuery + ( create + , createSql + , updateOne + , updateOneWoReturning + , updateOneSql + , updateOneSqlWoReturning + , updateExtended + , findOne + , findOneSql + , findAll + , findAllSql + , findAllExtended + , SqlReturning(..) + ) +where + +import Data.Aeson (encode) +import qualified Data.ByteString.Lazy as BSL +import qualified Database.Beam as B +import qualified Database.Beam.MySQL as BM +import qualified Database.Beam.Postgres as BP +import qualified Database.Beam.Sqlite as BS +import qualified Data.Text as T +import qualified EulerHS.Core.SqlDB.Language as DB +import EulerHS.Core.Types.DB +import EulerHS.Core.Types.Serializable +import EulerHS.Extra.Language (getOrInitSqlConn, rGet, rSetB) +import qualified EulerHS.Framework.Language as L +import EulerHS.Prelude +import Named (defaults, (!)) +import Sequelize + +-- TODO: What KVDB should be used +cacheName :: String +cacheName = "eulerKVDB" + +--------------- Core API --------------- + +-- | Create a new database entry with the given value. +-- Cache the value if the DB insert succeeds. + +class SqlReturning (beM :: Type -> Type) (be :: Type) where + createReturning :: + forall (table :: (Type -> Type) -> Type) + (m :: Type -> Type) . + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + B.HasQBuilder be, + Model be table, + ToJSON (table Identity), + FromJSON (table Identity), + Show (table Identity), + L.MonadFlow m + ) => + DBConfig beM -> + table Identity -> + Maybe Text -> + m (Either DBError (table Identity)) + +instance SqlReturning BM.MySQLM BM.MySQL where + createReturning = createMySQL + +instance SqlReturning BP.Pg BP.Postgres where + createReturning = create + +instance SqlReturning BS.SqliteM BS.Sqlite where + createReturning = create + + +create :: + forall (be :: Type) + (beM :: Type -> Type) + (table :: (Type -> Type) -> Type) + (m :: Type -> Type) . + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + B.HasQBuilder be, + Model be table, + ToJSON (table Identity), + FromJSON (table Identity), + Show (table Identity), + L.MonadFlow m + ) => + DBConfig beM -> + table Identity -> + Maybe Text -> + m (Either DBError (table Identity)) +create dbConf value mCacheKey = do + res <- createSql dbConf value + case res of + Right val -> do + whenJust mCacheKey (`cacheWithKey` val) + return $ Right val + Left e -> return $ Left e + +createMySQL :: + forall (table :: (Type -> Type) -> Type) + (m :: Type -> Type) . + ( HasCallStack, + Model BM.MySQL table, + ToJSON (table Identity), + FromJSON (table Identity), + Show (table Identity), + L.MonadFlow m + ) => + DBConfig BM.MySQLM -> + table Identity -> + Maybe Text -> + m (Either DBError (table Identity)) +createMySQL dbConf value mCacheKey = do + res <- createSqlMySQL dbConf value + case res of + Right val -> do + whenJust mCacheKey (`cacheWithKey` val) + return $ Right val + Left e -> return $ Left e + +-- | Update an element matching the query to the new value. +-- Cache the value at the given key if the DB update succeeds. +updateOne :: + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + Model be table, + B.HasQBuilder be, + ToJSON (table Identity), + FromJSON (table Identity), + Show (table Identity), + L.MonadFlow m + ) => + DBConfig beM -> + Maybe Text -> + [Set be table] -> + Where be table -> + m (Either DBError (table Identity)) +updateOne dbConf (Just cacheKey) newVals whereClause = do + val <- updateOneSql dbConf newVals whereClause + whenRight val (\_ -> cacheWithKey cacheKey val) + return val +updateOne dbConf Nothing value whereClause = updateOneSql dbConf value whereClause + +updateOneWoReturning :: + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + Model be table, + B.HasQBuilder be, + ToJSON (table Identity), + FromJSON (table Identity), + Show (table Identity), + L.MonadFlow m + ) => + DBConfig beM -> + Maybe Text -> + [Set be table] -> + Where be table -> + m (Either DBError ()) +updateOneWoReturning dbConf (Just _) newVals whereClause = do + val <- updateOneSqlWoReturning dbConf newVals whereClause + -- whenRight val (\_ -> cacheWithKey cacheKey val) + return val +updateOneWoReturning dbConf Nothing value whereClause = updateOneSqlWoReturning dbConf value whereClause + +updateOneSqlWoReturning :: + forall m be beM table. + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + Model be table, + B.HasQBuilder be, + FromJSON (table Identity), + ToJSON (table Identity), + Show (table Identity), + L.MonadFlow m + ) => + DBConfig beM -> + [Set be table] -> + Where be table -> + m (DBResult ()) +updateOneSqlWoReturning dbConf newVals whereClause = do + let updateQuery = DB.updateRows $ sqlUpdate + ! #set newVals + ! #where_ whereClause + res <- runQuery dbConf updateQuery + case res of + Right x -> do + L.logDebug @Text "updateOneSqlWoReturning" "query executed" + return $ Right x + -- Right xs -> do + -- let message = "DB returned \"" <> show xs <> "\" after update" + -- L.logError @Text "create" message + -- return $ Left $ DBError UnexpectedResult message + Left e -> return $ Left e + +updateOneSql :: + forall m be beM table. + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + Model be table, + B.HasQBuilder be, + FromJSON (table Identity), + ToJSON (table Identity), + Show (table Identity), + L.MonadFlow m + ) => + DBConfig beM -> + [Set be table] -> + Where be table -> + m (DBResult (table Identity)) +updateOneSql dbConf newVals whereClause = do + let updateQuery = DB.updateRowsReturningList $ sqlUpdate + ! #set newVals + ! #where_ whereClause + res <- runQuery dbConf updateQuery + case res of + Right [x] -> return $ Right x + Right xs -> do + let message = "DB returned \"" <> show xs <> "\" after update" + L.logError @Text "create" message + return $ Left $ DBError UnexpectedResult message + Left e -> return $ Left e + +-- | Perform an arbitrary 'SqlUpdate'. This will cache if successful. +updateExtended :: (HasCallStack, L.MonadFlow m, BeamRunner beM, BeamRuntime be beM) => + DBConfig beM -> Maybe Text -> B.SqlUpdate be table -> m (Either DBError ()) +updateExtended dbConf mKey upd = do + res <- runQuery dbConf . DB.updateRows $ upd + maybe (pure ()) (`cacheWithKey` res) mKey + pure res + +-- | Find an element matching the query. Only uses the DB if the cache is empty. +-- Caches the result using the given key. +findOne :: + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + Model be table, + B.HasQBuilder be, + ToJSON (table Identity), + FromJSON (table Identity), + L.MonadFlow m + ) => + DBConfig beM -> + Maybe Text -> + Where be table -> + m (Either DBError (Maybe (table Identity))) +findOne dbConf (Just cacheKey) whereClause = do + mRes <- rGet (T.pack cacheName) cacheKey + case join mRes of + (Just res) -> return $ Right $ Just res + Nothing -> do + mDBRes <- findOneSql dbConf whereClause + whenRight mDBRes (cacheWithKey cacheKey) + return mDBRes +findOne dbConf Nothing whereClause = findOneSql dbConf whereClause + +-- | Find all elements matching the query. Only uses the DB if the cache is empty. +-- Caches the result using the given key. +-- NOTE: Can't use the same key as findOne, updateOne or create since it's result is a list. +findAll :: + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + Model be table, + B.HasQBuilder be, + ToJSON (table Identity), + FromJSON (table Identity), + L.MonadFlow m + ) => + DBConfig beM -> + Maybe Text -> + Where be table -> + m (Either DBError [table Identity]) +findAll dbConf (Just cacheKey) whereClause = do + mRes <- rGet (T.pack cacheName) cacheKey + case mRes of + (Just res) -> return $ Right res + Nothing -> do + mDBRes <- findAllSql dbConf whereClause + whenRight mDBRes (cacheWithKey cacheKey) + return mDBRes +findAll dbConf Nothing whereClause = findAllSql dbConf whereClause + +-- | Like 'findAll', but takes an explicit 'SqlSelect'. +findAllExtended :: forall beM be table m . + (HasCallStack, + L.MonadFlow m, + B.FromBackendRow be (table Identity), + BeamRunner beM, + BeamRuntime be beM, + FromJSON (table Identity), + ToJSON (table Identity)) => + DBConfig beM -> + Maybe Text -> + B.SqlSelect be (table Identity) -> + m (Either DBError [table Identity]) +findAllExtended dbConf mKey sel = case mKey of + Nothing -> go + Just k -> do + mCached <- rGet (T.pack cacheName) k + case mCached of + Just res -> pure . Right $ res + Nothing -> do + dbRes <- go + either (\_ -> pure ()) (cacheWithKey k) dbRes + pure dbRes + where + go :: m (Either DBError [table Identity]) + go = do + eConn <- getOrInitSqlConn dbConf + join <$> traverse (\conn -> L.runDB conn . DB.findRows $ sel) eConn + +------------ Helper functions ------------ +runQuery :: + ( HasCallStack, + BeamRuntime be beM, BeamRunner beM, + JSONEx a, + L.MonadFlow m + ) => + DBConfig beM -> DB.SqlDB beM a -> m (Either DBError a) +runQuery dbConf query = do + conn <- getOrInitSqlConn dbConf + case conn of + Right c -> L.runDB c query + Left e -> return $ Left e + +runQueryMySQL :: + ( HasCallStack, + JSONEx a, + L.MonadFlow m + ) => + DBConfig BM.MySQLM -> DB.SqlDB BM.MySQLM a -> m (Either DBError a) +runQueryMySQL dbConf query = do + conn <- getOrInitSqlConn dbConf + case conn of + Right c -> L.runTransaction c query + Left e -> return $ Left e + +sqlCreate :: + forall be table. + (HasCallStack, B.HasQBuilder be, Model be table) => + table Identity -> + B.SqlInsert be table +sqlCreate value = B.insert modelTableEntity (mkExprWithDefault value) + +createSql :: + forall m be beM table. + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + B.HasQBuilder be, + Model be table, + ToJSON (table Identity), + FromJSON (table Identity), + Show (table Identity), + L.MonadFlow m + ) => + DBConfig beM -> + table Identity -> + m (Either DBError (table Identity)) +createSql dbConf value = do + res <- runQuery dbConf $ DB.insertRowsReturningList $ sqlCreate value + case res of + Right [val] -> return $ Right val + Right xs -> do + let message = "DB returned \"" <> show xs <> "\" after inserting \"" <> show value <> "\"" + L.logError @Text "create" message + return $ Left $ DBError UnexpectedResult message + Left e -> return $ Left e + +createSqlMySQL :: + forall m table. + ( HasCallStack, + Model BM.MySQL table, + ToJSON (table Identity), + FromJSON (table Identity), + Show (table Identity), + L.MonadFlow m + ) => + DBConfig BM.MySQLM -> + table Identity -> + m (Either DBError (table Identity)) +createSqlMySQL dbConf value = do + res <- runQueryMySQL dbConf $ DB.insertRowReturningMySQL $ sqlCreate value + case res of + Right (Just val) -> return $ Right val + Right Nothing -> do + let message = "DB returned \"" <> "Nothing" <> "\" after inserting \"" <> show value <> "\"" + L.logError @Text "createSqlMySQL" message + return $ Left $ DBError UnexpectedResult message + Left e -> return $ Left e + +findOneSql :: + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + Model be table, + B.HasQBuilder be, + ToJSON (table Identity), + FromJSON (table Identity), + L.MonadFlow m + ) => + DBConfig beM -> + Where be table -> + m (Either DBError (Maybe (table Identity))) +findOneSql dbConf whereClause = runQuery dbConf findQuery + where findQuery = DB.findRow (sqlSelect ! #where_ whereClause ! defaults) + +findAllSql :: + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + Model be table, + B.HasQBuilder be, + JSONEx (table Identity), + L.MonadFlow m + ) => + DBConfig beM -> + Where be table -> + m (Either DBError [table Identity]) +findAllSql dbConf whereClause = do + let findQuery = DB.findRows (sqlSelect ! #where_ whereClause ! defaults) + sqlConn <- getOrInitSqlConn dbConf + join <$> mapM (`L.runDB` findQuery) sqlConn + +cacheWithKey :: (HasCallStack, ToJSON table, L.MonadFlow m) => Text -> table -> m () +cacheWithKey key row = do + -- TODO: Should we log errors here? + void $ rSetB (T.pack cacheName) (encodeUtf8 key) (BSL.toStrict $ encode row) diff --git a/src/EulerHS/Core/Api.hs b/src/EulerHS/Core/Api.hs index 0bb44d60..4b98af19 100644 --- a/src/EulerHS/Core/Api.hs +++ b/src/EulerHS/Core/Api.hs @@ -1,22 +1,8 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{- | -Module : EulerHS.Core.Api -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -This module contains implementation of the low-level HTTP client subsystem. - -This is an internal module. Import EulerHS.Types instead. --} - module EulerHS.Core.Api where - import EulerHS.Prelude import qualified Servant.Client as SC import qualified Servant.Client.Core as SCC @@ -24,44 +10,49 @@ import Servant.Client.Core.RunClient (RunClient) import qualified Servant.Client.Free as SCF import qualified Servant.Client.Internal.HttpClient as SCIHC import qualified Network.HTTP.Types as HTTP - -data LogServantRequest = LogServantRequest - { url :: SCF.BaseUrl - , method :: HTTP.Method - , body :: String - , headers :: Seq HTTP.Header - , queryString :: Seq HTTP.QueryItem - } - deriving (Show) +import qualified Data.ByteString.Lazy as LBS(toStrict) +import qualified Data.Text as Text (unpack) +import qualified EulerHS.Core.Types.Logger as Log (LogMaskingConfig(..)) +import EulerHS.Core.Masking newtype EulerClient a = EulerClient (Free SCF.ClientF a) deriving newtype (Functor, Applicative, Monad, RunClient) +data LogServantRequest + = LogServantRequest + { url :: SCF.BaseUrl + , method :: HTTP.Method + , body :: String + , headers :: Seq HTTP.Header + , queryString :: Seq HTTP.QueryItem + } + deriving (Show) + +data LogServantResponse + = LogServantResponse + { statusCode :: HTTP.Status + , headers :: Seq HTTP.Header + , httpVersion :: HTTP.HttpVersion + , body :: String + } + deriving (Show) + client :: SC.HasClient EulerClient api => Proxy api -> SC.Client EulerClient api client api = SCC.clientIn api $ Proxy @EulerClient --- Servant >=0.18.1 changes --- interpretClientF :: (String -> IO ()) -> SCC.BaseUrl -> SCF.ClientF a -> SC.ClientM a --- interpretClientF _ _ (SCF.Throw e) = throwM e --- interpretClientF logMsg bUrl (SCF.RunRequest req next) = do --- liftIO $ logServantRequest logMsg bUrl req --- res <- SCC.runRequestAcceptStatus Nothing req --- liftIO . logMsg $ show res --- pure $ next res - -interpretClientF :: (String -> IO ()) -> SCC.BaseUrl -> SCF.ClientF a -> SC.ClientM a -interpretClientF _ _ (SCF.Throw e) = throwM e -interpretClientF log bUrl (SCF.RunRequest req next) = do - case SCC.requestBody req of - Just (body, _) -> liftIO . log $ show body - Nothing -> pure () - liftIO . log $ show (SCIHC.requestToClientRequest bUrl req) - res <- SCC.runRequest req - liftIO . log $ show (res) +interpretClientF :: (String -> IO ()) -> Maybe Log.LogMaskingConfig -> SCC.BaseUrl -> SCF.ClientF a -> SC.ClientM a +interpretClientF _ _ _ (SCF.Throw e) = throwM e +interpretClientF log mbMaskConfig bUrl (SCF.RunRequest req next) = do + liftIO $ logServantRequest log mbMaskConfig bUrl req + res <- SCC.runRequestAcceptStatus Nothing req + liftIO $ logServantResponse log mbMaskConfig res pure $ next res -logServantRequest :: (String -> IO ()) -> SCC.BaseUrl -> SCC.Request -> IO () -logServantRequest log url req = do +runEulerClient :: (String -> IO()) -> Maybe Log.LogMaskingConfig -> SCC.BaseUrl -> EulerClient a -> SCIHC.ClientM a +runEulerClient log mbMaskConfig bUrl (EulerClient f) = foldFree (interpretClientF log mbMaskConfig bUrl) f + +logServantRequest :: (String -> IO ()) -> Maybe Log.LogMaskingConfig -> SCC.BaseUrl -> SCC.Request -> IO () +logServantRequest log mbMaskConfig url req = do log $ show $ LogServantRequest { url = url , method = method @@ -69,14 +60,40 @@ logServantRequest log url req = do , headers = headers , queryString = queryString } + where body = case SCC.requestBody req of - Just (b, _) -> show b + Just (reqbody, _) -> + case reqbody of + SCC.RequestBodyBS s -> Text.unpack $ parseRequestResponseBody (shouldMaskKey mbMaskConfig) getMaskText (getContentTypeForServant . toList $ SCC.requestHeaders req) s + SCC.RequestBodyLBS s -> Text.unpack $ parseRequestResponseBody (shouldMaskKey mbMaskConfig) getMaskText (getContentTypeForServant . toList $ SCC.requestHeaders req) $ LBS.toStrict s + SCC.RequestBodySource sr -> show $ SCC.RequestBodySource sr Nothing -> "body = (empty)" + method = SCC.requestMethod req - headers = SCC.requestHeaders req - queryString = SCC.requestQueryString req - -- liftIO . log $ show (SCIHC.requestToClientRequest bUrl req) + headers = maskServantHeaders (shouldMaskKey mbMaskConfig) getMaskText $ SCC.requestHeaders req + queryString = maskQueryStrings (shouldMaskKey mbMaskConfig) getMaskText $ SCC.requestQueryString req + + getMaskText :: Text + getMaskText = maybe defaultMaskText (fromMaybe defaultMaskText . Log._maskText) mbMaskConfig + +logServantResponse :: (String -> IO ()) -> Maybe Log.LogMaskingConfig -> SCC.Response -> IO () +logServantResponse log mbMaskConfig res = + log $ show $ LogServantResponse + { statusCode = status + , headers = responseheaders + , httpVersion = version + , body = responseBody + } + where + status = SCC.responseStatusCode res + responseheaders = maskServantHeaders (shouldMaskKey mbMaskConfig) getMaskText $ SCC.responseHeaders res + version = SCC.responseHttpVersion res + responseBody = + Text.unpack + . parseRequestResponseBody (shouldMaskKey mbMaskConfig) getMaskText (getContentTypeForServant . toList $ SCC.responseHeaders res) + . LBS.toStrict + $ SCC.responseBody res -runEulerClient :: (String -> IO()) -> SCC.BaseUrl -> EulerClient a -> SCIHC.ClientM a -runEulerClient log bUrl (EulerClient f) = foldFree (interpretClientF log bUrl) f + getMaskText :: Text + getMaskText = maybe defaultMaskText (fromMaybe defaultMaskText . Log._maskText) mbMaskConfig \ No newline at end of file diff --git a/src/EulerHS/Core/Interpreters.hs b/src/EulerHS/Core/Interpreters.hs index 9eaf214f..672f6f5e 100644 --- a/src/EulerHS/Core/Interpreters.hs +++ b/src/EulerHS/Core/Interpreters.hs @@ -1,16 +1,3 @@ -{- | -Module : EulerHS.Core.Interpreters -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -This module reexports interpreters of the core subsystems. - -This is an internal module. Import EulerHS.Interpreters instead. --} - module EulerHS.Core.Interpreters ( module X ) where diff --git a/src/EulerHS/Core/KVDB/Entries.hs b/src/EulerHS/Core/KVDB/Entries.hs deleted file mode 100644 index 0861b25c..00000000 --- a/src/EulerHS/Core/KVDB/Entries.hs +++ /dev/null @@ -1,311 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} - -module EulerHS.Core.KVDB.Entries where - - -import qualified Data.Aeson as A -import EulerHS.Prelude -import EulerHS.Types (MockedResult (..), RRItem (..)) -import qualified EulerHS.Types as T -import qualified EulerHS.Core.KVDB.Language as L - -data SetEntry = SetEntry - { jsonKey :: A.Value - , jsonValue :: A.Value - , jsonResult :: A.Value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -instance RRItem SetEntry where - getTag _ = "SetEntry" - -instance MockedResult SetEntry (Either T.KVDBReply T.KVDBStatus) where - getMock SetEntry {jsonResult} = T.jsonDecode jsonResult - -mkSetEntry :: ByteString -> ByteString -> Either T.KVDBReply T.KVDBStatus -> SetEntry -mkSetEntry k v r = SetEntry - (T.jsonEncode k) - (T.jsonEncode v) - (T.jsonEncode r) - ----------------------------------------------------------------------- - -data SetExEntry = SetExEntry - { jsonKey :: A.Value - , jsonTtl :: A.Value - , jsonValue :: A.Value - , jsonResult :: A.Value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -instance RRItem SetExEntry where - getTag _ = "SetExEntry" - -instance MockedResult SetExEntry (Either T.KVDBReply T.KVDBStatus) where - getMock SetExEntry {jsonResult} = T.jsonDecode jsonResult - -mkSetExEntry :: ByteString -> Integer -> ByteString -> Either T.KVDBReply T.KVDBStatus -> SetExEntry -mkSetExEntry k e v r = SetExEntry - (T.jsonEncode k) - (toJSON e) - (T.jsonEncode v) - (T.jsonEncode r) - ----------------------------------------------------------------------- - -data SetOptsEntry = SetOptsEntry - { jsonKey :: A.Value - , jsonValue :: A.Value - , jsonTTL :: A.Value - , jsonCond :: A.Value - , jsonResult :: A.Value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -instance RRItem SetOptsEntry where - getTag _ = "SetOptsEntry" - -instance MockedResult SetOptsEntry (Either T.KVDBReply Bool) where - getMock SetOptsEntry {jsonResult} = T.jsonDecode jsonResult - -mkSetOptsEntry :: ByteString -> ByteString -> L.KVDBSetTTLOption -> L.KVDBSetConditionOption -> Either T.KVDBReply Bool -> SetOptsEntry -mkSetOptsEntry k v ttl cond r = SetOptsEntry - (T.jsonEncode k) - (T.jsonEncode v) - (toJSON ttl) - (toJSON cond) - (T.jsonEncode r) - ----------------------------------------------------------------------- - -data GetEntry = GetEntry - { jsonKey :: A.Value - , jsonResult :: A.Value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -instance RRItem GetEntry where - getTag _ = "GetEntry" - -instance MockedResult GetEntry (Either T.KVDBReply (Maybe ByteString)) where - getMock GetEntry {jsonResult} = T.jsonDecode jsonResult - - -mkGetEntry :: ByteString -> Either T.KVDBReply (Maybe ByteString) -> GetEntry -mkGetEntry k r = GetEntry - (T.jsonEncode k) - (T.jsonEncode r) - ----------------------------------------------------------------------- - -data ExistsEntry = ExistsEntry - { jsonKey :: A.Value - , jsonResult :: A.Value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -instance RRItem ExistsEntry where - getTag _ = "ExistsEntry" - -instance MockedResult ExistsEntry (Either T.KVDBReply Bool) where - getMock ExistsEntry {jsonResult} = T.jsonDecode jsonResult - -mkExistsEntry :: ByteString -> Either T.KVDBReply Bool -> ExistsEntry -mkExistsEntry k r = ExistsEntry - (T.jsonEncode k) - (T.jsonEncode r) - --- ---------------------------------------------------------------------- - -data DelEntry = DelEntry - { jsonKeys :: A.Value - , jsonResult :: A.Value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -instance RRItem DelEntry where - getTag _ = "DelEntry" - -instance MockedResult DelEntry (Either T.KVDBReply Integer) where - getMock DelEntry {jsonResult} = T.jsonDecode jsonResult - -mkDelEntry :: [ByteString] -> Either T.KVDBReply Integer -> DelEntry -mkDelEntry k r = DelEntry - (T.jsonEncode k) - (T.jsonEncode r) - - --- ---------------------------------------------------------------------- - -data ExpireEntry = ExpireEntry - { jsonKey :: A.Value - , duration :: Integer - , jsonResult :: A.Value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -instance RRItem ExpireEntry where - getTag _ = "ExpireEntry" - -instance MockedResult ExpireEntry (Either T.KVDBReply Bool) where - getMock ExpireEntry {jsonResult} = T.jsonDecode jsonResult - -mkExpireEntry :: ByteString -> Integer -> Either T.KVDBReply Bool -> ExpireEntry -mkExpireEntry k d r = ExpireEntry - (T.jsonEncode k) - d - (T.jsonEncode r) - --- ---------------------------------------------------------------------- - -data IncrEntry = IncrEntry - { jsonKey :: A.Value - , jsonResult :: A.Value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -instance RRItem IncrEntry where - getTag _ = "IncrEntry" - -instance MockedResult IncrEntry (Either T.KVDBReply Integer) where - getMock IncrEntry {jsonResult} = T.jsonDecode jsonResult - -mkIncrEntry :: ByteString -> Either T.KVDBReply Integer -> IncrEntry -mkIncrEntry k r = IncrEntry - (T.jsonEncode k) - (T.jsonEncode r) - --- ---------------------------------------------------------------------- - -data HSetEntry = HSetEntry - { jsonKey :: A.Value - , jsonField :: A.Value - , jsonValue :: A.Value - , jsonResult :: A.Value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -instance RRItem HSetEntry where - getTag _ = "HSetEntry" - -instance MockedResult HSetEntry (Either T.KVDBReply Bool) where - getMock HSetEntry {jsonResult} = T.jsonDecode jsonResult - -mkHSetEntry :: ByteString -> ByteString -> ByteString -> Either T.KVDBReply Bool -> HSetEntry -mkHSetEntry k f v r = HSetEntry - (T.jsonEncode k) - (T.jsonEncode f) - (T.jsonEncode v) - (T.jsonEncode r) - --- ---------------------------------------------------------------------- - -data HGetEntry = HGetEntry - { jsonKey :: A.Value - , jsonField :: A.Value - , jsonResult :: A.Value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -instance RRItem HGetEntry where - getTag _ = "HGetEntry" - -instance MockedResult HGetEntry (Either T.KVDBReply (Maybe ByteString)) where - getMock HGetEntry {jsonResult} = T.jsonDecode jsonResult - -mkHGetEntry :: ByteString -> ByteString -> Either T.KVDBReply (Maybe ByteString) -> HGetEntry -mkHGetEntry k f r = HGetEntry - (T.jsonEncode k) - (T.jsonEncode f) - (T.jsonEncode r) - --- ---------------------------------------------------------------------- - -data XAddEntry = XAddEntry - { jsonStream :: A.Value - , jsonEntryId :: A.Value - , jsonItems :: A.Value - , jsonResult :: A.Value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -instance RRItem XAddEntry where - getTag _ = "XAddEntry" - -instance MockedResult XAddEntry (Either T.KVDBReply L.KVDBStreamEntryID) where - getMock XAddEntry {jsonResult} = T.jsonDecode jsonResult - -mkXAddEntry :: ByteString -> L.KVDBStreamEntryIDInput -> [L.KVDBStreamItem] -> Either T.KVDBReply L.KVDBStreamEntryID -> XAddEntry -mkXAddEntry s e i r = XAddEntry - (T.jsonEncode s) - (toJSON e) - (T.jsonEncode i) - (T.jsonEncode r) - --- ---------------------------------------------------------------------- - -data XLenEntry = XLenEntry - { jsonStream :: A.Value - , jsonResult :: A.Value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -instance RRItem XLenEntry where - getTag _ = "XLenEntry" - -instance MockedResult XLenEntry (Either T.KVDBReply Integer) where - getMock XLenEntry {jsonResult} = T.jsonDecode jsonResult - -mkXLenEntry :: ByteString -> Either T.KVDBReply Integer -> XLenEntry -mkXLenEntry s r = XLenEntry - (T.jsonEncode s) - (T.jsonEncode r) - --- ---------------------------------------------------------------------- - -jsonExDecode :: forall a . T.JSONEx a => A.Value -> Maybe a -jsonExDecode = T.resolveJSONEx @a T.jsonDecode T.fromJSONMaybe - -data MultiExecEntry = MultiExecEntry - { jsonResult :: A.Value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -instance RRItem MultiExecEntry where - getTag _ = "MultiExecEntry" - -instance T.JSONEx a => MockedResult MultiExecEntry (Either T.KVDBReply (T.TxResult a)) where - getMock MultiExecEntry {jsonResult} = - case temp of - Nothing -> Nothing - Just (Left e) -> Just $ Left e - Just (Right (T.TxSuccess Nothing )) -> Nothing - Just (Right (T.TxSuccess (Just a))) -> Just $ Right $ T.TxSuccess a - Just (Right (T.TxAborted )) -> Just $ Right $ T.TxAborted - Just (Right (T.TxError s )) -> Just $ Right $ T.TxError s - where - temp :: Maybe (Either T.KVDBReply (T.TxResult (Maybe a))) - temp = fmap (fmap (fmap jsonExDecode)) $ jsonExDecode jsonResult - - -mkMultiExecEntry :: forall a . T.JSONEx a => Either T.KVDBReply (T.TxResult a) -> MultiExecEntry -mkMultiExecEntry r = MultiExecEntry $ - A.toJSON $ fmap (A.toJSON1 . fmap (T.resolveJSONEx @a T.jsonEncode toJSON)) r - - --- MultiExecWithHash - -data MultiExecWithHashEntry = MultiExecWithHashEntry - { hashValue :: A.Value - , jsonResult :: A.Value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -instance RRItem MultiExecWithHashEntry where - getTag _ = "MultiExecWithHashEntry" - -instance T.JSONEx a => MockedResult MultiExecWithHashEntry (Either T.KVDBReply (T.TxResult a)) where - getMock MultiExecWithHashEntry {jsonResult} = - case temp of - Nothing -> Nothing - Just (Left e) -> Just $ Left e - Just (Right (T.TxSuccess Nothing )) -> Nothing - Just (Right (T.TxSuccess (Just a))) -> Just $ Right $ T.TxSuccess a - Just (Right (T.TxAborted )) -> Just $ Right $ T.TxAborted - Just (Right (T.TxError s )) -> Just $ Right $ T.TxError s - where - temp :: Maybe (Either T.KVDBReply (T.TxResult (Maybe a))) - temp = fmap (fmap (fmap jsonExDecode)) $ jsonExDecode jsonResult - - -mkMultiExecWithHashEntry :: forall a . T.JSONEx a => ByteString -> Either T.KVDBReply (T.TxResult a) -> MultiExecWithHashEntry -mkMultiExecWithHashEntry h r = MultiExecWithHashEntry (T.jsonEncode h) $ - A.toJSON $ fmap (A.toJSON1 . fmap (T.resolveJSONEx @a T.jsonEncode toJSON)) r \ No newline at end of file diff --git a/src/EulerHS/Core/KVDB/Interpreter.hs b/src/EulerHS/Core/KVDB/Interpreter.hs index 9b8d976a..9cd60b04 100644 --- a/src/EulerHS/Core/KVDB/Interpreter.hs +++ b/src/EulerHS/Core/KVDB/Interpreter.hs @@ -1,182 +1,181 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} module EulerHS.Core.KVDB.Interpreter ( -- * KVDB Interpreter runKVDB ) where -import EulerHS.Prelude - import qualified Data.Map as Map -import qualified Database.Redis as R import qualified Data.Text as T import qualified Data.Text.Encoding as TE +import qualified Data.Text.Encoding.Error as TE +import qualified Database.Redis as R import qualified EulerHS.Core.KVDB.Language as L -import EulerHS.Core.Types.KVDB - -import qualified EulerHS.Core.KVDB.Entries as E -import qualified EulerHS.Core.Playback.Machine as P import qualified EulerHS.Core.Types as D - +import EulerHS.Core.Types.KVDB +import EulerHS.Prelude interpretKeyValueF - :: (forall b . R.Redis (Either R.Reply b) -> IO (Either KVDBReply b)) - -> D.RunMode + :: HasCallStack + => (forall b . R.Redis (Either R.Reply b) -> IO (Either KVDBReply b)) -> L.KeyValueF (Either KVDBReply) a -> IO a -interpretKeyValueF runRedis runMode (L.Set k v next) = - fmap next $ P.withRunMode runMode (E.mkSetEntry k v) $ - fmap (second fromRdStatus) $ runRedis $ R.set k v +interpretKeyValueF runRedis (L.Set k v next) = + next . second fromRdStatus <$> runRedis (R.set k v) -interpretKeyValueF runRedis runMode (L.SetEx k e v next) = - fmap next $ P.withRunMode runMode (E.mkSetExEntry k e v) $ - fmap (second fromRdStatus) $ runRedis $ R.setex k e v +interpretKeyValueF runRedis (L.SetEx k e v next) = + next . second fromRdStatus <$> runRedis (R.setex k e v) -interpretKeyValueF runRedis runMode (L.SetOpts k v ttl cond next) = - fmap next $ P.withRunMode runMode (E.mkSetOptsEntry k v ttl cond) $ do +interpretKeyValueF runRedis (L.SetOpts k v ttl cond next) = + fmap next $ do result <- runRedis $ R.setOpts k v (makeSetOpts ttl cond) pure $ case result of - Right _ -> Right True + Right _ -> Right True -- (nil) is ok, app should not fail Left (Bulk Nothing) -> Right False - Left reply -> Left reply + Left reply -> Left reply -interpretKeyValueF runRedis runMode (L.Get k next) = - fmap next $ P.withRunMode runMode (E.mkGetEntry k) $ +interpretKeyValueF runRedis (L.Get k next) = + fmap next $ runRedis $ R.get k -interpretKeyValueF runRedis runMode (L.Exists k next) = - fmap next $ P.withRunMode runMode (E.mkExistsEntry k) $ +interpretKeyValueF runRedis (L.Exists k next) = + fmap next $ runRedis $ R.exists k -interpretKeyValueF _ runMode (L.Del [] next) = - fmap next $ P.withRunMode runMode (E.mkDelEntry []) $ - pure $ pure 0 +interpretKeyValueF _ (L.Del [] next) = + pure . next . pure $ 0 -interpretKeyValueF runRedis runMode (L.Del ks next) = - fmap next $ P.withRunMode runMode (E.mkDelEntry ks) $ +interpretKeyValueF runRedis (L.Del ks next) = + fmap next $ runRedis $ R.del ks -interpretKeyValueF runRedis runMode (L.Expire k sec next) = - fmap next $ P.withRunMode runMode (E.mkExpireEntry k sec) $ +interpretKeyValueF runRedis (L.Expire k sec next) = + fmap next $ runRedis $ R.expire k sec -interpretKeyValueF runRedis runMode (L.Incr k next) = - fmap next $ P.withRunMode runMode (E.mkIncrEntry k) $ +interpretKeyValueF runRedis (L.Incr k next) = + fmap next $ runRedis $ R.incr k -interpretKeyValueF runRedis runMode (L.HSet k field value next) = - fmap next $ P.withRunMode runMode (E.mkHSetEntry k field value) $ +interpretKeyValueF runRedis (L.HSet k field value next) = + fmap next $ runRedis $ R.hset k field value -interpretKeyValueF runRedis runMode (L.HGet k field next) = - fmap next $ P.withRunMode runMode (E.mkHGetEntry k field) $ +interpretKeyValueF runRedis (L.HGet k field next) = + fmap next $ runRedis $ R.hget k field -interpretKeyValueF runRedis runMode (L.XAdd stream entryId items next) = - fmap next $ P.withRunMode runMode (E.mkXAddEntry stream entryId items) $ +interpretKeyValueF runRedis (L.XAdd stream entryId items next) = + fmap next $ runRedis $ do result <- R.xadd stream (makeStreamEntryId entryId) items pure $ parseStreamEntryId <$> result where - makeStreamEntryId (L.EntryID (L.KVDBStreamEntryID ms ss)) - = show ms <> "-" <> show ss + makeStreamEntryId (L.EntryID (L.KVDBStreamEntryID ms sq)) = show ms <> "-" <> show sq makeStreamEntryId L.AutoID = "*" - -- FIXME: this is a very dirty code! - unpackHelper bs = read . T.unpack <$> T.splitOn "-" (TE.decodeUtf8 bs) - parseStreamEntryId bs = case unpackHelper bs of - [ms, ss] -> L.KVDBStreamEntryID ms ss - _ -> error "Failed to unpack " + parseStreamEntryId bs = + -- "number-number" is redis entry id invariant + let [ms, sq] = read . T.unpack <$> T.splitOn "-" (TE.decodeUtf8With TE.lenientDecode bs) + in L.KVDBStreamEntryID ms sq -interpretKeyValueF runRedis runMode (L.XLen stream next) = - fmap next $ P.withRunMode runMode (E.mkXLenEntry stream) $ +interpretKeyValueF runRedis (L.XLen stream next) = + fmap next $ runRedis $ R.xlen stream +interpretKeyValueF runRedis (L.SAdd k v next) = + fmap next $ runRedis $ R.sadd k v + +interpretKeyValueF runRedis (L.SMem k v next) = + fmap next $ runRedis $ R.sismember k v -interpretKeyValueTxF :: L.KeyValueF R.Queued a -> R.RedisTx a +interpretKeyValueF runRedis (L.Raw args next) = next <$> runRedis (R.sendRequest args) + +interpretKeyValueTxF :: HasCallStack => L.KeyValueF R.Queued a -> R.RedisTx a interpretKeyValueTxF (L.Set k v next) = - fmap next $ fmap (fmap D.fromRdStatus) $ R.set k v + next . fmap D.fromRdStatus <$> R.set k v interpretKeyValueTxF (L.SetEx k e v next) = - fmap next $ fmap (fmap D.fromRdStatus) $ R.setex k e v + next . fmap D.fromRdStatus <$> R.setex k e v interpretKeyValueTxF (L.SetOpts k v ttl cond next) = - fmap next $ fmap (fmap rdStatusToBool) $ R.setOpts k v (makeSetOpts ttl cond) - where - rdStatusToBool R.Ok = True - rdStatusToBool _ = False + next . fmap (R.Ok ==) <$> (R.setOpts k v . makeSetOpts ttl $ cond) interpretKeyValueTxF (L.Get k next) = - fmap next $ R.get k + next <$> R.get k interpretKeyValueTxF (L.Exists k next) = - fmap next $ R.exists k + next <$> R.exists k interpretKeyValueTxF (L.Del [] next) = - fmap next $ return $ pure 0 + pure . next . pure $ 0 interpretKeyValueTxF (L.Del ks next) = - fmap next $ R.del ks + next <$> R.del ks interpretKeyValueTxF (L.Expire k sec next) = - fmap next $ R.expire k sec + next <$> R.expire k sec interpretKeyValueTxF (L.Incr k next) = - fmap next $ R.incr k + next <$> R.incr k interpretKeyValueTxF (L.HSet k field value next) = - fmap next $ R.hset k field value + next <$> R.hset k field value interpretKeyValueTxF (L.HGet k field next) = - fmap next $ R.hget k field + next <$> R.hget k field interpretKeyValueTxF (L.XLen stream next) = - fmap next $ R.xlen stream + next <$> R.xlen stream interpretKeyValueTxF (L.XAdd stream entryId items next) = - fmap next $ fmap (fmap parseStreamEntryId) $ R.xadd stream (makeStreamEntryId entryId) items + next . fmap parseStreamEntryId <$> R.xadd stream (makeStreamEntryId entryId) items where - makeStreamEntryId (L.EntryID (L.KVDBStreamEntryID ms ss)) = show ms <> "-" <> show ss + makeStreamEntryId (L.EntryID (L.KVDBStreamEntryID ms sq)) = show ms <> "-" <> show sq makeStreamEntryId L.AutoID = "*" - -- FIXME: this is a very dirty code! - unpackHelper bs = read . T.unpack <$> T.splitOn "-" (TE.decodeUtf8 bs) - parseStreamEntryId bs = case unpackHelper bs of - [ms, ss] -> L.KVDBStreamEntryID ms ss - _ -> error "Failed to unpack " + parseStreamEntryId bs = + -- "number-number" is redis entry id invariant + -- TODO: + let [ms, sq] = read . T.unpack <$> T.splitOn "-" (TE.decodeUtf8With TE.lenientDecode bs) + in L.KVDBStreamEntryID ms sq + +interpretKeyValueTxF (L.SAdd k v next) = + next <$> R.sadd k v + +interpretKeyValueTxF (L.SMem k v next) = + next <$> R.sismember k v + +interpretKeyValueTxF (L.Raw args next) = next <$> R.sendRequest args interpretTransactionF - :: (forall b. R.Redis (Either R.Reply b) -> IO (Either KVDBReply b)) - -> D.RunMode + :: HasCallStack + => (forall b. R.Redis (Either R.Reply b) -> IO (Either KVDBReply b)) -> L.TransactionF a -> IO a -interpretTransactionF runRedis runMode (L.MultiExec dsl next) = - fmap next $ P.withRunMode runMode E.mkMultiExecEntry $ +interpretTransactionF runRedis (L.MultiExec dsl next) = + fmap next $ runRedis $ fmap (Right . fromRdTxResult) $ R.multiExec $ foldF interpretKeyValueTxF dsl -interpretTransactionF runRedis runMode (L.MultiExecWithHash h dsl next) = - fmap next $ P.withRunMode runMode (E.mkMultiExecWithHashEntry h) $ +interpretTransactionF runRedis (L.MultiExecWithHash h dsl next) = + fmap next $ runRedis $ fmap (Right . fromRdTxResult) $ R.multiExecWithHash h $ foldF interpretKeyValueTxF dsl interpretDbF :: (forall b. R.Redis (Either R.Reply b) -> IO (Either KVDBReply b)) - -> D.RunMode -> L.KVDBF a -> IO a -interpretDbF runRedis runMode (L.KV f) = interpretKeyValueF runRedis runMode f -interpretDbF runRedis runMode (L.TX f) = interpretTransactionF runRedis runMode f +interpretDbF runRedis (L.KV f) = interpretKeyValueF runRedis f +interpretDbF runRedis (L.TX f) = interpretTransactionF runRedis f -runKVDB :: Text -> D.RunMode -> MVar (Map Text NativeKVDBConn) -> L.KVDB a -> IO (Either KVDBReply a) -runKVDB cName runMode kvdbConnMapMVar = +runKVDB :: HasCallStack => Text -> MVar (Map Text NativeKVDBConn) -> L.KVDB a -> IO (Either KVDBReply a) +runKVDB cName kvdbConnMapMVar = fmap (join . first exceptionToKVDBReply) . try @_ @SomeException . - foldF (interpretDbF runRedis runMode) . runExceptT + foldF (interpretDbF runRedis) . runExceptT where runRedis :: R.Redis (Either R.Reply a) -> IO (Either KVDBReply a) runRedis redisDsl = do @@ -185,25 +184,25 @@ runKVDB cName runMode kvdbConnMapMVar = Nothing -> pure $ Left $ KVDBError KVDBConnectionDoesNotExist "Can't find redis connection" Just conn -> case conn of - NativeKVDB c -> fmap (first hedisReplyToKVDBReply) $ R.runRedis c redisDsl + NativeKVDB c -> first hedisReplyToKVDBReply <$> R.runRedis c redisDsl NativeKVDBMockedConn -> pure $ Right $ error "Result of runRedis with mocked connection should not ever be evaluated" -makeSetOpts :: L.KVDBSetTTLOption -> L.KVDBSetConditionOption -> R.SetOpts +makeSetOpts :: HasCallStack => L.KVDBSetTTLOption -> L.KVDBSetConditionOption -> R.SetOpts makeSetOpts ttl cond = R.SetOpts { setSeconds = case ttl of L.Seconds s -> Just s - _ -> Nothing + _ -> Nothing , setMilliseconds = case ttl of L.Milliseconds ms -> Just ms - _ -> Nothing + _ -> Nothing , setCondition = case cond of - L.SetAlways -> Nothing - L.SetIfExist -> Just R.Xx + L.SetAlways -> Nothing + L.SetIfExist -> Just R.Xx L.SetIfNotExist -> Just R.Nx } diff --git a/src/EulerHS/Core/KVDB/Language.hs b/src/EulerHS/Core/KVDB/Language.hs index bbd44e3e..c685a7ac 100644 --- a/src/EulerHS/Core/KVDB/Language.hs +++ b/src/EulerHS/Core/KVDB/Language.hs @@ -1,24 +1,6 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -Werror #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DeriveAnyClass #-} - -{- | -Module : EulerHS.Core.KVDB.Language -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -Language of the KV DB subsystem. - -Currently, highly resembles the `hedis` library interface to Redis. -Other KV DBs are not yet supported. - -This module is internal and should not imported in the projects. -Import 'EulerHS.Language' instead. --} +{-# LANGUAGE MultiParamTypeClasses #-} module EulerHS.Core.KVDB.Language ( @@ -46,74 +28,50 @@ module EulerHS.Core.KVDB.Language , hsetTx, hgetTx , xaddTx, xlenTx , expireTx + -- *** Set + , sadd + , sismember + -- *** Raw + , rawRequest ) where -import qualified Data.Aeson as A import qualified Database.Redis as R import qualified EulerHS.Core.Types as T import EulerHS.Prelude hiding (get) --- | TTL options for the `set` operaion data KVDBSetTTLOption = NoTTL - -- ^ No TTL | Seconds Integer - -- ^ TTL in seconds | Milliseconds Integer - -- ^ TTL in millisecons deriving stock Generic - deriving anyclass A.ToJSON --- | Options for the `set` operation data KVDBSetConditionOption = SetAlways - -- ^ Set value no matter what | SetIfExist - -- ^ Set if exist | SetIfNotExist - -- ^ Set if not exist deriving stock Generic - deriving anyclass A.ToJSON --- | Raw key value (ByteString) type KVDBKey = ByteString - --- | Raw value (ByteString) type KVDBValue = ByteString - --- | Duration (seconds) type KVDBDuration = Integer - --- | Field type KVDBField = ByteString - --- | Channel type KVDBChannel = ByteString - --- | Message type KVDBMessage = ByteString --- | Stream type KVDBStream = ByteString --- | ID of a stream entity data KVDBStreamEntryID = KVDBStreamEntryID Integer Integer deriving stock Generic - deriving anyclass (A.ToJSON, A.FromJSON) --- | Input of a stream entity data KVDBStreamEntryIDInput = EntryID KVDBStreamEntryID | AutoID deriving stock Generic - deriving anyclass A.ToJSON --- | Stream item type KVDBStreamItem = (ByteString, ByteString) ---------------------------------------------------------------------- --- | Algebra of the KV DB language data KeyValueF f next where Set :: KVDBKey -> KVDBValue -> (f T.KVDBStatus -> next) -> KeyValueF f next SetEx :: KVDBKey -> KVDBDuration -> KVDBValue -> (f T.KVDBStatus -> next) -> KeyValueF f next @@ -127,6 +85,9 @@ data KeyValueF f next where HGet :: KVDBKey -> KVDBField -> (f (Maybe ByteString) -> next) -> KeyValueF f next XAdd :: KVDBStream -> KVDBStreamEntryIDInput -> [KVDBStreamItem] -> (f KVDBStreamEntryID -> next) -> KeyValueF f next XLen :: KVDBStream -> (f Integer -> next) -> KeyValueF f next + SAdd :: KVDBKey -> [KVDBValue] -> (f Integer -> next) -> KeyValueF f next + SMem :: KVDBKey -> KVDBKey -> (f Bool -> next) -> KeyValueF f next + Raw :: (R.RedisResult a) => [ByteString] -> (f a -> next) -> KeyValueF f next instance Functor (KeyValueF f) where fmap f (Set k value next) = Set k value (f . next) @@ -141,40 +102,36 @@ instance Functor (KeyValueF f) where fmap f (HGet k field next) = HGet k field (f . next) fmap f (XAdd s entryId items next) = XAdd s entryId items (f . next) fmap f (XLen s next) = XLen s (f . next) + fmap f (SAdd k v next) = SAdd k v (f . next) + fmap f (SMem k v next) = SMem k v (f . next) + fmap f (Raw args next) = Raw args (f . next) --- | KV DB transactional monadic language type KVDBTx = F (KeyValueF R.Queued) ---------------------------------------------------------------------- --- | Algebra of the transactional evaluation --- ('Exec' in hedis notaion) data TransactionF next where MultiExec - :: T.JSONEx a - => KVDBTx (R.Queued a) + :: KVDBTx (R.Queued a) -> (T.KVDBAnswer (T.TxResult a) -> next) -> TransactionF next MultiExecWithHash - :: T.JSONEx a - => ByteString + :: ByteString -> KVDBTx (R.Queued a) -> (T.KVDBAnswer (T.TxResult a) -> next) -> TransactionF next instance Functor TransactionF where - fmap f (MultiExec dsl next) = MultiExec dsl (f . next) + fmap f (MultiExec dsl next) = MultiExec dsl (f . next) fmap f (MultiExecWithHash h dsl next) = MultiExecWithHash h dsl (f . next) ---------------------------------------------------------------------- --- | Top-level algebra combining either a transactional or regular language method data KVDBF next = KV (KeyValueF T.KVDBAnswer next) | TX (TransactionF next) deriving Functor --- | Main KV DB language type KVDB next = ExceptT T.KVDBReply (F KVDBF) next ---------------------------------------------------------------------- @@ -206,14 +163,13 @@ delTx ks = liftFC $ Del ks id expireTx :: KVDBKey -> KVDBDuration -> KVDBTx (R.Queued Bool) expireTx key sec = liftFC $ Expire key sec id --- | Add entities to a stream xaddTx :: KVDBStream -> KVDBStreamEntryIDInput -> [KVDBStreamItem] -> KVDBTx (R.Queued KVDBStreamEntryID) xaddTx stream entryId items = liftFC $ XAdd stream entryId items id --- | Get length of a stream xlenTx :: KVDBStream -> KVDBTx (R.Queued Integer) xlenTx stream = liftFC $ XLen stream id +--- -- | Set the value of a key set :: KVDBKey -> KVDBValue -> KVDB T.KVDBStatus set key value = ExceptT $ liftFC $ KV $ Set key value id @@ -222,7 +178,6 @@ set key value = ExceptT $ liftFC $ KV $ Set key value id setex :: KVDBKey -> KVDBDuration -> KVDBValue -> KVDB T.KVDBStatus setex key ex value = ExceptT $ liftFC $ KV $ SetEx key ex value id --- | Specify set operation options setOpts :: KVDBKey -> KVDBValue -> KVDBSetTTLOption -> KVDBSetConditionOption -> KVDB Bool setOpts key value ttl cond = ExceptT $ liftFC $ KV $ SetOpts key value ttl cond id @@ -254,18 +209,33 @@ hset key field value = ExceptT $ liftFC $ KV $ HSet key field value id hget :: KVDBKey -> KVDBField -> KVDB (Maybe ByteString) hget key field = ExceptT $ liftFC $ KV $ HGet key field id --- | Add entities to a stream xadd :: KVDBStream -> KVDBStreamEntryIDInput -> [KVDBStreamItem] -> KVDB KVDBStreamEntryID xadd stream entryId items = ExceptT $ liftFC $ KV $ XAdd stream entryId items id --- | Get length of a stream xlen :: KVDBStream -> KVDB Integer xlen stream = ExceptT $ liftFC $ KV $ XLen stream id +-- | Add one or more members to a set +sadd :: KVDBKey -> [KVDBValue] -> KVDB Integer +sadd setKey setmem = ExceptT $ liftFC $ KV $ SAdd setKey setmem id + +sismember :: KVDBKey -> KVDBKey -> KVDB Bool +sismember key member = ExceptT $ liftFC $ KV $ SMem key member id + -- | Run commands inside a transaction(suited only for standalone redis setup). -multiExec :: T.JSONEx a => KVDBTx (R.Queued a) -> KVDB (T.TxResult a) +multiExec :: KVDBTx (R.Queued a) -> KVDB (T.TxResult a) multiExec kvtx = ExceptT $ liftFC $ TX $ MultiExec kvtx id -- | Run commands inside a transaction(suited only for cluster redis setup). -multiExecWithHash :: T.JSONEx a => ByteString -> KVDBTx (R.Queued a) -> KVDB (T.TxResult a) +multiExecWithHash :: ByteString -> KVDBTx (R.Queued a) -> KVDB (T.TxResult a) multiExecWithHash h kvtx = ExceptT $ liftFC $ TX $ MultiExecWithHash h kvtx id + +-- | Perform a raw call against the underlying Redis data store. This is +-- definitely unsafe, and should only be used if you know what you're doing. +-- +-- /See also:/ The +-- [Hedis function](http://hackage.haskell.org/package/hedis-0.12.8/docs/Database-Redis.html#v:sendRequest) this is based on. +-- +-- @since 2.0.3.2 +rawRequest :: (R.RedisResult a) => [ByteString] -> KVDB a +rawRequest args = ExceptT . liftFC . KV . Raw args $ id diff --git a/src/EulerHS/Core/Language.hs b/src/EulerHS/Core/Language.hs index 0456e499..115987d1 100644 --- a/src/EulerHS/Core/Language.hs +++ b/src/EulerHS/Core/Language.hs @@ -1,17 +1,3 @@ -{- | -Module : EulerHS.Core.Types -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -This module reexports the language of the core subsystems. - -This is an internal module. Import EulerHS.Language instead. --} - - module EulerHS.Core.Language ( module X ) where diff --git a/src/EulerHS/Core/Logger/Entries.hs b/src/EulerHS/Core/Logger/Entries.hs deleted file mode 100644 index 69c153bd..00000000 --- a/src/EulerHS/Core/Logger/Entries.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module EulerHS.Core.Logger.Entries where - - -import EulerHS.Prelude -import EulerHS.Types (MockedResult (..), RRItem (..)) -import qualified EulerHS.Types as T - - -data LogMessageEntry = LogMessageEntry - { level :: T.LogLevel - , tag :: T.Tag - , msg :: T.Message - } deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) - -mkLogMessageEntry - :: T.LogLevel - -> T.Tag - -> T.Message - -> a - -> LogMessageEntry -mkLogMessageEntry level tag msg _ = LogMessageEntry level tag msg - -instance RRItem LogMessageEntry where - getTag _ = "LogMessageEntry" - -instance MockedResult LogMessageEntry () where - getMock _ = Just () - diff --git a/src/EulerHS/Core/Logger/Impl/TinyLogger.hs b/src/EulerHS/Core/Logger/Impl/TinyLogger.hs index 3a136cc4..7a0bc553 100644 --- a/src/EulerHS/Core/Logger/Impl/TinyLogger.hs +++ b/src/EulerHS/Core/Logger/Impl/TinyLogger.hs @@ -10,7 +10,6 @@ module EulerHS.Core.Logger.Impl.TinyLogger , createVoidLogger , disposeLogger , withLogger - , withLogger' , defaultDateFormat , defaultRenderer , defaultBufferSize @@ -21,6 +20,8 @@ import EulerHS.Prelude hiding ((.=)) import Control.Concurrent (forkOn, getNumCapabilities) import qualified Control.Concurrent.Chan.Unagi.Bounded as Chan import qualified System.Logger as Log +import qualified System.Logger.Message as LogMsg + import qualified EulerHS.Core.Types as T type LogQueue = (Chan.InChan T.PendingMsg, Chan.OutChan T.PendingMsg) @@ -39,10 +40,17 @@ dispatchLogLevel T.Warning = Log.Warn dispatchLogLevel T.Error = Log.Error logPendingMsg :: T.FlowFormatter -> Loggers -> T.PendingMsg -> IO () -logPendingMsg flowFormatter loggers pendingMsg@(T.PendingMsg mbFlowGuid lvl _ _ _) = do +logPendingMsg flowFormatter loggers pendingMsg@(T.PendingMsg mbFlowGuid lvl tag msg msgNum logContext) = do formatter <- flowFormatter mbFlowGuid + let msgBuilder = formatter pendingMsg let lvl' = dispatchLogLevel lvl - let msg' = Log.msg $ formatter pendingMsg + let msg' = case msgBuilder of + T.SimpleString str -> Log.msg str + T.SimpleText txt -> Log.msg txt + T.SimpleBS bs -> Log.msg bs + T.SimpleLBS lbs -> Log.msg lbs + T.MsgBuilder bld -> Log.msg bld + T.MsgTransformer f -> f mapM_ (\logger -> Log.log logger lvl' msg') loggers loggerWorker :: T.FlowFormatter -> Chan.OutChan T.PendingMsg -> Loggers -> IO () @@ -73,7 +81,7 @@ createLogger' mbRenderer bufferSize flowFormatter - (T.LoggerConfig isAsync _ logFileName isConsoleLog isFileLog maxQueueSize _) = do + (T.LoggerConfig isAsync _ logFileName isConsoleLog isFileLog maxQueueSize _ _) = do let fileSettings = Log.setFormat mbDateFormat @@ -120,9 +128,19 @@ disposeLogger _ (SyncLoggerHandle loggers) = do disposeLogger flowFormatter (AsyncLoggerHandle threadIds (_, outChan) loggers) = do putStrLn @String "Disposing async logger..." traverse_ killThread threadIds - Chan.getChanContents outChan >>= mapM_ (logPendingMsg flowFormatter loggers) + logRemaining outChan mapM_ Log.flush loggers mapM_ Log.close loggers + where + logRemaining :: Chan.OutChan T.PendingMsg -> IO () + logRemaining oc = do + (el,_) <- Chan.tryReadChan oc + mPendingMsg <- Chan.tryRead el + case mPendingMsg of + Just pendingMsg -> do + logPendingMsg flowFormatter loggers pendingMsg + logRemaining oc + Nothing -> pure () withLogger' :: Maybe Log.DateFormat diff --git a/src/EulerHS/Core/Logger/Interpreter.hs b/src/EulerHS/Core/Logger/Interpreter.hs index 5ae3d516..13589763 100644 --- a/src/EulerHS/Core/Logger/Interpreter.hs +++ b/src/EulerHS/Core/Logger/Interpreter.hs @@ -10,43 +10,51 @@ where import EulerHS.Prelude import qualified EulerHS.Core.Language as L -import qualified EulerHS.Core.Logger.Entries as E import qualified EulerHS.Core.Logger.Impl.TinyLogger as Impl -import qualified EulerHS.Core.Playback.Machine as P import qualified EulerHS.Core.Runtime as R import qualified EulerHS.Core.Types as T import qualified Control.Concurrent.MVar as MVar import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.ByteString.Lazy as LBS -interpretLogger :: Maybe T.FlowGUID -> T.RunMode -> R.LoggerRuntime -> L.LoggerMethod a -> IO a +interpretLogger :: Maybe T.FlowGUID -> R.LoggerRuntime -> L.LoggerMethod a -> IO a + +-- Memory logger interpretLogger mbFlowGuid - runMode - (R.MemoryLoggerRuntime flowFormatter logLevel logsVar cntVar) + (R.MemoryLoggerRuntime flowFormatter logContext logLevel logsVar cntVar) (L.LogMessage msgLogLvl tag msg next) = - fmap next $ P.withRunMode runMode (E.mkLogMessageEntry msgLogLvl tag msg) $ + fmap next $ case compare logLevel msgLogLvl of GT -> pure () _ -> do formatter <- flowFormatter mbFlowGuid !msgNum <- R.incLogCounter cntVar - let !m = T.pack $ formatter $ T.PendingMsg mbFlowGuid msgLogLvl tag msg msgNum + let msgBuilder = formatter $ T.PendingMsg mbFlowGuid msgLogLvl tag msg msgNum logContext + let !m = case msgBuilder of + T.SimpleString str -> T.pack str + T.SimpleText txt -> txt + T.SimpleBS bs -> T.decodeUtf8 bs + T.SimpleLBS lbs -> T.decodeUtf8 $ LBS.toStrict lbs + T.MsgBuilder bld -> T.decodeUtf8 $ LBS.toStrict $ T.builderToByteString bld + T.MsgTransformer _ -> error "Msg -> Msg not supported for memory logger." MVar.modifyMVar logsVar $ \(!lgs) -> pure (m : lgs, ()) +-- Regular logger interpretLogger mbFlowGuid - runMode - (R.LoggerRuntime flowFormatter logLevel _ cntVar handle) + (R.LoggerRuntime flowFormatter logContext logLevel _ cntVar _ handle) (L.LogMessage msgLogLevel tag msg next) = - fmap next $ P.withRunMode runMode (E.mkLogMessageEntry msgLogLevel tag msg) $ + fmap next $ case compare logLevel msgLogLevel of GT -> pure () _ -> do msgNum <- R.incLogCounter cntVar - Impl.sendPendingMsg flowFormatter handle $ T.PendingMsg mbFlowGuid msgLogLevel tag msg msgNum + Impl.sendPendingMsg flowFormatter handle $ T.PendingMsg mbFlowGuid msgLogLevel tag msg msgNum logContext -runLogger :: Maybe T.FlowGUID -> T.RunMode -> R.LoggerRuntime -> L.Logger a -> IO a -runLogger mbFlowGuid runMode loggerRt = foldF (interpretLogger mbFlowGuid runMode loggerRt) +runLogger :: Maybe T.FlowGUID -> R.LoggerRuntime -> L.Logger a -> IO a +runLogger mbFlowGuid loggerRt = foldF (interpretLogger mbFlowGuid loggerRt) diff --git a/src/EulerHS/Core/Masking.hs b/src/EulerHS/Core/Masking.hs new file mode 100644 index 00000000..95fbaf6e --- /dev/null +++ b/src/EulerHS/Core/Masking.hs @@ -0,0 +1,90 @@ +module EulerHS.Core.Masking where + + +import qualified Data.Aeson as Aeson +import EulerHS.Prelude +import qualified Network.HTTP.Types as HTTP +import qualified Data.HashMap.Strict as HashMap +import Data.HashSet (member) +import qualified EulerHS.Core.Types.Logger as Log (LogMaskingConfig(..), MaskKeyType (..)) +import qualified Data.CaseInsensitive as CI +import qualified Data.Map as Map +import qualified Data.Text as Text +import qualified Data.List as List + +shouldMaskKey :: Maybe Log.LogMaskingConfig -> Text -> Bool +shouldMaskKey Nothing _ = False +shouldMaskKey (Just Log.LogMaskingConfig{..}) key = + case _keyType of + Log.WhiteListKey -> not $ member key _maskKeys + Log.BlackListKey -> member key _maskKeys + +defaultMaskText :: Text +defaultMaskText = "***" + + +maskHTTPHeaders :: (Text -> Bool) -> Text -> Map.Map Text Text -> Map.Map Text Text +maskHTTPHeaders shouldMask maskText = Map.mapWithKey maskHeader + where + maskHeader :: Text -> Text -> Text + maskHeader key value = if shouldMask key then maskText else value + +maskServantHeaders :: (Text -> Bool) -> Text -> Seq HTTP.Header -> Seq HTTP.Header +maskServantHeaders shouldMask maskText headers = maskHeader <$> headers + where + maskHeader :: HTTP.Header -> HTTP.Header + maskHeader (headerName,headerValue) = + if shouldMask (decodeUtf8 $ CI.original headerName) + then (headerName,encodeUtf8 maskText) + else (headerName,headerValue) + +maskQueryStrings :: (Text -> Bool) -> Text -> Seq HTTP.QueryItem -> Seq HTTP.QueryItem +maskQueryStrings shouldMask maskText queryStrings = maskQueryString <$> queryStrings + where + maskQueryString :: HTTP.QueryItem -> HTTP.QueryItem + maskQueryString (key,value) = + if shouldMask (decodeUtf8 key) + then (key,Just $ encodeUtf8 maskText) + else (key,value) + +parseRequestResponseBody :: (Text -> Bool) -> Text -> Maybe ByteString -> ByteString -> Text +parseRequestResponseBody shouldMask maskText mbContentType req + | isContentTypeBlockedForLogging mbContentType = notSupportedPlaceHolder + | otherwise = + case Aeson.eitherDecodeStrict req of + Right value -> decodeUtf8 . Aeson.encode $ maskJSON shouldMask maskText value + Left _ -> decodeUtf8 . Aeson.encode $ maskJSON shouldMask maskText $ handleQueryString req + +maskJSON :: (Text -> Bool) -> Text -> Aeson.Value -> Aeson.Value +maskJSON shouldMask maskText (Aeson.Object r) = Aeson.Object $ handleObject shouldMask maskText r +maskJSON shouldMask maskText (Aeson.Array r) = Aeson.Array $ maskJSON shouldMask maskText <$> r +maskJSON _ _ value = value + +handleObject :: (Text -> Bool) -> Text -> Aeson.Object -> Aeson.Object +handleObject shouldMask maskText = HashMap.mapWithKey maskingFn + where + maskingFn key value = maskJSON shouldMask maskText $ updatedValue key value + updatedValue key fn = if shouldMask key then Aeson.String maskText else fn + +handleQueryString :: ByteString -> Aeson.Value +handleQueryString strg = Aeson.Object . fmap (Aeson.String . fromMaybe "") . HashMap.fromList $ HTTP.parseQueryText strg + +notSupportedPlaceHolder :: Text +notSupportedPlaceHolder = "Logging Not Support For this content" + +isContentTypeBlockedForLogging :: Maybe ByteString -> Bool +isContentTypeBlockedForLogging Nothing = False +isContentTypeBlockedForLogging (Just contentType) = + Text.isInfixOf "html" (Text.toLower $ decodeUtf8 contentType) + || Text.isInfixOf "xml" (Text.toLower $ decodeUtf8 contentType) + + + +getContentTypeForServant :: HTTP.ResponseHeaders -> Maybe ByteString +getContentTypeForServant = List.lookup HTTP.hContentType + +getContentTypeForHTTP :: Map.Map Text Text -> Maybe ByteString +getContentTypeForHTTP header = getContentTypeForServant $ getTupleList + where + getTupleList = makeHeaderLableCI <$> (Map.assocs header) + makeHeaderLableCI (headerName,headerValue) = (CI.mk $ encodeUtf8 headerName, encodeUtf8 headerValue) diff --git a/src/EulerHS/Core/Playback/Entries.hs b/src/EulerHS/Core/Playback/Entries.hs deleted file mode 100644 index dbacc92d..00000000 --- a/src/EulerHS/Core/Playback/Entries.hs +++ /dev/null @@ -1,354 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} - -module EulerHS.Core.Playback.Entries where - -import qualified Data.Aeson as A -import Data.Generics.Product.Positions (getPosition) -import qualified Data.Text as Text -import EulerHS.Core.Types.Playback (MockedResult (..), RRItem (..)) -import EulerHS.Prelude -import qualified EulerHS.Types as T -import qualified Servant.Client as S - ----------------------------------------------------------------------- - -data RunDBEntry = RunDBEntry - { jsonResult :: A.Value - , rawSql :: [Text] - } - deriving (Show, Eq, Generic, ToJSON, FromJSON) - -mkRunDBEntry :: T.JSONEx a => (T.DBResult a, [Text]) -> RunDBEntry -mkRunDBEntry (res, sql) = RunDBEntry (T.jsonEncode res) sql - -instance RRItem RunDBEntry where - getTag _ = "RunDBEntry" - -instance T.JSONEx a => MockedResult RunDBEntry (T.DBResult a, [Text]) where - getMock RunDBEntry {jsonResult, rawSql} = fmap (\x -> (x,rawSql)) (T.jsonDecode jsonResult) - -data ThrowExceptionEntry = ThrowExceptionEntry - { exMessage :: String - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -mkThrowExceptionEntry :: Exception e => e -> a -> ThrowExceptionEntry -mkThrowExceptionEntry e _ = ThrowExceptionEntry $ show e - -instance RRItem ThrowExceptionEntry where - getTag _ = "ThrowExceptionEntry" - -instance MockedResult ThrowExceptionEntry a where - getMock _ = Just $ error "This shold not be evaluated: throw exception result" - ----------------------------------------------------------------------- - -data CallServantAPIEntry = CallServantAPIEntry - { baseUrl :: S.BaseUrl - , jsonResult :: A.Value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -mkCallServantAPIEntry - :: T.JSONEx a - => S.BaseUrl - -> Either S.ClientError a - -> CallServantAPIEntry -mkCallServantAPIEntry burl = CallServantAPIEntry burl . T.jsonEncode - -instance RRItem CallServantAPIEntry where - getTag _ = "CallServantAPIEntry" - -instance T.JSONEx a => MockedResult CallServantAPIEntry (Either S.ClientError a) where - getMock CallServantAPIEntry {jsonResult} = T.jsonDecode jsonResult - ----------------------------------------------------------------------- - -data CallHttpAPIEntry = CallHttpAPIEntry - { request :: T.HTTPRequest - , eResponse :: Either Text.Text T.HTTPResponse - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -mkCallHttpAPIEntry - :: T.HTTPRequest - -> Either Text.Text T.HTTPResponse - -> CallHttpAPIEntry -mkCallHttpAPIEntry = CallHttpAPIEntry - -instance RRItem CallHttpAPIEntry where - getTag _ = "CallHttpAPIEntry" - -instance MockedResult CallHttpAPIEntry (Either Text.Text T.HTTPResponse) where - getMock (CallHttpAPIEntry {eResponse}) = Just eResponse - --- ---------------------------------------------------------------------- - -data SetOptionEntry = SetOptionEntry - { key :: Text - , value :: A.Value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -mkSetOptionEntry :: ToJSON v => Text -> v -> () -> SetOptionEntry -mkSetOptionEntry k v _ = SetOptionEntry k (toJSON v) - -instance RRItem SetOptionEntry where - getTag _ = "SetOptionEntry" - -instance MockedResult SetOptionEntry () where - getMock _ = Just () -------------------------------------------------------------------------- - -data DelOptionEntry = DelOptionEntry { key :: Text } - deriving (Show, Eq, Generic, ToJSON, FromJSON) - -mkDelOptionEntry :: Text -> () -> DelOptionEntry -mkDelOptionEntry k _ = DelOptionEntry k - -instance RRItem DelOptionEntry where - getTag _ = "DelOptionEntry" - -instance MockedResult DelOptionEntry () where - getMock _ = Just () - --- ---------------------------------------------------------------------- - -data GetOptionEntry = GetOptionEntry - { key :: Text - , value :: A.Value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -mkGetOptionEntry :: ToJSON v => Text -> Maybe v -> GetOptionEntry -mkGetOptionEntry k mv = GetOptionEntry k (toJSON mv) - -instance RRItem GetOptionEntry where - getTag _ = "GetOptionEntry" - -instance FromJSON v => MockedResult GetOptionEntry v where - getMock GetOptionEntry{value} = T.fromJSONMaybe value - --- ---------------------------------------------------------------------- - -data RunSysCmdEntry = RunSysCmdEntry - { cmd :: String - , result :: String - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -mkRunSysCmdEntry :: String -> String -> RunSysCmdEntry -mkRunSysCmdEntry cmd result = RunSysCmdEntry cmd result - -instance RRItem RunSysCmdEntry where - getTag _ = "RunSysCmdEntry" - -instance MockedResult RunSysCmdEntry String where - getMock RunSysCmdEntry {..} = Just result - --- ---------------------------------------------------------------------- - -data ForkEntry = ForkEntry - { description :: Text - , guid :: Text - } deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) - -mkForkEntry :: Text -> Text -> () -> ForkEntry -mkForkEntry desc guid _ = ForkEntry desc guid - -instance RRItem ForkEntry where - getTag _ = "ForkEntry" - -instance MockedResult ForkEntry () where - getMock _ = Just () - --- ---------------------------------------------------------------------- - -data GenerateGUIDEntry = GenerateGUIDEntry - { guid :: Text - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -mkGenerateGUIDEntry :: Text -> GenerateGUIDEntry -mkGenerateGUIDEntry = GenerateGUIDEntry - -instance RRItem GenerateGUIDEntry where - getTag _ = "GenerateGUIDEntry" - -instance MockedResult GenerateGUIDEntry Text where - getMock (GenerateGUIDEntry g) = Just g - --- ---------------------------------------------------------------------- - -data RunIOEntry = RunIOEntry - { description :: Text - , jsonResult :: A.Value - } - deriving (Show, Eq, Generic, ToJSON, FromJSON) - -mkRunIOEntry - :: forall a - . T.JSONEx a - => Text - -> a - -> RunIOEntry -mkRunIOEntry descr a = RunIOEntry descr $ - (T.resolveJSONEx @a T.jsonEncode toJSON) a - -instance RRItem RunIOEntry where - getTag _ = "RunIOEntry" - -instance T.JSONEx a => MockedResult RunIOEntry a where - getMock (RunIOEntry _ r) = - T.resolveJSONEx @a T.jsonDecode T.fromJSONMaybe r - - --- ---------------------------------------------------------------------- - -data RunUntracedIOEntry = RunUntracedIOEntry - { description :: Text - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -mkRunUntracedIOEntry :: Text -> a -> RunUntracedIOEntry -mkRunUntracedIOEntry descr _ = RunUntracedIOEntry descr - -instance RRItem RunUntracedIOEntry where - getTag _ = "RunUntracedIOEntry" - --- Not possible to mock these values, you have to re-run the IO action --- instance MockedResult RunUntracedIOEntry () where --- getMock (RunUntracedIOEntry _) = Just () - ------------------------------------------------------------------------- - -data InitSqlDBConnectionEntry beM = InitSqlDBConnectionEntry - { dBConfig :: T.DBConfig beM - , initConnResult :: Either T.DBError () - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -mkInitSqlDBConnectionEntry :: T.DBConfig beM -> Either T.DBError a -> InitSqlDBConnectionEntry beM -mkInitSqlDBConnectionEntry dbcfg res = case res of - Left err -> InitSqlDBConnectionEntry dbcfg (Left err) - Right _ -> InitSqlDBConnectionEntry dbcfg (Right ()) - -instance RRItem (InitSqlDBConnectionEntry beM) where - getTag _ = "InitSqlDBConnectionEntry" - -instance MockedResult (InitSqlDBConnectionEntry beM) (T.DBResult (T.SqlConn beM)) where - getMock (InitSqlDBConnectionEntry _ res) = - case res of - Left err -> Just $ Left err - Right _ -> Just $ Right $ T.MockedPool "" - - ----------------------------------------------------------------------- - -data DeInitSqlDBConnectionEntry (beM :: Type -> Type) = DeInitSqlDBConnectionEntry - { connTag :: Text - } deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) - -mkDeInitSqlDBConnectionEntry :: T.SqlConn beM -> a -> DeInitSqlDBConnectionEntry beM -mkDeInitSqlDBConnectionEntry cfg _ = DeInitSqlDBConnectionEntry (getPosition @1 cfg) - -instance RRItem (DeInitSqlDBConnectionEntry beM) where - getTag _ = "DeInitSqlDBConnectionEntry" - -instance MockedResult (DeInitSqlDBConnectionEntry beM) () where - getMock (DeInitSqlDBConnectionEntry _) = Just () - ------------------------------------------------------------------------- - -data GetSqlDBConnectionEntry beM = GetSqlDBConnectionEntry - { dBConfig :: T.DBConfig beM - , getConnResult :: Either T.DBError () - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -mkGetSqlDBConnectionEntry :: T.DBConfig beM -> Either T.DBError a -> GetSqlDBConnectionEntry beM -mkGetSqlDBConnectionEntry dbcfg res = case res of - Left err -> GetSqlDBConnectionEntry dbcfg (Left err) - Right _ -> GetSqlDBConnectionEntry dbcfg (Right ()) - -instance RRItem (GetSqlDBConnectionEntry beM) where - getTag _ = "GetSqlDBConnectionEntry" - -instance MockedResult (GetSqlDBConnectionEntry beM) (T.DBResult (T.SqlConn beM)) where - getMock (GetSqlDBConnectionEntry _ res) = - case res of - Left err -> Just $ Left err - Right _ -> Just $ Right $ T.MockedPool "" - -------------------------------------------------------------------------- - -data InitKVDBConnectionEntry = InitKVDBConnectionEntry - { kvdbConfig :: T.KVDBConfig - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -mkInitKVDBConnectionEntry :: T.KVDBConfig -> a -> InitKVDBConnectionEntry -mkInitKVDBConnectionEntry dbcfg _ = InitKVDBConnectionEntry dbcfg - -instance RRItem InitKVDBConnectionEntry where - getTag _ = "InitKVDBConnectionEntry" - -instance MockedResult InitKVDBConnectionEntry (T.KVDBAnswer T.KVDBConn) where - getMock (InitKVDBConnectionEntry _) = Just $ Right $ T.Mocked "" - -------------------------------------------------------------------------- - -data DeInitKVDBConnectionEntry = DeInitKVDBConnectionEntry - { connTag :: Text - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -mkDeInitKVDBConnectionEntry :: T.KVDBConn -> a -> DeInitKVDBConnectionEntry -mkDeInitKVDBConnectionEntry conn _ = DeInitKVDBConnectionEntry (getPosition @1 conn) - -instance RRItem DeInitKVDBConnectionEntry where - getTag _ = "DeInitKVDBConnectionEntry" - -instance MockedResult DeInitKVDBConnectionEntry () where - getMock (DeInitKVDBConnectionEntry _) = Just () - -------------------------------------------------------------------------- - -data GetKVDBConnectionEntry = GetKVDBConnectionEntry - { kvdbConfig :: T.KVDBConfig - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -mkGetKVDBConnectionEntry :: T.KVDBConfig -> a -> GetKVDBConnectionEntry -mkGetKVDBConnectionEntry dbcfg _ = GetKVDBConnectionEntry dbcfg - -instance RRItem GetKVDBConnectionEntry where - getTag _ = "GetKVDBConnectionEntry" - -instance MockedResult GetKVDBConnectionEntry (T.KVDBAnswer T.KVDBConn) where - getMock (GetKVDBConnectionEntry _) = Just $ Right $ T.Mocked "" - ----------------------------------------------------------------------- - -data AwaitEntry = AwaitEntry - { timeout :: Maybe Int - , jsonResult :: A.Value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -mkAwaitEntry :: ToJSON v => Maybe T.Microseconds -> Either T.AwaitingError v -> AwaitEntry -mkAwaitEntry mbMcs val = AwaitEntry (unwrapMcs <$> mbMcs) (toJSON val) - where - unwrapMcs (T.Microseconds mcs) = fromIntegral mcs - -instance RRItem AwaitEntry where - getTag _ = "AwaitEntry" - -instance FromJSON v => MockedResult AwaitEntry v where - getMock (AwaitEntry _ jsonValue) = T.fromJSONMaybe jsonValue - -------------------------------------------------------------------------------------- - -data RunSafeFlowEntry = RunSafeFlowEntry - { guid :: Text - , jsonResult :: A.Value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -mkRunSafeFlowEntry :: ToJSON v => Text -> Either Text v -> RunSafeFlowEntry -mkRunSafeFlowEntry guid val = RunSafeFlowEntry guid (toJSON val) - -instance RRItem RunSafeFlowEntry where - getTag _ = "RunSafeFlowEntry" - -instance (FromJSON v) => MockedResult RunSafeFlowEntry v where - getMock (RunSafeFlowEntry _ jsonValue) = T.fromJSONMaybe jsonValue diff --git a/src/EulerHS/Core/Playback/Machine.hs b/src/EulerHS/Core/Playback/Machine.hs deleted file mode 100644 index f5c4058e..00000000 --- a/src/EulerHS/Core/Playback/Machine.hs +++ /dev/null @@ -1,221 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -{- | -Module : EulerHS.Core.Playback.Machine -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -Automatic Regression Testing (ART) system. - -You typically don't need to import this module. --} - -module EulerHS.Core.Playback.Machine - ( - -- * Playback Machine - record, - withRunMode - ) where - -import Control.Exception (throwIO) -import Data.Vector as V ((!?)) -import qualified Data.Vector as V -import EulerHS.Prelude hiding (note) -import EulerHS.Types - - -showInfo :: String -> String -> String -showInfo flowStep recordingEntry = - "\n>>>>Recording entry: \n" ++ recordingEntry - ++ "\n>>>>Flow step: \n" ++ flowStep - -unexpectedRecordingEnd :: Text -> String -> PlaybackError -unexpectedRecordingEnd errFlowGuid flowStep - = PlaybackError UnexpectedRecordingEnd - ("\n>>>>Flow step: " ++ flowStep) - errFlowGuid - -unknownRRItem :: Text -> String -> String -> PlaybackError -unknownRRItem errFlowGuid flowStep recordingEntry - = PlaybackError UnknownRRItem - (showInfo flowStep recordingEntry) - errFlowGuid - -mockDecodingFailed :: Text -> String -> String -> PlaybackError -mockDecodingFailed errFlowGuid flowStep recordingEntry - = PlaybackError MockDecodingFailed - (showInfo flowStep recordingEntry) - errFlowGuid - -itemMismatch :: Text -> String -> String -> PlaybackError -itemMismatch errFlowGuid flowStep recordingEntry - = PlaybackError ItemMismatch - (showInfo flowStep recordingEntry) - errFlowGuid - -setReplayingError :: MonadIO m => PlayerRuntime -> PlaybackError -> m e -setReplayingError playerRt err = do - let PlayerRuntime{rerror = ReplayErrors{errorMVar}} = playerRt - - void $ takeMVar errorMVar - putMVar errorMVar $ Just err - liftIO $ throwIO $ ReplayingException err - -pushRecordingEntry - :: MonadIO m - => RecorderRuntime - -> RecordingEntry - -> m () -pushRecordingEntry RecorderRuntime{recording} (RecordingEntry _ mode n p) = do - let recMVar = recordingMVar recording - entries <- takeMVar recMVar - let idx = V.length entries - let re = RecordingEntry idx mode n p - - putMVar recMVar $ V.snoc entries re - -popNextRecordingEntry :: MonadIO m => PlayerRuntime -> m (Maybe RecordingEntry) -popNextRecordingEntry PlayerRuntime{resRecording = ResultRecording{..}, ..} = do - cur <- takeMVar stepMVar - let mbItem = recording !? cur - when (isJust mbItem) $ putMVar stepMVar (cur + 1) - pure mbItem - -popNextRRItem - :: forall rrItem m - . MonadIO m - => Show rrItem - => RRItem rrItem - => PlayerRuntime - -> m (Either PlaybackError (RecordingEntry, rrItem)) -popNextRRItem playerRt@PlayerRuntime{..} = do - mbRecordingEntry <- popNextRecordingEntry playerRt - let flowStep = getTag $ Proxy @rrItem - pure $ do - recordingEntry <- note (unexpectedRecordingEnd flowGUID flowStep) mbRecordingEntry - let unknownErr = unknownRRItem flowGUID flowStep $ showRecEntry @rrItem recordingEntry -- show recordingEntry - rrItem <- note unknownErr $ fromRecordingEntry recordingEntry - pure (recordingEntry, rrItem) - -popNextRRItemAndResult - :: forall rrItem native m - . MonadIO m - => Show rrItem - => MockedResult rrItem native - => PlayerRuntime - -> m (Either PlaybackError (RecordingEntry, rrItem, native)) -popNextRRItemAndResult playerRt@PlayerRuntime{..} = do - let flowStep = getTag $ Proxy @rrItem - eNextRRItem <- popNextRRItem playerRt - pure $ do - (recordingEntry, rrItem) <- eNextRRItem - let mbNative = getMock rrItem - nextResult <- note (mockDecodingFailed flowGUID flowStep (show recordingEntry)) mbNative - pure (recordingEntry, rrItem, nextResult) - -compareRRItems - :: forall rrItem m native - . RRItem rrItem - => Show rrItem - => MonadIO m - => PlayerRuntime - -> (RecordingEntry, rrItem, native) - -> rrItem - -> m () -compareRRItems playerRt@PlayerRuntime{..} (recordingEntry, rrItem, _) flowRRItem = do - when (rrItem /= flowRRItem) $ do - let flowStep = show flowRRItem - setReplayingError playerRt $ itemMismatch flowGUID flowStep (showRecEntry @rrItem recordingEntry) -- show recordingEntry) - -getCurrentEntryReplayMode :: MonadIO m => PlayerRuntime -> m EntryReplayingMode -getCurrentEntryReplayMode PlayerRuntime{resRecording = ResultRecording{..}, ..} = do - cur <- readMVar stepMVar - pure $ fromMaybe Normal $ do - (RecordingEntry _ mode _ _) <- recording !? cur - pure mode - -replayWithGlobalConfig - :: forall rrItem native m - . MonadIO m - => Show rrItem - => MockedResult rrItem native - => PlayerRuntime - -> m native - -> (native -> rrItem) - -> Either PlaybackError (RecordingEntry, rrItem, native) - -> m native -replayWithGlobalConfig playerRt ioAct mkRRItem eNextRRItemRes = do - let tag = getTag $ Proxy @rrItem - let config = checkForReplayConfig playerRt tag - case config of - GlobalNoVerify -> case eNextRRItemRes of - Left err -> setReplayingError playerRt err - Right (_, _, r) -> pure r - GlobalNormal -> case eNextRRItemRes of - Left err -> setReplayingError playerRt err - Right stepInfo@(_, _, r) -> do - compareRRItems playerRt stepInfo $ mkRRItem r - pure r - GlobalNoMocking -> ioAct - GlobalSkip -> ioAct - -checkForReplayConfig :: PlayerRuntime -> String -> GlobalReplayingMode -checkForReplayConfig PlayerRuntime{..} tag | tag `elem` disableMocking = GlobalNoMocking - | tag `elem` disableVerify = GlobalNoVerify - | otherwise = GlobalNormal - -replay - :: forall rrItem native m - . MonadIO m - => Show rrItem - => MockedResult rrItem native - => PlayerRuntime - -> (native -> rrItem) - -> m native - -> m native -replay playerRt@PlayerRuntime{..} mkRRItem ioAct - | getTag (Proxy @rrItem) `elem` skipEntries = ioAct - | otherwise = do - entryReplayMode <- getCurrentEntryReplayMode playerRt - eNextRRItemRes <- popNextRRItemAndResult playerRt - case entryReplayMode of - Normal -> do - replayWithGlobalConfig playerRt ioAct mkRRItem eNextRRItemRes - NoVerify -> case eNextRRItemRes of - Left err -> setReplayingError playerRt err - Right (_, _, r) -> pure r - NoMock -> ioAct - -record - :: forall rrItem native m - . MonadIO m - => RRItem rrItem - => RecorderRuntime - -> (native -> rrItem) - -> m native - -> m native -record recorderRt@RecorderRuntime{..} mkRRItem ioAct = do - native <- ioAct - let tag = getTag $ Proxy @rrItem - when (tag `notElem` disableEntries) - $ pushRecordingEntry recorderRt $ toRecordingEntry (mkRRItem native) 0 Normal - pure native - - -withRunMode - :: MonadIO m - => Show rrItem - => MockedResult rrItem native - => RunMode - -> (native -> rrItem) - -> m native - -> m native -withRunMode RegularMode _ act = act -withRunMode (RecordingMode recorderRt) mkRRItem act = - record recorderRt mkRRItem act -withRunMode (ReplayingMode playerRt) mkRRItem act = - replay playerRt mkRRItem act diff --git a/src/EulerHS/Core/PubSub/Entries.hs b/src/EulerHS/Core/PubSub/Entries.hs deleted file mode 100644 index 6c11db33..00000000 --- a/src/EulerHS/Core/PubSub/Entries.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} - -module EulerHS.Core.PubSub.Entries where - - -import EulerHS.Prelude - -import qualified Data.Aeson as A -import qualified EulerHS.Types as T - ----------------------------------------------------------------------- - -data PublishEntry = PublishEntry - { jsonChannel :: A.Value - , jsonPayload :: A.Value - , jsonResult :: A.Value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -instance T.RRItem PublishEntry where - getTag _ = "PublishEntry" - -instance T.MockedResult PublishEntry (Either T.KVDBReply Integer) where - getMock PublishEntry {jsonResult} = T.jsonDecode jsonResult - -mkPublishEntry :: ByteString -> ByteString -> Either T.KVDBReply Integer -> PublishEntry -mkPublishEntry c p r = PublishEntry - (T.jsonEncode c) - (T.jsonEncode p) - (T.jsonEncode r) - ----------------------------------------------------------------------- - -data SubscribeEntry = SubscribeEntry - { jsonChannels :: A.Value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -instance T.RRItem SubscribeEntry where - getTag _ = "SubscribeEntry" - -instance T.MockedResult SubscribeEntry (IO ()) where - getMock _ = Just $ pure () - -mkSubscribeEntry :: [ByteString] -> IO () -> SubscribeEntry -mkSubscribeEntry c _ = SubscribeEntry $ T.jsonEncode c - ----------------------------------------------------------------------- - -data PSubscribeEntry = PSubscribeEntry - { jsonPatterns :: A.Value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - -instance T.RRItem PSubscribeEntry where - getTag _ = "PSubscribeEntry" - -instance T.MockedResult PSubscribeEntry (IO ()) where - getMock _ = Just $ pure () - -mkPSubscribeEntry :: [ByteString] -> IO () -> PSubscribeEntry -mkPSubscribeEntry p _ = PSubscribeEntry $ T.jsonEncode p - ----------------------------------------------------------------------- diff --git a/src/EulerHS/Core/PubSub/Interpreter.hs b/src/EulerHS/Core/PubSub/Interpreter.hs index b5a05504..d135253e 100644 --- a/src/EulerHS/Core/PubSub/Interpreter.hs +++ b/src/EulerHS/Core/PubSub/Interpreter.hs @@ -4,44 +4,38 @@ import EulerHS.Prelude import Data.Coerce import qualified Database.Redis as R -import qualified EulerHS.Core.Playback.Machine as P import qualified EulerHS.Types as T -import EulerHS.Core.PubSub.Entries import EulerHS.Core.PubSub.Language interpretPubSubF - :: T.RunMode - -> R.PubSubController + :: R.PubSubController -> R.Connection -> PubSubF a -> IO a -interpretPubSubF runMode _ conn (Publish ch pl next) = +interpretPubSubF _ conn (Publish ch pl next) = fmap next $ - P.withRunMode runMode (mkPublishEntry bsch bspl) $ fmap (first T.hedisReplyToKVDBReply) $ R.runRedis conn $ R.publish bsch bspl where bsch = coerce ch bspl = coerce pl -interpretPubSubF runMode pubSubController _ (Subscribe chs cb next) = +interpretPubSubF pubSubController _ (Subscribe chs cb next) = fmap next $ - P.withRunMode runMode (mkSubscribeEntry bsChs) $ R.addChannelsAndWait pubSubController (zip bsChs $ repeat cb) [] where bsChs = coerce chs -interpretPubSubF runMode pubSubController _ (PSubscribe patts cb next) = +interpretPubSubF pubSubController _ (PSubscribe patts cb next) = fmap next $ - P.withRunMode runMode (mkPSubscribeEntry bsPatts) $ R.addChannelsAndWait pubSubController [] (zip bsPatts $ repeat cb) where bsPatts = coerce patts -runPubSub :: T.RunMode -> R.PubSubController -> R.Connection -> PubSub a -> IO a -runPubSub runMode pubSubController conn = - foldF (interpretPubSubF runMode pubSubController conn) +runPubSub :: R.PubSubController -> R.Connection -> PubSub a -> IO a +runPubSub pubSubController conn = + foldF (interpretPubSubF pubSubController conn) diff --git a/src/EulerHS/Core/PubSub/Language.hs b/src/EulerHS/Core/PubSub/Language.hs index 12c131c6..5c3723c2 100644 --- a/src/EulerHS/Core/PubSub/Language.hs +++ b/src/EulerHS/Core/PubSub/Language.hs @@ -1,19 +1,5 @@ {-# LANGUAGE DeriveFunctor #-} -{- | -Module : EulerHS.Core.PubSub.Language -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -Experimental PubSub subsystem (Redis-based) - -This module is internal and should not imported in the projects. -Import 'EulerHS.Language' instead. --} - module EulerHS.Core.PubSub.Language where import EulerHS.Prelude @@ -21,33 +7,25 @@ import EulerHS.Prelude import qualified Database.Redis as R import qualified EulerHS.Types as T --- | Channel newtype Channel = Channel ByteString - --- | Channel pattern newtype ChannelPattern = ChannelPattern ByteString - --- | Payload newtype Payload = Payload ByteString --- | Algebra for the PubSub mechanism data PubSubF next = Publish Channel Payload (Either T.KVDBReply Integer -> next) | Subscribe [Channel ] R.MessageCallback (IO () -> next) | PSubscribe [ChannelPattern] R.PMessageCallback (IO () -> next) deriving Functor --- | PubSub language type PubSub = F PubSubF --- | Publish some payload into channel publish :: Channel -> Payload -> PubSub (Either T.KVDBReply Integer) publish channel payload = liftFC $ Publish channel payload id --- | Subscribe to channel subscribe :: [Channel] -> R.MessageCallback -> PubSub (IO ()) subscribe channels cb = liftFC $ Subscribe channels cb id --- | Subscribe to channels with this pattern psubscribe :: [ChannelPattern] -> R.PMessageCallback -> PubSub (IO ()) psubscribe channels cb = liftFC $ PSubscribe channels cb id + + diff --git a/src/EulerHS/Core/Runtime.hs b/src/EulerHS/Core/Runtime.hs index afada9fb..7214fb07 100644 --- a/src/EulerHS/Core/Runtime.hs +++ b/src/EulerHS/Core/Runtime.hs @@ -1,16 +1,3 @@ -{- | -Module : EulerHS.Core.Runtime -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -This module contains functions and types to work with `CoreRuntime`. - -This is an internal module. Import EulerHS.Runtime instead. --} - module EulerHS.Core.Runtime ( -- * Core Runtime @@ -25,11 +12,18 @@ module EulerHS.Core.Runtime , createLoggerRuntime' , clearCoreRuntime , clearLoggerRuntime + , getLogMaskingConfig , module X ) where import EulerHS.Prelude - +import EulerHS.Core.Types + ( LogCounter + , LogLevel(..) + , LoggerConfig(..) + , LogMaskingConfig(..) + , ShouldLogSQL(SafelyOmitSqlLogs, UnsafeLogSQL_DO_NOT_USE_IN_PRODUCTION) + ) -- Currently, TinyLogger is highly coupled with the Runtime. -- Fix it if an interchangable implementations are needed. import qualified EulerHS.Core.Logger.Impl.TinyLogger as Impl @@ -37,54 +31,41 @@ import qualified EulerHS.Core.Types as T import EulerHS.Core.Types.DB as X (withTransaction) import qualified System.Logger as Log --- | A counter of log messages sent since the `LoggerRuntime` creation. -type LogCounter = IORef Int -- No race condition: atomicModifyIORef' is used. --- | Runtime sturcture holding all the necessary operational information --- for the logging subsystem. +-- TODO: add StaticLoggerRuntimeContext if we'll need more than a single Bool data LoggerRuntime - -- | Runtime structure of a regular logger. = LoggerRuntime - { _flowFormatter :: T.FlowFormatter - -- ^ A callback for obtaining a flow-specific formatter. - , _logLevel :: T.LogLevel - -- ^ Log level - , _logRawSql :: !Bool - -- ^ Whether to log raw SQL as Debug messages. - , _logCounter :: !LogCounter - -- ^ Log messages counter variable. - , _logLoggerHandle :: Impl.LoggerHandle - -- ^ Internal logging subsystem handler. - } - -- | Runtime structure for a memory logger. - | MemoryLoggerRuntime !T.FlowFormatter !T.LogLevel !(MVar [Text]) !LogCounter - --- | Runtime that keeps all the operational info for the core subsystems. + { _flowFormatter :: T.FlowFormatter + , _logContext :: T.LogContext + , _logLevel :: T.LogLevel + , _logRawSql :: ShouldLogSQL + , _logCounter :: !T.LogCounter + , _logMaskingConfig :: Maybe T.LogMaskingConfig + , _logLoggerHandle :: Impl.LoggerHandle + } + | MemoryLoggerRuntime !T.FlowFormatter T.LogContext !T.LogLevel !(MVar [Text]) !T.LogCounter + data CoreRuntime = CoreRuntime { _loggerRuntime :: LoggerRuntime - -- ^ Logger runtime } --- | Create a memory logger runtime. --- --- This function can be passed to `createFlowRuntime'`. +-- createLoggerRuntime :: LoggerConfig -> IO LoggerRuntime +-- createLoggerRuntime (MemoryLoggerConfig cfgLogLevel) = +-- MemoryLoggerRuntime cfgLogLevel <$> newMVar [] +-- createLoggerRuntime cfg = do +-- counter <- initLogCounter +-- LoggerRuntime (_level cfg) (_logRawSql cfg) counter Nothing Nothing (_logMaskingConfig cfg)<$> Impl.createLogger cfg + createMemoryLoggerRuntime :: T.FlowFormatter -> T.LogLevel -> IO LoggerRuntime createMemoryLoggerRuntime flowFormatter logLevel = - MemoryLoggerRuntime flowFormatter logLevel <$> newMVar [] <*> initLogCounter + MemoryLoggerRuntime flowFormatter mempty logLevel <$> newMVar [] <*> initLogCounter --- | Create a regular logger runtime according to the config passed. --- --- This function can be passed to `createFlowRuntime'`. createLoggerRuntime :: T.FlowFormatter -> T.LoggerConfig -> IO LoggerRuntime createLoggerRuntime flowFormatter cfg = do counter <- initLogCounter - LoggerRuntime flowFormatter (T._logLevel cfg) (T._logRawSql cfg) counter + LoggerRuntime flowFormatter mempty (T._logLevel cfg) (T._logRawSql cfg) counter Nothing <$> Impl.createLogger flowFormatter cfg --- | The same as `createLoggerRuntime` but allows to setup different tweaks --- of the specific tiny-logger subsystem. --- --- This function can be passed to `createFlowRuntime'`. createLoggerRuntime' :: Maybe Log.DateFormat -> Maybe Log.Renderer @@ -95,43 +76,35 @@ createLoggerRuntime' createLoggerRuntime' mbDateFormat mbRenderer bufferSize flowFormatter cfg = do counter <- initLogCounter loggerHandle <- Impl.createLogger' mbDateFormat mbRenderer bufferSize flowFormatter cfg - pure $ LoggerRuntime flowFormatter (T._logLevel cfg) (T._logRawSql cfg) counter loggerHandle + pure $ LoggerRuntime flowFormatter mempty (T._logLevel cfg) (T._logRawSql cfg) counter Nothing loggerHandle --- | Create a void logger: nothing will be logged. createVoidLoggerRuntime :: IO LoggerRuntime createVoidLoggerRuntime = do counter <- initLogCounter - LoggerRuntime (const $ pure show) T.Debug True counter <$> Impl.createVoidLogger + LoggerRuntime (const $ pure T.showingMessageFormatter) mempty T.Debug SafelyOmitSqlLogs counter Nothing <$> Impl.createVoidLogger --- | Clear a logger runtime and dispose the logger. --- --- This function flushes the last log messages existing in the log queue. clearLoggerRuntime :: LoggerRuntime -> IO () -clearLoggerRuntime (LoggerRuntime flowFormatter _ _ _ handle) = Impl.disposeLogger flowFormatter handle -clearLoggerRuntime (MemoryLoggerRuntime _ _ msgsVar _) = void $ swapMVar msgsVar [] +clearLoggerRuntime (LoggerRuntime flowFormatter _ _ _ _ _ handle) = Impl.disposeLogger flowFormatter handle +clearLoggerRuntime (MemoryLoggerRuntime _ _ _ msgsVar _) = void $ swapMVar msgsVar [] --- | Creates a core runtime. createCoreRuntime :: LoggerRuntime -> IO CoreRuntime createCoreRuntime = pure . CoreRuntime --- | Clears the core runtime. clearCoreRuntime :: CoreRuntime -> IO () clearCoreRuntime _ = pure () --- | Returns True if debug logging of raw SQL queries was set. shouldLogRawSql :: LoggerRuntime -> Bool shouldLogRawSql = \case - (LoggerRuntime _ _ logRawSql _ _) -> logRawSql - _ -> True + (LoggerRuntime _ _ _ UnsafeLogSQL_DO_NOT_USE_IN_PRODUCTION _ _ _) -> True + _ -> False + +getLogMaskingConfig :: LoggerRuntime -> Maybe T.LogMaskingConfig +getLogMaskingConfig = \case + (LoggerRuntime _ _ _ _ _ mbMaskConfig _) -> mbMaskConfig + _ -> Nothing --- | Init log messages counter. --- --- Internal function, should not be used in the BL. -initLogCounter :: IO LogCounter +initLogCounter :: IO T.LogCounter initLogCounter = newIORef 0 --- | Incremenet log messages counter. --- --- Internal function, should not be used in the BL. -incLogCounter :: LogCounter -> IO Int +incLogCounter :: T.LogCounter -> IO Int incLogCounter = flip atomicModifyIORef' (\cnt -> (cnt + 1, cnt)) diff --git a/src/EulerHS/Core/SqlDB/Interpreter.hs b/src/EulerHS/Core/SqlDB/Interpreter.hs index 24ad6ea1..1212aa9a 100644 --- a/src/EulerHS/Core/SqlDB/Interpreter.hs +++ b/src/EulerHS/Core/SqlDB/Interpreter.hs @@ -9,7 +9,9 @@ import EulerHS.Prelude import qualified EulerHS.Core.Language as L import qualified EulerHS.Core.Types as T +import Control.Exception (throwIO) +-- TODO: The runner runner gets composed in in `sqlDBMethod`. Move it into the interpreter! interpretSqlDBMethod :: T.NativeSqlConn -> (Text -> IO ()) @@ -18,5 +20,9 @@ interpretSqlDBMethod interpretSqlDBMethod conn logger (L.SqlDBMethod runner next) = next <$> runner conn logger + +interpretSqlDBMethod _ _ (L.SqlThrowException ex next) = do + next <$> throwIO ex + runSqlDB :: T.NativeSqlConn -> (Text -> IO ()) -> L.SqlDB beM a -> IO a runSqlDB sqlConn logger = foldF (interpretSqlDBMethod sqlConn logger) diff --git a/src/EulerHS/Core/SqlDB/Language.hs b/src/EulerHS/Core/SqlDB/Language.hs index 65365bf6..f8c003f7 100644 --- a/src/EulerHS/Core/SqlDB/Language.hs +++ b/src/EulerHS/Core/SqlDB/Language.hs @@ -3,22 +3,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{- | -Module : EulerHS.Core.SqlDB.Language -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -Language of the SQL DB subsystem. - -Uses `beam` as relational DBs connector. - -This module is internal and should not imported in the projects. -Import 'EulerHS.Language' instead. --} - module EulerHS.Core.SqlDB.Language ( -- * SQLDB language @@ -36,6 +20,7 @@ module EulerHS.Core.SqlDB.Language , deleteRowsReturningListPG , updateRowsReturningListPG , insertRowReturningMySQL + , sqlThrowException -- for tests ) where import qualified Database.Beam as B @@ -44,61 +29,66 @@ import qualified Database.Beam.Postgres as BP import qualified EulerHS.Core.Types as T import EulerHS.Prelude --- | Language of the SQL DB subsytem. + type SqlDB beM = F (SqlDBMethodF beM) --- | Algebra of the SQL DB subsytem. data SqlDBMethodF (beM :: Type -> Type) next where SqlDBMethod :: HasCallStack => (T.NativeSqlConn -> (Text -> IO ()) -> IO a) -> (a -> next) -> SqlDBMethodF beM next + SqlThrowException :: (HasCallStack, Exception e) => e -> (a -> next) -> SqlDBMethodF beM next + instance Functor (SqlDBMethodF beM) where fmap f (SqlDBMethod runner next) = SqlDBMethod runner (f . next) + fmap f (SqlThrowException message next) = SqlThrowException message (f . next) --- | Wrapping helper sqlDBMethod - :: (HasCallStack, T.BeamRunner beM) + :: (HasCallStack, T.BeamRunner beM, T.BeamRuntime be beM) => beM a -> SqlDB beM a sqlDBMethod act = liftFC $ SqlDBMethod (flip T.getBeamDebugRunner act) id +-- For testing purpose +sqlThrowException :: forall a e beM be . (HasCallStack, Exception e, T.BeamRunner beM, T.BeamRuntime be beM) => e -> SqlDB beM a +sqlThrowException ex = liftFC $ SqlThrowException ex id + -- Convenience interface --- | Select many rows query +-- | Select many findRows :: (HasCallStack, T.BeamRunner beM, T.BeamRuntime be beM, B.FromBackendRow be a) => B.SqlSelect be a -> SqlDB beM [a] findRows = sqlDBMethod . T.rtSelectReturningList --- | Select one row query +-- | Select one findRow :: (HasCallStack, T.BeamRunner beM, T.BeamRuntime be beM, B.FromBackendRow be a) => B.SqlSelect be a -> SqlDB beM (Maybe a) findRow = sqlDBMethod . T.rtSelectReturningOne --- | Insert query +-- | Insert insertRows :: (HasCallStack, T.BeamRunner beM, T.BeamRuntime be beM) => B.SqlInsert be table -> SqlDB beM () insertRows = sqlDBMethod . T.rtInsert --- | Insert returning list query +-- | Insert returning list insertRowsReturningList :: (HasCallStack, B.Beamable table, B.FromBackendRow be (table Identity), T.BeamRuntime be beM, T.BeamRunner beM) => B.SqlInsert be table -> SqlDB beM [table Identity] insertRowsReturningList = sqlDBMethod . T.rtInsertReturningList --- | Update query +-- | Update updateRows :: (HasCallStack, T.BeamRunner beM, T.BeamRuntime be beM) => B.SqlUpdate be table -> SqlDB beM () updateRows = sqlDBMethod . T.rtUpdate --- | Update returning list query +-- | Update returning list updateRowsReturningList :: (HasCallStack, T.BeamRunner beM, T.BeamRuntime be beM, B.Beamable table, B.FromBackendRow be (table Identity)) @@ -106,7 +96,7 @@ updateRowsReturningList -> SqlDB beM [table Identity] updateRowsReturningList = sqlDBMethod . T.rtUpdateReturningList --- | Delete query +-- | Delete deleteRows :: (HasCallStack, T.BeamRunner beM, T.BeamRuntime be beM) => B.SqlDelete be table @@ -114,16 +104,14 @@ deleteRows deleteRows = sqlDBMethod . T.rtDelete --- Postgres-only extra methods +-- Postgres only extra methods --- | Postgres-only DELETE query (returning list) deleteRowsReturningListPG :: (HasCallStack, B.Beamable table, B.FromBackendRow BP.Postgres (table Identity)) => B.SqlDelete BP.Postgres table -> SqlDB BP.Pg [table Identity] deleteRowsReturningListPG = sqlDBMethod . T.deleteReturningListPG --- | Postgres-only UPDATE query (returning list) updateRowsReturningListPG :: (HasCallStack, B.Beamable table, B.FromBackendRow BP.Postgres (table Identity)) => B.SqlUpdate BP.Postgres table @@ -132,10 +120,6 @@ updateRowsReturningListPG = sqlDBMethod . T.updateReturningListPG -- MySQL only extra methods -- NOTE: This should be run inside a SQL transaction! - --- | MySQL-only INSERT query (returning list) --- --- NOTE: This should be run inside a SQL transaction! insertRowReturningMySQL :: (HasCallStack, B.FromBackendRow BM.MySQL (table Identity)) => B.SqlInsert BM.MySQL table -> SqlDB BM.MySQLM (Maybe (table Identity)) diff --git a/src/EulerHS/Core/Types.hs b/src/EulerHS/Core/Types.hs index 1ef5296e..20f1b924 100644 --- a/src/EulerHS/Core/Types.hs +++ b/src/EulerHS/Core/Types.hs @@ -1,21 +1,9 @@ -{- | -Module : EulerHS.Core.Types -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -This module reexports general functions and types of the framework. - -This is an internal module. Import EulerHS.Types instead. --} - module EulerHS.Core.Types ( module X ) where import EulerHS.Core.Api as X +import EulerHS.Core.Masking as X import EulerHS.Core.Types.BinaryString as X import EulerHS.Core.Types.Common as X import EulerHS.Core.Types.DB as X hiding (withTransaction) @@ -25,6 +13,5 @@ import EulerHS.Core.Types.KVDB as X import EulerHS.Core.Types.Logger as X import EulerHS.Core.Types.MySQL as X import EulerHS.Core.Types.Options as X -import EulerHS.Core.Types.Playback as X import EulerHS.Core.Types.Postgres as X import EulerHS.Core.Types.Serializable as X diff --git a/src/EulerHS/Core/Types/BinaryString.hs b/src/EulerHS/Core/Types/BinaryString.hs index 95f17096..688fe4ce 100644 --- a/src/EulerHS/Core/Types/BinaryString.hs +++ b/src/EulerHS/Core/Types/BinaryString.hs @@ -1,3 +1,5 @@ +-- {-# LANGUAGE GeneralizedNewtypeDeriving #-} + module EulerHS.Core.Types.BinaryString ( BinaryString(..) , LBinaryString(..) @@ -15,6 +17,8 @@ import qualified Data.String.Conversions as Conversions import qualified Data.Text as Text import qualified Data.Text.Encoding as Encoding +-- TODO: Move to euler-db + -------------------------------------------------------------------------- -- Base64 encoding/decoding helpers -------------------------------------------------------------------------- diff --git a/src/EulerHS/Core/Types/Common.hs b/src/EulerHS/Core/Types/Common.hs index 3494ab90..20d6ecb2 100644 --- a/src/EulerHS/Core/Types/Common.hs +++ b/src/EulerHS/Core/Types/Common.hs @@ -1,24 +1,16 @@ -{- | -Module : EulerHS.Core.Types.Common -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -Common types and helper functions. - -This module is internal and should not imported in the projects. -Import 'EulerHS.Types' instead. --} - module EulerHS.Core.Types.Common ( + -- * Guid for any flow FlowGUID + -- * Guid for a forked flow , ForkGUID + -- * Guid for a safe flow , SafeFlowGUID + -- * Network manager selector , ManagerSelector + -- * Description type , Description + -- * A variable for await results from a forked flow , Awaitable (..) , Microseconds (..) ) where @@ -26,31 +18,10 @@ module EulerHS.Core.Types.Common import qualified Data.Word as W import EulerHS.Prelude - -- | Guid for any flow. - -- This type can be used to specify a separate logger formatting - -- for each flow. type FlowGUID = Text - --- | Guid for a forked flow. --- Service type, rarely needed in the business logic. type ForkGUID = Text - - -- | Guid for a safe flow. - -- Service type, rarely needed in business logic. type SafeFlowGUID = Text - - -- | Network manager selector. - -- Allows to have a set of named managers with own configs - -- when the default one is not enough. type ManagerSelector = String - - -- | Description type type Description = Text - - -- | Awaitable object. Ask it for results from forked flow. data Awaitable s = Awaitable (MVar s) - - -- | Wrapper for microseconds. -newtype Microseconds - = Microseconds W.Word32 - -- ^ Max timeout ~71 minutes with Word32 +data Microseconds = Microseconds W.Word32 -- Max timeout ~71 minutes with Word32 diff --git a/src/EulerHS/Core/Types/DB.hs b/src/EulerHS/Core/Types/DB.hs index 3b56f2a1..c1490ed8 100644 --- a/src/EulerHS/Core/Types/DB.hs +++ b/src/EulerHS/Core/Types/DB.hs @@ -3,31 +3,17 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE RecordWildCards #-} -{- | -Module : EulerHS.Core.Types.DB -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -This module contains general DB-related types and helper functions. - -This module is internal and should not imported in the projects. -Import 'EulerHS.Types' instead. - -Types and helpers for specific databases can be found in separate modules: - -'EulerHS.Core.Types.MySQL' -'EulerHS.Core.Types.Postgres' --} - --- TODO: separate runtime, implementation and public interface. module EulerHS.Core.Types.DB ( -- * Core DB - -- ** Public types - ConnTag + -- ** Types + BeamRuntime(..) + , deleteReturningListPG + , updateReturningListPG + , BeamRunner(..) + , NativeSqlPool(..) + , NativeSqlConn(..) + , ConnTag , SQliteDBname , SqlConn(..) , DBConfig @@ -35,20 +21,9 @@ module EulerHS.Core.Types.DB , DBErrorType(..) , DBError(..) , DBResult - , PostgresSqlError(..) - , PostgresExecStatus(..) - , MysqlSqlError(..) - , SqliteSqlError(..) - , SqliteError(..) - , SQLError(..) - - -- ** Private types - , BeamRuntime(..) - , BeamRunner(..) - , NativeSqlPool(..) - , NativeSqlConn(..) - - -- ** Public helpers + -- ** Methods + , bemToNative + , nativeToBem , mkSqlConn , mkSQLiteConfig , mkSQLitePoolConfig @@ -57,24 +32,23 @@ module EulerHS.Core.Types.DB , mkMySQLConfig , mkMySQLPoolConfig , getDBName - , deleteReturningListPG - , updateReturningListPG - , defaultPoolConfig - - -- ** Private helpers - , bemToNative - , nativeToBem + -- ** Helpers , withTransaction , mysqlErrorToDbError , sqliteErrorToDbError , postgresErrorToDbError + , PostgresSqlError(..) + , PostgresExecStatus(..) + , MysqlSqlError(..) + , SqliteSqlError(..) + , SqliteError(..) + , SQLError(..) ) where import EulerHS.Prelude import qualified Data.Pool as DP import Data.Time.Clock (NominalDiffTime) -import qualified Data.Text as T import qualified Database.Beam as B import qualified Database.Beam.Backend.SQL as B import qualified Database.Beam.Backend.SQL.BeamExtensions as B @@ -90,33 +64,126 @@ import EulerHS.Core.Types.MySQL (MySQLConfig(..), createMySQLConn) import EulerHS.Core.Types.Postgres (PostgresConfig(..), createPostgresConn) --- * Public types and helpers --- | Creates 'SqlConn' from 'DBConfig'. --- --- You can use this function to prepare your DB connections before running a flow. --- It's also possible to call this function during the flow evaluation --- (using 'runIO' or 'runUntracedIO'). -mkSqlConn :: DBConfig beM -> IO (SqlConn beM) -mkSqlConn (PostgresPoolConf connTag cfg PoolConfig {..}) = PostgresPool connTag - <$> DP.createPool (createPostgresConn cfg) BP.close stripes keepAlive resourcesPerStripe -mkSqlConn (MySQLPoolConf connTag cfg PoolConfig {..}) = MySQLPool connTag - <$> DP.createPool (createMySQLConn cfg) MySQL.close stripes keepAlive resourcesPerStripe +class (B.BeamSqlBackend be, B.MonadBeam be beM) => BeamRuntime be beM + | be -> beM, beM -> be where + rtSelectReturningList :: B.FromBackendRow be a => B.SqlSelect be a -> beM [a] + rtSelectReturningOne :: B.FromBackendRow be a => B.SqlSelect be a -> beM (Maybe a) + rtInsert :: B.SqlInsert be table -> beM () + rtInsertReturningList :: forall table . (B.Beamable table, B.FromBackendRow be (table Identity)) => B.SqlInsert be table -> beM [table Identity] + rtUpdate :: B.SqlUpdate be table -> beM () + rtUpdateReturningList :: forall table. (B.Beamable table, B.FromBackendRow be (table Identity)) => B.SqlUpdate be table -> beM [table Identity] + rtDelete :: B.SqlDelete be table -> beM () -mkSqlConn (SQLitePoolConf connTag dbname PoolConfig {..}) = SQLitePool connTag - <$> DP.createPool (SQLite.open dbname) SQLite.close stripes keepAlive resourcesPerStripe +-- TODO: move somewhere (it's implementation) +instance BeamRuntime BS.Sqlite BS.SqliteM where + rtSelectReturningList = B.runSelectReturningList + rtSelectReturningOne = B.runSelectReturningOne + rtInsert = B.runInsert + rtInsertReturningList = B.runInsertReturningList + rtUpdate = B.runUpdate + rtUpdateReturningList = error "Not implemented" + rtDelete = B.runDelete -mkSqlConn (MockConfig connTag) = pure $ MockedPool connTag +-- TODO: move somewhere (it's implementation) +instance BeamRuntime BP.Postgres BP.Pg where + rtSelectReturningList = B.runSelectReturningList + rtSelectReturningOne = B.runSelectReturningOne + rtInsert = B.runInsert + rtInsertReturningList = B.runInsertReturningList + rtUpdate = B.runUpdate + rtUpdateReturningList = updateReturningListPG + rtDelete = B.runDelete --- | Special version of DELETE query specified for Postgres. --- TODO: unify this with other backends. deleteReturningListPG :: (B.Beamable table, B.FromBackendRow BP.Postgres (table Identity)) => B.SqlDelete BP.Postgres table -> BP.Pg [table Identity] deleteReturningListPG = B.runDeleteReturningList + +updateReturningListPG + :: (B.Beamable table, B.FromBackendRow BP.Postgres (table Identity)) + => B.SqlUpdate BP.Postgres table + -> BP.Pg [table Identity] +updateReturningListPG = B.runUpdateReturningList + +instance BeamRuntime BM.MySQL BM.MySQLM where + rtSelectReturningList = B.runSelectReturningList + rtSelectReturningOne = B.runSelectReturningOne + rtInsert = B.runInsert + rtInsertReturningList = error "Not implemented" + rtUpdate = B.runUpdate + rtUpdateReturningList = error "Not implemented" + rtDelete = B.runDelete + +class BeamRunner beM where + getBeamDebugRunner :: NativeSqlConn -> beM a -> ((Text -> IO ()) -> IO a) + + +instance BeamRunner BS.SqliteM where + getBeamDebugRunner (NativeSQLiteConn conn) beM = + \logger -> SQLite.runBeamSqliteDebug logger conn beM + getBeamDebugRunner _ _ = \_ -> error "Not a SQLite connection" + + +instance BeamRunner BP.Pg where + getBeamDebugRunner (NativePGConn conn) beM = + \logger -> BP.runBeamPostgresDebug logger conn beM + getBeamDebugRunner _ _ = \_ -> error "Not a Postgres connection" + +instance BeamRunner BM.MySQLM where + getBeamDebugRunner (NativeMySQLConn conn) beM = + \logger -> BM.runBeamMySQLDebug logger conn beM + getBeamDebugRunner _ _ = \_ -> error "Not a MySQL connection" + +withTransaction :: forall beM a . + SqlConn beM -> (NativeSqlConn -> IO a) -> IO (Either SomeException a) +withTransaction conn f = case conn of + MockedPool _ -> error "Mocked pool connections are not supported." + PostgresPool _ pool -> DP.withResource pool (go PGS.withTransaction NativePGConn) + MySQLPool _ pool -> DP.withResource pool (go MySQL.withTransaction NativeMySQLConn) + SQLitePool _ pool -> DP.withResource pool (go SQLite.withTransaction NativeSQLiteConn) + where + go :: forall b . (b -> IO a -> IO a) -> (b -> NativeSqlConn) -> b -> IO (Either SomeException a) + go hof wrap conn' = tryAny (hof conn' (f . wrap $ conn')) + +-- | Representation of native DB pools that we store in FlowRuntime +data NativeSqlPool + = NativePGPool (DP.Pool BP.Connection) -- ^ 'Pool' with Postgres connections + | NativeMySQLPool (DP.Pool MySQL.MySQLConn) -- ^ 'Pool' with MySQL connections + | NativeSQLitePool (DP.Pool SQLite.Connection) -- ^ 'Pool' with SQLite connections + | NativeMockedPool + deriving Show + +-- | Representation of native DB connections that we use in implementation. +data NativeSqlConn + = NativePGConn BP.Connection + | NativeMySQLConn MySQL.MySQLConn + | NativeSQLiteConn SQLite.Connection + +-- | Transform 'SqlConn' to 'NativeSqlPool' +bemToNative :: SqlConn beM -> NativeSqlPool +bemToNative (MockedPool _) = NativeMockedPool +bemToNative (PostgresPool _ pool) = NativePGPool pool +bemToNative (MySQLPool _ pool) = NativeMySQLPool pool +bemToNative (SQLitePool _ pool) = NativeSQLitePool pool + +-- | Create 'SqlConn' from 'DBConfig' +mkSqlConn :: DBConfig beM -> IO (SqlConn beM) +mkSqlConn (PostgresPoolConf connTag cfg PoolConfig {..}) = PostgresPool connTag + <$> DP.createPool (createPostgresConn cfg) BP.close stripes keepAlive resourcesPerStripe + +mkSqlConn (MySQLPoolConf connTag cfg PoolConfig {..}) = MySQLPool connTag + <$> DP.createPool (createMySQLConn cfg) MySQL.close stripes keepAlive resourcesPerStripe + +mkSqlConn (SQLitePoolConf connTag dbname PoolConfig {..}) = SQLitePool connTag + <$> DP.createPool (SQLite.open dbname) SQLite.close stripes keepAlive resourcesPerStripe + +mkSqlConn (MockConfig connTag) = pure $ MockedPool connTag + + -- | Tag for SQL connections type ConnTag = Text @@ -127,52 +194,37 @@ type SQliteDBname = String -- Parametrised by BEAM monad corresponding to the certain DB (MySQL, Postgres, SQLite) data SqlConn (beM :: Type -> Type) = MockedPool ConnTag - -- ^ This mocked connection is not related to any DBs. Used in the ART system and tests. | PostgresPool ConnTag (DP.Pool BP.Connection) - -- ^ 'Pool' with Postgres connections. + -- ^ 'Pool' with Postgres connections | MySQLPool ConnTag (DP.Pool MySQL.MySQLConn) - -- ^ 'Pool' with MySQL connections. + -- ^ 'Pool' with MySQL connections | SQLitePool ConnTag (DP.Pool SQLite.Connection) - -- ^ 'Pool' with SQLite connections. + -- ^ 'Pool' with SQLite connections deriving (Generic) + -- | Represents DB configurations data DBConfig (beM :: Type -> Type) = MockConfig ConnTag - -- ^ This mocked configs is not related to any DBs. Used in the ART system and tests. | PostgresPoolConf ConnTag PostgresConfig PoolConfig - -- ^ Config for 'Pool' with Postgres connections + -- ^ config for 'Pool' with Postgres connections | MySQLPoolConf ConnTag MySQLConfig PoolConfig - -- ^ Config for 'Pool' with MySQL connections + -- ^ config for 'Pool' with MySQL connections | SQLitePoolConf ConnTag SQliteDBname PoolConfig - -- ^ Config for 'Pool' with SQlite connections + -- ^ config for 'Pool' with SQlite connections deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) --- | Represents 'Pool' parameters. --- --- All the DB connections use a pool internally. --- Configure pools according to your needs. +-- | Represents 'Pool' parameters data PoolConfig = PoolConfig { stripes :: Int - -- ^ The number of stripes (distinct sub-pools) to maintain. The smallest acceptable value is 1. + -- ^ a number of sub-pools , keepAlive :: NominalDiffTime - -- ^ Amount of time for which an unused resource is kept open. The smallest acceptable value is 0.5 seconds. - -- - -- The elapsed time before destroying a resource may be a little longer than requested, as the reaper thread wakes at 1-second intervals. - -- - -- Conversion functions will treat it as seconds. - -- For example, (0.010 :: NominalDiffTime) corresponds to 10 milliseconds. + -- ^ the amount of time the connection will be stored , resourcesPerStripe :: Int - -- ^ Maximum number of resources to keep open per stripe. The smallest acceptable value is 1. + -- ^ maximum number of connections to be stored in each sub-pool } deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) --- | Default pool config. --- --- stripes = 1 --- keepAlive = 100 (seconds) --- resourcesPerStripe = 1 --- defaultPoolConfig :: PoolConfig defaultPoolConfig = PoolConfig { stripes = 1 @@ -204,18 +256,14 @@ mkMySQLConfig connTag dbName = MySQLPoolConf connTag dbName defaultPoolConfig mkMySQLPoolConfig :: ConnTag -> MySQLConfig -> PoolConfig -> DBConfig BM.MySQLM mkMySQLPoolConfig = MySQLPoolConf --- | Obtains a DB name from 'DBConfig'. --- --- For a mocked config, returns ConnTag as a DB name. getDBName :: DBConfig beM -> String getDBName (PostgresPoolConf _ (PostgresConfig{..}) _) = connectDatabase getDBName (MySQLPoolConf _ (MySQLConfig{..}) _) = connectDatabase getDBName (SQLitePoolConf _ dbName _) = dbName -getDBName (MockConfig tag) = T.unpack tag +getDBName (MockConfig _) = error "Can't get DB name of MockConfig" ---------------------------------------------------------------------- --- | Abstracted type for SQLite error types. data SqliteError = SqliteErrorOK | SqliteErrorError @@ -250,31 +298,65 @@ data SqliteError | SqliteErrorDone deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) --- | Abstracted type for SQLite error. +toSqliteError :: SQLite.Error -> SqliteError +toSqliteError SQLite.ErrorOK = SqliteErrorOK +toSqliteError SQLite.ErrorError = SqliteErrorError +toSqliteError SQLite.ErrorInternal = SqliteErrorInternal +toSqliteError SQLite.ErrorPermission = SqliteErrorPermission +toSqliteError SQLite.ErrorAbort = SqliteErrorAbort +toSqliteError SQLite.ErrorBusy = SqliteErrorBusy +toSqliteError SQLite.ErrorLocked = SqliteErrorLocked +toSqliteError SQLite.ErrorNoMemory = SqliteErrorNoMemory +toSqliteError SQLite.ErrorReadOnly = SqliteErrorReadOnly +toSqliteError SQLite.ErrorInterrupt = SqliteErrorInterrupt +toSqliteError SQLite.ErrorIO = SqliteErrorIO +toSqliteError SQLite.ErrorCorrupt = SqliteErrorCorrupt +toSqliteError SQLite.ErrorNotFound = SqliteErrorNotFound +toSqliteError SQLite.ErrorFull = SqliteErrorFull +toSqliteError SQLite.ErrorCan'tOpen = SqliteErrorCantOpen +toSqliteError SQLite.ErrorProtocol = SqliteErrorProtocol +toSqliteError SQLite.ErrorEmpty = SqliteErrorEmpty +toSqliteError SQLite.ErrorSchema = SqliteErrorSchema +toSqliteError SQLite.ErrorTooBig = SqliteErrorTooBig +toSqliteError SQLite.ErrorConstraint = SqliteErrorConstraint +toSqliteError SQLite.ErrorMismatch = SqliteErrorMismatch +toSqliteError SQLite.ErrorMisuse = SqliteErrorMisuse +toSqliteError SQLite.ErrorNoLargeFileSupport = SqliteErrorNoLargeFileSupport +toSqliteError SQLite.ErrorAuthorization = SqliteErrorAuthorization +toSqliteError SQLite.ErrorFormat = SqliteErrorFormat +toSqliteError SQLite.ErrorRange = SqliteErrorRange +toSqliteError SQLite.ErrorNotADatabase = SqliteErrorNotADatabase +toSqliteError SQLite.ErrorNotice = SqliteErrorNotice +toSqliteError SQLite.ErrorWarning = SqliteErrorWarning +toSqliteError SQLite.ErrorRow = SqliteErrorRow +toSqliteError SQLite.ErrorDone = SqliteErrorDone + data SqliteSqlError = SqliteSqlError { sqlError :: !SqliteError - -- ^ Error type , sqlErrorDetails :: Text - -- ^ Additional error details , sqlErrorContext :: Text - -- ^ Error context } deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) --- | Abstracted type for any errors occurring when dealing with the SQL DB subsystem. +toSqliteSqlError :: SQLite.SQLError -> SqliteSqlError +toSqliteSqlError sqlErr = SqliteSqlError + { sqlError = toSqliteError $ SQLite.sqlError sqlErr + , sqlErrorDetails = SQLite.sqlErrorDetails sqlErr + , sqlErrorContext = SQLite.sqlErrorContext sqlErr + } + +sqliteErrorToDbError :: Text -> SQLite.SQLError -> DBError +sqliteErrorToDbError descr e = DBError (SQLError $ SqliteError $ toSqliteSqlError e) descr + data SQLError = PostgresError PostgresSqlError - -- ^ Contains a Postgres abstracted error | MysqlError MysqlSqlError - -- ^ Contains a MySQL abstracted error | SqliteError SqliteSqlError - -- ^ Contains a SQLite abstracted error deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) ---------------------------------------------------------------------- --- | Abstracted type for MySQL error. data MysqlSqlError = MysqlSqlError { errCode :: {-# UNPACK #-} !Word16, @@ -283,9 +365,16 @@ data MysqlSqlError = deriving stock (Show, Eq, Ord, Generic) deriving anyclass (ToJSON, FromJSON) +toMysqlSqlError :: MySQL.ERR -> MysqlSqlError +toMysqlSqlError err = MysqlSqlError { errCode = MySQL.errCode err, + errMsg = decodeUtf8 . MySQL.errMsg $ err } + +mysqlErrorToDbError :: Text -> MySQL.ERRException -> DBError +mysqlErrorToDbError desc (MySQL.ERRException e) = + DBError (SQLError . MysqlError . toMysqlSqlError $ e) desc + ---------------------------------------------------------------------- --- | Abstracted type for Postgress exec status. data PostgresExecStatus = PostgresEmptyQuery | PostgresCommandOk @@ -299,7 +388,20 @@ data PostgresExecStatus | PostgresSingleTuple deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) --- | Abstracted type for Postgress SQL error. + +toPostgresExecStatus :: PGS.ExecStatus -> PostgresExecStatus +toPostgresExecStatus PGS.EmptyQuery = PostgresEmptyQuery +toPostgresExecStatus PGS.CommandOk = PostgresCommandOk +toPostgresExecStatus PGS.TuplesOk = PostgresTuplesOk +toPostgresExecStatus PGS.CopyOut = PostgresCopyOut +toPostgresExecStatus PGS.CopyIn = PostgresCopyIn +toPostgresExecStatus PGS.CopyBoth = PostgresCopyBoth +toPostgresExecStatus PGS.BadResponse = PostgresBadResponse +toPostgresExecStatus PGS.NonfatalError = PostgresNonfatalError +toPostgresExecStatus PGS.FatalError = PostgresFatalError +toPostgresExecStatus PGS.SingleTuple = PostgresSingleTuple + + data PostgresSqlError = PostgresSqlError { sqlState :: Text @@ -310,28 +412,33 @@ data PostgresSqlError = } deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) + +toPostgresSqlError :: PGS.SqlError -> PostgresSqlError +toPostgresSqlError e = PostgresSqlError + { sqlState = decodeUtf8 $ PGS.sqlState e + , sqlExecStatus = toPostgresExecStatus $ PGS.sqlExecStatus e + , sqlErrorMsg = decodeUtf8 $ PGS.sqlErrorMsg e + , sqlErrorDetail = decodeUtf8 $ PGS.sqlErrorDetail e + , sqlErrorHint = decodeUtf8 $ PGS.sqlErrorHint e + } + + +postgresErrorToDbError :: Text -> PGS.SqlError -> DBError +postgresErrorToDbError descr e = DBError (SQLError $ PostgresError $ toPostgresSqlError e) descr + ---------------------------------------------------------------------- --- | Represents different failures that the SQL subsystem may return + +-- TODO: more informative typed error. +-- | Represents failures that may occur while working with the database data DBErrorType = ConnectionFailed - -- ^ Connection problem. Can be anything that causes the connection to break. | ConnectionAlreadyExists - -- ^ This error indicates that the connection for this particular config already exist. | ConnectionDoesNotExist - -- ^ This error indicates that the connection for this particular config is not found. | TransactionRollbacked - -- ^ This error indicates about a rollbacked transaction. - -- - -- (Not supported yet) | SQLError SQLError - -- ^ Some specific error the DB backend has returned. | UnexpectedResult - -- ^ An unexpected error happened in the SQL DB subsystem. - -- - -- (Not supported yet) | UnrecognizedError - -- ^ Unknown error from a native DB backend or from the SQL DB subsystem. deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) -- | Represents DB error @@ -342,258 +449,10 @@ data DBError -- | Represents resulting type for DB actions type DBResult a = Either DBError a --- * Internal types and functions - --- | This type class ties internal beam-related type classes --- and implementation details. --- --- In typical scenarios, you won't be needing this type class or its methods, --- because the 'SqlDB' language provides a more high level interface to the --- SQL DB subsystem. --- --- It's not guaranteed that this type class will remain public. --- --- This type class helps to support multiple DB backends. --- 3 different backends are supported out of the box: --- --- - SQLite --- - MySQL --- - Postgres -class (B.BeamSqlBackend be, B.MonadBeam be beM) => BeamRuntime be beM - | be -> beM, beM -> be where - rtSelectReturningList :: B.FromBackendRow be a => B.SqlSelect be a -> beM [a] - rtSelectReturningOne :: B.FromBackendRow be a => B.SqlSelect be a -> beM (Maybe a) - rtInsert :: B.SqlInsert be table -> beM () - rtInsertReturningList :: forall table . (B.Beamable table, B.FromBackendRow be (table Identity)) => B.SqlInsert be table -> beM [table Identity] - rtUpdate :: B.SqlUpdate be table -> beM () - rtUpdateReturningList :: forall table. (B.Beamable table, B.FromBackendRow be (table Identity)) => B.SqlUpdate be table -> beM [table Identity] - rtDelete :: B.SqlDelete be table -> beM () - --- | Implements 'BeamRuntime' for SQLite. -instance BeamRuntime BS.Sqlite BS.SqliteM where - rtSelectReturningList = B.runSelectReturningList - rtSelectReturningOne = B.runSelectReturningOne - rtInsert = B.runInsert - rtInsertReturningList = B.runInsertReturningList - rtUpdate = B.runUpdate - rtUpdateReturningList = error "Not implemented" - rtDelete = B.runDelete - --- | Implements 'BeamRuntime' for Postgres. -instance BeamRuntime BP.Postgres BP.Pg where - rtSelectReturningList = B.runSelectReturningList - rtSelectReturningOne = B.runSelectReturningOne - rtInsert = B.runInsert - rtInsertReturningList = B.runInsertReturningList - rtUpdate = B.runUpdate - rtUpdateReturningList = updateReturningListPG - rtDelete = B.runDelete - --- | Implements 'BeamRuntime' for MySQL. -instance BeamRuntime BM.MySQL BM.MySQLM where - rtSelectReturningList = B.runSelectReturningList - rtSelectReturningOne = B.runSelectReturningOne - rtInsert = B.runInsert - rtInsertReturningList = error "Not implemented" - rtUpdate = B.runUpdate - rtUpdateReturningList = error "Not implemented" - rtDelete = B.runDelete - --- | Special version of UPDATE query specified for Postgres. --- TODO: unify this with other backends. -updateReturningListPG - :: (B.Beamable table, B.FromBackendRow BP.Postgres (table Identity)) - => B.SqlUpdate BP.Postgres table - -> BP.Pg [table Identity] -updateReturningListPG = B.runUpdateReturningList - --- | This type class ties native connections, beam and native SQL backends. --- --- In typical scenarios, you won't be needing this type class or its methods, --- because the 'SqlDB' language provides a more high level interface to the --- SQL DB subsystem. --- --- It's not guaranteed that this type class will remain public. --- --- This type class helps to support multiple SQL backends. --- 3 different backends are supported out of the box: --- --- - SQLite --- - MySQL --- - Postgres -class BeamRunner beM where - getBeamDebugRunner :: NativeSqlConn -> beM a -> ((Text -> IO ()) -> IO a) - --- | Implements 'BeamRunner' for SQLite. -instance BeamRunner BS.SqliteM where - getBeamDebugRunner (NativeSQLiteConn conn) beM = - \logger -> SQLite.runBeamSqliteDebug logger conn beM - getBeamDebugRunner _ _ = \_ -> error "Not a SQLite connection" - --- | Implements 'BeamRunner' for Postgres. -instance BeamRunner BP.Pg where - getBeamDebugRunner (NativePGConn conn) beM = - \logger -> BP.runBeamPostgresDebug logger conn beM - getBeamDebugRunner _ _ = \_ -> error "Not a Postgres connection" - --- | Implements 'BeamRunner' for MySQL. -instance BeamRunner BM.MySQLM where - getBeamDebugRunner (NativeMySQLConn conn) beM = - \logger -> BM.runBeamMySQLDebug logger conn beM - getBeamDebugRunner _ _ = \_ -> error "Not a MySQL connection" - --- | Evaluates an action over a native connection within a native transaction. --- All the backends have this support of transactions: --- --- - SQLite --- - MySQL --- - Postgres --- --- This is an internal function. Don't use it in the BL code. -withTransaction :: forall beM a . - SqlConn beM -> (NativeSqlConn -> IO a) -> IO (Either SomeException a) -withTransaction conn f = case conn of - MockedPool _ -> error "Mocked pool connections are not supported." - PostgresPool _ pool -> DP.withResource pool (go PGS.withTransaction NativePGConn) - MySQLPool _ pool -> DP.withResource pool (go MySQL.withTransaction NativeMySQLConn) - SQLitePool _ pool -> DP.withResource pool (go SQLite.withTransaction NativeSQLiteConn) - where - go :: forall b . (b -> IO a -> IO a) -> (b -> NativeSqlConn) -> b -> IO (Either SomeException a) - go hof wrap conn' = tryAny (hof conn' (f . wrap $ conn')) - --- | Representation of native DB pools that we store in FlowRuntime. --- --- This is an internal type. Don't use it in the BL code. -data NativeSqlPool - = NativePGPool (DP.Pool BP.Connection) -- ^ 'Pool' with Postgres connections - | NativeMySQLPool (DP.Pool MySQL.MySQLConn) -- ^ 'Pool' with MySQL connections - | NativeSQLitePool (DP.Pool SQLite.Connection) -- ^ 'Pool' with SQLite connections - | NativeMockedPool - deriving Show - --- | Representation of native DB connections that we use in the implementation. --- --- This is an internal type. Don't use it in the BL code. -data NativeSqlConn - = NativePGConn BP.Connection - | NativeMySQLConn MySQL.MySQLConn - | NativeSQLiteConn SQLite.Connection - --- | Transform 'SqlConn' to 'NativeSqlPool'. --- --- This is an internal function. Don't use it in the BL code. -bemToNative :: SqlConn beM -> NativeSqlPool -bemToNative (MockedPool _) = NativeMockedPool -bemToNative (PostgresPool _ pool) = NativePGPool pool -bemToNative (MySQLPool _ pool) = NativeMySQLPool pool -bemToNative (SQLitePool _ pool) = NativeSQLitePool pool --- | Transforms 'NativeSqlPool' to 'SqlConn'. --- --- This is an internal function. Don't use it in the BL code. +-- | Transforms 'NativeSqlPool' to 'SqlConn' nativeToBem :: ConnTag -> NativeSqlPool -> SqlConn beM nativeToBem connTag NativeMockedPool = MockedPool connTag nativeToBem connTag (NativePGPool conn) = PostgresPool connTag conn nativeToBem connTag (NativeMySQLPool conn) = MySQLPool connTag conn nativeToBem connTag (NativeSQLitePool conn) = SQLitePool connTag conn - ----- - --- | Transforms a native Postgres SQL error into an abstracted error type 'PostgresSqlError'. --- --- This is an internal function. Don't use it in the BL code. -toPostgresSqlError :: PGS.SqlError -> PostgresSqlError -toPostgresSqlError e = PostgresSqlError - { sqlState = decodeUtf8 $ PGS.sqlState e - , sqlExecStatus = toPostgresExecStatus $ PGS.sqlExecStatus e - , sqlErrorMsg = decodeUtf8 $ PGS.sqlErrorMsg e - , sqlErrorDetail = decodeUtf8 $ PGS.sqlErrorDetail e - , sqlErrorHint = decodeUtf8 $ PGS.sqlErrorHint e - } - --- | Transforms a native Postgres SQL error into the general DB error type 'DBError'. --- --- This is an internal function. Don't use it in the BL code. -postgresErrorToDbError :: Text -> PGS.SqlError -> DBError -postgresErrorToDbError descr e = DBError (SQLError $ PostgresError $ toPostgresSqlError e) descr - --- | Transforms a native Postgres exec status into an abstracted type 'PostgresExecStatus'. --- --- This is an internal function. Don't use it in the BL code. -toPostgresExecStatus :: PGS.ExecStatus -> PostgresExecStatus -toPostgresExecStatus PGS.EmptyQuery = PostgresEmptyQuery -toPostgresExecStatus PGS.CommandOk = PostgresCommandOk -toPostgresExecStatus PGS.TuplesOk = PostgresTuplesOk -toPostgresExecStatus PGS.CopyOut = PostgresCopyOut -toPostgresExecStatus PGS.CopyIn = PostgresCopyIn -toPostgresExecStatus PGS.CopyBoth = PostgresCopyBoth -toPostgresExecStatus PGS.BadResponse = PostgresBadResponse -toPostgresExecStatus PGS.NonfatalError = PostgresNonfatalError -toPostgresExecStatus PGS.FatalError = PostgresFatalError -toPostgresExecStatus PGS.SingleTuple = PostgresSingleTuple - --- | Transforms a native SQLite SQL error type into an abstracted error type 'SqliteError'. --- --- This is an internal function. Don't use it in the BL code. -toSqliteError :: SQLite.Error -> SqliteError -toSqliteError SQLite.ErrorOK = SqliteErrorOK -toSqliteError SQLite.ErrorError = SqliteErrorError -toSqliteError SQLite.ErrorInternal = SqliteErrorInternal -toSqliteError SQLite.ErrorPermission = SqliteErrorPermission -toSqliteError SQLite.ErrorAbort = SqliteErrorAbort -toSqliteError SQLite.ErrorBusy = SqliteErrorBusy -toSqliteError SQLite.ErrorLocked = SqliteErrorLocked -toSqliteError SQLite.ErrorNoMemory = SqliteErrorNoMemory -toSqliteError SQLite.ErrorReadOnly = SqliteErrorReadOnly -toSqliteError SQLite.ErrorInterrupt = SqliteErrorInterrupt -toSqliteError SQLite.ErrorIO = SqliteErrorIO -toSqliteError SQLite.ErrorCorrupt = SqliteErrorCorrupt -toSqliteError SQLite.ErrorNotFound = SqliteErrorNotFound -toSqliteError SQLite.ErrorFull = SqliteErrorFull -toSqliteError SQLite.ErrorCan'tOpen = SqliteErrorCantOpen -toSqliteError SQLite.ErrorProtocol = SqliteErrorProtocol -toSqliteError SQLite.ErrorEmpty = SqliteErrorEmpty -toSqliteError SQLite.ErrorSchema = SqliteErrorSchema -toSqliteError SQLite.ErrorTooBig = SqliteErrorTooBig -toSqliteError SQLite.ErrorConstraint = SqliteErrorConstraint -toSqliteError SQLite.ErrorMismatch = SqliteErrorMismatch -toSqliteError SQLite.ErrorMisuse = SqliteErrorMisuse -toSqliteError SQLite.ErrorNoLargeFileSupport = SqliteErrorNoLargeFileSupport -toSqliteError SQLite.ErrorAuthorization = SqliteErrorAuthorization -toSqliteError SQLite.ErrorFormat = SqliteErrorFormat -toSqliteError SQLite.ErrorRange = SqliteErrorRange -toSqliteError SQLite.ErrorNotADatabase = SqliteErrorNotADatabase -toSqliteError SQLite.ErrorNotice = SqliteErrorNotice -toSqliteError SQLite.ErrorWarning = SqliteErrorWarning -toSqliteError SQLite.ErrorRow = SqliteErrorRow -toSqliteError SQLite.ErrorDone = SqliteErrorDone - --- | Transforms a native SQLite SQL error into an abstracted error type 'SqliteSqlError'. --- --- This is an internal function. Don't use it in the BL code. -toSqliteSqlError :: SQLite.SQLError -> SqliteSqlError -toSqliteSqlError sqlErr = SqliteSqlError - { sqlError = toSqliteError $ SQLite.sqlError sqlErr - , sqlErrorDetails = SQLite.sqlErrorDetails sqlErr - , sqlErrorContext = SQLite.sqlErrorContext sqlErr - } - --- | Transforms a native SQLite SQL error into the general DB error type 'DBError'. --- --- This is an internal function. Don't use it in the BL code. -sqliteErrorToDbError :: Text -> SQLite.SQLError -> DBError -sqliteErrorToDbError descr e = DBError (SQLError $ SqliteError $ toSqliteSqlError e) descr - --- | Transforms a native MySQL error into an abstracted error type 'MysqlSqlError'. --- --- This is an internal function. Don't use it in the BL code. -toMysqlSqlError :: MySQL.ERR -> MysqlSqlError -toMysqlSqlError err = MysqlSqlError { errCode = MySQL.errCode err, - errMsg = decodeUtf8 . MySQL.errMsg $ err } - --- | Transforms a native MySQL error into the general DB error type 'DBError'. --- --- This is an internal function. Don't use it in the BL code. -mysqlErrorToDbError :: Text -> MySQL.ERRException -> DBError -mysqlErrorToDbError desc (MySQL.ERRException e) = - DBError (SQLError . MysqlError . toMysqlSqlError $ e) desc diff --git a/src/EulerHS/Core/Types/Exceptions.hs b/src/EulerHS/Core/Types/Exceptions.hs index fc0757ba..ccee1e76 100644 --- a/src/EulerHS/Core/Types/Exceptions.hs +++ b/src/EulerHS/Core/Types/Exceptions.hs @@ -1,19 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} -{- | -Module : EulerHS.Core.Types.Exceptions -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -This module contains some exceptions and error types used in the framework. - -This module is internal and should not imported in the projects. -Import 'EulerHS.Types' instead. --} - module EulerHS.Core.Types.Exceptions ( -- * Exceptions HttpManagerNotFound(..) @@ -22,15 +8,10 @@ module EulerHS.Core.Types.Exceptions import EulerHS.Prelude --- | Exception type for indicating that a named Http manager is not set. + data HttpManagerNotFound = HttpManagerNotFound String deriving (Show, Eq, Exception) --- | This error may be returned on some problem with an awaitable value. -data AwaitingError - = AwaitingTimeout - -- ^ Awaiting period has expired. - | ForkedFlowError Text - -- ^ A forked flow has finished with this error. - deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) +data AwaitingError = AwaitingTimeout | ForkedFlowError Text + deriving (Show, Eq, Ord, Generic) diff --git a/src/EulerHS/Core/Types/HttpAPI.hs b/src/EulerHS/Core/Types/HttpAPI.hs index 9b170105..127c6eb3 100644 --- a/src/EulerHS/Core/Types/HttpAPI.hs +++ b/src/EulerHS/Core/Types/HttpAPI.hs @@ -1,20 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} -{- | -Module : EulerHS.Core.Types.HttpAPI -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -This module contains types and helper functions for the low-level -client HTTP subsystem (the `CallHTTP` method; not servant-based `CallServantAPI` method). - -This module is internal and should not imported in the projects. -Import 'EulerHS.Types' instead. --} - module EulerHS.Core.Types.HttpAPI ( -- * Core Logger @@ -25,7 +10,6 @@ module EulerHS.Core.Types.HttpAPI , HTTPCert(..) , HTTPRequestResponse(HTTPRequestResponse) , HTTPIOException(HTTPIOException) - , defaultRequest , defaultTimeout , extractBody , httpGet @@ -33,11 +17,14 @@ module EulerHS.Core.Types.HttpAPI , httpPost , httpDelete , httpHead + , defaultRequest , withHeader , withOptionalHeader , withBody , withTimeout , withRedirects + , maskHTTPRequest + , maskHTTPResponse ) where import EulerHS.Prelude hiding ((.=), ord) @@ -51,6 +38,9 @@ import qualified Data.Char as Char import qualified Data.Map as Map import Data.String.Conversions (convertString) import qualified Data.Text.Encoding as Text +import EulerHS.Core.Masking +import qualified EulerHS.Core.Types.Logger as Log (LogMaskingConfig(..)) + data HTTPRequest = HTTPRequest @@ -61,7 +51,7 @@ data HTTPRequest , getRequestTimeout :: Maybe Int -- ^ timeout, in microseconds , getRequestRedirects :: Maybe Int } - deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) + deriving (Eq, Ord, Generic, ToJSON) data HTTPResponse = HTTPResponse @@ -70,7 +60,7 @@ data HTTPResponse , getResponseHeaders :: Map.Map HeaderName HeaderValue , getResponseStatus :: Text } - deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) + deriving (Eq, Ord, Generic, ToJSON) data HTTPCert = HTTPCert @@ -86,7 +76,7 @@ data HTTPMethod | Post | Delete | Head - deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) + deriving (Eq, Ord, Generic, ToJSON) type HeaderName = Text type HeaderValue = Text @@ -96,7 +86,7 @@ data HTTPRequestResponse { request :: HTTPRequest , response :: HTTPResponse } - deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) + deriving (Eq, Ord, Generic, ToJSON) -- | Used when some IO (or other) exception ocurred during a request data HTTPIOException @@ -104,7 +94,17 @@ data HTTPIOException { errorMessage :: Text , request :: HTTPRequest } - deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) + deriving (Eq, Ord, Generic, ToJSON) + + +-- Not Used anywhere +-- getMaybeUtf8 :: T.LBinaryString -> Maybe LazyText.Text +-- getMaybeUtf8 body = case LazyText.decodeUtf8' (T.getLBinaryString body) of +-- -- return request body as base64-encoded text (not valid UTF-8) +-- Left e -> Nothing +-- -- return request body as UTF-8 decoded text +-- Right utf8Body -> Just utf8Body + -------------------------------------------------------------------------- @@ -166,6 +166,7 @@ withRedirects :: Int -> HTTPRequest -> HTTPRequest withRedirects redirects request = request {getRequestRedirects = Just redirects} +-- TODO: Rename to `withFormData` or some such? withBody :: [(Text, Text)] -> HTTPRequest -> HTTPRequest withBody pairs request = request {getRequestBody = Just body} where @@ -221,3 +222,43 @@ formUrlEncode = Builder.toLazyByteString . mconcat . intersperse amp . map encod offset | n < 10 = 48 | otherwise = 55 + +maskHTTPRequest :: Maybe Log.LogMaskingConfig -> HTTPRequest -> HTTPRequest +maskHTTPRequest mbMaskConfig request = + request + { getRequestHeaders = maskHTTPHeaders (shouldMaskKey mbMaskConfig) getMaskText requestHeaders + , getRequestBody = maskedRequestBody + } + where + requestHeaders = getRequestHeaders request + + requestBody = getRequestBody request + + getMaskText = maybe defaultMaskText (fromMaybe defaultMaskText . Log._maskText) mbMaskConfig + + maskedRequestBody = + T.LBinaryString + . encodeUtf8 + . parseRequestResponseBody (shouldMaskKey mbMaskConfig) getMaskText (getContentTypeForHTTP requestHeaders) + . LB.toStrict + . T.getLBinaryString <$> requestBody + +maskHTTPResponse :: Maybe Log.LogMaskingConfig -> HTTPResponse -> HTTPResponse +maskHTTPResponse mbMaskConfig response = + response + { getResponseHeaders = maskHTTPHeaders (shouldMaskKey mbMaskConfig) getMaskText responseHeaders + , getResponseBody = maskedResponseBody + } + where + responseHeaders = getResponseHeaders response + + responseBody = getResponseBody response + + getMaskText = maybe defaultMaskText (fromMaybe defaultMaskText . Log._maskText) mbMaskConfig + + maskedResponseBody = + T.LBinaryString + . encodeUtf8 + . parseRequestResponseBody (shouldMaskKey mbMaskConfig) getMaskText (getContentTypeForHTTP responseHeaders) + . LB.toStrict + $ T.getLBinaryString responseBody diff --git a/src/EulerHS/Core/Types/KVDB.hs b/src/EulerHS/Core/Types/KVDB.hs index b2e5ee3d..661c9f22 100644 --- a/src/EulerHS/Core/Types/KVDB.hs +++ b/src/EulerHS/Core/Types/KVDB.hs @@ -2,23 +2,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RecordWildCards #-} -{- | -Module : EulerHS.Core.Types.KVDB -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -Types and helper functions of the KV DB subsystem. - -Currently, highly resembles the `hedis` library interface to Redis. -Other KV DBs are not yet supported. - -This module is internal and should not imported in the projects. -Import 'EulerHS.Types' instead. --} - module EulerHS.Core.Types.KVDB ( -- * Core KVDB @@ -30,6 +13,8 @@ module EulerHS.Core.Types.KVDB , TxResult(..) , KVDBStatus , KVDBStatusF(..) + , KVDBMockedValues + , KVDBMockedValues'(..) , KVDBReplyF(..) , NativeKVDBConn (..) , KVDBConfig (..) @@ -48,39 +33,44 @@ module EulerHS.Core.Types.KVDB , kvdbToNative ) where -import qualified Data.Aeson as A import Data.Time (NominalDiffTime) import qualified Database.Redis as RD -import EulerHS.Core.Types.Serializable import EulerHS.Prelude import qualified GHC.Generics as G --- | Alias for denoting a raw key type. + type KVDBKey = Text --- | Key-value database connection +-- Key-value database connection data KVDBConn = Mocked Text -- TODO swap Text with ConnTag type - -- ^ Mocked connection. Used for ART and tests. | Redis Text RD.Connection - -- ^ Real Redis connection. + -- ^ Real connection. deriving (Generic) +data KVDBMockedValues' = KVDBMockedValues' + { kvdbSet :: [KVDBStatus] + , kvdbGet :: [(Maybe ByteString)] + , kvdbExists :: [Bool] + , kvdbDel :: [Integer] + , kvdbExpire :: [Bool] + , kvdbIncr :: [Integer] + , kvdbHSet :: [Bool] + , kvdbHGet :: [(Maybe ByteString)] + , kvdbTX :: [TxResult Any] + } deriving (Generic, Typeable) + + +type KVDBMockedValues = MVar (KVDBMockedValues') + ---------------------------------------------------------------------- --- | Error that may occur when initializing / deinitializing a KV DB connection. data KVDBError = KVDBConnectionAlreadyExists - -- ^ Connection for a particular config already exist. | KVDBConnectionDoesNotExist - -- ^ Connection for a particular config is not found. | KVDBConnectionFailed - -- ^ Connection procedure failed. - deriving (Eq, Show, Generic, ToJSON, FromJSON) + deriving (Eq, Show, Generic) --- | A unified parametrizable type for return values of the KV DB subsystem. --- --- Mostly duplicates the @hedis@ library interface. data KVDBReplyF bs = SingleLine bs | Err bs @@ -91,111 +81,104 @@ data KVDBReplyF bs | KVDBError KVDBError String deriving (Eq, Show, Generic, Functor) -instance ToJSON (KVDBReplyF ByteStringS) -instance FromJSON (KVDBReplyF ByteStringS) - --- | A unified type for return values of the KV DB subsystem. --- --- Mostly duplicates the @hedis@ library interface. type KVDBReply = KVDBReplyF ByteString -instance ToJSON KVDBReply where - toJSON = toJSON . fromKVDBReply - -fromKVDBReply :: KVDBReply -> KVDBReplyF ByteStringS -fromKVDBReply = fmap fromByteString +-- fromKVDBReply :: KVDBReply -> KVDBReplyF ByteStringS +-- fromKVDBReply = fmap fromByteString -instance FromJSON KVDBReply where - parseJSON = fmap toKVDBReply . parseJSON - -toKVDBReply :: KVDBReplyF ByteStringS -> KVDBReply -toKVDBReply = fmap toByteString +-- toKVDBReply :: KVDBReplyF ByteStringS -> KVDBReply +-- toKVDBReply = fmap toByteString ---------------------------------------------------------------------- --- | Status that may be returned by the methods of the KVDB language. data KVDBStatusF bs = Ok | Pong | Status bs deriving (Eq, Show, Generic, Functor) -instance ToJSON (KVDBStatusF ByteStringS) -instance FromJSON (KVDBStatusF ByteStringS) - --- | Status that may be returned by the methods of the KVDB language. type KVDBStatus = KVDBStatusF ByteString -instance ToJSON KVDBStatus where - toJSON = toJSON . fromStatus +-- fromStatus :: KVDBStatus -> KVDBStatusF ByteStringS +-- fromStatus Ok = Ok +-- fromStatus Pong = Pong +-- fromStatus (Status bs) = Status $ fromByteString bs -fromStatus :: KVDBStatus -> KVDBStatusF ByteStringS -fromStatus Ok = Ok -fromStatus Pong = Pong -fromStatus (Status bs) = Status $ fromByteString bs +-- toStatus :: KVDBStatusF ByteStringS -> KVDBStatus +-- toStatus Ok = Ok +-- toStatus Pong = Pong +-- toStatus (Status bs) = Status $ toByteString bs -instance FromJSON KVDBStatus where - parseJSON = fmap toStatus . parseJSON +fromRdStatus :: RD.Status -> KVDBStatus +fromRdStatus RD.Ok = Ok +fromRdStatus RD.Pong = Pong +fromRdStatus (RD.Status bs) = Status $ bs -toStatus :: KVDBStatusF ByteStringS -> KVDBStatus -toStatus Ok = Ok -toStatus Pong = Pong -toStatus (Status bs) = Status $ toByteString bs +---------------------------------------------------------------------- --- | Result of a transactional evaluation of KV DB methods. data TxResult a = TxSuccess a - -- ^ Transaction is successful | TxAborted - -- ^ Transaction is aborted | TxError String - -- ^ Some error happened - deriving (Eq, Show, Functor, Generic, G.Generic1, A.ToJSON1, A.FromJSON1, ToJSON, FromJSON) + deriving (Eq, Show, Functor, Generic, G.Generic1) + +fromRdTxResult :: RD.TxResult a -> TxResult a +fromRdTxResult (RD.TxSuccess a) = TxSuccess a +fromRdTxResult RD.TxAborted = TxAborted +fromRdTxResult (RD.TxError s) = TxError s + +---------------------------------------------------------------------- --- | A type that contains either a valid result or a detailed info --- about the response from the KV DB subsystem. type KVDBAnswer = Either KVDBReply --- | A config type used to create a connection with a KV DB. +hedisReplyToKVDBReply :: RD.Reply -> KVDBReply +hedisReplyToKVDBReply (RD.SingleLine s) = SingleLine s +hedisReplyToKVDBReply (RD.Error s) = Err s +hedisReplyToKVDBReply (RD.Integer s) = Integer s +hedisReplyToKVDBReply (RD.Bulk s) = Bulk s +hedisReplyToKVDBReply (RD.MultiBulk s) = MultiBulk (map (hedisReplyToKVDBReply <$>) s) + + +exceptionToKVDBReply :: Exception e => e -> KVDBReply +exceptionToKVDBReply e = ExceptionMessage $ displayException e + +---------------------------------------------------------------------- + +data NativeKVDBConn + = NativeKVDB (RD.Connection) + | NativeKVDBMockedConn + +-- | Transform 'KVDBConn' to 'NativeKVDBConn' +kvdbToNative :: KVDBConn -> NativeKVDBConn +kvdbToNative (Mocked _) = NativeKVDBMockedConn +kvdbToNative (Redis _ conn) = NativeKVDB conn + +-- | Transforms 'NativeKVDBConn' to 'KVDBConn' +nativeToKVDB :: Text -> NativeKVDBConn -> KVDBConn +nativeToKVDB connTag NativeKVDBMockedConn = Mocked connTag +nativeToKVDB connTag (NativeKVDB conn) = Redis connTag conn + + data KVDBConfig = KVDBConfig Text RedisConfig - -- ^ Regular Redis config | KVDBClusterConfig Text RedisConfig - -- ^ KV DB config for a Redis cluster | KVDBMockedConfig Text - -- ^ Mocked config. Used in ART and tests. - deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) + deriving (Show, Eq, Ord, Generic) --- | Redis config data RedisConfig = RedisConfig { connectHost :: String - -- ^ Host , connectPort :: Word16 - -- ^ Port , connectAuth :: Maybe Text - -- ^ Auth credentials , connectDatabase :: Integer - -- ^ Database number , connectMaxConnections :: Int - -- ^ Max number of connections , connectMaxIdleTime :: NominalDiffTime - -- ^ Max connection idle time , connectTimeout :: Maybe NominalDiffTime - -- ^ Timeout for a connection - } deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) - --- | Default Redis config. --- connectHost = "127.0.0.1" --- connectPort = 6379 --- connectAuth = Nothing --- connectDatabase = 0 --- connectMaxConnections = 50 --- connectMaxIdleTime = 30 --- connectTimeout = Nothing + } deriving (Show, Eq, Ord, Generic) + defaultKVDBConnConfig :: RedisConfig defaultKVDBConnConfig = RedisConfig - { connectHost = "127.0.0.1" + { connectHost = "localhost" , connectPort = 6379 , connectAuth = Nothing , connectDatabase = 0 @@ -204,72 +187,7 @@ defaultKVDBConnConfig = RedisConfig , connectTimeout = Nothing } --- | Create configuration KVDBConfig for Redis -mkKVDBConfig :: Text -> RedisConfig -> KVDBConfig -mkKVDBConfig = KVDBConfig - --- | Create cluster configuration KVDBConfig for Redis -mkKVDBClusterConfig :: Text -> RedisConfig -> KVDBConfig -mkKVDBClusterConfig = KVDBClusterConfig - --- * Internal types and functions - --- | Native connection of a particular KV DB. --- --- Internal type, should not be used in the BL. -data NativeKVDBConn - = NativeKVDB (RD.Connection) - | NativeKVDBMockedConn - --- | Transform 'KVDBConn' to 'NativeKVDBConn' --- --- Internal function, should not be used in the BL. -kvdbToNative :: KVDBConn -> NativeKVDBConn -kvdbToNative (Mocked _) = NativeKVDBMockedConn -kvdbToNative (Redis _ conn) = NativeKVDB conn - --- | Transforms 'NativeKVDBConn' to 'KVDBConn' --- --- Internal function, should not be used in the BL. -nativeToKVDB :: Text -> NativeKVDBConn -> KVDBConn -nativeToKVDB connTag NativeKVDBMockedConn = Mocked connTag -nativeToKVDB connTag (NativeKVDB conn) = Redis connTag conn - --- | Transforms a Redis-related @Status@ to an abstracted 'KVDBStatus' --- --- Internal function, should not be used in the BL. -fromRdStatus :: RD.Status -> KVDBStatus -fromRdStatus RD.Ok = Ok -fromRdStatus RD.Pong = Pong -fromRdStatus (RD.Status bs) = Status $ bs - --- | Transforms a Redis-related @TxResult@ to an abstracted 'TxResult' --- --- Internal function, should not be used in the BL. -fromRdTxResult :: RD.TxResult a -> TxResult a -fromRdTxResult (RD.TxSuccess a) = TxSuccess a -fromRdTxResult RD.TxAborted = TxAborted -fromRdTxResult (RD.TxError s) = TxError s - --- | Transforms a Redis-related @Reply@ to an abstracted 'KVDBReply' --- --- Internal function, should not be used in the BL. -hedisReplyToKVDBReply :: RD.Reply -> KVDBReply -hedisReplyToKVDBReply (RD.SingleLine s) = SingleLine s -hedisReplyToKVDBReply (RD.Error s) = Err s -hedisReplyToKVDBReply (RD.Integer s) = Integer s -hedisReplyToKVDBReply (RD.Bulk s) = Bulk s -hedisReplyToKVDBReply (RD.MultiBulk s) = MultiBulk (map (hedisReplyToKVDBReply <$>) s) - --- | Wraps an exception into 'KVDBReply' --- --- Internal function, should not be used in the BL. -exceptionToKVDBReply :: Exception e => e -> KVDBReply -exceptionToKVDBReply e = ExceptionMessage $ displayException e - --- | Transform `RedisConfig` to the Redis-related @ConnectInfo@. --- --- Internal function, should not be used in the BL. +-- | Transform RedisConfig to the Redis ConnectInfo. toRedisConnectInfo :: RedisConfig -> RD.ConnectInfo toRedisConnectInfo RedisConfig {..} = RD.ConnInfo { RD.connectHost = connectHost @@ -282,22 +200,24 @@ toRedisConnectInfo RedisConfig {..} = RD.ConnInfo , RD.connectTLSParams = Nothing } +-- | Create configuration KVDBConfig for Redis +mkKVDBConfig :: Text -> RedisConfig -> KVDBConfig +mkKVDBConfig = KVDBConfig + +-- | Create cluster configuration KVDBConfig for Redis +mkKVDBClusterConfig :: Text -> RedisConfig -> KVDBConfig +mkKVDBClusterConfig = KVDBClusterConfig + -- | Create 'KVDBConn' from 'KVDBConfig' --- --- Internal function, should not be used in the BL. mkRedisConn :: KVDBConfig -> IO KVDBConn mkRedisConn (KVDBMockedConfig connTag) = pure $ Mocked connTag mkRedisConn (KVDBConfig connTag cfg) = Redis connTag <$> createRedisConn cfg mkRedisConn (KVDBClusterConfig connTag cfg) = Redis connTag <$> createClusterRedisConn cfg -- | Connect with the given config to the database. --- --- Internal function, should not be used in the BL. createRedisConn :: RedisConfig -> IO RD.Connection createRedisConn = RD.connect . toRedisConnectInfo -- | Connect with the given cluster config to the database. --- --- Internal function, should not be used in the BL. createClusterRedisConn :: RedisConfig -> IO RD.Connection createClusterRedisConn = RD.connectCluster . toRedisConnectInfo diff --git a/src/EulerHS/Core/Types/Logger.hs b/src/EulerHS/Core/Types/Logger.hs index 4b69f7df..673bec75 100644 --- a/src/EulerHS/Core/Types/Logger.hs +++ b/src/EulerHS/Core/Types/Logger.hs @@ -1,178 +1,116 @@ {-# LANGUAGE DeriveAnyClass #-} -{- | -Module : EulerHS.Core.Types.Logger -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -Types and helper functions of the Logging subsystem. - -This module is internal and should not imported in the projects. -Import 'EulerHS.Types' instead. --} - module EulerHS.Core.Types.Logger ( -- * Core Logger -- ** Types LogLevel(..) , BufferSize + , MessageBuilder (..) , MessageFormatter , FlowFormatter , LoggerConfig(..) , Message , Tag , PendingMsg(..) + , ShouldLogSQL(..) , LogEntry (..) , Log + , LogContext + , LogCounter + , LogMaskingConfig (..) + , MaskKeyType (..) -- ** defaults , defaultLoggerConfig , defaultMessageFormatter + , showingMessageFormatter , defaultFlowFormatter + , builderToByteString ) where import EulerHS.Prelude +import Data.HashSet(HashSet) import qualified EulerHS.Core.Types.Common as T +-- Currently, TinyLogger is highly coupled with the interface. +-- Reason: unclear current practice of logging that affects design and performance. +import qualified System.Logger.Message as LogMsg +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString as BS + -- | Logging level. -data LogLevel - = Debug - | Info - | Warning - | Error +data LogLevel = Debug | Info | Warning | Error deriving (Generic, Eq, Ord, Show, Read, Enum, ToJSON, FromJSON) --- | Message type -type Message = Text +data LogMaskingConfig = + LogMaskingConfig + { _maskKeys :: HashSet Text -- Check : Better to make this case insensitive + , _maskText :: Maybe Text + , _keyType :: MaskKeyType + } deriving (Generic, Show, Read) --- | Tag that accompanies every call of `logMessage`, `logInfo` and other functions. +data MessageBuilder + = SimpleString String + | SimpleText Text + | SimpleBS ByteString + | SimpleLBS LBS.ByteString + | MsgBuilder LogMsg.Builder + | MsgTransformer (LogMsg.Msg -> LogMsg.Msg) + +data MaskKeyType = + WhiteListKey + | BlackListKey + deriving (Generic, Show, Read) + +data ShouldLogSQL + -- | Log SQL queries, including sensitive data and API keys. Do NOT PR code + -- with this enabled, and make sure this doesn't make it into production + = UnsafeLogSQL_DO_NOT_USE_IN_PRODUCTION + -- | omit SQL logs + | SafelyOmitSqlLogs + deriving (Generic, Show, Read) + +type LogCounter = IORef Int -- No race condition: atomicModifyIORef' is used. +type Message = Text type Tag = Text - --- | The number of a log message in the this run. --- --- It's 0 for a fresh `LoggerRuntime`, and increases on each logging call. type MessageNumber = Int - --- | Buffer size of a logger. Can be important in some cases. type BufferSize = Int - -{- | Formatter of a message. - -Can be used to format a particular logging message (wrapped into `PendingMsg`). - -The simplest formatter is just `show`. -@ -import qualified EulerHS.Types as T - -simplestFormatter :: T.MessageFormatter -simplestFormatter = show -@ --} - -type MessageFormatter = PendingMsg -> String - -{- | A flow-specific message formatter. - -It's a callback that should return a `MessageFormatter` before a message -goes to the underlying logging library. - -In the simplest case, you return the same message formatter for any flow. -The @FlowGUID@ argument then has no effect. - -@ --- flowFormatter :: T.FlowFormatter -flowFormatter :: Maybe T.FlowGUID -> IO T.MessageFormatter -flowFormatter _ = pure simplestFormatter -@ - -In fact, you can setup your own message formatter for each new flow. -To do this, you define a callback which is able to track your flows -and return a particular message formatter. - -This logic should be thread-safe. - -@ -type FlowsFormatters = MVar (Map T.FlowGUID T.MessageFormatter) - -flowsFormatter - :: FlowsFormatters - -> Maybe T.FlowGUID - -> IO T.MessageFormatter -flowsFormatter flowFsVar Nothing = pure simplestFormatter -flowsFormatter flowFsVar (Just flowGuid) = do - flowFs <- readMVar flowFsVar - case Map.lookup flowGuid flowFS of - Nothing -> pure simplestFormatter -- You should decide on what to return here - Just formatter -> pure formatter -@ - -You can update your formatters map right before and after running a flow. -There is a special function `runFlow'` to run a flow with a particular GUID. - -GUID string can be anything unique across your flows. --} - +type MessageFormatter = PendingMsg -> MessageBuilder type FlowFormatter = Maybe T.FlowGUID -> IO MessageFormatter +type LogContext = HashMap Text Text --- | Config of a logger data LoggerConfig = LoggerConfig { _isAsync :: Bool - -- ^ Is it async. - -- - -- N.B. The async logger feature is not well-tested. , _logLevel :: LogLevel - -- ^ System log level , _logFilePath :: FilePath - -- ^ Log file path if a file logger is enabled , _logToConsole :: Bool - -- ^ Enable / disable a console logging. , _logToFile :: Bool - -- ^ Enable / disable a file logging , _maxQueueSize :: Word - -- ^ Allows to configure a logging queue. - , _logRawSql :: Bool - -- ^ Enable / disable logging of SQL queries in the SQL DB subsystem. - -- - -- SQL queries will be written as Debug messages. - -- - -- N.B. Enabling this feature slows down the performance of the SQL DB subsystem. + , _logRawSql :: ShouldLogSQL + , _logMaskingConfig :: Maybe LogMaskingConfig } deriving (Generic, Show, Read) --- | A message to send to the underlying logger subsystem. --- --- Can be formatted with `MessageFormatter`. data PendingMsg = PendingMsg !(Maybe T.FlowGUID) !LogLevel !Tag !Message !MessageNumber + !LogContext deriving (Show) -{- | Default message formatter: -@ -defaultMessageFormatter (PendingMsg _ lvl tag msg _) = - "[" +|| lvl ||+ "] <" +| tag |+ "> " +| msg |+ "" -@ --} +data LogEntry = LogEntry !LogLevel !Message +type Log = [LogEntry] + defaultMessageFormatter :: MessageFormatter -defaultMessageFormatter (PendingMsg _ lvl tag msg _) = - "[" +|| lvl ||+ "] <" +| tag |+ "> " +| msg |+ "" - -{- | Default logger config: - isAsync = False - logLevel = Debug - logFilePath = "" - logToConsole = True - logToFile = False - maxQueueSize = 1000 - logRawSql = True --} +defaultMessageFormatter (PendingMsg _ lvl tag msg _ _) = + SimpleString $ "[" +|| lvl ||+ "] <" +| tag |+ "> " +| msg |+ "" + +showingMessageFormatter :: MessageFormatter +showingMessageFormatter = SimpleString . show + defaultLoggerConfig :: LoggerConfig defaultLoggerConfig = LoggerConfig { _isAsync = False @@ -181,18 +119,12 @@ defaultLoggerConfig = LoggerConfig , _logToConsole = True , _logToFile = False , _maxQueueSize = 1000 - , _logRawSql = True + , _logRawSql = SafelyOmitSqlLogs + , _logMaskingConfig = Nothing } --- | Default flow formatter. --- Ignores the flow GUID and just returns `defaultMessageFormatter`. defaultFlowFormatter :: FlowFormatter defaultFlowFormatter _ = pure defaultMessageFormatter --- * Internal types - --- | Service type for tracking log entries -data LogEntry = LogEntry !LogLevel !Message - --- | Service type for tracking log entries -type Log = [LogEntry] +builderToByteString :: LogMsg.Builder -> LBS.ByteString +builderToByteString = LogMsg.eval diff --git a/src/EulerHS/Core/Types/MySQL.hs b/src/EulerHS/Core/Types/MySQL.hs index 91303e6b..15343d1a 100644 --- a/src/EulerHS/Core/Types/MySQL.hs +++ b/src/EulerHS/Core/Types/MySQL.hs @@ -1,19 +1,6 @@ -{-# LANGUAGE DerivingStrategies #-} +{-# OPTIONS_GHC -Werror #-} {-# LANGUAGE DeriveAnyClass #-} - -{- | -Module : EulerHS.Core.Types.MySQL -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -Types and helper functions to wrap a MySQL-related stuff. - -This module is internal and should not imported in the projects. -Import 'EulerHS.Types' instead. --} +{-# LANGUAGE DerivingStrategies #-} module EulerHS.Core.Types.MySQL ( @@ -21,6 +8,7 @@ module EulerHS.Core.Types.MySQL -- ** Types MySQLConfig(..) , MySqlOption(..) + , MySQLCharset(..) -- ** Methods , createMySQLConn , closeMySQLConn @@ -28,14 +16,14 @@ module EulerHS.Core.Types.MySQL , defaultMySQLConfig ) where -import Prelude -import Data.Word (Word16) -import Data.Aeson (ToJSON, FromJSON) -import GHC.Generics (Generic) -import Database.MySQL.Base (MySQLConn, close, ConnectInfo (..), connect, defaultConnectInfoMB4) -import Data.ByteString.UTF8 (fromString) +import Data.Aeson (FromJSON, ToJSON) +import Data.ByteString.UTF8 (fromString) +import Data.Word (Word16, Word8) +import Database.MySQL.Base (ConnectInfo (..), MySQLConn, close, + connect) +import GHC.Generics (Generic) +import Prelude --- | MySQL connection protocol data MySqlProtocol = TCP | Socket @@ -44,7 +32,6 @@ data MySqlProtocol deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) deriving anyclass (ToJSON, FromJSON) --- | MySQL options data MySqlOption = ConnectTimeout Word | Compress @@ -78,7 +65,6 @@ data MySqlOption deriving stock (Show, Eq, Ord, Generic) deriving anyclass (ToJSON, FromJSON) --- | Auth credentials data SSLInfo = SSLInfo { sslKey :: FilePath , sslCert :: FilePath @@ -89,7 +75,35 @@ data SSLInfo = SSLInfo deriving stock (Show, Eq, Ord, Generic) deriving anyclass (ToJSON, FromJSON) --- | MySQL config +-- | Describes the character set to be used with the database. This also +-- includes collation information. +-- +-- Currently, only a limited number of these are provided. +-- +-- /See also:/ [MySQL documentation on character +-- sets](https://dev.mysql.com/doc/refman/5.7/en/charset-mysql.html) +-- +-- @since 2.0.3.0 +data MySQLCharset = + -- | Corresponds to the @latin1@ character set, with the @latin1_swedish_ci@ + -- collation. + -- + -- @since 2.0.3.0 + Latin1 + -- | Corresponds to the @utf8@ character set, with the @utf8_general_ci@ + -- collation. + -- + -- @since 2.0.3.0 + | UTF8General + -- | Corresponds to the @utf8mb@ character set, with the @unicode_ci@ + -- collation. + -- + -- @since 2.0.3.0 + | UTF8Full + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (ToJSON, FromJSON) + +-- | @since 2.0.3.0 data MySQLConfig = MySQLConfig { connectHost :: String , connectPort :: Word16 @@ -99,46 +113,48 @@ data MySQLConfig = MySQLConfig , connectOptions :: [MySqlOption] , connectPath :: FilePath , connectSSL :: Maybe SSLInfo + , connectCharset :: !MySQLCharset -- ^ @since 2.0.3.0 } deriving stock (Show, Eq, Ord, Generic) deriving anyclass (ToJSON, FromJSON) -{- | Default MySQL config. - -connectHost = "127.0.0.1" -connectPort = 3306 -connectUser = "root" -connectPassword = "" -connectDatabase = "test" -connectOptions = [CharsetName "utf8"] -connectPath = "" -connectSSL = Nothing --} +-- | @since 2.0.3.0 defaultMySQLConfig :: MySQLConfig -defaultMySQLConfig = MySQLConfig - { connectHost = "127.0.0.1" - , connectPort = 3306 - , connectUser = "root" - , connectPassword = "" - , connectDatabase = "test" - , connectOptions = [CharsetName "utf8"] - , connectPath = "" - , connectSSL = Nothing +defaultMySQLConfig = MySQLConfig { + connectHost = "localhost", + connectPort = 3306, + connectUser = "root", + connectPassword = "", + connectDatabase = "test", + connectOptions = [CharsetName "utf8"], + connectPath = "", + connectSSL = Nothing, + connectCharset = Latin1 } -- | Connect with the given config to the database. +-- +-- @since 2.0.3.0 createMySQLConn :: MySQLConfig -> IO MySQLConn createMySQLConn conf = do - let dbConf = ConnectInfo - { ciHost = connectHost conf - , ciPort = fromIntegral . connectPort $ conf - , ciDatabase = fromString . connectDatabase $ conf - , ciUser = fromString . connectUser $ conf - , ciPassword = fromString . connectPassword $ conf - , ciCharset = ciCharset defaultConnectInfoMB4 - } + let dbConf = ConnectInfo { + ciHost = connectHost conf, + ciPort = fromIntegral . connectPort $ conf, + ciDatabase = fromString . connectDatabase $ conf, + ciUser = fromString . connectUser $ conf, + ciPassword = fromString . connectPassword $ conf, + ciCharset = charsetToDBCharset . connectCharset $ conf + } connect dbConf -- | Close the given connection. closeMySQLConn :: MySQLConn -> IO () closeMySQLConn = close + +-- Helpers + +charsetToDBCharset :: MySQLCharset -> Word8 +charsetToDBCharset = \case + Latin1 -> 8 + UTF8General -> 33 + UTF8Full -> 224 diff --git a/src/EulerHS/Core/Types/Options.hs b/src/EulerHS/Core/Types/Options.hs index 3afd62d5..825f4a99 100644 --- a/src/EulerHS/Core/Types/Options.hs +++ b/src/EulerHS/Core/Types/Options.hs @@ -1,19 +1,3 @@ -{- | -Module : EulerHS.Core.Types.Options -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -Options can be used as a stateful mutable KV storage. - -One should be careful in mutating it from different threads. - -This module is internal and should not imported in the projects. -Import 'EulerHS.Types' instead. --} - module EulerHS.Core.Types.Options ( -- * Options @@ -28,12 +12,8 @@ import qualified Data.ByteString.Lazy as BSL import EulerHS.Prelude import Type.Reflection (typeRep) --- | This type class helps to tie a key to a value. --- --- You can't have different values for the same key. -class (Typeable k, FromJSON k, ToJSON k, FromJSON v, ToJSON v) - => OptionEntity k v | k -> v +class (Typeable k, ToJSON k) + => OptionEntity k v | k -> v --- | Converts a value-like key into a string. mkOptionKey :: forall k v. OptionEntity k v => k -> Text mkOptionKey k = show (typeRep @k) <> (decodeUtf8 $ BSL.toStrict $ encode k) diff --git a/src/EulerHS/Core/Types/Playback.hs b/src/EulerHS/Core/Types/Playback.hs deleted file mode 100644 index 7da16f86..00000000 --- a/src/EulerHS/Core/Types/Playback.hs +++ /dev/null @@ -1,246 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{- | -Module : EulerHS.Core.Types.Playback -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -Types and helper functions of the ART subsystem. - -This module is internal and should not imported in the projects. -Import 'EulerHS.Types' instead. --} - -module EulerHS.Core.Types.Playback - ( - -- * Core Playback - -- ** Types - RRItem(..) - , MockedResult(..) - , RecordingEntry(..) - , RecordingEntries - , GlobalReplayingMode(..) - , EntryReplayingMode(..) - , PlaybackErrorType(..) - , PlaybackError(..) - , ReplayingException(..) - , ResultRecording(..) - , Recording(..) - , ReplayErrors(..) - , ResultReplayError - , RecorderRuntime(..) - , PlayerRuntime(..) - , RunMode (..) - -- ** Methods - , awaitRecording - , awaitErrors - , flattenErrors - , note - , encodeToStr - , decodeFromStr - , showRecEntry - ) where - - -import qualified Data.Aeson as A -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as BSL -import qualified Data.Map as Map -import qualified EulerHS.Core.Types.Serializable as S -import EulerHS.Prelude hiding (note) -import qualified Prelude as P (show) - - --- Represents ART single entry, saved in recordings -data RecordingEntry = RecordingEntry - { _entryIndex :: Int - -- ^ Index in entries array - , _entryReplayMode :: EntryReplayingMode - -- ^ entry replay mode, could be one of 'Normal' 'NoVerify' 'NoMock' - , _entryName :: String - -- ^ name of the method that this entry represents - , _entryPayload :: A.Value - -- ^ method result value - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - --- | Shows RecordingEntry with decoded _entryPayload -showRecEntry :: forall a. (FromJSON a, Show a) => RecordingEntry -> String -showRecEntry RecordingEntry{..} = - "RecordingEntry {_entryIndex = " - <> show _entryIndex - <> ", _entryReplayMode = " - <> show _entryReplayMode - <> ", _entryName = " - <> _entryName - <> ", _entryPayload = \n" - <> payload <> "\n}" - where - (payload :: String) = case A.fromJSON @a _entryPayload of - A.Success a -> P.show a - A.Error err -> err - --- | Represents method entries from the flow -type RecordingEntries = Vector RecordingEntry - --- | Global replaying mode to be applied to all entries -data GlobalReplayingMode = GlobalNormal | GlobalNoVerify | GlobalNoMocking | GlobalSkip - --- | Entry individual replaying mode settings -data EntryReplayingMode - = Normal - -- ^ (default) Verifying enabled. Mocking enabled. - | NoVerify - -- ^ Verifying disabled. Mocking enabled. - | NoMock - -- ^ Verifying disabled. Mocking disabled (real effect will be evaluated). - deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) - - - -class (Eq rrItem, ToJSON rrItem, FromJSON rrItem) => RRItem rrItem where - toRecordingEntry :: rrItem -> Int -> EntryReplayingMode -> RecordingEntry - toRecordingEntry rrItem idx mode = RecordingEntry idx mode (getTag (Proxy :: Proxy rrItem)) $ - toJSON rrItem - - fromRecordingEntry :: RecordingEntry -> Maybe rrItem - fromRecordingEntry (RecordingEntry _ _ _ payload) = S.fromJSONMaybe payload - - getTag :: Proxy rrItem -> String - {-# MINIMAL getTag #-} - -class RRItem rrItem => MockedResult rrItem native where - getMock :: rrItem -> Maybe native - --- | Playback errors -data PlaybackErrorType - -- | Player successfully replayed all recordings, but the current flow has - -- some additional steps. - = UnexpectedRecordingEnd - -- | Current flow step and recorded step is different. Signals about changes in the code - -- (removed or added new steps, changed logic/behavior of a function - flow go to another branch, etc.) - | UnknownRRItem - -- | Mistakes in Encode/Decode instances, changes in types (another fields, different types of fields, etc.) - | MockDecodingFailed - -- | Results of execution of current flow step and recorded step is different. Something in code was changed - -- (output format, order of values in result, etc), compare results to see what exactly is different. - | ItemMismatch - -- | Something went wrong. - | UnknownPlaybackError - -- | Flow is forked on this step, but there are no forked flow recordings. Check difference in the code. - | ForkedFlowRecordingsMissed - -- | Flow is placed to safe flow on this step, but there are no safe flow recordings. Check difference in the code. - | SafeFlowRecordingsMissed - deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON, Exception) - --- | Playback error -data PlaybackError = PlaybackError - { errorType :: PlaybackErrorType - , errorMessage :: String - , errorFlowGUID :: Text - } deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) - --- | Playback exception -data ReplayingException = ReplayingException PlaybackError - deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) - -instance Exception ReplayingException - - ----------------------------------------------------------------------- --- | Final recordings from main flow, forked and safe flows. -data ResultRecording = ResultRecording - { recording :: RecordingEntries - , safeRecordings :: Map Text RecordingEntries - , forkedRecordings :: Map Text ResultRecording - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - --- | Thread safe Recording representation that used in record process -data Recording = Recording - { recordingMVar :: MVar RecordingEntries - , safeRecordingsVar :: MVar (Map Text RecordingEntries) - , forkedRecordingsVar :: MVar (Map Text Recording) - } - --- | Transform 'Recording' to 'ResultRecording' in safe way -awaitRecording :: Recording -> IO ResultRecording -awaitRecording Recording{..}= do - recording <- readMVar recordingMVar - safeRecordings <- readMVar safeRecordingsVar - forkedRecordings <- traverse awaitRecording =<< readMVar forkedRecordingsVar - pure ResultRecording{..} - ----------------------------------------------------------------------- --- | Thread safe ReplayErrors representation used in replay process -data ReplayErrors = ReplayErrors - { errorMVar :: MVar (Maybe PlaybackError) - , safeFlowErrorsVar :: MVar (Map Text PlaybackError) - , forkedFlowErrorsVar :: MVar (Map Text ReplayErrors) - } - --- | Final player errors representation -data ResultReplayError = ResultReplayError - { rerror :: Maybe PlaybackError - , safeError :: Map Text PlaybackError - , forkedError :: Map Text ResultReplayError - } deriving (Show, Eq, Generic, ToJSON, FromJSON) - --- | Transform 'ReplayErrors' to 'ResultReplayError' in safe way -awaitErrors :: ReplayErrors -> IO ResultReplayError -awaitErrors ReplayErrors{..}= do - rerror <- readMVar errorMVar - safeError <- readMVar safeFlowErrorsVar - forkedError <- traverse awaitErrors =<< readMVar forkedFlowErrorsVar - pure ResultReplayError{..} - --- | Extracts all errors from 'ResultReplayError' structure and puts them in the list -flattenErrors :: ResultReplayError -> [PlaybackError] -flattenErrors = catMaybes . flattenErrors_ - where - flattenErrors_ ResultReplayError{..} = - rerror : (pure <$> Map.elems safeError) <> (Map.elems forkedError >>= flattenErrors_) - ----------------------------------------------------------------------- - --- | Represents ART recorder state and parameters -data RecorderRuntime = RecorderRuntime - { flowGUID :: Text - , recording :: Recording - , disableEntries :: [String] - } - --- | Represents ART player state and parameters -data PlayerRuntime = PlayerRuntime - { resRecording :: ResultRecording - , rerror :: ReplayErrors - , stepMVar :: MVar Int - , disableVerify :: [String] - , disableMocking :: [String] - , skipEntries :: [String] - , entriesFiltered :: Bool - , flowGUID :: Text - } - --- | ART running mode -data RunMode - = RegularMode - -- ^ Flow executed as-is, ART has no impact - | RecordingMode RecorderRuntime - -- ^ ART collecting recordings for each backend method - | ReplayingMode PlayerRuntime - -- ^ ART replaying given recordings on corresponding flow scenario - - -encodeToStr :: ToJSON a => a -> String -encodeToStr = BS.unpack . BSL.toStrict . A.encode - -decodeFromStr :: FromJSON a => String -> Maybe a -decodeFromStr = A.decode . BSL.fromStrict . BS.pack - -note :: forall a b. a -> Maybe b -> Either a b -note a Nothing = Left a -note _ (Just b) = Right b diff --git a/src/EulerHS/Core/Types/Postgres.hs b/src/EulerHS/Core/Types/Postgres.hs index a89bd6c8..b30453c0 100644 --- a/src/EulerHS/Core/Types/Postgres.hs +++ b/src/EulerHS/Core/Types/Postgres.hs @@ -1,20 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} -{- | -Module : EulerHS.Core.Types.Postgres -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -Types and helper functions to wrap a Postgres-related stuff. - -This module is internal and should not imported in the projects. -Import 'EulerHS.Types' instead. --} - module EulerHS.Core.Types.Postgres ( -- * Core Postgres @@ -29,7 +15,7 @@ import EulerHS.Prelude import qualified Database.Beam.Postgres as BP --- | Postgres config + data PostgresConfig = PostgresConfig { connectHost :: String , connectPort :: Word16 @@ -49,3 +35,4 @@ createPostgresConn = BP.connect . toBeamPostgresConnectInfo -- | Close the given connection. closePostgresConn :: BP.Connection -> IO () closePostgresConn = BP.close + diff --git a/src/EulerHS/Core/Types/Serializable.hs b/src/EulerHS/Core/Types/Serializable.hs index d5eff087..930d79a2 100644 --- a/src/EulerHS/Core/Types/Serializable.hs +++ b/src/EulerHS/Core/Types/Serializable.hs @@ -7,6 +7,7 @@ {-# LANGUAGE UndecidableInstances #-} + module EulerHS.Core.Types.Serializable ( -- * Core Serializable @@ -160,7 +161,7 @@ instance JSONEx a => EitherC (Serializable [a]) d where resolve r _ = r ---------------------------------------------------------------------- instance Serializable ByteString where - jsonEncode bs = A.object ["b64" A..= mkBS64 bs, "utf8" A..= decodeUtf8 @Text bs] + jsonEncode bs = A.object ["b64" A..= mkBS64 bs] jsonDecode = A.parseMaybe . A.withObject "bs" $ \o -> fmap getBS64 (o A..: "b64") instance Serializable ByteString64 where diff --git a/src/EulerHS/Extra/Aeson.hs b/src/EulerHS/Extra/Aeson.hs index 8d357fc2..d531e44d 100644 --- a/src/EulerHS/Extra/Aeson.hs +++ b/src/EulerHS/Extra/Aeson.hs @@ -1,10 +1,10 @@ module EulerHS.Extra.Aeson - ( stripLensPrefixOptions - , stripAllLensPrefixOptions - , jsonSetField - , encodeJSON - , decodeJSON - ) where +( stripLensPrefixOptions +, stripAllLensPrefixOptions +, jsonSetField +, encodeJSON +, decodeJSON +) where import Prelude @@ -17,6 +17,7 @@ import Data.Text (Text) import qualified Data.Text.Encoding as Text import qualified Data.Text.Lazy as LazyText + stripLensPrefixOptions :: Options stripLensPrefixOptions = defaultOptions { fieldLabelModifier = drop 1 } diff --git a/src/EulerHS/Extra/AltValidation.hs b/src/EulerHS/Extra/AltValidation.hs index 440c2020..2ceb225c 100644 --- a/src/EulerHS/Extra/AltValidation.hs +++ b/src/EulerHS/Extra/AltValidation.hs @@ -30,6 +30,7 @@ module EulerHS.Extra.AltValidation import EulerHS.Prelude hiding (or, pred) import qualified Prelude as P +import Data.Data hiding (typeRep) import Data.Either.Extra (mapLeft) import Data.Generics.Product.Fields import qualified Data.Text as T @@ -63,6 +64,7 @@ type Ctx = Text type Errors = [VErrorPayload] type V a = Validation [VErrorPayload] a +-- TODO: Looks like Profunctor. Does it hold laws? -- | Represents Transformer from one type to another. --- | This class represents transformation abilities between types. @@ -104,19 +106,22 @@ guardedCustom err pred | pred = ReaderT (\_ -> pure ()) | otherwise = ReaderT (\ctx -> Left [err {error_field = Just ctx }]) -- | Trying to decode 'Text' into a target type -decode :: forall t . (Read t) => Transformer Text t +decode :: forall t . (Data t, Read t) => Transformer Text t decode v = ReaderT (\ctx -> case (readMaybe $ toString v) of Just x -> Right x _ -> Left [ validationError { error_message = Just ("Can't decode value: " <> v) , error_field = Just ctx}]) -- | Trying to decode 'Text' into a target type, use custom error -decodeCustom :: forall t . (Read t) => VErrorPayload -> Transformer Text t +decodeCustom :: forall t . (Data t, Read t) => VErrorPayload -> Transformer Text t decodeCustom err v = ReaderT (\_ -> case (readMaybe $ toString v) of Just x -> Right x _ -> Left [ err ]) +-- Could throw 'Data.Data.dataTypeConstrs is not supported for Prelude.Double' for primitive types! +-- _ -> Left [ err { error_message = Just ("Can't decode value" <> v <> ", should be one of " <> showConstructors @t) +-- , error_field = Just ctx}]) -mkTransformer :: VErrorPayload -> (a -> Maybe b) -> Transformer a b +mkTransformer :: Show a => VErrorPayload -> (a -> Maybe b) -> Transformer a b mkTransformer err f v = ReaderT (\_ -> case f v of Just x -> Right x Nothing -> Left [ err ]) @@ -143,7 +148,7 @@ extractMaybeWithDefault d r = ReaderT (\_ -> maybe (Right d) Right r) -- | Extract value and run validators on it withField :: forall (f :: Symbol) v r a - . (HasField' f r v, KnownSymbol f) + . (Generic r, HasField' f r v, KnownSymbol f) => r -> Transformer v a -> Validation Errors a withField rec pav = fromEither $ runReaderT (pav $ getField @f rec) $ fieldName_ @f @@ -155,6 +160,14 @@ runParser -> Validation Errors a runParser p err = fromEither $ runReaderT p err +-- | Return text representation of constructors of a given type +-- showConstructors :: forall t . Data t => Text +-- showConstructors = T.pack $ show $ getConstructors @t + +-- | Return list with constructors of a given type +-- getConstructors :: forall t . Data t => [Constr] +-- getConstructors = dataTypeConstrs (dataTypeOf (undefined :: t)) + -- | Return given 'Symbol' as 'Text' -- >>> fieldName @"userId" -- "userId" diff --git a/src/EulerHS/Extra/Language.hs b/src/EulerHS/Extra/Language.hs index d3bfb62e..d10e701f 100644 --- a/src/EulerHS/Extra/Language.hs +++ b/src/EulerHS/Extra/Language.hs @@ -1,20 +1,6 @@ -{- | -Module : EulerHS.Extra.Language -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -This module contains additional methods and functions providing extra functionality -over the stok ones. - -This is an internal module. Import `EulerHS.Language` instead. --} - module EulerHS.Extra.Language - ( getOrInitSqlConnection - , getOrInitKVDBConnection + ( getOrInitSqlConn + , getOrInitKVDBConn , rExpire , rExpireB , rDel @@ -37,7 +23,14 @@ module EulerHS.Extra.Language , rSetex , rSetexB , rSetexT -- alias for rSetex (back compat) + , rSetOpts + , rSetOptsB + , rSetOptsT , keyToSlot + , rSadd + , rSismember + , updateLoggerContext + , withLoggerContext ) where import EulerHS.Prelude hiding (get, id) @@ -49,6 +42,8 @@ import Database.Redis (keyToSlot) import qualified EulerHS.Core.KVDB.Language as L import qualified EulerHS.Core.Types as T import qualified EulerHS.Framework.Language as L +import EulerHS.Runtime (CoreRuntime (..), FlowRuntime (..), + LoggerRuntime (..)) type RedisName = Text type TextKey = Text @@ -58,116 +53,84 @@ type ByteField = ByteString type ByteValue = ByteString -- | Get existing SQL connection, or init a new connection. -getOrInitSqlConnection :: (HasCallStack, L.MonadFlow m) => +getOrInitSqlConn :: (HasCallStack, L.MonadFlow m) => T.DBConfig beM -> m (T.DBResult (T.SqlConn beM)) -getOrInitSqlConnection cfg = do +getOrInitSqlConn cfg = do eConn <- L.getSqlDBConnection cfg case eConn of Left (T.DBError T.ConnectionDoesNotExist _) -> L.initSqlDBConnection cfg res -> pure res -- | Get existing Redis connection, or init a new connection. -getOrInitKVDBConnection :: (HasCallStack, L.MonadFlow m) => T.KVDBConfig -> m (T.KVDBAnswer T.KVDBConn) -getOrInitKVDBConnection cfg = do +getOrInitKVDBConn :: (HasCallStack, L.MonadFlow m) => T.KVDBConfig -> m (T.KVDBAnswer T.KVDBConn) +getOrInitKVDBConn cfg = do conn <- L.getKVDBConnection cfg case conn of Left (T.KVDBError T.KVDBConnectionDoesNotExist _) -> L.initKVDBConnection cfg res -> pure res --- ---------------------------------------------------------------------------- -- KVDB convenient functions + -- ---------------------------------------------------------------------------- --- | Set a key's time to live in seconds. --- Key is a text string. --- --- mtl version of the original function. rExpire :: (HasCallStack, Integral t, L.MonadFlow m) => RedisName -> TextKey -> t -> m (Either T.KVDBReply Bool) rExpire cName k t = rExpireB cName (TE.encodeUtf8 k) t --- | Set a key's time to live in seconds. --- Key is a byte string. --- --- mtl version of the original function. --- Additionally, logs the error may happen. rExpireB :: (HasCallStack, Integral t, L.MonadFlow m) => RedisName -> ByteKey -> t -> m (Either T.KVDBReply Bool) rExpireB cName k t = do res <- L.runKVDB cName $ L.expire k $ toInteger t case res of - Right _ -> pure res + Right _ -> do + -- L.logInfo @Text "Redis expire" $ show r + pure res Left err -> do L.logError @Text "Redis expire" $ show err pure res -- ---------------------------------------------------------------------------- --- | Delete a keys. --- Key is a text string. --- --- mtl version of the original function. rDel :: (HasCallStack, L.MonadFlow m) => RedisName -> [TextKey] -> m (Either T.KVDBReply Integer) rDel cName ks = rDelB cName (TE.encodeUtf8 <$> ks) --- | Delete a keys. --- Key is a byte string. --- --- mtl version of the original function. --- Additionally, logs the error may happen. rDelB :: (HasCallStack, L.MonadFlow m) => RedisName -> [ByteKey] -> m (Either T.KVDBReply Integer) rDelB cName ks = do res <- L.runKVDB cName $ L.del ks case res of - Right _ -> pure res + Right _ -> do + -- L.logInfo @Text "Redis del" $ show r + pure res Left err -> do L.logError @Text "Redis del" $ show err pure res -- ---------------------------------------------------------------------------- --- | Determine if a key exists. --- Key is a text string. --- --- mtl version of the original function. --- Additionally, logs the error may happen. rExists :: (HasCallStack, L.MonadFlow m) => RedisName -> TextKey -> m (Either T.KVDBReply Bool) rExists cName k = rExistsB cName $ TE.encodeUtf8 k --- | Determine if a key exists. --- Key is a byte string. --- --- mtl version of the original function. --- Additionally, logs the error may happen. rExistsB :: (HasCallStack, L.MonadFlow m) => RedisName -> ByteKey -> m (Either T.KVDBReply Bool) rExistsB cName k = do res <- L.runKVDB cName $ L.exists k case res of - Right _ -> pure res + Right _ -> do + -- L.logInfo @Text "Redis exists" $ show r + pure res Left err -> do L.logError @Text "Redis exists" $ show err pure res --- | Determine if a key exists. --- Key is a text string. --- --- mtl version of the original function. rExistsT :: (HasCallStack, L.MonadFlow m) => RedisName -> TextKey -> m (Either T.KVDBReply Bool) rExistsT = rExists -- ---------------------------------------------------------------------------- --- | Get the value of a hash field. --- Key is a text string. --- --- Performs decodings of the value. --- mtl version of the original function. --- Additionally, logs the error may happen. rHget :: (HasCallStack, FromJSON v, L.MonadFlow m) => RedisName -> TextKey -> TextField -> m (Maybe v) rHget cName k f = do @@ -181,17 +144,14 @@ rHget cName k f = do Left err -> do L.logError @Text "Decoding error: " $ show err pure Nothing - Right v' -> pure $ Just v' + Right v' -> do + -- L.logDebug @Text "Decoded value" $ show v' + pure $ Just v' Right Nothing -> pure Nothing Left err -> do L.logError @Text "Redis rHget" $ show err pure Nothing --- | Get the value of a hash field. --- Key is a byte string. --- --- mtl version of the original function. --- Additionally, logs the error may happen. rHgetB :: (HasCallStack, L.MonadFlow m) => Text -> ByteKey -> ByteField -> m (Maybe ByteValue) rHgetB cName k f = do @@ -205,10 +165,6 @@ rHgetB cName k f = do -- ---------------------------------------------------------------------------- --- | Set the value of a hash field. --- Key is a text string. --- --- mtl version of the original function. rHset :: (HasCallStack, ToJSON v, L.MonadFlow m) => RedisName -> TextKey -> TextField -> v -> m (Either T.KVDBReply Bool) rHset cName k f v = rHsetB cName k' f' v' @@ -217,52 +173,39 @@ rHset cName k f v = rHsetB cName k' f' v' f' = TE.encodeUtf8 f v' = BSL.toStrict $ A.encode v --- | Set the value of a hash field. --- Key is a byte string. --- --- mtl version of the original function. --- Additionally, logs the error may happen. rHsetB :: (HasCallStack, L.MonadFlow m) => RedisName -> ByteKey -> ByteField -> ByteValue -> m (Either T.KVDBReply Bool) rHsetB cName k f v = do - res <- L.runKVDB cName $ L.hset k f v + res <- L.runKVDB cName $ + L.hset k f v case res of - Right _ -> pure res + Right _ -> do + -- L.logInfo @Text "Redis hset" $ show r + pure res Left err -> do L.logError @Text "Redis hset" $ show err pure res -- ---------------------------------------------------------------------------- --- | Increment the integer value of a key by one. --- Key is a text string. --- --- mtl version of the original function. rIncr :: (HasCallStack, L.MonadFlow m) => RedisName -> TextKey -> m (Either T.KVDBReply Integer) rIncr cName k = rIncrB cName (TE.encodeUtf8 k) --- | Increment the integer value of a key by one. --- Key is a byte string. --- --- mtl version of the original function. --- Additionally, logs the error may happen. rIncrB :: (HasCallStack, L.MonadFlow m) => RedisName -> ByteKey -> m (Either T.KVDBReply Integer) rIncrB cName k = do res <- L.runKVDB cName $ L.incr k case res of - Right _ -> pure res + Right _ -> do + -- L.logInfo @Text "Redis incr" $ show r + pure res Left err -> do L.logError @Text "Redis incr" $ show err pure res -- ---------------------------------------------------------------------------- --- | Set the value of a key. --- Key is a text string. --- --- mtl version of the original function. rSet :: (HasCallStack, ToJSON v, L.MonadFlow m) => RedisName -> TextKey -> v -> m (Either T.KVDBReply T.KVDBStatus) rSet cName k v = rSetB cName k' v' @@ -270,53 +213,27 @@ rSet cName k v = rSetB cName k' v' k' = TE.encodeUtf8 k v' = BSL.toStrict $ A.encode v --- | Set the value of a key. --- Key is a byte string. --- --- mtl version of the original function. --- Additionally, logs the error may happen. rSetB :: (HasCallStack, L.MonadFlow m) => Text -> ByteKey -> ByteValue -> m (Either T.KVDBReply T.KVDBStatus) rSetB cName k v = do res <- L.runKVDB cName $ L.set k v case res of - Right _ -> pure res + Right _ -> do + -- L.logInfo @Text "Redis set" $ show r + pure res Left err -> do L.logError @Text "Redis set" $ show err pure res --- | Set the value of a key. --- Key is a text string. --- --- mtl version of the original function. -rSetT :: (HasCallStack, ToJSON v, L.MonadFlow m) => - RedisName -> TextKey -> v -> m (Either T.KVDBReply T.KVDBStatus) -rSetT = rSet +rSetT :: (HasCallStack, L.MonadFlow m) => + RedisName -> TextKey -> Text -> m (Either T.KVDBReply T.KVDBStatus) +rSetT cName k v = rSetB cName k' v' + where + k' = TE.encodeUtf8 k + v' = TE.encodeUtf8 v -- ---------------------------------------------------------------------------- --- | Get the value of a key. --- Key is a text string. --- --- Performs encodings of the value. --- mtl version of the original function. --- Additionally, logs the error may happen. -rGet :: (HasCallStack, FromJSON v, L.MonadFlow m) => - RedisName -> TextKey -> m (Maybe v) -rGet cName k = do - mv <- L.runKVDB cName $ L.get (TE.encodeUtf8 k) - case mv of - Right (Just val) -> pure $ A.decode $ BSL.fromStrict val - Right Nothing -> pure Nothing - Left err -> do - L.logError @Text "Redis get" $ show err - pure Nothing - --- | Get the value of a key. --- Key is a byte string. --- --- mtl version of the original function. --- Additionally, logs the error may happen. rGetB :: (HasCallStack, L.MonadFlow m) => RedisName -> ByteKey -> m (Maybe ByteValue) -- Binary.decode? rGetB cName k = do @@ -327,21 +244,34 @@ rGetB cName k = do L.logError @Text "Redis get" $ show err pure Nothing --- | Get the value of a key. --- Key is a text string. --- --- mtl version of the original function. -rGetT :: (HasCallStack, FromJSON v, L.MonadFlow m) => - Text -> Text -> m (Maybe v) -rGetT = rGet +rGet :: (HasCallStack, FromJSON v, L.MonadFlow m) => + RedisName -> TextKey -> m (Maybe v) +rGet cName k = do + mv <- rGetB cName (TE.encodeUtf8 k) + case mv of + Just val -> case A.eitherDecode' $ BSL.fromStrict val of + Left err -> do + L.logError @Text "Redis rGet json decodeEither error" $ show err + pure Nothing + Right resp -> pure $ Just resp + Nothing -> pure Nothing + +rGetT :: (HasCallStack, L.MonadFlow m) => + Text -> Text -> m (Maybe Text) +rGetT cName k = do + mv <- rGetB cName (TE.encodeUtf8 k) + case mv of + Just val -> + case TE.decodeUtf8' val of + Left err -> do + L.logError @Text "Redis rGetT unicode decode error" (show err) + pure Nothing + Right x -> + pure $ Just x + Nothing -> pure Nothing -- ---------------------------------------------------------------------------- --- | Set the value and ttl of a key. --- Key is a text string. --- --- Performs encodings of the key and value. --- mtl version of the original function. rSetex :: (HasCallStack, ToJSON v, Integral t, L.MonadFlow m) => RedisName -> TextKey -> v -> t -> m (Either T.KVDBReply T.KVDBStatus) rSetex cName k v t = rSetexB cName k' v' t @@ -349,25 +279,97 @@ rSetex cName k v t = rSetexB cName k' v' t k' = TE.encodeUtf8 k v' = BSL.toStrict $ A.encode v --- | Set the value and ttl of a key. --- Key is a byte string. --- --- mtl version of the original function. --- Additionally, logs the error may happen. rSetexB :: (HasCallStack, Integral t, L.MonadFlow m) => RedisName -> ByteKey -> ByteValue -> t -> m (Either T.KVDBReply T.KVDBStatus) rSetexB cName k v t = do res <- L.runKVDB cName $ L.setex k (toInteger t) v case res of - Right _ -> pure res + Right _ -> do + -- L.logInfo @Text "Redis setex" $ show r + pure res Left err -> do L.logError @Text "Redis setex" $ show err pure res --- | Set the value and ttl of a key. --- Key is a text string. --- --- mtl version of the original function. rSetexT :: (HasCallStack, ToJSON v, Integral t, L.MonadFlow m) => RedisName -> TextKey -> v -> t -> m (Either T.KVDBReply T.KVDBStatus) rSetexT = rSetex + +-- ---------------------------------------------------------------------------- + +rSetOpts + :: (HasCallStack, ToJSON v, L.MonadFlow m) + => RedisName + -> TextKey + -> v + -> L.KVDBSetTTLOption + -> L.KVDBSetConditionOption + -> m (Either T.KVDBReply Bool) +rSetOpts cName k v ttl cond = rSetOptsB cName k' v' ttl cond + where + k' = TE.encodeUtf8 k + v' = BSL.toStrict $ A.encode v + +rSetOptsB + :: (HasCallStack, L.MonadFlow m) + => RedisName + -> ByteKey + -> ByteValue + -> L.KVDBSetTTLOption + -> L.KVDBSetConditionOption + -> m (Either T.KVDBReply Bool) +rSetOptsB cName k v ttl cond = do + res <- L.runKVDB cName $ L.setOpts k v ttl cond + case res of + Right _ -> pure res + Left err -> do + L.logError @Text "Redis setOpts" $ show err + pure res + +rSetOptsT + :: (HasCallStack, L.MonadFlow m) + => RedisName + -> TextKey + -> Text + -> L.KVDBSetTTLOption + -> L.KVDBSetConditionOption + -> m (Either T.KVDBReply Bool) +rSetOptsT cName k v ttl cond = rSetOptsB cName k' v' ttl cond + where + k' = TE.encodeUtf8 k + v' = TE.encodeUtf8 v + +-- ------------------------------------------------------------------------------ + +rSadd :: (HasCallStack, L.MonadFlow m) => + RedisName -> L.KVDBKey -> [L.KVDBValue] -> m (Either T.KVDBReply Integer) +rSadd cName k v = do + res <- L.runKVDB cName $ L.sadd k v + case res of + Right _ -> pure res + Left err -> do + L.logError @Text "Redis sadd" $ show err + pure res + +rSismember :: (HasCallStack, L.MonadFlow m) => + RedisName -> L.KVDBKey -> L.KVDBValue -> m (Either T.KVDBReply Bool) +rSismember cName k v = do + res <- L.runKVDB cName $ L.sismember k v + case res of + Right _ -> pure res + Left err -> do + L.logError @Text "Redis sismember" $ show err + pure res + +withLoggerContext :: (HasCallStack, L.MonadFlow m) => (T.LogContext -> T.LogContext) -> L.Flow a -> m a +withLoggerContext updateLCtx = L.withModifiedRuntime (updateLoggerContext updateLCtx) + + +updateLoggerContext :: HasCallStack => (T.LogContext -> T.LogContext) -> FlowRuntime -> FlowRuntime +updateLoggerContext updateLCtx rt@FlowRuntime{..} = rt {_coreRuntime = _coreRuntime {_loggerRuntime = newLrt}} + where + newLrt :: LoggerRuntime + newLrt = case _loggerRuntime _coreRuntime of + MemoryLoggerRuntime a lc b c d -> MemoryLoggerRuntime a (updateLCtx lc) b c d + LoggerRuntime { _flowFormatter, _logContext, _logLevel, _logRawSql, _logCounter, _logMaskingConfig, _logLoggerHandle} + -> LoggerRuntime _flowFormatter (updateLCtx _logContext) _logLevel _logRawSql _logCounter _logMaskingConfig _logLoggerHandle \ No newline at end of file diff --git a/src/EulerHS/Extra/Test.hs b/src/EulerHS/Extra/Test.hs index 0c48c94f..72793463 100644 --- a/src/EulerHS/Extra/Test.hs +++ b/src/EulerHS/Extra/Test.hs @@ -5,6 +5,7 @@ module EulerHS.Extra.Test where import EulerHS.Prelude import qualified Database.Beam.Postgres as BP +-- import Database.MySQL.Base import qualified Database.MySQL.Base as MySQL import qualified Database.PostgreSQL.Simple as PG (execute_) import EulerHS.Interpreters @@ -17,7 +18,7 @@ import System.Process mwhen :: Monoid m => Bool -> m -> m mwhen True = id -mwhen False = const mempty +mwnen False = const mempty withMysqlDb :: String -> String -> MySQLConfig -> IO a -> IO a @@ -59,6 +60,52 @@ withMysqlDb dbName filePath msRootCfg next = void . MySQL.execute_ rootConn . MySQL.Query $ "grant all privileges on " <> encodeUtf8 dbName <> ".* to 'cloud'@'%'" +-- prepareMysqlDB +-- :: FilePath +-- -> T.MySQLConfig +-- -> T.MySQLConfig +-- -> (T.MySQLConfig -> DBConfig BM.MySQLM) +-- -> (forall a . (FlowRuntime -> IO a) -> IO a) +-- -> (FlowRuntime -> IO ()) +-- -> IO() +-- prepareMysqlDB filePath msRootCfg msCfg@T.MySQLConfig{..} msCfgToDbCfg withRt next = +-- withRt $ \flowRt -> +-- bracket (T.createMySQLConn msRootCfg) T.closeMySQLConn $ \rootConn -> do +-- let +-- dropTestDbIfExist :: IO () +-- dropTestDbIfExist = do +-- query rootConn $ "drop database if exists " <> fromString connectDatabase + +-- createTestDb :: IO () +-- createTestDb = do +-- query rootConn $ "create database " <> fromString connectDatabase +-- query rootConn $ "grant all privileges on " <> fromString connectDatabase <> ".* to 'cloud'@'%'" + +-- bracket_ +-- (dropTestDbIfExist >> createTestDb) +-- (dropTestDbIfExist) +-- (loadMySQLDump >> prepareDBConnections flowRt >> next flowRt) + +-- where +-- prepareDBConnections :: FlowRuntime -> IO () +-- prepareDBConnections flowRuntime = runFlow flowRuntime $ do +-- ePool <- initSqlDBConnection $ msCfgToDbCfg msCfg +-- either (error "Failed to connect to MySQL") (const $ pure ()) ePool + +-- loadMySQLDump :: IO () +-- loadMySQLDump = +-- void $ system $ +-- "mysql " <> options <> " " <> connectDatabase <> " 2> /dev/null < " <> filePath +-- where +-- options = +-- intercalate " " +-- [ "--port=" <> show connectPort +-- , mwhen (not $ null connectHost ) $ "--host=" <> connectHost +-- , mwhen (not $ null connectUser ) $ "--user=" <> connectUser +-- , mwhen (not $ null connectPassword) $ "--password=" <> connectPassword +-- ] + + preparePostgresDB :: FilePath -> T.PostgresConfig @@ -78,6 +125,7 @@ preparePostgresDB filePath pgRootCfg pgCfg@T.PostgresConfig{..} pgCfgToDbCfg wit createTestDb :: IO () createTestDb = do void $ PG.execute_ rootConn "create database euler_test_db" + -- void $ execute_ rootConn "grant all privileges on euler_test_db.* to 'cloud'@'%'" bracket_ (dropTestDbIfExist >> createTestDb) diff --git a/src/EulerHS/Extra/Validation.hs b/src/EulerHS/Extra/Validation.hs index cf5b4314..3a664d2f 100644 --- a/src/EulerHS/Extra/Validation.hs +++ b/src/EulerHS/Extra/Validation.hs @@ -25,6 +25,7 @@ module EulerHS.Extra.Validation import EulerHS.Prelude hiding (or, pred) import qualified Prelude as P +import Data.Data hiding (typeRep) import Data.Generics.Product.Fields import qualified Data.Text as T import Data.Validation @@ -37,6 +38,7 @@ type Ctx = Text type Errors = [Text] type V a = Validation [Text] a +-- TODO: Looks like Profunctor. Does it hold laws? -- | Represents Transformer from one type to another. --- | This class represents transformation abilities between types. @@ -59,9 +61,10 @@ guarded err pred | pred = ReaderT (\_ -> pure ()) | otherwise = ReaderT (\ctx -> Left [ctx <> " " <> err]) -- | Trying to decode Text to target type -decode :: forall t . Read t => Transformer Text t +decode :: forall t . (Data t, Read t) => Transformer Text t decode v = ReaderT (\ctx -> case (readMaybe $ toString v) of Just x -> Right x +-- _ -> Left ["Can't decode " <> v <> " from field " <> ctx <> ", should be one of " <> showConstructors @t]) _ -> Left ["Can't decode " <> v <> " from field " <> ctx]) mkTransformer :: Text -> (a -> Maybe b) -> Transformer a b @@ -84,7 +87,7 @@ extractMaybeWithDefault d r = ReaderT (\_ -> maybe (Right d) Right r) -- | Extract value and run validators on it withField :: forall (f :: Symbol) v r a - . (HasField' f r v, KnownSymbol f) + . (Generic r, HasField' f r v, KnownSymbol f) => r -> Transformer v a -> Validation Errors a withField rec pav = fromEither $ runReaderT (pav $ getField @f rec) $ fieldName_ @f @@ -96,6 +99,14 @@ runParser -> Validation Errors a runParser p msg = fromEither $ runReaderT p msg +-- | Return text representation of constructors of a given type +-- showConstructors :: forall t . Data t => Text +-- showConstructors = T.pack $ show $ getConstructors @t + +-- | Return list with constructors of a given type +-- getConstructors :: forall t . Data t => [Constr] +-- getConstructors = dataTypeConstrs (dataTypeOf (undefined :: t)) + -- | Return given 'Symbol' as 'Text' -- >>> fieldName @"userId" -- "userId" diff --git a/src/EulerHS/Framework/Flow/Interpreter.hs b/src/EulerHS/Framework/Flow/Interpreter.hs index a6e777fa..36a537bc 100644 --- a/src/EulerHS/Framework/Flow/Interpreter.hs +++ b/src/EulerHS/Framework/Flow/Interpreter.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Werror -Wno-redundant-constraints #-} + module EulerHS.Framework.Flow.Interpreter ( -- * Flow Interpreter runFlow @@ -15,15 +17,13 @@ import Data.Either.Extra (mapLeft) import Data.Generics.Product.Positions (getPosition) import qualified Data.Map as Map import qualified Data.Pool as DP +import Data.Profunctor (dimap) import qualified Data.Text as Text import qualified Data.Text.Encoding as Encoding import qualified Data.UUID as UUID (toText) import qualified Data.UUID.V4 as UUID (nextRandom) -import qualified Data.Vector as V import qualified EulerHS.Core.Interpreters as R import qualified EulerHS.Core.Logger.Language as L -import qualified EulerHS.Core.Playback.Entries as P -import qualified EulerHS.Core.Playback.Machine as P import qualified EulerHS.Core.Runtime as R import qualified EulerHS.Core.Types as T import EulerHS.Core.Types.KVDB @@ -33,6 +33,7 @@ import EulerHS.Prelude import qualified Network.Connection as Conn import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.TLS as TLS +import Network.HTTP.Client.Internal import qualified Network.HTTP.Types as HTTP import qualified Network.TLS as TLS import qualified Network.TLS.Extra.Cipher as TLS @@ -81,9 +82,6 @@ awaitMVarWithTimeout mvar mcs | mcs <= 0 = go 0 Just (Left err) -> pure $ Left $ T.ForkedFlowError err Nothing -> threadDelay portion >> go (rest - portion) --- TODO: update the code with timeouts when servant 0.18.1 is released --- (see the code in the private downstream repo) - -- | Utility function to convert HttpApi HTTPRequests to http-client HTTP -- requests getHttpLibRequest :: MonadThrow m => T.HTTPRequest -> m HTTP.Request @@ -112,8 +110,8 @@ getHttpLibRequest request = do let setTimeout = case T.getRequestTimeout request of - Just x -> \req -> req {HTTP.responseTimeout = HTTP.responseTimeoutMicro x} - Nothing -> id + Just x -> setRequestTimeout x + Nothing -> setRequestTimeout T.defaultTimeout let setRedirects = case T.getRequestRedirects request of @@ -126,6 +124,11 @@ getHttpLibRequest request = do , HTTP.requestHeaders = headers } +-- | Set timeout in microseconds +setRequestTimeout :: Int -> HTTP.Request -> HTTP.Request +setRequestTimeout x req = req {HTTP.responseTimeout = HTTP.responseTimeoutMicro x} + + -- | Utility function to translate http-client HTTP responses back to HttpAPI -- responses translateHttpResponse :: HTTP.Response Lazy.ByteString -> Either Text T.HTTPResponse @@ -179,15 +182,20 @@ mkManagerFromCert T.HTTPCert {..} = do -- translateHeaderName :: CI.CI Strict.ByteString -> Text.Text -- translateHeaderName = Encoding.decodeUtf8' . CI.original -interpretFlowMethod :: Maybe T.FlowGUID -> R.FlowRuntime -> L.FlowMethod a -> IO a +interpretFlowMethod :: HasCallStack => Maybe T.FlowGUID -> R.FlowRuntime -> L.FlowMethod a -> IO a interpretFlowMethod mbFlowGuid flowRt@R.FlowRuntime {..} (L.CallServantAPI mbMgrSel bUrl clientAct next) = - fmap next $ P.withRunMode _runMode (P.mkCallServantAPIEntry bUrl) $ do + fmap next $ do let mbClientMngr = case mbMgrSel of Nothing -> Right _defaultHttpClientManager Just mngrName -> maybeToRight mngrName $ Map.lookup mngrName _httpClientManagers case mbClientMngr of Right mngr -> do - eitherResult <- S.runClientM (T.runEulerClient (dbgLogger T.Debug) bUrl clientAct) (S.mkClientEnv mngr bUrl) + let S.ClientEnv manager baseUrl cookieJar makeClientRequest = S.mkClientEnv mngr bUrl + let setR req = if HTTP.responseTimeout req == HTTP.responseTimeoutNone + then setRequestTimeout T.defaultTimeout req + else req {HTTP.responseTimeout = mResponseTimeout mngr} + eitherResult <- S.runClientM (T.runEulerClient (dbgLogger T.Debug) getLoggerMaskConfig bUrl clientAct) $ + S.ClientEnv manager baseUrl cookieJar (\url -> setR . makeClientRequest url) case eitherResult of Left err -> do dbgLogger T.Error $ show err @@ -200,182 +208,85 @@ interpretFlowMethod mbFlowGuid flowRt@R.FlowRuntime {..} (L.CallServantAPI mbMgr pure $ Left err where dbgLogger debugLevel = - R.runLogger mbFlowGuid T.RegularMode (R._loggerRuntime . R._coreRuntime $ flowRt) + R.runLogger mbFlowGuid (R._loggerRuntime . R._coreRuntime $ flowRt) . L.logMessage' debugLevel ("CallServantAPI impl" :: String) . show + getLoggerMaskConfig = + R.getLogMaskingConfig . R._loggerRuntime . R._coreRuntime $ flowRt -interpretFlowMethod mbFlowGuid flowRt@R.FlowRuntime {..} (L.CallHTTP request cert next) = - fmap next $ P.withRunMode _runMode (P.mkCallHttpAPIEntry request) $ do +interpretFlowMethod _ flowRt@R.FlowRuntime {..} (L.CallHTTP request cert next) = + fmap next $ do httpLibRequest <- getHttpLibRequest request _manager <- maybe (pure $ Right _defaultHttpClientManager) mkManagerFromCert cert -- TODO: Refactor case _manager of Left err -> do let errMsg = "Certificate failure: " <> Text.pack err - logJsonError errMsg request pure $ Left errMsg Right manager -> do eResponse <- try $ HTTP.httpLbs httpLibRequest manager case eResponse of Left (err :: SomeException) -> do let errMsg = Text.pack $ displayException err - logJsonError errMsg request pure $ Left errMsg Right httpResponse -> do case translateHttpResponse httpResponse of Left errMsg -> do - logJsonError errMsg request + logJsonError errMsg (T.maskHTTPRequest getLoggerMaskConfig request) pure $ Left errMsg Right response -> do - logJson T.Debug $ T.HTTPRequestResponse request response + logJson T.Debug + $ T.HTTPRequestResponse + (T.maskHTTPRequest getLoggerMaskConfig request) + (T.maskHTTPResponse getLoggerMaskConfig response) pure $ Right response where logJsonError :: Text -> T.HTTPRequest -> IO () logJsonError err = logJson T.Error . T.HTTPIOException err - logJson :: ToJSON a => T.LogLevel -> a -> IO () logJson debugLevel = - R.runLogger mbFlowGuid T.RegularMode (R._loggerRuntime . R._coreRuntime $ flowRt) - . L.logMessage' debugLevel ("callHTTP failure" :: String) + R.runLogger (Just "API CALL:") (R._loggerRuntime . R._coreRuntime $ flowRt) + . L.logMessage' debugLevel ("callHTTP" :: String) . encodeJSON + + getLoggerMaskConfig = + R.getLogMaskingConfig . R._loggerRuntime . R._coreRuntime $ flowRt interpretFlowMethod mbFlowGuid R.FlowRuntime {..} (L.EvalLogger loggerAct next) = - next <$> R.runLogger mbFlowGuid _runMode (R._loggerRuntime _coreRuntime) loggerAct + next <$> R.runLogger mbFlowGuid (R._loggerRuntime _coreRuntime) loggerAct -interpretFlowMethod _ R.FlowRuntime {..} (L.RunIO descr ioAct next) = - next <$> P.withRunMode _runMode (P.mkRunIOEntry descr) ioAct - -interpretFlowMethod _ R.FlowRuntime {..} (L.RunUntracedIO descr ioAct next) = - case _runMode of - (T.RecordingMode recorderRt) -> - next <$> P.record recorderRt (P.mkRunUntracedIOEntry descr) ioAct - _ -> - next <$> ioAct +interpretFlowMethod _ _ (L.RunIO _ ioAct next) = + next <$> ioAct interpretFlowMethod _ R.FlowRuntime {..} (L.GetOption k next) = - fmap next $ P.withRunMode _runMode (P.mkGetOptionEntry k) $ do + fmap next $ do m <- readMVar _options pure $ do valAny <- Map.lookup k m pure $ unsafeCoerce valAny interpretFlowMethod _ R.FlowRuntime {..} (L.SetOption k v next) = - fmap next $ P.withRunMode _runMode (P.mkSetOptionEntry k v) $ do + fmap next $ do m <- takeMVar _options let newMap = Map.insert k (unsafeCoerce @_ @Any v) m putMVar _options newMap interpretFlowMethod _ R.FlowRuntime {..} (L.DelOption k next) = - fmap next $ P.withRunMode _runMode (P.mkDelOptionEntry k) $ do + fmap next $ do m <- takeMVar _options let newMap = Map.delete k m putMVar _options newMap -interpretFlowMethod _ R.FlowRuntime {_runMode} (L.GenerateGUID next) = do - next <$> P.withRunMode _runMode P.mkGenerateGUIDEntry - (UUID.toText <$> UUID.nextRandom) +interpretFlowMethod _ R.FlowRuntime {..} (L.GenerateGUID next) = do + next <$> (UUID.toText <$> UUID.nextRandom) -interpretFlowMethod _ R.FlowRuntime {_runMode} (L.RunSysCmd cmd next) = - next <$> P.withRunMode _runMode - (P.mkRunSysCmdEntry cmd) - (readCreateProcess (shell cmd) "") +interpretFlowMethod _ R.FlowRuntime {..} (L.RunSysCmd cmd next) = + next <$> readCreateProcess (shell cmd) "" ---------------------------------------------------------------------- -interpretFlowMethod mbFlowGuid rt (L.Fork desc newFlowGUID flow next) = do +interpretFlowMethod mbFlowGuid rt (L.Fork _desc _newFlowGUID flow next) = do awaitableMVar <- newEmptyMVar - case R._runMode rt of - T.RegularMode -> void $ forkIO (suppressErrors (runFlow' mbFlowGuid rt (L.runSafeFlow flow) >>= putMVar awaitableMVar)) - - T.RecordingMode T.RecorderRuntime{recording = T.Recording{..}, ..} -> do - finalRecordingMVar <- newEmptyMVar - finalSafeRecordingVar <- newEmptyMVar - finalForkedRecordingsVar <- newEmptyMVar - - forkRecordingMVar <- newMVar V.empty - forkSafeRecordingVar <- newMVar Map.empty - forkForkedRecordingsVar <- newMVar Map.empty - - let freshRecording = T.Recording forkRecordingMVar forkSafeRecordingVar forkForkedRecordingsVar - let emptyRecording = T.Recording finalRecordingMVar finalSafeRecordingVar finalForkedRecordingsVar - - let forkRuntime = T.RecorderRuntime - { flowGUID = newFlowGUID - , recording = freshRecording - , .. - } - - forkedRecs <- takeMVar forkedRecordingsVar - putMVar forkedRecordingsVar $ - Map.insert newFlowGUID emptyRecording forkedRecs - - let newRt = rt {R._runMode = T.RecordingMode forkRuntime} - - void $ forkIO $ do - suppressErrors (runFlow' mbFlowGuid newRt (L.runSafeFlow flow) >>= putMVar awaitableMVar) - putMVar finalRecordingMVar =<< readMVar forkRecordingMVar - putMVar finalSafeRecordingVar =<< readMVar forkSafeRecordingVar - putMVar finalForkedRecordingsVar =<< readMVar forkForkedRecordingsVar - ----------------------------------------------------------------------- - - T.ReplayingMode playerRt -> do - let - T.PlayerRuntime - { rerror = T.ReplayErrors {..} - , resRecording = T.ResultRecording{ forkedRecordings } - , .. - } = playerRt - - case Map.lookup newFlowGUID forkedRecordings of - Nothing -> do - let - err = - T.PlaybackError - { errorType = T.ForkedFlowRecordingsMissed - , errorMessage = "No recordings found for forked flow: " <> Text.unpack newFlowGUID - , errorFlowGUID = flowGUID } - - takeMVar errorMVar *> putMVar errorMVar (Just err) - throwIO $ T.ReplayingException err - - Just recording -> do - stepVar <- newMVar 0 - - finalErrorMVar <- newEmptyMVar - finalSafeFlowErrorVar <- newEmptyMVar - finalForkedFlowErrorVar <- newEmptyMVar - - forkErrorMVar <- newMVar Nothing - forkSafeFlowErrorVar <- newMVar Map.empty - forkForkedFlowErrorVar <- newMVar Map.empty - - let freshReplayErrors = T.ReplayErrors forkErrorMVar forkSafeFlowErrorVar forkForkedFlowErrorVar - let finalReplayErrors = T.ReplayErrors finalErrorMVar finalSafeFlowErrorVar finalForkedFlowErrorVar - - let forkRuntime = T.PlayerRuntime - { flowGUID = newFlowGUID - , stepMVar = stepVar - , resRecording = recording - , rerror = freshReplayErrors - , .. - } - - forkedFlowErrs <- takeMVar forkedFlowErrorsVar - - putMVar forkedFlowErrorsVar $ - Map.insert newFlowGUID finalReplayErrors forkedFlowErrs - - let newRt = rt {R._runMode = T.ReplayingMode forkRuntime} - void $ forkIO $ do - suppressErrors (runFlow' mbFlowGuid newRt (L.runSafeFlow flow) >>= putMVar awaitableMVar) - putMVar finalErrorMVar =<< readMVar forkErrorMVar - putMVar finalSafeFlowErrorVar =<< readMVar forkSafeFlowErrorVar - putMVar finalForkedFlowErrorVar =<< readMVar forkForkedFlowErrorVar - ----------------------------------------------------------------------- ----------------------------------------------------------------------- - - void $ P.withRunMode (R._runMode rt) (P.mkForkEntry desc newFlowGUID) (pure ()) + void $ forkIO (suppressErrors (runFlow' mbFlowGuid rt (L.runSafeFlow flow) >>= putMVar awaitableMVar)) pure $ next $ T.Awaitable awaitableMVar ---------------------------------------------------------------------- @@ -388,100 +299,36 @@ interpretFlowMethod _ R.FlowRuntime {..} (L.Await mbMcs (T.Awaitable awaitableMV Left err -> pure $ Left $ T.ForkedFlowError err Right res -> pure $ Right res Just (T.Microseconds mcs) -> awaitMVarWithTimeout awaitableMVar $ fromIntegral mcs - next <$> P.withRunMode _runMode (P.mkAwaitEntry mbMcs) act + next <$> act -interpretFlowMethod _ R.FlowRuntime {_runMode} (L.ThrowException ex _) = do - void $ P.withRunMode _runMode (P.mkThrowExceptionEntry ex) (pure ()) +interpretFlowMethod _ R.FlowRuntime {..} (L.ThrowException ex _) = do throwIO ex -interpretFlowMethod mbFlowGuid rt@R.FlowRuntime {_runMode} (L.RunSafeFlow newFlowGUID flow next) = fmap next $ do - fl <- case R._runMode rt of - T.RegularMode -> do - fl <- try @_ @SomeException $ runFlow' mbFlowGuid rt flow - pure $ mapLeft show fl +interpretFlowMethod mbFlowGuid rt (L.CatchException comp handler cont) = + cont <$> catch (runFlow' mbFlowGuid rt comp) (runFlow' mbFlowGuid rt . handler) - T.RecordingMode T.RecorderRuntime{recording = T.Recording{..}, ..} -> do - freshRecordingMVar <- newMVar V.empty +-- Lack of impredicative polymorphism in GHC makes me sad. - Koz +interpretFlowMethod mbFlowGuid rt (L.Mask cb cont) = + cont <$> mask (\cb' -> runFlow' mbFlowGuid rt (cb (dimap (runFlow' mbFlowGuid rt) (L.runIO' "Mask") cb'))) - let freshRecording = T.Recording freshRecordingMVar safeRecordingsVar forkedRecordingsVar +interpretFlowMethod mbFlowGuid rt (L.UninterruptibleMask cb cont) = + cont <$> uninterruptibleMask + (\cb' -> runFlow' mbFlowGuid rt (cb (dimap (runFlow' mbFlowGuid rt) (L.runIO' "UninterruptibleMask") cb'))) - let safeRuntime = T.RecorderRuntime - { flowGUID = newFlowGUID - , recording = freshRecording - , .. - } +interpretFlowMethod mbFlowGuid rt (L.GeneralBracket acquire release use' cont) = + cont <$> generalBracket + (runFlow' mbFlowGuid rt acquire) + (\x -> runFlow' mbFlowGuid rt . release x) + (runFlow' mbFlowGuid rt . use') - let newRt = rt {R._runMode = T.RecordingMode safeRuntime} - - fl <- try @_ @SomeException $ runFlow' mbFlowGuid newRt flow - - freshRec <- readMVar freshRecordingMVar - - safeRecs <- takeMVar safeRecordingsVar - - putMVar safeRecordingsVar $ - Map.insert newFlowGUID freshRec safeRecs - - pure $ mapLeft show fl +interpretFlowMethod mbFlowGuid rt (L.RunSafeFlow _ flow next) = fmap next $ do + fl <- try @_ @SomeException $ runFlow' mbFlowGuid rt flow + pure $ mapLeft show fl ---------------------------------------------------------------------- - T.ReplayingMode playerRt -> do - let - T.PlayerRuntime - { rerror = T.ReplayErrors {..} - , resRecording - , .. - } = playerRt - - T.ResultRecording{ safeRecordings } = resRecording - - case Map.lookup newFlowGUID safeRecordings of - Nothing -> do - let - err = - T.PlaybackError - { errorType = T.SafeFlowRecordingsMissed - , errorMessage = "No recordings found for safe flow " <> Text.unpack newFlowGUID - , errorFlowGUID = flowGUID } - - takeMVar errorMVar *> putMVar errorMVar (Just err) - throwIO $ T.ReplayingException err - - Just (newrecording :: T.RecordingEntries) -> do - stepVar <- newMVar 0 - freshErrorMVar <- newMVar Nothing - - let freshReplayErrors = T.ReplayErrors freshErrorMVar safeFlowErrorsVar forkedFlowErrorsVar - - let forkRuntime = T.PlayerRuntime - { flowGUID = newFlowGUID - , stepMVar = stepVar - , resRecording = resRecording { T.recording = newrecording } - , rerror = freshReplayErrors - , .. - } - - let newRt = rt {R._runMode = T.ReplayingMode forkRuntime} - fl <- try @_ @SomeException $ runFlow' mbFlowGuid newRt flow - - safeFlowErrs <- takeMVar safeFlowErrorsVar - freshError <- takeMVar freshErrorMVar - - putMVar safeFlowErrorsVar $ - case freshError of - Just err -> Map.insert newFlowGUID err safeFlowErrs - Nothing -> safeFlowErrs - - pure $ mapLeft show fl - ----------------------------------------------------------------------- - - P.withRunMode (R._runMode rt) (P.mkRunSafeFlowEntry newFlowGUID) (pure fl) - - interpretFlowMethod _ R.FlowRuntime {..} (L.InitSqlDBConnection cfg next) = - fmap next $ P.withRunMode _runMode (P.mkInitSqlDBConnectionEntry cfg) $ do + fmap next $ do let connTag = getPosition @1 cfg connMap <- takeMVar _sqldbConnections res <- case Map.lookup connTag connMap of @@ -493,7 +340,7 @@ interpretFlowMethod _ R.FlowRuntime {..} (L.InitSqlDBConnection cfg next) = pure res interpretFlowMethod _ R.FlowRuntime {..} (L.DeInitSqlDBConnection conn next) = - fmap next $ P.withRunMode _runMode (P.mkDeInitSqlDBConnectionEntry conn) $ do + fmap next $ do let connTag = getPosition @1 conn connMap <- takeMVar _sqldbConnections case Map.lookup connTag connMap of @@ -503,7 +350,7 @@ interpretFlowMethod _ R.FlowRuntime {..} (L.DeInitSqlDBConnection conn next) = putMVar _sqldbConnections $ Map.delete connTag connMap interpretFlowMethod _ R.FlowRuntime {..} (L.GetSqlDBConnection cfg next) = - fmap next $ P.withRunMode _runMode (P.mkGetSqlDBConnectionEntry cfg) $ do + fmap next $ do let connTag = getPosition @1 cfg connMap <- readMVar _sqldbConnections pure $ case Map.lookup connTag connMap of @@ -511,7 +358,7 @@ interpretFlowMethod _ R.FlowRuntime {..} (L.GetSqlDBConnection cfg next) = Nothing -> Left $ T.DBError T.ConnectionDoesNotExist $ "Connection for " <> connTag <> " does not exists." interpretFlowMethod _ R.FlowRuntime {..} (L.InitKVDBConnection cfg next) = - fmap next $ P.withRunMode _runMode (P.mkInitKVDBConnectionEntry cfg) $ do + fmap next $ do let connTag = getPosition @1 cfg connections <- takeMVar _kvdbConnections res <- case Map.lookup connTag connections of @@ -524,7 +371,7 @@ interpretFlowMethod _ R.FlowRuntime {..} (L.InitKVDBConnection cfg next) = pure res interpretFlowMethod _ R.FlowRuntime {..} (L.DeInitKVDBConnection conn next) = - fmap next $ P.withRunMode _runMode (P.mkDeInitKVDBConnectionEntry conn) $ do + fmap next $ do let connTag = getPosition @1 conn connections <- takeMVar _kvdbConnections case Map.lookup connTag connections of @@ -534,7 +381,7 @@ interpretFlowMethod _ R.FlowRuntime {..} (L.DeInitKVDBConnection conn next) = putMVar _kvdbConnections $ Map.delete connTag connections interpretFlowMethod _ R.FlowRuntime {..} (L.GetKVDBConnection cfg next) = - fmap next $ P.withRunMode _runMode (P.mkGetKVDBConnectionEntry cfg) $ do + fmap next $ do let connTag = getPosition @1 cfg connMap <- readMVar _kvdbConnections pure $ case Map.lookup connTag connMap of @@ -542,17 +389,16 @@ interpretFlowMethod _ R.FlowRuntime {..} (L.GetKVDBConnection cfg next) = Nothing -> Left $ KVDBError KVDBConnectionDoesNotExist $ "Connection for " +|| connTag ||+ " does not exists." interpretFlowMethod mbFlowGuid flowRt (L.RunDB conn sqlDbMethod runInTransaction next) = do - let runMode = R._runMode flowRt let dbgLogger = if R.shouldFlowLogRawSql flowRt - then R.runLogger mbFlowGuid T.RegularMode (R._loggerRuntime . R._coreRuntime $ flowRt) + then R.runLogger mbFlowGuid (R._loggerRuntime . R._coreRuntime $ flowRt) . L.logMessage' T.Debug ("RunDB Impl" :: String) else const $ pure () rawSqlTVar <- newTVarIO mempty -- This function would be used inside beam and write raw sql, generated by beam backend, in TVar. let dbgLogAction = \rawSqlStr -> atomically (modifyTVar' rawSqlTVar (`DL.snoc` rawSqlStr)) *> dbgLogger rawSqlStr -- TODO: unify the below two branches - fmap (next . fst) $ P.withRunMode runMode P.mkRunDBEntry $ case runInTransaction of + fmap (next . fst) $ fmap connPoolExceptionWrapper $ tryAny $ case runInTransaction of True -> case conn of (T.MockedPool _) -> error "Mocked Pool not implemented" @@ -586,7 +432,7 @@ interpretFlowMethod mbFlowGuid flowRt (L.RunDB conn sqlDbMethod runInTransaction wrapException :: HasCallStack => SomeException -> IO T.DBError wrapException exception = do - R.runLogger mbFlowGuid T.RegularMode (R._loggerRuntime . R._coreRuntime $ flowRt) + R.runLogger mbFlowGuid (R._loggerRuntime . R._coreRuntime $ flowRt) . L.logMessage' T.Debug ("CALLSTACK" :: String) $ Text.pack $ prettyCallStack callStack pure (wrapException' exception) @@ -596,22 +442,25 @@ interpretFlowMethod mbFlowGuid flowRt (L.RunDB conn sqlDbMethod runInTransaction T.mysqlErrorToDbError (show e) <$> fromException e <|> T.postgresErrorToDbError (show e) <$> fromException e) + connPoolExceptionWrapper :: Either SomeException (Either T.DBError _a1, [Text]) -> (Either T.DBError _a1, [Text]) + connPoolExceptionWrapper (Left e) = (Left $ T.DBError T.ConnectionFailed $ show e, []) + connPoolExceptionWrapper (Right r) = r interpretFlowMethod _ R.FlowRuntime {..} (L.RunKVDB cName act next) = - next <$> R.runKVDB cName _runMode _kvdbConnections act + next <$> R.runKVDB cName _kvdbConnections act - -interpretFlowMethod mbFlowGuid rt@R.FlowRuntime {_runMode, _pubSubController, _pubSubConnection} (L.RunPubSub act next) = - case (_pubSubConnection, _runMode) of - (Nothing, T.ReplayingMode _) -> go $ error "Connection mock. Shold not ever be evaluated" - (Just cn, _ ) -> go cn - _ -> error "RunPubSub method called, while proper Redis connection has not been provided" +interpretFlowMethod mbFlowGuid rt@R.FlowRuntime {_pubSubController, _pubSubConnection} (L.RunPubSub act next) = + case _pubSubConnection of + Nothing -> go $ error "Connection to pubSub is not set in FlowRuntime" + Just cn -> go cn where - go conn = next <$> R.runPubSub _runMode _pubSubController conn - (L.unpackLanguagePubSub act $ runFlow' mbFlowGuid $ rt { R._runMode = T.RegularMode }) + go conn = next <$> R.runPubSub _pubSubController conn + (L.unpackLanguagePubSub act $ runFlow' mbFlowGuid rt) + +interpretFlowMethod _ rt (L.WithModifiedRuntime f flow next) = next <$> runFlow (f rt) flow -runFlow' :: Maybe T.FlowGUID -> R.FlowRuntime -> L.Flow a -> IO a +runFlow' :: HasCallStack => Maybe T.FlowGUID -> R.FlowRuntime -> L.Flow a -> IO a runFlow' mbFlowGuid flowRt (L.Flow comp) = foldF (interpretFlowMethod mbFlowGuid flowRt) comp -runFlow :: R.FlowRuntime -> L.Flow a -> IO a +runFlow :: HasCallStack => R.FlowRuntime -> L.Flow a -> IO a runFlow = runFlow' Nothing diff --git a/src/EulerHS/Framework/Flow/Language.hs b/src/EulerHS/Framework/Flow/Language.hs index ed290f97..fff32353 100644 --- a/src/EulerHS/Framework/Flow/Language.hs +++ b/src/EulerHS/Framework/Flow/Language.hs @@ -1,22 +1,9 @@ +{-# OPTIONS_GHC -Werror #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} -{- | -Module : EulerHS.Framework.Flow.Language -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -The `Flow` eDSL for building a pure, monadic business logic. - -This is an internal module. Import `EulerHS.Language` instead. --} - - module EulerHS.Framework.Flow.Language ( -- * Flow language @@ -37,7 +24,6 @@ module EulerHS.Framework.Flow.Language , callAPI' , callHTTP , runIO - , runUntracedIO , forkFlow , forkFlow' -- *** PublishSubscribe @@ -46,7 +32,8 @@ module EulerHS.Framework.Flow.Language , foldFlow ) where -import Control.Monad.Catch (MonadThrow (throwM)) +import Control.Monad.Catch (ExitCase, MonadCatch (catch), + MonadThrow (throwM)) import Control.Monad.Free.Church (MonadFree) import Control.Monad.Trans.RWS.Strict (RWST) import Control.Monad.Trans.Writer (WriterT) @@ -55,14 +42,14 @@ import EulerHS.Core.Language (KVDB, Logger, logMessage') import qualified EulerHS.Core.Language as L import qualified EulerHS.Core.PubSub.Language as PSL import qualified EulerHS.Core.Types as T +import EulerHS.Framework.Runtime (FlowRuntime) import EulerHS.Prelude hiding (getOption, throwM) import Servant.Client (BaseUrl, ClientError) --- | Algebra of the `Flow` language. - +-- | Flow language. data FlowMethod (next :: Type) where CallServantAPI - :: (HasCallStack, T.JSONEx a) + :: HasCallStack => Maybe T.ManagerSelector -> BaseUrl -> T.EulerClient a @@ -83,13 +70,6 @@ data FlowMethod (next :: Type) where -> FlowMethod next RunIO - :: (HasCallStack, T.JSONEx a) - => Text - -> IO a - -> (a -> next) - -> FlowMethod next - - RunUntracedIO :: HasCallStack => Text -> IO a @@ -97,21 +77,21 @@ data FlowMethod (next :: Type) where -> FlowMethod next GetOption - :: (HasCallStack, ToJSON a, FromJSON a) - => T.KVDBKey + :: HasCallStack + => Text -> (Maybe a -> next) -> FlowMethod next SetOption - :: (HasCallStack, ToJSON a, FromJSON a) - => T.KVDBKey + :: HasCallStack + => Text -> a -> (() -> next) -> FlowMethod next DelOption :: HasCallStack - => T.KVDBKey + => Text -> (() -> next) -> FlowMethod next @@ -127,7 +107,7 @@ data FlowMethod (next :: Type) where -> FlowMethod next Fork - :: (HasCallStack, FromJSON a, ToJSON a) + :: HasCallStack => T.Description -> T.ForkGUID -> Flow a @@ -135,7 +115,7 @@ data FlowMethod (next :: Type) where -> FlowMethod next Await - :: (HasCallStack, FromJSON a, ToJSON a) + :: HasCallStack => Maybe T.Microseconds -> T.Awaitable (Either Text a) -> (Either T.AwaitingError a -> next) @@ -148,8 +128,41 @@ data FlowMethod (next :: Type) where -> (a -> next) -> FlowMethod next + CatchException + :: forall a e next + . (HasCallStack, Exception e) + => Flow a + -> (e -> Flow a) + -> (a -> next) + -> FlowMethod next + + Mask + :: forall b next + . HasCallStack + => ((forall a . Flow a -> Flow a) -> Flow b) + -> (b -> next) + -> FlowMethod next + + UninterruptibleMask + :: forall b next + . HasCallStack + => ((forall a . Flow a -> Flow a) -> Flow b) + -> (b -> next) + -> FlowMethod next + + GeneralBracket + :: forall a b c next + . HasCallStack + => Flow a + -> (a -> ExitCase b -> Flow c) + -> (a -> Flow b) + -> ((b, c) -> next) + -> FlowMethod next + + -- This is technically redundant - we can implement this using something like + -- bracket, but better. - Koz RunSafeFlow - :: (HasCallStack, FromJSON a, ToJSON a) + :: HasCallStack => T.SafeFlowGUID -> Flow a -> (Either Text a -> next) @@ -192,7 +205,7 @@ data FlowMethod (next :: Type) where -> FlowMethod next RunDB - :: (HasCallStack, T.JSONEx a) + :: HasCallStack => T.SqlConn beM -> L.SqlDB beM a -> Bool @@ -212,6 +225,15 @@ data FlowMethod (next :: Type) where -> (a -> next) -> FlowMethod next + WithModifiedRuntime + :: HasCallStack + => (FlowRuntime -> FlowRuntime) + -> Flow a + -> (a -> next) + -> FlowMethod next + +-- Needed due to lack of impredicative instantiation (for stuff like Mask). - +-- Koz instance Functor FlowMethod where {-# INLINEABLE fmap #-} fmap f = \case @@ -220,7 +242,6 @@ instance Functor FlowMethod where CallHTTP req cert cont -> CallHTTP req cert (f . cont) EvalLogger logger cont -> EvalLogger logger (f . cont) RunIO t act cont -> RunIO t act (f . cont) - RunUntracedIO t act cont -> RunUntracedIO t act (f . cont) GetOption k cont -> GetOption k (f . cont) SetOption k v cont -> SetOption k v (f . cont) DelOption k cont -> DelOption k (f . cont) @@ -229,6 +250,11 @@ instance Functor FlowMethod where Fork desc guid flow cont -> Fork desc guid flow (f . cont) Await time awaitable cont -> Await time awaitable (f . cont) ThrowException e cont -> ThrowException e (f . cont) + CatchException flow handler cont -> CatchException flow handler (f . cont) + Mask cb cont -> Mask cb (f . cont) + UninterruptibleMask cb cont -> UninterruptibleMask cb (f . cont) + GeneralBracket acquire release act cont -> + GeneralBracket acquire release act (f . cont) RunSafeFlow guid flow cont -> RunSafeFlow guid flow (f . cont) InitSqlDBConnection conf cont -> InitSqlDBConnection conf (f . cont) DeInitSqlDBConnection conn cont -> DeInitSqlDBConnection conn (f . cont) @@ -239,6 +265,8 @@ instance Functor FlowMethod where RunDB conn db b cont -> RunDB conn db b (f . cont) RunKVDB t db cont -> RunKVDB t db (f . cont) RunPubSub pubSub cont -> RunPubSub pubSub (f . cont) + WithModifiedRuntime g innerFlow cont -> + WithModifiedRuntime g innerFlow (f . cont) newtype Flow (a :: Type) = Flow (F FlowMethod a) deriving newtype (Functor, Applicative, Monad, MonadFree FlowMethod) @@ -247,6 +275,19 @@ instance MonadThrow Flow where {-# INLINEABLE throwM #-} throwM e = liftFC . ThrowException e $ id +instance MonadCatch Flow where + {-# INLINEABLE catch #-} + catch comp handler = liftFC . CatchException comp handler $ id + +instance MonadMask Flow where + {-# INLINEABLE mask #-} + mask cb = liftFC . Mask cb $ id + {-# INLINEABLE uninterruptibleMask #-} + uninterruptibleMask cb = liftFC . UninterruptibleMask cb $ id + {-# INLINEABLE generalBracket #-} + generalBracket acquire release act = + liftFC . GeneralBracket acquire release act $ id + foldFlow :: (Monad m) => (forall b . FlowMethod b -> m b) -> Flow a -> m a foldFlow f (Flow comp) = foldF f comp @@ -304,7 +345,7 @@ forkFlow description flow = void $ forkFlow' description $ do -- > awaitable <- forkFlow' "myFlow1 fork" myFlow1 -- > await Nothing awaitable -- -forkFlow' :: (HasCallStack, FromJSON a, ToJSON a) => +forkFlow' :: HasCallStack => T.Description -> Flow a -> Flow (T.Awaitable (Either Text a)) forkFlow' description flow = do flowGUID <- generateGUID @@ -316,7 +357,7 @@ forkFlow' description flow = do -- | Method for calling external HTTP APIs using the facilities of servant-client. -- Allows to specify what manager should be used. If no manager found, --- `HttpManagerNotFound` will be returned (as part of `ClientError.ConnectionError`). +-- `HttpManagerNotFound` will be returne (as part of `ClientError.ConnectionError`). -- -- Thread safe, exception free. -- @@ -341,18 +382,18 @@ forkFlow' description flow = do -- > getBook :: HasCallStack => EulerClient Book -- > (getUser :<|> getBook) = client api -- > --- > url = BaseUrl Http "127.0.0.1" port "" +-- > url = BaseUrl Http "localhost" port "" -- > -- > -- > myFlow = do -- > book <- callAPI url getBook -- > user <- callAPI url getUser -callAPI' :: (HasCallStack, T.JSONEx a, MonadFlow m) => +callAPI' :: (HasCallStack, MonadFlow m) => Maybe T.ManagerSelector -> BaseUrl -> T.EulerClient a -> m (Either ClientError a) callAPI' = callServantAPI -- | The same as `callAPI'` but with default manager to be used. -callAPI :: (HasCallStack, T.JSONEx a, MonadFlow m) => +callAPI :: (HasCallStack, MonadFlow m) => BaseUrl -> T.EulerClient a -> m (Either ClientError a) callAPI = callServantAPI Nothing @@ -395,23 +436,9 @@ logWarning tag msg = evalLogger' $ logMessage' T.Warning tag msg -- > content <- runIO $ readFromFile file -- > logDebugT "content id" $ extractContentId content -- > pure content -runIO :: (HasCallStack, MonadFlow m, T.JSONEx a) => IO a -> m a +runIO :: (HasCallStack, MonadFlow m) => IO a -> m a runIO = runIO' "" --- | The same as runIO, but does not record IO outputs in the ART recordings. --- For example, this can be useful to implement things like STM or use mutable --- state. --- --- Warning. This method is dangerous and should be used wisely. --- Also, it breask the ART system. --- --- > myFlow = do --- > content <- runUntracedIO $ readFromFile file --- > logDebugT "content id" $ extractContentId content --- > pure content -runUntracedIO :: (HasCallStack, MonadFlow m) => IO a -> m a -runUntracedIO = runUntracedIO' "" - -- | The same as callHTTPWithCert but does not need certificate data. -- -- Thread safe, exception free. @@ -429,7 +456,7 @@ callHTTP url = callHTTPWithCert url Nothing -- -- Omit `forkFlow` as this will break some monads like StateT (you can lift this manually if you -- know what you're doing) -class (MonadThrow m) => MonadFlow m where +class (MonadMask m) => MonadFlow m where -- | Method for calling external HTTP APIs using the facilities of servant-client. -- Allows to specify what manager should be used. If no manager found, @@ -456,14 +483,14 @@ class (MonadThrow m) => MonadFlow m where -- > getBook :: HasCallStack => EulerClient Book -- > (getUser :<|> getBook) = client api -- > - -- > url = BaseUrl Http "127.0.0.1" port "" + -- > url = BaseUrl Http "localhost" port "" -- > -- > -- > myFlow = do -- > book <- callServantAPI url getBook -- > user <- callServantAPI url getUser callServantAPI - :: (HasCallStack, T.JSONEx a) + :: HasCallStack => Maybe T.ManagerSelector -- ^ name of the connection manager to be used -> BaseUrl -- ^ remote url 'BaseUrl' -> T.EulerClient a -- ^ servant client 'EulerClient' @@ -484,7 +511,7 @@ class (MonadThrow m) => MonadFlow m where -> m (Either Text.Text T.HTTPResponse) -- ^ result -- | Evaluates a logging action. - evalLogger' :: (HasCallStack, ToJSON a, FromJSON a) => Logger a -> m a + evalLogger' :: HasCallStack => Logger a -> m a -- | The same as runIO, but accepts a description which will be written into the ART recordings -- for better clarity. @@ -495,18 +522,7 @@ class (MonadThrow m) => MonadFlow m where -- > content <- runIO' "reading from file" $ readFromFile file -- > logDebugT "content id" $ extractContentId content -- > pure content - runIO' :: (HasCallStack, T.JSONEx a) => Text -> IO a -> m a - - -- | The same as runUntracedIO, but accepts a description which will be written into - -- the ART recordings for better clarity. - -- - -- Warning. This method is dangerous and should be used wisely. - -- - -- > myFlow = do - -- > content <- runUntracedIO' "reading secret data" $ readFromFile secret_file - -- > logDebugT "content id" $ extractContentId content - -- > pure content - runUntracedIO' :: HasCallStack => Text -> IO a -> m a + runIO' :: HasCallStack => Text -> IO a -> m a -- | Gets stored a typed option by a typed key. -- @@ -597,8 +613,9 @@ class (MonadThrow m) => MonadFlow m where -- Thread safe, exception free. getKVDBConnection :: HasCallStack => T.KVDBConfig -> m (T.KVDBAnswer T.KVDBConn) - -- | Evaluates SQL DB operations without creating a transaction. + -- | Evaluates SQL DB operations outside of any transaction. -- It's possible to have a chain of SQL DB calls (within the SqlDB language). + -- These chains will be executed as a single transaction. -- -- Thread safe, exception free. -- @@ -632,7 +649,6 @@ class (MonadThrow m) => MonadFlow m where runDB :: ( HasCallStack - , T.JSONEx a , T.BeamRunner beM , T.BeamRuntime be beM ) @@ -640,13 +656,10 @@ class (MonadThrow m) => MonadFlow m where -> L.SqlDB beM a -> m (T.DBResult a) - -- | Like @runDB@ but the SqlDB script will be considered a transactional scope. - -- All the queries made within a single @runDBTransaction@ scope will be placed - -- into a single transaction. - runDBTransaction + -- | Like `runDB` but runs inside a SQL transaction. + runTransaction :: ( HasCallStack - , T.JSONEx a , T.BeamRunner beM , T.BeamRuntime be beM ) @@ -676,7 +689,7 @@ class (MonadThrow m) => MonadFlow m where -- > awaitable <- forkFlow' "myFlow1 fork" myFlow1 -- > await Nothing awaitable await - :: (HasCallStack, FromJSON a, ToJSON a) + :: HasCallStack => Maybe T.Microseconds -> T.Awaitable (Either Text a) -> m (Either T.AwaitingError a) @@ -719,7 +732,7 @@ class (MonadThrow m) => MonadFlow m where -- > case eitherContent of -- > Left err -> ... -- > Right content -> ... - runSafeFlow :: (HasCallStack, FromJSON a, ToJSON a) => Flow a -> m (Either Text a) + runSafeFlow :: HasCallStack => Flow a -> m (Either Text a) -- | Execute kvdb actions. -- @@ -769,6 +782,16 @@ class (MonadThrow m) => MonadFlow m where -> PMessageCallback -- ^ Callback function -> m (Flow ()) -- ^ Inner flow is a canceller of current subscription + -- | Run a flow with a modified runtime. The runtime will be restored after + -- the computation finishes. + -- + -- @since 2.0.3.1 + withModifiedRuntime + :: (HasCallStack, MonadFlow m) + => (FlowRuntime -> FlowRuntime) -- ^ Temporary modification function for runtime + -> Flow a -- ^ Computation to run with modified runtime + -> m a + instance MonadFlow Flow where {-# INLINEABLE callServantAPI #-} callServantAPI mbMgrSel url cl = liftFC $ CallServantAPI mbMgrSel url cl id @@ -778,8 +801,6 @@ instance MonadFlow Flow where evalLogger' logAct = liftFC $ EvalLogger logAct id {-# INLINEABLE runIO' #-} runIO' descr ioAct = liftFC $ RunIO descr ioAct id - {-# INLINEABLE runUntracedIO' #-} - runUntracedIO' descr ioAct = liftFC $ RunUntracedIO descr ioAct id {-# INLINEABLE getOption #-} getOption :: forall k v. (HasCallStack, T.OptionEntity k v) => k -> Flow (Maybe v) getOption k = liftFC $ GetOption (T.mkOptionKey @k @v k) id @@ -807,8 +828,8 @@ instance MonadFlow Flow where getKVDBConnection cfg = liftFC $ GetKVDBConnection cfg id {-# INLINEABLE runDB #-} runDB conn dbAct = liftFC $ RunDB conn dbAct False id - {-# INLINEABLE runDBTransaction #-} - runDBTransaction conn dbAct = liftFC $ RunDB conn dbAct True id + {-# INLINEABLE runTransaction #-} + runTransaction conn dbAct = liftFC $ RunDB conn dbAct True id {-# INLINEABLE await #-} await mbMcs awaitable = liftFC $ Await mbMcs awaitable id {-# INLINEABLE runSafeFlow #-} @@ -827,6 +848,8 @@ instance MonadFlow Flow where {-# INLINEABLE psubscribe #-} psubscribe channels cb = fmap (runIO' "psubscribe") $ runPubSub $ PubSub $ \runFlow -> PSL.psubscribe channels (\ch -> runFlow . cb ch) + {-# INLINEABLE withModifiedRuntime #-} + withModifiedRuntime f flow = liftFC $ WithModifiedRuntime f flow id instance MonadFlow m => MonadFlow (ReaderT r m) where {-# INLINEABLE callServantAPI #-} @@ -837,8 +860,6 @@ instance MonadFlow m => MonadFlow (ReaderT r m) where evalLogger' = lift . evalLogger' {-# INLINEABLE runIO' #-} runIO' descr = lift . runIO' descr - {-# INLINEABLE runUntracedIO' #-} - runUntracedIO' descr = lift . runUntracedIO' descr {-# INLINEABLE getOption #-} getOption = lift . getOption {-# INLINEABLE setOption #-} @@ -863,8 +884,8 @@ instance MonadFlow m => MonadFlow (ReaderT r m) where getKVDBConnection = lift . getKVDBConnection {-# INLINEABLE runDB #-} runDB conn = lift . runDB conn - {-# INLINEABLE runDBTransaction #-} - runDBTransaction conn = lift . runDBTransaction conn + {-# INLINEABLE runTransaction #-} + runTransaction conn = lift . runTransaction conn {-# INLINEABLE await #-} await mbMcs = lift . await mbMcs {-# INLINEABLE runSafeFlow #-} @@ -879,6 +900,8 @@ instance MonadFlow m => MonadFlow (ReaderT r m) where subscribe channels = lift . subscribe channels {-# INLINEABLE psubscribe #-} psubscribe channels = lift . psubscribe channels + {-# INLINEABLE withModifiedRuntime #-} + withModifiedRuntime f = lift . withModifiedRuntime f instance MonadFlow m => MonadFlow (StateT s m) where {-# INLINEABLE callServantAPI #-} @@ -889,8 +912,6 @@ instance MonadFlow m => MonadFlow (StateT s m) where evalLogger' = lift . evalLogger' {-# INLINEABLE runIO' #-} runIO' descr = lift . runIO' descr - {-# INLINEABLE runUntracedIO' #-} - runUntracedIO' descr = lift . runUntracedIO' descr {-# INLINEABLE getOption #-} getOption = lift . getOption {-# INLINEABLE setOption #-} @@ -915,8 +936,8 @@ instance MonadFlow m => MonadFlow (StateT s m) where getKVDBConnection = lift . getKVDBConnection {-# INLINEABLE runDB #-} runDB conn = lift . runDB conn - {-# INLINEABLE runDBTransaction #-} - runDBTransaction conn = lift . runDBTransaction conn + {-# INLINEABLE runTransaction #-} + runTransaction conn = lift . runTransaction conn {-# INLINEABLE await #-} await mbMcs = lift . await mbMcs {-# INLINEABLE runSafeFlow #-} @@ -931,6 +952,8 @@ instance MonadFlow m => MonadFlow (StateT s m) where subscribe channels = lift . subscribe channels {-# INLINEABLE psubscribe #-} psubscribe channels = lift . psubscribe channels + {-# INLINEABLE withModifiedRuntime #-} + withModifiedRuntime f = lift . withModifiedRuntime f instance (MonadFlow m, Monoid w) => MonadFlow (WriterT w m) where {-# INLINEABLE callServantAPI #-} @@ -941,8 +964,6 @@ instance (MonadFlow m, Monoid w) => MonadFlow (WriterT w m) where evalLogger' = lift . evalLogger' {-# INLINEABLE runIO' #-} runIO' descr = lift . runIO' descr - {-# INLINEABLE runUntracedIO' #-} - runUntracedIO' descr = lift . runUntracedIO' descr {-# INLINEABLE getOption #-} getOption = lift . getOption {-# INLINEABLE setOption #-} @@ -967,8 +988,8 @@ instance (MonadFlow m, Monoid w) => MonadFlow (WriterT w m) where getKVDBConnection = lift . getKVDBConnection {-# INLINEABLE runDB #-} runDB conn = lift . runDB conn - {-# INLINEABLE runDBTransaction #-} - runDBTransaction conn = lift . runDBTransaction conn + {-# INLINEABLE runTransaction #-} + runTransaction conn = lift . runTransaction conn {-# INLINEABLE await #-} await mbMcs = lift . await mbMcs {-# INLINEABLE runSafeFlow #-} @@ -983,6 +1004,8 @@ instance (MonadFlow m, Monoid w) => MonadFlow (WriterT w m) where subscribe channels = lift . subscribe channels {-# INLINEABLE psubscribe #-} psubscribe channels = lift . psubscribe channels + {-# INLINEABLE withModifiedRuntime #-} + withModifiedRuntime f = lift . withModifiedRuntime f instance MonadFlow m => MonadFlow (ExceptT e m) where {-# INLINEABLE callServantAPI #-} @@ -993,8 +1016,6 @@ instance MonadFlow m => MonadFlow (ExceptT e m) where evalLogger' = lift . evalLogger' {-# INLINEABLE runIO' #-} runIO' descr = lift . runIO' descr - {-# INLINEABLE runUntracedIO' #-} - runUntracedIO' descr = lift . runUntracedIO' descr {-# INLINEABLE getOption #-} getOption = lift . getOption {-# INLINEABLE setOption #-} @@ -1019,8 +1040,8 @@ instance MonadFlow m => MonadFlow (ExceptT e m) where getKVDBConnection = lift . getKVDBConnection {-# INLINEABLE runDB #-} runDB conn = lift . runDB conn - {-# INLINEABLE runDBTransaction #-} - runDBTransaction conn = lift . runDBTransaction conn + {-# INLINEABLE runTransaction #-} + runTransaction conn = lift . runTransaction conn {-# INLINEABLE await #-} await mbMcs = lift . await mbMcs {-# INLINEABLE runSafeFlow #-} @@ -1035,6 +1056,8 @@ instance MonadFlow m => MonadFlow (ExceptT e m) where subscribe channels = lift . subscribe channels {-# INLINEABLE psubscribe #-} psubscribe channels = lift . psubscribe channels + {-# INLINEABLE withModifiedRuntime #-} + withModifiedRuntime f = lift . withModifiedRuntime f instance (MonadFlow m, Monoid w) => MonadFlow (RWST r w s m) where {-# INLINEABLE callServantAPI #-} @@ -1045,8 +1068,6 @@ instance (MonadFlow m, Monoid w) => MonadFlow (RWST r w s m) where evalLogger' = lift . evalLogger' {-# INLINEABLE runIO' #-} runIO' descr = lift . runIO' descr - {-# INLINEABLE runUntracedIO' #-} - runUntracedIO' descr = lift . runUntracedIO' descr {-# INLINEABLE getOption #-} getOption = lift . getOption {-# INLINEABLE setOption #-} @@ -1071,8 +1092,8 @@ instance (MonadFlow m, Monoid w) => MonadFlow (RWST r w s m) where getKVDBConnection = lift . getKVDBConnection {-# INLINEABLE runDB #-} runDB conn = lift . runDB conn - {-# INLINEABLE runDBTransaction #-} - runDBTransaction conn = lift . runDBTransaction conn + {-# INLINEABLE runTransaction #-} + runTransaction conn = lift . runTransaction conn {-# INLINEABLE await #-} await mbMcs = lift . await mbMcs {-# INLINEABLE runSafeFlow #-} @@ -1087,6 +1108,8 @@ instance (MonadFlow m, Monoid w) => MonadFlow (RWST r w s m) where subscribe channels = lift . subscribe channels {-# INLINEABLE psubscribe #-} psubscribe channels = lift . psubscribe channels + {-# INLINEABLE withModifiedRuntime #-} + withModifiedRuntime f = lift . withModifiedRuntime f -- TODO: save a builder in some state for using `hPutBuilder`? -- @@ -1104,3 +1127,4 @@ logCallStack = logDebug ("CALLSTACK" :: Text) $ Text.pack $ prettyCallStack call logExceptionCallStack :: (HasCallStack, Exception e, MonadFlow m) => e -> m () logExceptionCallStack ex = logError ("EXCEPTION" :: Text) $ Text.pack $ displayException ex + diff --git a/src/EulerHS/Framework/Interpreters.hs b/src/EulerHS/Framework/Interpreters.hs index 004fdfac..686d4822 100644 --- a/src/EulerHS/Framework/Interpreters.hs +++ b/src/EulerHS/Framework/Interpreters.hs @@ -1,16 +1,3 @@ -{- | -Module : EulerHS.Framework.Interpreters -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -This module reexports interpreters of the framework. - -This is an internal module. Import EulerHS.Interpreters instead. --} - module EulerHS.Framework.Interpreters ( module X ) where diff --git a/src/EulerHS/Framework/Language.hs b/src/EulerHS/Framework/Language.hs index 32953ade..1ae86b69 100644 --- a/src/EulerHS/Framework/Language.hs +++ b/src/EulerHS/Framework/Language.hs @@ -1,16 +1,3 @@ -{- | -Module : EulerHS.Core.Types -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -This module reexports the language of the framework. - -This is an internal module. Import EulerHS.Language instead. --} - module EulerHS.Framework.Language ( X.Flow, X.FlowMethod (..), @@ -26,7 +13,6 @@ module EulerHS.Framework.Language X.callAPI', X.callHTTP, X.runIO, - X.runUntracedIO, X.forkFlow, X.forkFlow', X.unpackLanguagePubSub, diff --git a/src/EulerHS/Framework/Runtime.hs b/src/EulerHS/Framework/Runtime.hs index 0dced3c8..6b78272b 100644 --- a/src/EulerHS/Framework/Runtime.hs +++ b/src/EulerHS/Framework/Runtime.hs @@ -1,16 +1,3 @@ -{- | -Module : EulerHS.Framework.Runtime -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -This module contains functions and types to work with `FlowRuntime`. - -This is an internal module. Import EulerHS.Runtime instead. --} - module EulerHS.Framework.Runtime ( -- * Framework Runtime @@ -39,36 +26,7 @@ import qualified EulerHS.Core.Runtime as R import qualified EulerHS.Core.Types as T -{- | FlowRuntime state and options. - -`FlowRuntime` is a structure that stores operational data of the framework, -such as native connections, internal state, threads, and other things -needed to run the framework. - -@ -import qualified EulerHS.Types as T -import qualified EulerHS.Language as L -import qualified EulerHS.Runtime as R -import qualified EulerHS.Interpreters as R - -myFlow :: L.Flow () -myFlow = L.runIO $ putStrLn @String "Hello there!" - -runApp :: IO () -runApp = do - let mkLoggerRt = R.createLoggerRuntime T.defaultFlowFormatter T.defaultLoggerConfig - R.withFlowRuntime (Just mkLoggerRt) - $ \flowRt -> R.runFlow flowRt myFlow -@ - -Typically, you need only one instance of `FlowRuntime` in your project. -You can run your flows with this instance in parallel, it should be thread-safe. - -It's okay to pass `FlowRuntime` here and there, but avoid changing its data. -Only the framework has a right to update those fields. - -Mutating any of its data from the outside will lead to an undefined behavior. --} +-- | FlowRuntime state and options. data FlowRuntime = FlowRuntime { _coreRuntime :: R.CoreRuntime -- ^ Contains logger settings @@ -80,8 +38,6 @@ data FlowRuntime = FlowRuntime -- ^ Typed key-value storage , _kvdbConnections :: MVar (Map Text T.NativeKVDBConn) -- ^ Connections for key-value databases - , _runMode :: T.RunMode - -- ^ ART mode in which current flow runs , _sqldbConnections :: MVar (Map T.ConnTag T.NativeSqlPool) -- ^ Connections for SQL databases , _pubSubController :: RD.PubSubController @@ -105,16 +61,12 @@ createFlowRuntime coreRt = do , _httpClientManagers = Map.empty , _options = optionsVar , _kvdbConnections = kvdbConnections - , _runMode = T.RegularMode + -- , _runMode = T.RegularMode , _sqldbConnections = sqldbConnections , _pubSubController = pubSubController , _pubSubConnection = Nothing } --- | Create a flow runtime. This function takes a creation function for `LoggerRuntime`. --- --- Normally, you should not create `LoggerRuntime` manually, but rather delegate its creation --- to this function and like. createFlowRuntime' :: Maybe (IO R.LoggerRuntime) -> IO FlowRuntime createFlowRuntime' Nothing = R.createVoidLoggerRuntime >>= R.createCoreRuntime >>= createFlowRuntime createFlowRuntime' (Just loggerRtCreator) = loggerRtCreator >>= R.createCoreRuntime >>= createFlowRuntime @@ -133,10 +85,21 @@ clearFlowRuntime FlowRuntime{..} = do -- The Manager will be shut down automatically via garbage collection. SYSM.performGC --- | Returns True if the logger option "log raw SQL queries as debug messages" set. shouldFlowLogRawSql :: FlowRuntime -> Bool shouldFlowLogRawSql = R.shouldLogRawSql . R._loggerRuntime . _coreRuntime +sqlDisconnect :: T.NativeSqlPool -> IO () +sqlDisconnect = \case + T.NativePGPool connPool -> DP.destroyAllResources connPool + T.NativeMySQLPool connPool -> DP.destroyAllResources connPool + T.NativeSQLitePool connPool -> DP.destroyAllResources connPool + T.NativeMockedPool -> pure () + +kvDisconnect :: T.NativeKVDBConn -> IO () +kvDisconnect = \case + T.NativeKVDBMockedConn -> pure () + T.NativeKVDB conn -> RD.disconnect conn + -- | Run flow with given logger runtime creation function. withFlowRuntime :: Maybe (IO R.LoggerRuntime) -> (FlowRuntime -> IO a) -> IO a withFlowRuntime Nothing actionF = @@ -148,8 +111,6 @@ withFlowRuntime (Just loggerRuntimeCreator) actionF = bracket (R.createCoreRuntime loggerRt) R.clearCoreRuntime $ \coreRt -> bracket (createFlowRuntime coreRt) clearFlowRuntime actionF --- * Experimental PubSub mechanism bits. - -- Use {-# NOINLINE foo #-} as a pragma on any function foo that calls unsafePerformIO. -- If the call is inlined, the I/O may be performed more than once. {-# NOINLINE pubSubWorkerLock #-} @@ -194,23 +155,3 @@ runPubSubWorker rt log = do killThread threadId putMVar pubSubWorkerLock () log $ "Publish/Subscribe worker: Killed" - --- * Internal functions - --- | Disconnect from a SQL DB. --- --- Internal function, should not be used in the business logic. -sqlDisconnect :: T.NativeSqlPool -> IO () -sqlDisconnect = \case - T.NativePGPool connPool -> DP.destroyAllResources connPool - T.NativeMySQLPool connPool -> DP.destroyAllResources connPool - T.NativeSQLitePool connPool -> DP.destroyAllResources connPool - T.NativeMockedPool -> pure () - --- | Disconnect from an KV DB. --- --- Internal function, should not be used in the business logic. -kvDisconnect :: T.NativeKVDBConn -> IO () -kvDisconnect = \case - T.NativeKVDBMockedConn -> pure () - T.NativeKVDB conn -> RD.disconnect conn diff --git a/src/EulerHS/Interpreters.hs b/src/EulerHS/Interpreters.hs index df8945ad..9be544f0 100644 --- a/src/EulerHS/Interpreters.hs +++ b/src/EulerHS/Interpreters.hs @@ -1,31 +1,3 @@ -{- | -Module : EulerHS.Interpreters -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -This module contains interpreters and methods for running `Flow` scenarios. - -This module is better imported as qualified. - -@ -import qualified EulerHS.Types as T -import qualified EulerHS.Language as L -import qualified EulerHS.Runtime as R -import qualified EulerHS.Interpreters as R - -myFlow :: L.Flow () -myFlow = L.runIO $ putStrLn @String "Hello there!" - -runApp :: IO () -runApp = do - let mkLoggerRt = R.createLoggerRuntime T.defaultFlowFormatter T.defaultLoggerConfig - R.withFlowRuntime (Just mkLoggerRt) $ \flowRt -> R.runFlow flowRt myFlow -@ --} - module EulerHS.Interpreters ( module X ) where diff --git a/src/EulerHS/Language.hs b/src/EulerHS/Language.hs index 0e026b98..7cc97acc 100644 --- a/src/EulerHS/Language.hs +++ b/src/EulerHS/Language.hs @@ -1,61 +1,3 @@ -{- | -Module : EulerHS.Language -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -This module provides you a public interface to the free monadic eDSLs of the framework. - -The `Flow` type or its derivations for different monad stacks can be used -to describe business logic of a typical web application. - -This language provides you with several features out-of-the-box: - -- Logging -- SQL DB subsystem. Supported SQL DB backends: - * MySQL - * Postgres - * SQLite -- KV DB subsystem (Redis) -- Fork/await of flows (async evaluation) -- Typed options -- Servant-like HTTP client runner -- Low-level HTTP client runner -- Arbitrary IO effects -- Exception throwing and handling -- Redis-based PubSub connector (experimental) - -The `Flow` is a monad, so you can write sequential scenarios in a monadic form: - -@ -import EulerHS.Prelude -import qualified EulerHS.Types as T -import qualified EulerHS.Language as L -import qualified Servant.Client as S - -myFlow :: L.Flow (Either T.ClientError User) -myFlow = do - L.runIO $ putStrLn @String "Hello there!" - L.logInfo "myFlow" "This is a message from myFlow." - - let url = S.BaseUrl Http "127.0.0.1" 8081 "" - L.callAPI Nothing url getUser - --- HTTP API powered by Servant -type API = "user" :> Get '[JSON] User - -getUser :: T.EulerClient User -getUser = client api -@ - -To run this logic, you need to create an instance of `FlowRuntime`, -and pass @myFlow@ to the `runFlow` method. - -This module is better imported as qualified. --} - module EulerHS.Language ( module X ) where diff --git a/src/EulerHS/Prelude.hs b/src/EulerHS/Prelude.hs index 10ea2eec..eecbd080 100644 --- a/src/EulerHS/Prelude.hs +++ b/src/EulerHS/Prelude.hs @@ -1,22 +1,7 @@ {-# OPTIONS -fno-warn-orphans #-} -{-# OPTIONS -fno-warn-unused-imports #-} - -{- | -Module : EulerHS.Prelude -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -Custom prelude based on @universum@ by Serokell. -In contrast with the latter, it exports unsafe versions of such functions as -@head@, @last@ etc. It also has some other tiny changes here and there. -You may want to get familiar with the @universum@ documentation first. --} - module EulerHS.Prelude + -- TODO: This entire export lists needs to be explicit ( module X , liftFC , catchAny @@ -78,4 +63,4 @@ import qualified Control.Monad.Free.Class as MF -- Lift for Church encoded Free liftFC :: (Functor f, MF.MonadFree f m) => f a -> m a -liftFC = CF.liftF +liftFC = CF.liftF \ No newline at end of file diff --git a/src/EulerHS/Runtime.hs b/src/EulerHS/Runtime.hs index 18463995..2a15be58 100644 --- a/src/EulerHS/Runtime.hs +++ b/src/EulerHS/Runtime.hs @@ -1,38 +1,3 @@ -{- | -Module : EulerHS.Runtime -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -This is a top module that reexports all the runtime-specific types and functions. - -This layer of the framework contains methods for creating and disposing runtimes -of different subsystems: logger, SQL, state and others. - -You typically create a single `FlowRuntime` instance and then use it to run your -`Flow` scenarios. - -This module is better imported as qualified. - -@ -import qualified EulerHS.Types as T -import qualified EulerHS.Language as L -import qualified EulerHS.Runtime as R -import qualified EulerHS.Interpreters as R - -myFlow :: L.Flow () -myFlow = L.runIO $ putStrLn @String "Hello there!" - -runApp :: IO () -runApp = do - let mkLoggerRt = R.createLoggerRuntime T.defaultFlowFormatter T.defaultLoggerConfig - R.withFlowRuntime (Just mkLoggerRt) $ \flowRt -> R.runFlow flowRt myFlow -@ - --} - module EulerHS.Runtime ( module X ) where diff --git a/src/EulerHS/Types.hs b/src/EulerHS/Types.hs index 4dbebc8b..111e98aa 100644 --- a/src/EulerHS/Types.hs +++ b/src/EulerHS/Types.hs @@ -1,36 +1,3 @@ -{- | -Module : EulerHS.Types -Copyright : (C) Juspay Technologies Pvt Ltd 2019-2021 -License : Apache 2.0 (see the file LICENSE) -Maintainer : opensource@juspay.in -Stability : experimental -Portability : non-portable - -This is a top module that reexports all the public types of the framework -along with some helper functions. - -This module is better imported as qualified. - -@ -import qualified EulerHS.Types as T - --- Beam imports -import Database.Beam.MySQL (MySQLM) - -mySQLDevConfig :: T.'DBConfig' MySQLM -mySQLDevConfig = T.'mkMySQLPoolConfig' "MySQL dev DB" cfg poolCfg - where - cfg :: T.'MySQLConfig' - cfg = T.'defaultMySQLConfig' - { T.connectPassword = "my pass" - , T.connectDatabase = "my db" - } - poolCfg = T.'defaultPoolConfig' - { T.keepAlive = 1000000 - } -@ --} - module EulerHS.Types ( module X ) where diff --git a/stack.yaml b/stack.yaml index 28517e11..3eeb61de 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,14 +1,15 @@ +--- resolver: lts-15.15 +allow-newer: true packages: - . - - demo/echo-server extra-deps: - git: https://github.com/juspay/hedis - commit: 46ea0ea78e6d8d1a2b1a66e6f08078a37864ad80 + commit: 46ea0ea78e6d8d1a2b1a66e6f08078a37864ad80 #4ea54f16c0057acc99a9f0e9b63ea51ea4bf420e - git: https://github.com/juspay/beam-mysql - commit: eab93370b30f90e26e39e4d99f51db052aebc992 + commit: 4c876ea2eae60bf3402d6f5c1ecb60a386fe3ace - git: https://github.com/juspay/mysql-haskell commit: 788022d65538db422b02ecc0be138b862d2e5cee - git: https://github.com/juspay/bytestring-lexing @@ -20,7 +21,16 @@ extra-deps: - beam-migrate - beam-sqlite - beam-postgres - + - git: https://github.com/juspay/haskell-sequelize.git + commit: 3abc8fe10edde3fd1c9a776ede81d057dc590341 + # Needed for us + - servant-0.18.1 + - servant-mock-0.8.7 + - servant-server-0.18.1 + - servant-client-0.18.1 + - servant-client-core-0.18.1 + # Needed for sequelize + - named-0.3.0.1@sha256:2975d50c9c5d88095026ffc1303d2d9be52e5f588a8f8bcb7003a04b79f10a06,2312 # Needed for beam - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 @@ -32,8 +42,7 @@ extra-deps: - tcp-streams-1.0.1.1@sha256:35e9ecfa515797052f8c3c01834d2daebd5e93f3152c7fc98b32652bf6f0c052,2329 - wire-streams-0.1.1.0@sha256:08816c7fa53b20f52e5c465252c106d9de8e6d9580ec0b6d9f000a34c7bcefc8,2130 - mason-0.2.3@sha256:186ff6306c7d44dbf7b108b87f73a30d45c70cd5c87d6f2a88d300def5542fef,1226 - - record-dot-preprocessor-0.2.7@sha256:bf7e83b2a01675577f81536fc3246e3b54e9d2dd28bb645599813dc5c486fbee,2440 - + - record-dot-preprocessor-0.2.7@sha256:bf7e83b2a01675577f81536fc3246e3b54e9d2dd28bb645599813dc5c486fbee,2440 # MySQL # MacOS: # Problem: MacOS build failure @@ -51,3 +60,7 @@ extra-lib-dirs: # Linux: # sudo apt install mysql-client # sudo apt-get install libmysqlclient-dev + +nix: + enable: false + packages: [mysql57, openssl, zlib, postgresql] diff --git a/stack.yaml.lock b/stack.yaml.lock index be7ae3dd..88fad0a5 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -21,11 +21,11 @@ packages: git: https://github.com/juspay/beam-mysql pantry-tree: size: 3064 - sha256: 895257a8580c28e74b8f91e00280ab22a694a4c24f4318ab6161dace37375d8d - commit: eab93370b30f90e26e39e4d99f51db052aebc992 + sha256: c612aef440faa9a9278858c8a52b952c20240555c3d7e84ac8bfc1e94eb35c61 + commit: 4c876ea2eae60bf3402d6f5c1ecb60a386fe3ace original: git: https://github.com/juspay/beam-mysql - commit: eab93370b30f90e26e39e4d99f51db052aebc992 + commit: 4c876ea2eae60bf3402d6f5c1ecb60a386fe3ace - completed: name: mysql-haskell version: 0.8.4.2 @@ -100,6 +100,59 @@ packages: subdir: beam-postgres git: https://github.com/juspay/beam commit: 185ff060e63ab0b8a72775ee2742621dd6fefeb1 +- completed: + name: sequelize + version: 1.1.0.0 + git: https://github.com/juspay/haskell-sequelize.git + pantry-tree: + size: 543 + sha256: cc5224453360f8399ab3c71b03c646d8b515d52f29b727e1e929e9ef441068f3 + commit: 3abc8fe10edde3fd1c9a776ede81d057dc590341 + original: + git: https://github.com/juspay/haskell-sequelize.git + commit: 3abc8fe10edde3fd1c9a776ede81d057dc590341 +- completed: + hackage: servant-0.18.1@sha256:d322da8a5033203b3da510fdd41c949f61d25b7a2e3ab707035aef5484bbeb13,5273 + pantry-tree: + size: 2594 + sha256: 59fe629e1b6e92571e1b54a7028c09abfff655077361bedc0689bcaca30c7240 + original: + hackage: servant-0.18.1 +- completed: + hackage: servant-mock-0.8.7@sha256:64cb3e52bbd51ab6cb25e3f412a99ea712c6c26f1efd117f01a8d1664df49c67,2306 + pantry-tree: + size: 555 + sha256: b263e932ec6b151e52987054ec0a4cd692fa787f856c79e51498302eb0d6c388 + original: + hackage: servant-mock-0.8.7 +- completed: + hackage: servant-server-0.18.1@sha256:f0824cfa57b23b6b698dbd93e11598c4c5355aaa26121f48c091f6e5f03623fc,5665 + pantry-tree: + size: 2614 + sha256: afba7a901c86dfe0c65d18470bca144b371cbff13d4fb516247b200fbd62597b + original: + hackage: servant-server-0.18.1 +- completed: + hackage: servant-client-0.18.1@sha256:03d5628829331eaa72402e7c5cc059cff72cb91c34c5f10042fe09fd05454eb4,4745 + pantry-tree: + size: 1300 + sha256: a8e23be4307bef89466b4dd60035980820566cf6142b74b29b120a60490dd851 + original: + hackage: servant-client-0.18.1 +- completed: + hackage: servant-client-core-0.18.1@sha256:a116901bf2aa8b6ff63b1c8e24b34c4fe7c505682e9862f314c5bcd2f9279312,3763 + pantry-tree: + size: 1444 + sha256: 8a47f39a046ba959fc150c44a95cec46f41feec28970e11ec6397604e785d36f + original: + hackage: servant-client-core-0.18.1 +- completed: + hackage: named-0.3.0.1@sha256:2975d50c9c5d88095026ffc1303d2d9be52e5f588a8f8bcb7003a04b79f10a06,2312 + pantry-tree: + size: 426 + sha256: e0df5f146ecd48ef129dd74f868e8d2d754f0a11b36c5d0e56bd4b1947433c9f + original: + hackage: named-0.3.0.1@sha256:2975d50c9c5d88095026ffc1303d2d9be52e5f588a8f8bcb7003a04b79f10a06,2312 - completed: hackage: dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 pantry-tree: diff --git a/test/EulerHS/TestData/API/Client.hs b/test/EulerHS/TestData/API/Client.hs index f3917b75..b5988805 100644 --- a/test/EulerHS/TestData/API/Client.hs +++ b/test/EulerHS/TestData/API/Client.hs @@ -1,31 +1,67 @@ -module EulerHS.TestData.API.Client where +{-# OPTIONS_GHC -Werror #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} -import EulerHS.Prelude +module EulerHS.TestData.API.Client + ( + Book(..), User(..), + port, api, server, + getUser, getBook + ) where -import EulerHS.Types -import Servant.API +import EulerHS.Prelude +import EulerHS.Types (EulerClient, client) +import Servant.API (Get, JSON, type (:>), (:<|>) ((:<|>))) import Servant.Mock (mock) import Servant.Server (Server) +import Test.QuickCheck (Arbitrary (arbitrary, shrink)) +import Test.QuickCheck.Arbitrary.Generic (genericArbitrary, + genericShrink) +import Test.QuickCheck.Instances.Text () + +data User = User { + firstName :: {-# UNPACK #-} !Text, + lastName :: {-# UNPACK #-} !Text , + userGUID :: {-# UNPACK #-} !Text + } + deriving stock (Generic, Show, Eq) + deriving anyclass (ToJSON, FromJSON) -import EulerHS.TestData.Types +instance Arbitrary User where + arbitrary = genericArbitrary + shrink = genericShrink +data Book = Book { + author :: {-# UNPACK #-} !Text, + name :: {-# UNPACK #-} !Text + } + deriving stock (Generic, Show, Eq) + deriving anyclass (ToJSON, FromJSON) + +instance Arbitrary Book where + arbitrary = genericArbitrary + shrink = genericShrink type API = "user" :> Get '[JSON] User :<|> "book" :> Get '[JSON] Book - port :: Int port = 8081 api :: Proxy API api = Proxy -context :: Proxy '[] -context = Proxy - +-- This rather bizarre construction is needed because of the way the 'client' +-- function works. The third line is a pattern match on the result, which a +-- sorta-kinda Servant API type, with additional wrapping. However, because it's +-- a value match, the identifiers are promoted to the top level, and thus need +-- their own signatures. - Koz getUser :: EulerClient User getBook :: EulerClient Book (getUser :<|> getBook) = client api +context :: Proxy '[] +context = Proxy + server :: Server API server = mock api context diff --git a/test/EulerHS/TestData/Scenarios/Scenario1.hs b/test/EulerHS/TestData/Scenarios/Scenario1.hs index ba9da5e7..c0bafb79 100644 --- a/test/EulerHS/TestData/Scenarios/Scenario1.hs +++ b/test/EulerHS/TestData/Scenarios/Scenario1.hs @@ -1,24 +1,28 @@ -{-# OPTIONS -fno-warn-deprecations #-} -module EulerHS.TestData.Scenarios.Scenario1 where +{-# OPTIONS_GHC -fno-warn-deprecations -Werror #-} -import qualified EulerHS.Language as L -import EulerHS.Prelude hiding (getOption) -import Servant.Client (BaseUrl (..), Scheme (..)) +module EulerHS.TestData.Scenarios.Scenario1 + ( + mkUrl, testScenario1 + ) where -import EulerHS.TestData.API.Client +import EulerHS.TestData.API.Client (User (User), getUser, port, userGUID) +import Data.Text (pack) +import EulerHS.Language +import EulerHS.Prelude hiding (getOption, pack) import EulerHS.TestData.Types +import Servant.Client (BaseUrl (..), Scheme (..)) + +mkUrl :: String -> BaseUrl +mkUrl host = BaseUrl Http host port "" -testScenario1 :: L.Flow User +testScenario1 :: Flow User testScenario1 = do - localUserName <- L.runSysCmd "whoami" - localGUID <- L.runIO (undefined :: IO String) - guid <- L.generateGUID - url <- maybe (mkUrl "127.0.0.1") mkUrl <$> L.getOption UrlKey - res <- L.callServantAPI Nothing url getUser - pure $ case res of - Right u | localGUID /= userGUID u -> u - Right u | otherwise -> User localUserName "" $ toString guid - _ -> User localUserName "Smith" $ toString guid - where - mkUrl :: String -> BaseUrl - mkUrl host = BaseUrl Http host port "" + localUserName <- pack <$> runSysCmd "whoami" + localGUID <- runIO (undefined :: IO Text) + guid <- generateGUID + url <- maybe (mkUrl "localhost") mkUrl <$> getOption UrlKey + res <- callServantAPI Nothing url getUser + case res of + Right u -> if localGUID /= userGUID u then pure u + else pure $ User localUserName "" guid + _ -> pure $ User localUserName "Smith" guid diff --git a/test/EulerHS/TestData/Types.hs b/test/EulerHS/TestData/Types.hs index 16d59fa6..d1f8a754 100644 --- a/test/EulerHS/TestData/Types.hs +++ b/test/EulerHS/TestData/Types.hs @@ -1,66 +1,64 @@ {-# LANGUAGE DeriveAnyClass #-} + module EulerHS.TestData.Types where import qualified Data.Aeson as A import EulerHS.Prelude import EulerHS.Types -import Test.QuickCheck.Arbitrary - - data UrlKey = UrlKey - deriving (Generic, Typeable, Show, Eq, ToJSON, FromJSON) + deriving (Generic, Typeable, Show, Eq, ToJSON) data TestStringKey = TestStringKey - deriving (Generic, Typeable, Show, Eq, ToJSON, FromJSON) + deriving (Generic, Typeable, Show, Eq, ToJSON) data TestStringKey2 = TestStringKey2 - deriving (Generic, Typeable, Show, Eq, ToJSON, FromJSON) + deriving (Generic, Typeable, Show, Eq, ToJSON) data TestIntKey = TestIntKey - deriving (Generic, Typeable, Show, Eq, ToJSON, FromJSON) + deriving (Generic, Typeable, Show, Eq, ToJSON) data TestIntKey2 = TestIntKey2 - deriving (Generic, Typeable, Show, Eq, ToJSON, FromJSON) + deriving (Generic, Typeable, Show, Eq, ToJSON) data TestStringKeyAnotherEnc = TestStringKeyAnotherEnc - deriving (Generic, Typeable, Show, Eq, FromJSON) + deriving (Generic, Typeable, Show, Eq) data TestStringKey2AnotherEnc = TestStringKey2AnotherEnc - deriving (Generic, Typeable, Show, Eq, FromJSON) + deriving (Generic, Typeable, Show, Eq) data TestKeyWithStringPayload = TestKeyWithStringPayload String - deriving (Generic, Typeable, Show, Eq, ToJSON, FromJSON) + deriving (Generic, Typeable, Show, Eq, ToJSON) data TestKeyWithIntPayload = TestKeyWithIntPayload Int - deriving (Generic, Typeable, Show, Eq, ToJSON, FromJSON) + deriving (Generic, Typeable, Show, Eq, ToJSON) data TestKeyWithStringPayloadAnotherEnc = TestKeyWithStringPayloadAnotherEnc String - deriving (Generic, Typeable, Show, Eq, FromJSON) + deriving (Generic, Typeable, Show, Eq) data TestKeyWithIntPayloadAnotherEnc = TestKeyWithIntPayloadAnotherEnc Int - deriving (Generic, Typeable, Show, Eq, FromJSON) + deriving (Generic, Typeable, Show, Eq) newtype NTTestKeyWithStringPayload = NTTestKeyWithStringPayload String - deriving (Generic, Typeable, Show, Eq, ToJSON, FromJSON) + deriving (Generic, Typeable, Show, Eq, ToJSON) newtype NTTestKeyWithIntPayload = NTTestKeyWithIntPayload Int - deriving (Generic, Typeable, Show, Eq, ToJSON, FromJSON) + deriving (Generic, Typeable, Show, Eq, ToJSON) newtype NTTestKeyWithStringPayloadAnotherEnc = NTTestKeyWithStringPayloadAnotherEnc String - deriving (Generic, Typeable, Show, Eq, FromJSON) + deriving (Generic, Typeable, Show, Eq) newtype NTTestKeyWithIntPayloadAnotherEnc = NTTestKeyWithIntPayloadAnotherEnc Int - deriving (Generic, Typeable, Show, Eq, FromJSON) + deriving (Generic, Typeable, Show, Eq) @@ -136,14 +134,4 @@ data TestKVals = TestKVals ---------------------------------- -data User = User { firstName :: String, lastName :: String , userGUID :: String} - deriving (Generic, Show, Eq, ToJSON, FromJSON ) - -instance Arbitrary User where - arbitrary = User <$> arbitrary <*> arbitrary <*> arbitrary - -data Book = Book { author :: String, name :: String } - deriving (Generic, Show, Eq, ToJSON, FromJSON ) -instance Arbitrary Book where - arbitrary = Book <$> arbitrary <*> arbitrary diff --git a/test/EulerHS/Testing/Flow/Interpreter.hs b/test/EulerHS/Testing/Flow/Interpreter.hs index 07c3fcbf..4f9cacf0 100644 --- a/test/EulerHS/Testing/Flow/Interpreter.hs +++ b/test/EulerHS/Testing/Flow/Interpreter.hs @@ -1,56 +1,40 @@ +{-# OPTIONS_GHC -Werror #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE NoMonomorphismRestriction #-} module EulerHS.Testing.Flow.Interpreter where -import Data.Aeson (decode) -import Data.Generics.Product.Fields -import qualified EulerHS.Framework.Flow.Language as L +import Data.Generics.Product.Fields (HasField', getField, setField) +import EulerHS.Language (Flow, FlowMethod, foldFlow) +import qualified EulerHS.Language as L import EulerHS.Prelude -import qualified EulerHS.Runtime as R -import EulerHS.Testing.Types -import GHC.TypeLits +import EulerHS.Runtime (FlowRuntime) +import EulerHS.Testing.Types (FlowMockedValues) +import GHC.TypeLits (KnownSymbol, Symbol) import Type.Reflection (typeRep) -import Unsafe.Coerce - -runFlowWithTestInterpreter :: FlowMockedValues -> R.FlowRuntime -> L.Flow a -> IO a -runFlowWithTestInterpreter mv flowRt (L.Flow comp) = foldF (interpretFlowMethod mv flowRt) comp - -interpretFlowMethod :: FlowMockedValues -> R.FlowRuntime -> L.FlowMethod a -> IO a - -interpretFlowMethod mmv _ (L.RunIO _ _ next) = do - v <- takeMockedVal @"mockedRunIO" mmv - next <$> (pure $ unsafeCoerce v) - -interpretFlowMethod mmv _ (L.CallServantAPI _ _ _ next) = do - v <- takeMockedVal @"mockedCallServantAPI" mmv - next <$> (pure $ unsafeCoerce v) - -interpretFlowMethod mmv R.FlowRuntime {..} (L.GetOption _ next) = do - v <- takeMockedVal @"mockedGetOption" mmv - next <$> (pure $ decode v) - -interpretFlowMethod _ R.FlowRuntime {..} (L.SetOption _ _ next) = - next <$> pure () - -interpretFlowMethod mmv _ (L.GenerateGUID next) = do - v <- takeMockedVal @"mockedGenerateGUID" mmv - next <$> (pure v) - -interpretFlowMethod mmv _ (L.RunSysCmd _ next) = do - v <- takeMockedVal @"mockedRunSysCmd" mmv - next <$> (pure v) - -interpretFlowMethod _ _ _ = error "not yet supported." - - -takeMockedVal ::forall (f :: Symbol) a r +import Unsafe.Coerce (unsafeCoerce) + +runFlowWithTestInterpreter :: FlowMockedValues -> FlowRuntime -> Flow a -> IO a +runFlowWithTestInterpreter mv flowRt = foldFlow (interpretFlowMethod mv flowRt) + +interpretFlowMethod :: FlowMockedValues -> FlowRuntime -> FlowMethod a -> IO a +interpretFlowMethod mmv _ = \case + L.RunIO _ _ next -> next . unsafeCoerce <$> takeMockedVal @"mockedRunIO" mmv + L.CallServantAPI _ _ _ next -> + next . unsafeCoerce <$> takeMockedVal @"mockedCallServantAPI" mmv + L.GetOption _ next -> next <$> (unsafeCoerce $ Just $ takeMockedVal @"mockedGetOption" mmv) + L.SetOption _ _ next -> pure . next $ () + L.GenerateGUID next -> next <$> takeMockedVal @"mockedGenerateGUID" mmv + L.RunSysCmd _ next -> next <$> takeMockedVal @"mockedRunSysCmd" mmv + _ -> error "not yet supported." + +takeMockedVal :: forall (f :: Symbol) (a :: Type) (r :: Type) . (KnownSymbol f, Typeable r, HasField' f r [a]) => MVar r -> IO a takeMockedVal mmv = do mv <- takeMVar mmv - (v,t) <- case (getField @f mv) of - [] -> error $ "empty " <> (show $ typeRep @f) <> " in " <> (show $ typeRep @r) + (v,t) <- case getField @f mv of + [] -> error $ "empty " <> show (typeRep @f) <> " in " <> show (typeRep @r) (x:xs) -> pure (x,xs) putMVar mmv $ setField @f t mv pure v diff --git a/test/EulerHS/Testing/Flow/Runtime.hs b/test/EulerHS/Testing/Flow/Runtime.hs index 0b124830..3d3df32d 100644 --- a/test/EulerHS/Testing/Flow/Runtime.hs +++ b/test/EulerHS/Testing/Flow/Runtime.hs @@ -1,18 +1,18 @@ module EulerHS.Testing.Flow.Runtime where --- import EulerHS.Prelude --- import EulerHS.Runtime --- import Network.HTTP.Client (defaultManagerSettings, newManager) --- import Database.Redis (checkedConnect, defaultConnectInfo, Redis(..)) --- import Data.Map (singleton) +import EulerHS.Prelude +import EulerHS.Runtime +import Network.HTTP.Client (defaultManagerSettings, newManager) +import Database.Redis (checkedConnect, defaultConnectInfo, Redis(..)) +import Data.Map (singleton) --- type FlowRtInitializer = IO FlowRuntime +type FlowRtInitializer = IO FlowRuntime ---initDefaultFlowRt :: FlowRtInitializer ---initDefaultFlowRt = do --- manager <- newMVar =<< newManager defaultManagerSettings --- options <- newMVar mempty --- coreRuntime <- createCoreRuntime =<< createVoidLoggerRuntime --- conn <- checkedConnect defaultConnectInfo --- connPool <- newMVar (singleton "redis" $ T.Redis conn) --- pure $ FlowRuntime coreRuntime manager options connPool +initDefaultFlowRt :: FlowRtInitializer +initDefaultFlowRt = do + manager <- newMVar =<< newManager defaultManagerSettings + options <- newMVar mempty + coreRuntime <- createCoreRuntime =<< createVoidLoggerRuntime + conn <- checkedConnect defaultConnectInfo + connPool <- newMVar (singleton "redis" $ T.Redis conn) + pure $ FlowRuntime coreRuntime manager options connPool diff --git a/test/EulerHS/Testing/Types.hs b/test/EulerHS/Testing/Types.hs index cba21cab..f894251f 100644 --- a/test/EulerHS/Testing/Types.hs +++ b/test/EulerHS/Testing/Types.hs @@ -1,14 +1,13 @@ {-# LANGUAGE DeriveDataTypeable #-} module EulerHS.Testing.Types where -import qualified Data.ByteString.Lazy as BSL import Data.Data import EulerHS.Prelude data FlowMockedValues' = FlowMockedValues' { mockedCallServantAPI :: [Any] , mockedRunIO :: [Any] - , mockedGetOption :: [BSL.ByteString] + , mockedGetOption :: [ByteString] , mockedGenerateGUID :: [Text] , mockedRunSysCmd :: [String] } deriving (Generic, Typeable) diff --git a/test/EulerHS/Tests/Framework/ArtSpec.hs b/test/EulerHS/Tests/Framework/ArtSpec.hs index 0d17ce66..dc00aa85 100644 --- a/test/EulerHS/Tests/Framework/ArtSpec.hs +++ b/test/EulerHS/Tests/Framework/ArtSpec.hs @@ -1,321 +1,314 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# OPTIONS_GHC -Werror -Wno-name-shadowing #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE StandaloneDeriving #-} - -module EulerHS.Tests.Framework.ArtSpec where - -import Control.Monad (void) -import Data.Aeson as A -import Data.Aeson.Encode.Pretty -import qualified Data.ByteString.Lazy as Lazy -import qualified Data.Map as Map -import qualified Data.String.Conversions as Conversions -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Encoding -import qualified Data.Text.Encoding.Error as Encoding -import qualified Data.UUID as UUID (toText) -import qualified Data.UUID.V4 as UUID (nextRandom) -import qualified Data.Vector as V -import Network.Wai.Handler.Warp -import Servant.Client -import Servant.Server -import qualified System.IO.Error as Error -import Test.Hspec - -import EulerHS.Interpreters -import EulerHS.Language as L -import EulerHS.Prelude -import EulerHS.Runtime -import EulerHS.TestData.API.Client -import EulerHS.TestData.Types -import EulerHS.Tests.Framework.Common -import EulerHS.Types as T - - -spec :: Spec -spec = do - describe "ART Test" $ do - it "Regular mode" $ do - rt <- initRegularRT - res <- runFlow rt $ mainScript - res `shouldBe` "hello\n" - - it "Recorder mode" $ do - flowRuntime <- initRecorderRT - result <- runFlow flowRuntime mainScript - case _runMode flowRuntime of - T.RecordingMode T.RecorderRuntime{recording} -> do - T.ResultRecording{..} <- awaitRecording recording - V.length recording `shouldBe` 10 - Map.size forkedRecordings `shouldBe` 2 - result `shouldBe` "hello\n" - _ -> fail "wrong mode" - - it "Player mode: replaying incorrect flow returns error (main flow)" $ do - flowRuntime <- initRecorderRT - _ <- runFlow flowRuntime mainScript - case _runMode flowRuntime of - T.RecordingMode T.RecorderRuntime{recording} -> do - entries <- awaitRecording recording - playerRuntime <- initPlayerRT entries - -- TODO runFlow shoul catch all exceptions internally - _ <- try @_ @SomeException $ runFlow playerRuntime mainScriptWrong - case _runMode playerRuntime of - T.ReplayingMode T.PlayerRuntime{rerror} -> do - errors <- awaitErrors rerror - flattenErrors errors `shouldNotBe` [] - _ -> fail "wrong mode" - _ -> fail "wrong mode" - - it "Player mode: replaying incorrect flow returns error (fork flow)" $ do - flowRuntime <- initRecorderRT - _ <- runFlow flowRuntime mainScript - case _runMode flowRuntime of - T.RecordingMode T.RecorderRuntime{recording} -> do - entries <- awaitRecording recording - playerRuntime <- initPlayerRT entries - -- TODO runFlow shoul catch all exceptions internally - _ <- try @_ @SomeException $ runFlow playerRuntime mainScriptWrongFork - case _runMode playerRuntime of - T.ReplayingMode T.PlayerRuntime{rerror} -> do - errors <- awaitErrors rerror - flattenErrors errors `shouldNotBe` [] - _ -> fail "wrong mode" - _ -> fail "wrong mode" - - it "Player mode: missing fork recording returns error (fork flow)" $ do - flowRuntime <- initRecorderRT - _ <- runFlow flowRuntime mainScript - case _runMode flowRuntime of - T.RecordingMode T.RecorderRuntime{recording} -> do - entries <- awaitRecording recording - playerRuntime <- initPlayerRT $ entries {forkedRecordings = Map.empty} - -- TODO runFlow shoul catch all exceptions internally - _ <- try @_ @SomeException $ runFlow playerRuntime mainScript - case _runMode playerRuntime of - T.ReplayingMode T.PlayerRuntime{rerror} -> do - errors <- awaitErrors rerror - flattenErrors errors `shouldNotBe` [] - _ -> fail "wrong mode" - _ -> fail "wrong mode" + +module EulerHS.Tests.Framework.ArtSpec ( + -- spec + ) where + +-- import Client (getBook, getUser, port) +-- import Common (initPlayerRT, initRecorderRT, initRegularRT, +-- runFlowWithArt, withServer) +-- import qualified Data.Map as Map +-- import qualified Data.String.Conversions as Conversions +-- import qualified Data.Text as Text +-- import qualified Data.Text.Encoding as Encoding +-- import qualified Data.Text.Encoding.Error as Encoding +-- import qualified Data.UUID as UUID (toText) +-- import qualified Data.UUID.V4 as UUID (nextRandom) +-- import qualified Data.Vector as V +-- import EulerHS.Interpreters (runFlow) +-- import EulerHS.Language as L +-- import EulerHS.Prelude +-- import EulerHS.Runtime (_runMode) +-- import EulerHS.TestData.Types (TestStringKey (TestStringKey)) +-- import EulerHS.Types as T +-- import Servant.Client (BaseUrl (BaseUrl), Scheme (Http)) +-- import Servant.Server (err403, errBody) +-- import qualified System.IO.Error as Error +-- import Test.Hspec (Spec, around_, describe, it, shouldBe, shouldNotBe, +-- shouldSatisfy, xit) + +-- spec :: Spec +-- spec = do +-- describe "ART Test" $ do +-- it "Regular mode" $ do +-- rt <- initRegularRT +-- res <- runFlow rt mainScript +-- res `shouldBe` "hello\n" + +-- it "Recorder mode" $ do +-- flowRuntime <- initRecorderRT +-- result <- runFlow flowRuntime mainScript +-- case _runMode flowRuntime of +-- T.RecordingMode T.RecorderRuntime{recording} -> do +-- T.ResultRecording{..} <- awaitRecording recording +-- V.length recording `shouldBe` 10 +-- Map.size forkedRecordings `shouldBe` 2 +-- result `shouldBe` "hello\n" +-- _ -> fail "wrong mode" + +-- it "Player mode: replaying incorrect flow returns error (main flow)" $ do +-- flowRuntime <- initRecorderRT +-- _ <- runFlow flowRuntime mainScript +-- case _runMode flowRuntime of +-- T.RecordingMode T.RecorderRuntime{recording} -> do +-- entries <- awaitRecording recording +-- playerRuntime <- initPlayerRT entries +-- -- TODO runFlow shoul catch all exceptions internally +-- _ <- try @_ @SomeException $ runFlow playerRuntime mainScriptWrong +-- case _runMode playerRuntime of +-- T.ReplayingMode T.PlayerRuntime{rerror} -> do +-- errors <- awaitErrors rerror +-- flattenErrors errors `shouldNotBe` [] +-- _ -> fail "wrong mode" +-- _ -> fail "wrong mode" + +-- it "Player mode: replaying incorrect flow returns error (fork flow)" $ do +-- flowRuntime <- initRecorderRT +-- _ <- runFlow flowRuntime mainScript +-- case _runMode flowRuntime of +-- T.RecordingMode T.RecorderRuntime{recording} -> do +-- entries <- awaitRecording recording +-- playerRuntime <- initPlayerRT entries +-- -- TODO runFlow shoul catch all exceptions internally +-- _ <- try @_ @SomeException $ runFlow playerRuntime mainScriptWrongFork +-- case _runMode playerRuntime of +-- T.ReplayingMode T.PlayerRuntime{rerror} -> do +-- errors <- awaitErrors rerror +-- flattenErrors errors `shouldNotBe` [] +-- _ -> fail "wrong mode" +-- _ -> fail "wrong mode" + +-- it "Player mode: missing fork recording returns error (fork flow)" $ do +-- flowRuntime <- initRecorderRT +-- _ <- runFlow flowRuntime mainScript +-- case _runMode flowRuntime of +-- T.RecordingMode T.RecorderRuntime{recording} -> do +-- entries <- awaitRecording recording +-- playerRuntime <- initPlayerRT $ entries {forkedRecordings = Map.empty} +-- -- TODO runFlow shoul catch all exceptions internally +-- _ <- try @_ @SomeException $ runFlow playerRuntime mainScript +-- case _runMode playerRuntime of +-- T.ReplayingMode T.PlayerRuntime{rerror} -> do +-- errors <- awaitErrors rerror +-- flattenErrors errors `shouldNotBe` [] +-- _ -> fail "wrong mode" +-- _ -> fail "wrong mode" ---------------------------------------------------------------------- - it "Set/Get Option" $ do - let testOptionValue = "testOptionValue" :: String - mopt <- runFlowWithArt $ do - L.setOption TestStringKey testOptionValue - L.getOption TestStringKey - mopt `shouldBe` Just testOptionValue - - it "Generate distinct GUID" $ do - (guid1, guid2) <- runFlowWithArt $ do - guid1 <- L.generateGUID - guid2 <- L.generateGUID - pure (guid1, guid2) - guid1 `shouldNotBe` guid2 - - it "RunIO" $ do - res <- runFlowWithArt $ do - L.runIO $ pure () - res `shouldBe` () - - it "RunIO" $ do - res <- runFlowWithArt $ do - L.runIO $ pure () - res `shouldBe` () - - it "RunIO also works with Serializable types" $ do - let bs :: ByteString = "Hello" - res <- runFlowWithArt $ do - L.runIO $ pure bs - res `shouldBe` bs - - it "RunUntracedIO" $ do - res <- runFlowWithArt $ do - L.runUntracedIO $ pure () - res `shouldBe` () + -- it "Set/Get Option" $ do + -- let testOptionValue = "testOptionValue" :: String + -- mopt <- runFlowWithArt $ do + -- L.setOption TestStringKey testOptionValue + -- L.getOption TestStringKey + -- mopt `shouldBe` Just testOptionValue + + -- it "Generate distinct GUID" $ do + -- (guid1, guid2) <- runFlowWithArt $ do + -- guid1 <- L.generateGUID + -- guid2 <- L.generateGUID + -- pure (guid1, guid2) + -- guid1 `shouldNotBe` guid2 + + -- it "RunIO" $ do + -- res <- runFlowWithArt $ do + -- L.runIO $ pure () + -- res `shouldBe` () + + -- it "RunIO" $ do + -- res <- runFlowWithArt $ do + -- L.runIO $ pure () + -- res `shouldBe` () + + -- it "RunIO also works with Serializable types" $ do + -- let bs :: ByteString = "Hello" + -- res <- runFlowWithArt $ do + -- L.runIO $ pure bs + -- res `shouldBe` bs + + -- it "RunUntracedIO" $ do + -- res <- runFlowWithArt $ do + -- L.runUntracedIO $ pure () + -- res `shouldBe` () -- run an example with non-deterministic outputs - it "RunUntracedIO with UUID" $ do - runFlowWithArt $ do - L.runUntracedIO (UUID.toText <$> UUID.nextRandom) - pure () - - it "RunSysCmd" $ do - let value = "hello" - res <- runFlowWithArt $ do - L.runSysCmd $ "echo " <> value - res `shouldBe` "hello\n" - - it "Logging" $ runFlowWithArt $ do - L.logInfo "Info" "L.logInfo" - L.logError "Error" "L.logError" - L.logDebug "Debug" "L.logDebug" - L.logWarning "Warning" "L.logWarning" - - it "SafeFlow, throwException" $ do - res <- runFlowWithArt $ do - runSafeFlow $ (throwException err403 {errBody = "403"} :: Flow Text) - res `shouldBe` (Left $ show err403{errBody = "403"}) - - it "SafeFlow, RunSysCmd" $ do - res <- runFlowWithArt $ do - runSafeFlow $ L.runSysCmd $ "echo " <> "safe hello" - runSafeFlow $ L.runSysCmd $ "echo " <> "safe hello2" - res `shouldBe` (Right "safe hello2\n") - - it "Fork" $ runFlowWithArt $ do - L.forkFlow "Fork" $ - L.logInfo "Fork" "Hello" - - it "SafeFlow and Fork" $ runFlowWithArt $ do - runSafeFlow $ L.runSysCmd $ "echo " <> "safe hello" - L.forkFlow "Fork" $ - L.logInfo "Fork" "Hello" - - it "SafeFlow exception and Fork" $ runFlowWithArt $ do - runSafeFlow $ (throwException err403 {errBody = "403"} :: Flow Text) - L.forkFlow "Fork" $ - L.logInfo "Fork" "Hello" - - it "Fork by fork" $ runFlowWithArt $ do - L.forkFlow "Fork" $ - L.logInfo "Fork" "Hello" - L.forkFlow "Fork 2" $ - L.logInfo "Fork 2" "Bye" - - it "SafeFlow and Fork" $ runFlowWithArt $ do - runSafeFlow $ L.runSysCmd $ "echo " <> "safe hello" - L.forkFlow "Fork" $ - L.logInfo "Fork" "Hello" - - it "Fork and flow from SafeFlow" $ do - res <- runFlowWithArt $ do - runSafeFlow $ do - L.runSysCmd $ "echo " <> "safe hello" - L.forkFlow "Fork" $ - L.logInfo "Fork" "Hello" - res `shouldBe` (Right ()) - - it "Flow and fork from SafeFlow" $ do - res <- runFlowWithArt $ do - runSafeFlow $ do - L.forkFlow "Fork" $ - L.logInfo "Fork" "Hello" - L.runSysCmd $ "echo " <> "safe hello" - res `shouldBe` (Right "safe hello\n") - - it "Fork from Fork" $ runFlowWithArt $ do - L.forkFlow "ForkOne" $ do - L.logInfo "ForkOne" "Hello" - L.forkFlow "ForkTwo" $ - L.forkFlow "ForkThree" $ do - L.forkFlow "ForkFour" $ - L.logInfo "ForkFour" "Hello" - - it "Fork and safeFlow from Fork" $ runFlowWithArt $ do - L.forkFlow "ForkOne" $ do - L.logInfo "ForkOne" "Hello" - runSafeFlow $ L.runSysCmd $ "echo " <> "safe hello" - L.forkFlow "ForkTwo" $ - L.forkFlow "ForkThree" $ do - L.forkFlow "ForkFour" $ - L.logInfo "ForkFour" "Hello" - - around_ withServer $ do - describe "CallServantAPI tests" $ do - it "Simple request (book)" $ do - let url = BaseUrl Http "127.0.0.1" port "" - bookEither <- runFlowWithArt $ callServantAPI Nothing url getBook - bookEither `shouldSatisfy` isRight - - it "Simple request (user)" $ do - let url = BaseUrl Http "127.0.0.1" port "" - userEither <- runFlowWithArt $ callServantAPI Nothing url getUser - userEither `shouldSatisfy` isRight - - xit "Untyped HTTP API Calls" $ do - let url = "https://google.com" - (statusCode, status, body, headers) <- runFlowWithArt $ do - eResponse <- L.callHTTP $ T.httpGet "https://google.com" :: Flow (Either Text T.HTTPResponse) - response <- case eResponse of - Left err -> throwException err403 {errBody = "Expected a response"} - Right response -> pure response - return - ( getResponseCode response - , getResponseStatus response - , getResponseBody response - , getResponseHeaders response - ) - -- check status code - statusCode `shouldBe` 200 - status `shouldBe` "OK" - -- check body - -- Lazy.putStr (getLBinaryString body) - -- seem to be non-breaking latin-1 encoded spaces in what is supposed to - -- be a UTF-8 output xD; show some leniency - let - body' = - Encoding.decodeUtf8With - Encoding.lenientDecode - (Conversions.convertString body) - Text.isInfixOf "google" body' `shouldBe` True - Text.isInfixOf " - throwM $ Error.userError "Expected a Content-Type header" - Just headerValue -> do - Text.isInfixOf "text/html" headerValue `shouldBe` True - - xit "Untyped HTTP API Calls" $ do - let url = "https://127.0.0.1:666/fourohhhfour" - result <- runFlowWithArt $ do - L.callHTTP $ T.httpGet url :: Flow (Either Text T.HTTPResponse) - - err <- extractLeft result - -- putStrLn $ "ERROR" <> err - pure () - - -extractLeft :: Either a b -> IO a -extractLeft eitherVal = - case eitherVal of - Left val -> - pure val - Right res -> - throwM $ Error.userError "Expected Left from erroneous call!" - -mainScript :: Flow String -mainScript = do - guid1 <- generateGUID - guid2 <- generateGUID - -- This should re-execute each time and not break replay - runUntracedIO (UUID.toText <$> UUID.nextRandom) - forkFlow guid1 (void forkScript) - forkFlow guid2 (void forkScript) - runSysCmd "echo hello" - -mainScriptWrong :: Flow String -mainScriptWrong = do - guid1 <- generateGUID - forkFlow guid1 (void forkScript) - runSysCmd "echo hello" - -mainScriptWrongFork :: Flow String -mainScriptWrongFork = do - guid1 <- generateGUID - guid2 <- generateGUID - forkFlow guid1 (void forkScript) - forkFlow guid2 (void forkScriptWrong) - runSysCmd "echo hello" - -forkScript :: Flow String -forkScript = do - _ <- generateGUID - runSysCmd "echo hello" - -forkScriptWrong :: Flow String -forkScriptWrong = do - runSysCmd "echo hello" +-- it "RunUntracedIO with UUID" $ do +-- runFlowWithArt $ do +-- _ <- L.runUntracedIO (UUID.toText <$> UUID.nextRandom) +-- pure () + +-- it "RunSysCmd" $ do +-- let value = "hello" +-- res <- runFlowWithArt $ do +-- L.runSysCmd $ "echo " <> value +-- res `shouldBe` "hello\n" + +-- it "Logging" $ runFlowWithArt $ do +-- L.logInfo @Text "Info" "L.logInfo" +-- L.logError @Text "Error" "L.logError" +-- L.logDebug @Text "Debug" "L.logDebug" +-- L.logWarning @Text "Warning" "L.logWarning" + +-- it "SafeFlow, throwException" $ do +-- res <- runFlowWithArt $ do +-- runSafeFlow (throwException err403 {errBody = "403"} :: Flow Text) +-- res `shouldBe` Left (show err403{errBody = "403"}) + +-- it "SafeFlow, RunSysCmd" $ do +-- res <- runFlowWithArt $ do +-- _ <- runSafeFlow $ L.runSysCmd $ "echo " <> "safe hello" +-- runSafeFlow $ L.runSysCmd $ "echo " <> "safe hello2" +-- res `shouldBe` Right "safe hello2\n" + +-- it "Fork" $ runFlowWithArt $ do +-- L.forkFlow "Fork" $ +-- L.logInfo @Text "Fork" "Hello" + +-- it "SafeFlow and Fork" $ runFlowWithArt $ do +-- _ <- runSafeFlow $ L.runSysCmd $ "echo " <> "safe hello" +-- L.forkFlow "Fork" $ +-- L.logInfo @Text "Fork" "Hello" + +-- it "SafeFlow exception and Fork" $ runFlowWithArt $ do +-- _ <- runSafeFlow (throwException err403 {errBody = "403"} :: Flow Text) +-- L.forkFlow "Fork" $ +-- L.logInfo @Text "Fork" "Hello" + +-- it "Fork by fork" $ runFlowWithArt $ do +-- L.forkFlow "Fork" $ +-- L.logInfo @Text "Fork" "Hello" +-- L.forkFlow "Fork 2" $ +-- L.logInfo @Text "Fork 2" "Bye" + +-- it "SafeFlow and Fork" $ runFlowWithArt $ do +-- _ <- runSafeFlow $ L.runSysCmd $ "echo " <> "safe hello" +-- L.forkFlow "Fork" $ +-- L.logInfo @Text "Fork" "Hello" + +-- it "Fork and flow from SafeFlow" $ do +-- res <- runFlowWithArt $ do +-- runSafeFlow $ do +-- _ <- L.runSysCmd $ "echo " <> "safe hello" +-- L.forkFlow "Fork" $ +-- L.logInfo @Text "Fork" "Hello" +-- res `shouldBe` Right () + +-- it "Flow and fork from SafeFlow" $ do +-- res <- runFlowWithArt $ do +-- runSafeFlow $ do +-- L.forkFlow "Fork" $ +-- L.logInfo @Text "Fork" "Hello" +-- L.runSysCmd $ "echo " <> "safe hello" +-- res `shouldBe` Right "safe hello\n" + +-- it "Fork from Fork" $ runFlowWithArt $ do +-- L.forkFlow "ForkOne" $ do +-- L.logInfo @Text "ForkOne" "Hello" +-- L.forkFlow "ForkTwo" $ +-- L.forkFlow "ForkThree" $ do +-- L.forkFlow "ForkFour" $ +-- L.logInfo @Text "ForkFour" "Hello" + +-- it "Fork and safeFlow from Fork" $ runFlowWithArt $ do +-- L.forkFlow "ForkOne" $ do +-- L.logInfo @Text "ForkOne" "Hello" +-- _ <- runSafeFlow $ L.runSysCmd $ "echo " <> "safe hello" +-- L.forkFlow "ForkTwo" $ +-- L.forkFlow "ForkThree" $ do +-- L.forkFlow "ForkFour" $ +-- L.logInfo @Text "ForkFour" "Hello" + +-- around_ withServer $ do +-- describe "CallServantAPI tests" $ do +-- it "Simple request (book)" $ do +-- let url = BaseUrl Http "127.0.0.1" port "" +-- bookEither <- runFlowWithArt $ callServantAPI Nothing url getBook +-- bookEither `shouldSatisfy` isRight + +-- it "Simple request (user)" $ do +-- let url = BaseUrl Http "127.0.0.1" port "" +-- userEither <- runFlowWithArt $ callServantAPI Nothing url getUser +-- userEither `shouldSatisfy` isRight + +-- xit "Untyped HTTP API Calls" $ do +-- (statusCode, status, body, headers) <- runFlowWithArt $ do +-- eResponse <- L.callHTTP $ T.httpGet "https://google.com" :: Flow (Either Text T.HTTPResponse) +-- response <- case eResponse of +-- Left _ -> throwException err403 {errBody = "Expected a response"} +-- Right response -> pure response +-- return +-- ( getResponseCode response +-- , getResponseStatus response +-- , getResponseBody response +-- , getResponseHeaders response +-- ) +-- -- check status code +-- statusCode `shouldBe` 200 +-- status `shouldBe` "OK" +-- -- check body +-- -- Lazy.putStr (getLBinaryString body) +-- -- seem to be non-breaking latin-1 encoded spaces in what is supposed to +-- -- be a UTF-8 output xD; show some leniency +-- let +-- body' = +-- Encoding.decodeUtf8With +-- Encoding.lenientDecode +-- (Conversions.convertString body) +-- Text.isInfixOf "google" body' `shouldBe` True +-- Text.isInfixOf " +-- throwM $ Error.userError "Expected a Content-Type header" +-- Just headerValue -> do +-- Text.isInfixOf "text/html" headerValue `shouldBe` True + +-- xit "Untyped HTTP API Calls" $ do +-- let url = "https://127.0.0.1:666/fourohhhfour" +-- result <- runFlowWithArt $ do +-- L.callHTTP $ T.httpGet url :: Flow (Either Text T.HTTPResponse) + +-- _ <- extractLeft result +-- -- putStrLn $ "ERROR" <> err +-- pure () + + +-- extractLeft :: Either a b -> IO a +-- extractLeft eitherVal = +-- case eitherVal of +-- Left val -> pure val +-- Right _ -> throwM $ Error.userError "Expected Left from erroneous call!" + +-- mainScript :: Flow String +-- mainScript = do +-- guid1 <- generateGUID +-- guid2 <- generateGUID +-- -- This should re-execute each time and not break replay +-- _ <- runUntracedIO (UUID.toText <$> UUID.nextRandom) +-- forkFlow guid1 (void forkScript) +-- forkFlow guid2 (void forkScript) +-- runSysCmd "echo hello" + +-- mainScriptWrong :: Flow String +-- mainScriptWrong = do +-- guid1 <- generateGUID +-- forkFlow guid1 (void forkScript) +-- runSysCmd "echo hello" + +-- mainScriptWrongFork :: Flow String +-- mainScriptWrongFork = do +-- guid1 <- generateGUID +-- guid2 <- generateGUID +-- forkFlow guid1 (void forkScript) +-- forkFlow guid2 (void forkScriptWrong) +-- runSysCmd "echo hello" + +-- forkScript :: Flow String +-- forkScript = do +-- _ <- generateGUID +-- runSysCmd "echo hello" + +-- forkScriptWrong :: Flow String +-- forkScriptWrong = do +-- runSysCmd "echo hello" diff --git a/test/EulerHS/Tests/Framework/CachedDBSpec.hs b/test/EulerHS/Tests/Framework/CachedDBSpec.hs new file mode 100644 index 00000000..fbd3348e --- /dev/null +++ b/test/EulerHS/Tests/Framework/CachedDBSpec.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} + +module EulerHS.Tests.Framework.CachedDBSpec where + +-- import Common +import EulerHS.Tests.Framework.DBSetup +import EulerHS.Tests.Framework.DBSetup as DBS +-- import Data.Aeson as A +-- import Data.Aeson.Encode.Pretty +import qualified Database.Beam as B +-- import qualified Database.Beam.Backend.SQL as B +-- import qualified Database.Beam.Query as B +-- import Database.Beam.Sqlite.Connection (Sqlite, SqliteM) +import EulerHS.CachedSqlDBQuery +import EulerHS.Interpreters as I +import EulerHS.Language as L +import EulerHS.Prelude +-- import EulerHS.Runtime +import EulerHS.Types as T +-- import Named +import Sequelize +-- import System.Process +import Test.Hspec + + +redisCfg = T.mkKVDBConfig "eulerKVDB" T.defaultKVDBConnConfig + +spec :: Spec +spec = do + around (withEmptyDB) $ + + describe "Cached sequelize layer" $ do + + it "findOne returns Nothing for empty table" $ \rt -> do + let testKey = "key1" + res <- runFlow rt $ do + _ <- L.initKVDBConnection redisCfg + findOne sqliteCfg (Just testKey) [] + (res :: Either DBError (Maybe User)) `shouldBe` Right Nothing + + it "findOne returns first row from table" $ \rt -> do + let testKey = "key2" + res <- runFlow rt $ do + _ <- L.initKVDBConnection redisCfg + conn <- connectOrFail sqliteCfg + L.runDB conn $ L.insertRows $ + B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates"] + findOne sqliteCfg (Just testKey) [] + res `shouldBe` Right (Just (User 1 "Bill" "Gates")) + + it "findOne successfully reads `Nothing` from cache" $ \rt -> do + let testKey = "key3" + -- Test with `Nothing` + res <- runFlow rt $ do + _ <- L.initKVDBConnection redisCfg + -- This read should write `Nothing` to the cache + _ <- findOne sqliteCfg (Just testKey) [] + :: Flow (Either DBError (Maybe User)) + -- Read `Nothing` from the cache + findOne sqliteCfg (Just testKey) [] + (res :: Either DBError (Maybe User)) `shouldBe` Right Nothing + -- Also test with a value (Just ...) + + it "findOne reads (Just result) from cache" $ \rt -> do + let testKey = "key4" + res <- runFlow rt $ do + _ <- L.initKVDBConnection redisCfg + conn <- connectOrFail sqliteCfg + L.runDB conn $ L.insertRows $ + B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates"] + _ <- findOne sqliteCfg (Just testKey) [] + :: Flow (Either DBError (Maybe User)) + -- Delete value to ensure the cache is used + L.runDB conn $ L.deleteRows $ + B.delete (users userDB) (\u -> _userGUID u B.==. 1) + findOne sqliteCfg (Just testKey) [] + res `shouldBe` Right (Just (User 1 "Bill" "Gates")) + + it "findAll finds all values in the database" $ \rt -> do + let testKey = "key5" + res <- runFlow rt $ do + redisConn <- L.initKVDBConnection redisCfg + conn <- connectOrFail sqliteCfg + L.runDB conn $ L.insertRows $ + B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates"] + L.runDB conn $ L.insertRows $ + B.insert (users userDB) $ B.insertValues [User 2 "Steve" "Jobs"] + _ <- findAll sqliteCfg (Just testKey) [] + :: Flow (Either DBError [User]) + findAll sqliteCfg (Just testKey) [] + res `shouldSatisfy` \case + Right xs -> User 1 "Bill" "Gates" `elem` xs + && User 2 "Steve" "Jobs" `elem` xs + Left _ -> False + + it "findAll successfully reads `[]` from cache" $ \rt -> do + let testKey = "key6" + res <- runFlow rt $ do + _ <- L.initKVDBConnection redisCfg + -- This read should write `Nothing` to the cache + _ <- findAll sqliteCfg (Just testKey) [] + :: Flow (Either DBError [User]) + -- Read `Nothing` from the cache + findAll sqliteCfg (Just testKey) [] + (res :: Either DBError [User]) `shouldBe` Right [] + -- Also test with a value (Just ...) + + it "findAll reads nonempty list from cache after writing to it" $ \rt -> do + let testKey = "key7" + res <- runFlow rt $ do + _ <- L.initKVDBConnection redisCfg + conn <- connectOrFail sqliteCfg + L.runDB conn $ L.insertRows $ + B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates"] + L.runDB conn $ L.insertRows $ + B.insert (users userDB) $ B.insertValues [User 2 "Steve" "Jobs"] + something <- findAll sqliteCfg (Just testKey) [] + :: Flow (Either DBError [User]) + -- Delete everything to ensure the cache is used + L.runDB conn $ L.deleteRows $ + B.delete (users userDB) (\u -> _userGUID u B.<. 3) + findAll sqliteCfg (Just testKey) [] + res `shouldSatisfy` \case + Right xs -> User 1 "Bill" "Gates" `elem` xs + && User 2 "Steve" "Jobs" `elem` xs + Left _ -> False + + it "create inserts into the DB" $ \rt -> do + let user = User 10 "Alonzo" "Church" + res <- runFlow rt $ do + _ <- initKVDBConnection redisCfg + create sqliteCfg user Nothing + findOne sqliteCfg Nothing [] + res `shouldBe` Right (Just user) + + it "create writes to the cache and findOne can read it" $ \rt -> do + let testKey = "key8" + let user = User 10 "Alan" "Turing" + res <- runFlow rt $ do + _ <- initKVDBConnection redisCfg + conn <- connectOrFail sqliteCfg + create sqliteCfg user (Just testKey) + -- Delete from DB to ensure the cache is used + L.runDB conn $ L.deleteRows $ + B.delete (users userDB) (\u -> _userGUID u B.==. 10) + findOne sqliteCfg (Just testKey) [] + res `shouldBe` Right (Just user) + + it "updateOne updates the DB" $ \rt -> do + let user1 :: User = User 10 "Alan" "Turing" + let user2 :: User = User 11 "Kurt" "Goedel" + res <- runFlow rt $ do + _ <- initKVDBConnection redisCfg + create sqliteCfg user1 Nothing + updateOne sqliteCfg Nothing [Sequelize.Set DBS._firstName "Kurt"] [Is _userGUID (Eq 10)] + findOne sqliteCfg Nothing [] + res `shouldBe` Right (Just user1 {DBS._firstName = "Kurt"}) + + it "updateOne updates the cache" $ \rt -> do + let user1 :: User = User 10 "Alan" "Turing" + let user2 :: User = User 11 "Kurt" "Goedel" + let testKey = "key9" + res <- runFlow rt $ do + _ <- initKVDBConnection redisCfg + conn <- connectOrFail sqliteCfg + create sqliteCfg user1 (Just testKey) + updateOne sqliteCfg (Just testKey) [Sequelize.Set DBS._firstName "Kurt"] [Is _userGUID (Eq 10)] + -- Delete from DB to ensure the cache is used + L.runDB conn $ L.deleteRows $ + B.delete (users userDB) (\u -> _userGUID u B.==. 10) + findOne sqliteCfg (Just testKey) [] + res `shouldBe` Right (Just user1 {DBS._firstName = "Kurt"}) diff --git a/test/EulerHS/Tests/Framework/Common.hs b/test/EulerHS/Tests/Framework/Common.hs index 00071773..453f9a96 100644 --- a/test/EulerHS/Tests/Framework/Common.hs +++ b/test/EulerHS/Tests/Framework/Common.hs @@ -1,68 +1,65 @@ -module EulerHS.Tests.Framework.Common where - -import Data.Aeson +{-# OPTIONS_GHC -Werror #-} + +module EulerHS.Tests.Framework.Common + ( + withServer, + initRTWithManagers + -- runFlowWithArt, initPlayerRT, initRecorderRT, initRegularRT, + -- withServer, runFlowRecording, initRTWithManagers, replayRecording, + -- emptyMVarWithWatchDog + ) where + +import EulerHS.TestData.API.Client (api, port, server) +import Control.Concurrent.Async (withAsync) import qualified Data.Map as Map -import qualified Data.Vector as V +-- import qualified Data.Vector as V +-- import EulerHS.Interpreters (runFlow) +-- import EulerHS.Language as L +import EulerHS.Prelude +import EulerHS.Runtime (FlowRuntime, _httpClientManagers, + withFlowRuntime) +-- import EulerHS.Types as T import Network.HTTP.Client (newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) -import Network.Wai.Handler.Warp -import Servant.Server -import Test.Hspec - -import Control.Concurrent.MVar (modifyMVar_) -import Database.Redis (ConnectInfo, checkedConnect) -import EulerHS.Interpreters -import EulerHS.Language as L -import EulerHS.Prelude -import EulerHS.Runtime -import EulerHS.TestData.API.Client -import EulerHS.Types as T - - -runFlowWithArt :: (Show b, Eq b) => Flow b -> IO b -runFlowWithArt flow = do - (recording, recResult) <- runFlowRecording ($) flow - (errors , repResult) <- runFlowReplaying recording flow - -- print $ encode $ recording - -- putStrLn $ encodePretty $ recording - flattenErrors errors `shouldBe` [] - recResult `shouldBe` repResult - pure recResult - -runFlowRecording :: (forall b . (FlowRuntime -> IO b) -> FlowRuntime -> IO b) -> Flow a -> IO (ResultRecording, a) -runFlowRecording mode flow = do - let next flowRuntime = do - result <- runFlow flowRuntime flow - case _runMode flowRuntime of - T.RecordingMode T.RecorderRuntime{recording} -> do - entries <- awaitRecording recording - pure (entries, result) - _ -> fail "wrong mode" - - initRecorderRT >>= mode next - -runFlowReplaying :: ResultRecording -> Flow a -> IO (ResultReplayError, a) -runFlowReplaying recording flow = do - playerRuntime <- initPlayerRT recording - result <- runFlow playerRuntime flow - case _runMode playerRuntime of - T.ReplayingMode T.PlayerRuntime{rerror} -> do - errors <- awaitErrors rerror - pure (errors, result) - _ -> fail "wrong mode" +import Network.Wai.Handler.Warp (run) +import Servant.Server (serve) +-- import Test.Hspec (shouldBe) + +-- runFlowWithArt :: (Show b, Eq b) => Flow b -> IO b +-- runFlowWithArt flow = do +-- (recording, recResult) <- runFlowRecording ($) flow +-- (errors , repResult) <- runFlowReplaying recording flow +-- flattenErrors errors `shouldBe` [] +-- recResult `shouldBe` repResult +-- pure recResult + +-- runFlowRecording :: +-- (forall b . (FlowRuntime -> IO b) -> FlowRuntime -> IO b) -> +-- Flow a -> +-- IO (ResultRecording, a) +-- runFlowRecording mod' flow = do +-- let next flowRuntime = do +-- result <- runFlow flowRuntime flow +-- case _runMode flowRuntime of +-- T.RecordingMode T.RecorderRuntime{recording} -> do +-- entries <- awaitRecording recording +-- pure (entries, result) +-- _ -> fail "wrong mode" +-- initRecorderRT >>= mod' next + +-- runFlowReplaying :: ResultRecording -> Flow a -> IO (ResultReplayError, a) +-- runFlowReplaying recording flow = do +-- playerRuntime <- initPlayerRT recording +-- result <- runFlow playerRuntime flow +-- case _runMode playerRuntime of +-- T.ReplayingMode T.PlayerRuntime{rerror} -> do +-- errors <- awaitErrors rerror +-- pure (errors, result) +-- _ -> fail "wrong mode" withServer :: IO () -> IO () -withServer action = do - serverStartupLock <- newEmptyMVar - - let - settings = setBeforeMainLoop (putMVar serverStartupLock ()) $ - setPort port defaultSettings - - threadId <- forkIO $ runSettings settings $ serve api server - readMVar serverStartupLock - action - killThread threadId +withServer action = withAsync (run port . serve api $ server) + (const action) initRTWithManagers :: IO FlowRuntime initRTWithManagers = do @@ -75,102 +72,80 @@ initRTWithManagers = do ] pure $ flowRt { _httpClientManagers = managersMap } -initRegularRT :: IO FlowRuntime -initRegularRT = do - flowRt <- withFlowRuntime Nothing pure - pure $ flowRt { _runMode = T.RegularMode } - -initRecorderRT :: IO FlowRuntime -initRecorderRT = do - recMVar <- newMVar V.empty - safeRecMVar <- newMVar Map.empty - forkedRecMVar <- newMVar Map.empty - let - recorderRuntime = T.RecorderRuntime - { flowGUID = "testFlow" - , recording = T.Recording recMVar safeRecMVar forkedRecMVar - , disableEntries = [] - } - flowRuntime <- withFlowRuntime Nothing pure - pure $ flowRuntime { _runMode = T.RecordingMode recorderRuntime } - - -initPlayerRT :: ResultRecording -> IO FlowRuntime -initPlayerRT recEntries = do - step <- newMVar 0 - freshReplayErrors <- T.ReplayErrors <$> newMVar Nothing <*> newMVar Map.empty <*> newMVar Map.empty - - let - playerRuntime = T.PlayerRuntime - { resRecording = recEntries - , stepMVar = step - , rerror = freshReplayErrors - , disableVerify = [] - , disableMocking = [] - , skipEntries = [] - , entriesFiltered = False - , flowGUID = "testFlow" - } - - flowRuntime <- withFlowRuntime Nothing pure - pure $ flowRuntime { _runMode = T.ReplayingMode playerRuntime } - -replayRecording :: ResultRecording -> Flow a -> IO a -replayRecording rec flow = do - (errors, result) <- runFlowReplaying rec flow - flattenErrors errors `shouldBe` [] - pure result - --- TODO: This should not take a dummy argument! --- prints replay in JSON format to console -runWithRedisConn :: ConnectInfo -> a -> Flow b -> IO b -runWithRedisConn connectInfo _ flow = do - (recording, recResult) <- runFlowRecording withInitRedis flow - print $ encode $ recording - -- putStrLn $ encodePretty $ recording - pure recResult - where - withInitRedis :: (FlowRuntime -> IO c) -> FlowRuntime -> IO c - withInitRedis next _rt = do - realRedisConnection <- checkedConnect connectInfo - let rt = _rt { _pubSubConnection = Just $ realRedisConnection } - - cancelWorker <- runPubSubWorker rt (const $ pure ()) - - modifyMVar_ (_kvdbConnections rt) $ - pure . Map.insert "redis" (NativeKVDB realRedisConnection) - - res <- next rt - cancelWorker - pure res - - -emptyMVarWithWatchDog :: Int -> IO (MVar a, IO (Maybe a), IO ()) -emptyMVarWithWatchDog t = do - guard $ t >= 0 - targetMVar <- newEmptyMVar - finalMVar <- newEmptyMVar - let watch = forkIO $ do - let loop n = do - mresult <- tryTakeMVar targetMVar - - case mresult of - Just a -> do - putMVar targetMVar a - putMVar finalMVar $ Just a - - Nothing -> do - if n > 0 - then do - threadDelay $ 10 ^ (5 :: Integer) - loop $ n - 1 - - else putMVar finalMVar Nothing - - - loop $ t * 10 - - let reset = void $ tryTakeMVar targetMVar - - - pure (targetMVar, watch >> takeMVar finalMVar, reset) +-- initRegularRT :: IO FlowRuntime +-- initRegularRT = do +-- flowRt <- withFlowRuntime Nothing pure +-- pure $ flowRt { _runMode = T.RegularMode } + +-- initRecorderRT :: IO FlowRuntime +-- initRecorderRT = do +-- recMVar <- newMVar V.empty +-- safeRecMVar <- newMVar Map.empty +-- forkedRecMVar <- newMVar Map.empty +-- let +-- recorderRuntime = T.RecorderRuntime +-- { flowGUID = "testFlow" +-- , recording = T.Recording recMVar safeRecMVar forkedRecMVar +-- , disableEntries = [] +-- } +-- flowRuntime <- withFlowRuntime Nothing pure +-- pure $ flowRuntime { _runMode = T.RecordingMode recorderRuntime } + + +-- initPlayerRT :: ResultRecording -> IO FlowRuntime +-- initPlayerRT recEntries = do +-- step <- newMVar 0 +-- freshReplayErrors <- T.ReplayErrors <$> newMVar Nothing <*> newMVar Map.empty <*> newMVar Map.empty + +-- let +-- playerRuntime = T.PlayerRuntime +-- { resRecording = recEntries +-- , stepMVar = step +-- , rerror = freshReplayErrors +-- , disableVerify = [] +-- , disableMocking = [] +-- , skipEntries = [] +-- , entriesFiltered = False +-- , flowGUID = "testFlow" +-- } + +-- flowRuntime <- withFlowRuntime Nothing pure +-- pure $ flowRuntime { _runMode = T.ReplayingMode playerRuntime } + +-- replayRecording :: ResultRecording -> Flow a -> IO a +-- replayRecording rec flow = do +-- (errors, result) <- runFlowReplaying rec flow +-- flattenErrors errors `shouldBe` [] +-- pure result + +-- emptyMVarWithWatchDog :: Int -> IO (MVar a, IO (Maybe a), IO ()) +-- emptyMVarWithWatchDog t = do +-- guard $ t >= 0 +-- targetMVar <- newEmptyMVar +-- finalMVar <- newEmptyMVar +-- let watch = forkIO $ do +-- let loop n = do +-- mresult <- tryTakeMVar targetMVar + +-- case mresult of +-- Just a -> do +-- putMVar targetMVar a +-- putMVar finalMVar $ Just a + +-- Nothing -> do +-- if n > 0 +-- then do +-- threadDelay 100000 +-- loop $ n - 1 + +-- else putMVar finalMVar Nothing + + +-- loop $ t * 10 + +-- let reset = void $ tryTakeMVar targetMVar + + +-- pure (targetMVar, watch >> takeMVar finalMVar, reset) + + diff --git a/test/EulerHS/Tests/Framework/DBSetup.hs b/test/EulerHS/Tests/Framework/DBSetup.hs index 0fe75a88..9ea2e77b 100644 --- a/test/EulerHS/Tests/Framework/DBSetup.hs +++ b/test/EulerHS/Tests/Framework/DBSetup.hs @@ -3,19 +3,21 @@ module EulerHS.Tests.Framework.DBSetup where +-- import Common (runFlowRecording) import Data.Aeson as A -import Data.Aeson.Encode.Pretty +-- import Data.Aeson.Encode.Pretty import qualified Database.Beam as B -import qualified Database.Beam.Backend.SQL as B -import qualified Database.Beam.Query as B +-- import qualified Database.Beam.Backend.SQL as B +-- import qualified Database.Beam.Query as B import Database.Beam.Sqlite.Connection (Sqlite, SqliteM) - -import EulerHS.Interpreters as I -import EulerHS.Language as L -import EulerHS.Prelude -import EulerHS.Runtime -import EulerHS.Tests.Framework.Common -import EulerHS.Types as T +-- import EulerHS.CachedSqlDBQuery +import EulerHS.Interpreters as I +import EulerHS.Language as L +import EulerHS.Prelude +import EulerHS.Runtime +import EulerHS.Types as T +-- import Named +import Sequelize -- TODO: Refactor the helper db functionskA @@ -32,6 +34,10 @@ instance B.Table UserT where UserId (B.C f Int) deriving (Generic, B.Beamable) primaryKey = UserId . _userGUID +instance ModelMeta UserT where + modelFieldModification = userTMod + modelTableName = "users" + type User = UserT Identity type UserId = B.PrimaryKey UserT Identity @@ -56,7 +62,7 @@ userTMod = userEMod :: B.EntityModification (B.DatabaseEntity be db) be (B.TableEntity UserT) userEMod = B.modifyTableFields userTMod -data UserDB f = UserDB +newtype UserDB f = UserDB { users :: f (B.TableEntity UserT) } deriving (Generic, B.Database be) @@ -91,7 +97,6 @@ prepareTestDB = do rmTestDB -- L.runSysCmd "pwd" >>= L.runIO . print void $ L.runSysCmd $ "cp " <> testDBTemplateName <> " " <> testDBName - pure () withEmptyDB :: (FlowRuntime -> IO ()) -> IO () withEmptyDB act = withFlowRuntime Nothing (\rt -> do @@ -104,15 +109,15 @@ withEmptyDB act = withFlowRuntime Nothing (\rt -> do -- Prepare record log and test returns connectOrFail :: T.DBConfig beM -> Flow (T.SqlConn beM) -connectOrFail cfg = L.getOrInitSqlConnection cfg >>= \case +connectOrFail cfg = L.getOrInitSqlConn cfg >>= \case Left e -> error $ show e Right conn -> pure conn -runWithSQLConn :: (Show b, Eq b) => Flow b -> IO b -runWithSQLConn flow = do - (recording, recResult) <- runFlowRecording ($) flow - -- putStrLn $ encodePretty $ recording - print $ encode recording - -- writeFile "recorded" $ show $ encode $ recording - -- print recResult - pure recResult +-- runWithSQLConn :: (Show b, Eq b) => Flow b -> IO b +-- runWithSQLConn flow = do +-- (recording, recResult) <- runFlowRecording ($) flow +-- -- putStrLn $ encodePretty $ recording +-- print $ encode recording +-- -- writeFile "recorded" $ show $ encode $ recording +-- -- print recResult +-- pure recResult diff --git a/test/EulerHS/Tests/Framework/FlowSpec.hs b/test/EulerHS/Tests/Framework/FlowSpec.hs index 3b04d398..b48e626d 100644 --- a/test/EulerHS/Tests/Framework/FlowSpec.hs +++ b/test/EulerHS/Tests/Framework/FlowSpec.hs @@ -1,118 +1,103 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# OPTIONS_GHC -Werror #-} -module EulerHS.Tests.Framework.FlowSpec where +module EulerHS.Tests.Framework.FlowSpec (spec) where +import EulerHS.TestData.API.Client (User (User), getBook, getUser, port) +import EulerHS.Tests.Framework.Common (initRTWithManagers, withServer) import qualified Control.Exception as E -import Control.Monad (void) -import Data.Aeson (encode) -import qualified Data.ByteString.Lazy as BSL import qualified Data.UUID as UUID (fromText) -import EulerHS.Interpreters +import EulerHS.Interpreters (runFlow) import EulerHS.Language as L import EulerHS.Prelude hiding (get, getOption) import EulerHS.Runtime (withFlowRuntime, createLoggerRuntime) -import EulerHS.TestData.API.Client -import EulerHS.TestData.Scenarios.Scenario1 (testScenario1) -import EulerHS.TestData.Types +import EulerHS.TestData.Types (NTTestKeyWithIntPayload (NTTestKeyWithIntPayload), + NTTestKeyWithIntPayloadAnotherEnc (NTTestKeyWithIntPayloadAnotherEnc), + NTTestKeyWithStringPayload (NTTestKeyWithStringPayload), + NTTestKeyWithStringPayloadAnotherEnc (NTTestKeyWithStringPayloadAnotherEnc), + TestIntKey (TestIntKey), + TestIntKey2 (TestIntKey2), + TestKVals (TestKVals), + TestKeyWithIntPayload (TestKeyWithIntPayload), + TestKeyWithIntPayloadAnotherEnc (TestKeyWithIntPayloadAnotherEnc), + TestKeyWithStringPayload (TestKeyWithStringPayload), + TestKeyWithStringPayloadAnotherEnc (TestKeyWithStringPayloadAnotherEnc), + TestStringKey (TestStringKey), + TestStringKey2 (TestStringKey2), + TestStringKey2AnotherEnc (TestStringKey2AnotherEnc), + TestStringKeyAnotherEnc (TestStringKeyAnotherEnc), + mbNTTestKeyWithIntPayloadAnotherEncS1, + mbNTTestKeyWithIntPayloadAnotherEncS2, + mbNTTestKeyWithIntPayloadS1, + mbNTTestKeyWithIntPayloadS2, + mbNTTestKeyWithStringPayloadAnotherEncS1, + mbNTTestKeyWithStringPayloadAnotherEncS2, + mbNTTestKeyWithStringPayloadS1, + mbNTTestKeyWithStringPayloadS2, + mbTestIntKey, mbTestIntKey2, + mbTestKeyWithIntPayloadAnotherEncS1, + mbTestKeyWithIntPayloadAnotherEncS2, + mbTestKeyWithIntPayloadS1, + mbTestKeyWithIntPayloadS2, + mbTestKeyWithStringPayloadAnotherEncS1, + mbTestKeyWithStringPayloadAnotherEncS2, + mbTestKeyWithStringPayloadS1, + mbTestKeyWithStringPayloadS2, + mbTestStringKey, mbTestStringKey2, + mbTestStringKey2AnotherEnc, + mbTestStringKeyAnotherEnc) import EulerHS.Testing.Flow.Interpreter (runFlowWithTestInterpreter) import EulerHS.Testing.Types (FlowMockedValues' (..)) -import EulerHS.Tests.Framework.Common (initRTWithManagers) -import EulerHS.Types (HttpManagerNotFound (..)) +import EulerHS.Types (HttpManagerNotFound (..), defaultFlowFormatter) import qualified EulerHS.Types as T -import Network.Wai.Handler.Warp +import EulerHS.TestData.Scenarios.Scenario1 (testScenario1) import Servant.Client (BaseUrl (..), ClientError (..), Scheme (..)) -import Servant.Server -import Test.Hspec hiding (runIO) -import Unsafe.Coerce - - -user :: Any -user = unsafeCoerce $ Right $ User "John" "Snow" "00000000-0000-0000-0000-000000000000" - -localGUID :: Any -localGUID = unsafeCoerce ("FFFFFFFF-FFFF-FFFF-FFFF-FFFFFFFFFFFF" :: String) - -lhost :: BSL.ByteString -lhost = encode ("127.0.0.1" :: String) - - -scenario1MockedValues :: FlowMockedValues' -scenario1MockedValues = FlowMockedValues' - { mockedCallServantAPI = [user] - , mockedRunIO = [localGUID] - , mockedGetOption = [lhost] - , mockedGenerateGUID = ["00000000-0000-0000-0000-000000000000"] - , mockedRunSysCmd = ["Neo"] - } - -ioActWithException :: IO Text -ioActWithException = do - E.throw (E.AssertionFailed "Exception from IO") - pure "Text from IO" - -withServer :: IO () -> IO () -withServer action = do - serverStartupLock <- newEmptyMVar - let settings = setBeforeMainLoop (putMVar serverStartupLock ()) $ - setPort port defaultSettings - threadId <- forkIO $ runSettings settings $ serve api server - readMVar serverStartupLock - finally action (killThread threadId) +import Servant.Server (err403, errBody) +import Test.Hspec (Spec, around, around_, describe, it, shouldBe, + shouldSatisfy, xit) +import Unsafe.Coerce (unsafeCoerce) spec :: Maybe T.LoggerConfig -> Spec -spec mbLoggerCfg = do - around (withFlowRuntime (mbLoggerCfg >>= Just . createLoggerRuntime (const $ pure show))) $ do - +spec loggerCfg = do + around (withFlowRuntime (map (createLoggerRuntime defaultFlowFormatter) loggerCfg)) $ do describe "EulerHS flow language tests" $ do - describe "TestInterpreters" $ do - it "testScenario1" $ \rt -> do mv <- newMVar scenario1MockedValues res <- runFlowWithTestInterpreter mv rt testScenario1 - res `shouldBe` (User "John" "Snow" "00000000-0000-0000-0000-000000000000") - + res `shouldBe` User "John" "Snow" "00000000-0000-0000-0000-000000000000" around_ withServer $ do describe "CallServantAPI tests with server" $ do - - it "Simple request (book) with default manager" $ \rt -> do + xit "Simple request (book) with default manager" $ \rt -> do let url = BaseUrl Http "127.0.0.1" port "" bookEither <- runFlow rt $ callServantAPI Nothing url getBook bookEither `shouldSatisfy` isRight - - it "Simple request (user) with default manager" $ \rt -> do + xit "Simple request (user) with default manager" $ \rt -> do let url = BaseUrl Http "127.0.0.1" port "" userEither <- runFlow rt $ callServantAPI Nothing url getUser userEither `shouldSatisfy` isRight - it "Simple request (book) with manager1" $ \_ -> do rt <- initRTWithManagers let url = BaseUrl Http "127.0.0.1" port "" bookEither <- runFlow rt $ callServantAPI (Just "manager1") url getBook bookEither `shouldSatisfy` isRight - it "Simple request (user) with manager2" $ \_ -> do rt <- initRTWithManagers let url = BaseUrl Http "127.0.0.1" port "" userEither <- runFlow rt $ callServantAPI (Just "manager2") url getUser userEither `shouldSatisfy` isRight - it "Simple request with not existing manager" $ \_ -> do rt <- initRTWithManagers let url = BaseUrl Http "127.0.0.1" port "" - let error = displayException (ConnectionError (toException $ HttpManagerNotFound "notexist")) + let err = displayException (ConnectionError (toException $ HttpManagerNotFound "notexist")) userEither <- runFlow rt $ callServantAPI (Just "notexist") url getUser case userEither of - Left e -> displayException e `shouldBe` error - Right x -> fail "Success result not expected" - + Left e -> displayException e `shouldBe` err + Right _ -> fail "Success result not expected" xit "Untyped HTTP API Calls" $ \rt -> do - -- rt <- initRTWithManagers - let url = "https://google.com" - (statusCode, status, body, headers) <- runFlow rt $ do + (statusCode, status, _, _) <- runFlow rt $ do eResponse <- L.callHTTP $ T.httpGet "https://google.com" :: Flow (Either Text T.HTTPResponse) response <- case eResponse of - Left err -> throwException err403 {errBody = "Expected a response"} + Left _ -> throwException err403 {errBody = "Expected a response"} Right response -> pure response return ( T.getResponseCode response @@ -123,42 +108,32 @@ spec mbLoggerCfg = do -- check status code statusCode `shouldBe` 200 status `shouldBe` "OK" - xit "Untyped HTTP API Calls" $ \rt -> do - -- rt <- initRTWithManagers let url = "https://127.0.0.1:666/fourohhhfour" - result <- runFlow rt $ do + _ <- runFlow rt $ do L.callHTTP $ T.httpGet url :: Flow (Either Text T.HTTPResponse) - pure () - - describe "CallServantAPI tests without server" $ do - it "Simple request (book)" $ \rt -> do - let url = BaseUrl Http "127.0.0.1" port "" + let url = BaseUrl Http "localhost" port "" bookEither <- runFlow rt $ callServantAPI Nothing url getBook bookEither `shouldSatisfy` isLeft - it "Simple request (user)" $ \rt -> do - let url = BaseUrl Http "127.0.0.1" port "" + let url = BaseUrl Http "localhost" port "" userEither <- runFlow rt $ callServantAPI Nothing url getUser userEither `shouldSatisfy` isLeft - describe "runIO tests" $ do it "RunIO" $ \rt -> do result <- runFlow rt $ runIO (pure ("hi" :: String)) result `shouldBe` "hi" - it "RunIO with exception" $ \rt -> do result <- E.catch (runFlow rt $ do - runIO ioActWithException + _ <- runIO ioActWithException pure ("Never returned" :: Text)) (\e -> do let err = show (e :: E.AssertionFailed) pure err) result `shouldBe` ("Exception from IO" :: Text) - it "RunIO with catched exception" $ \rt -> do result <-runFlow rt $ do runIO $ @@ -167,52 +142,40 @@ spec mbLoggerCfg = do (\e -> do let err = show (e :: E.AssertionFailed) pure err) result `shouldBe` ("Exception from IO" :: Text) - it "RunUntracedIO" $ \rt -> do - result <- runFlow rt $ runUntracedIO (pure ("hi" :: String)) + result <- runFlow rt $ runIO (pure ("hi" :: String)) result `shouldBe` "hi" - describe "STM tests" $ do it "STM Test" $ \rt -> do result <- runFlow rt $ do - countVar <- runUntracedIO $ newTVarIO (0 :: Int) - + countVar <- runIO $ newTVarIO (0 :: Int) let updateCount = do count <- readTVar countVar when (count < 100) (writeTVar countVar (count + 1)) readTVar countVar - let countTo100 = do - count <- atomically $ updateCount + count <- atomically updateCount if count < 100 then countTo100 else return count - - threadId1 <- forkFlow' "counter1" $ runUntracedIO $ void countTo100 - threadId2 <- forkFlow' "counter2" $ runUntracedIO $ void countTo100 - count <- runUntracedIO $ atomically $ readTVar countVar - void $ await Nothing threadId1 - void $ await Nothing threadId2 - return count - + awaitable1 <- forkFlow' "counter1" $ runIO $ void countTo100 + awaitable2 <- forkFlow' "counter2" $ runIO $ void countTo100 + _ <- await Nothing awaitable1 >> await Nothing awaitable2 + runIO $ readTVarIO countVar result `shouldBe` 100 - describe "Options" $ do - it "One key" $ \rt -> do result <- runFlow rt $ do _ <- setOption TestStringKey "lore ipsum" getOption TestStringKey - result `shouldBe` (Just "lore ipsum") - + result `shouldBe` Just "lore ipsum" it "Not found" $ \rt -> do result <- runFlow rt $ do _ <- setOption TestStringKey "lore ipsum" getOption TestStringKey2 result `shouldBe` Nothing - it "Two keys" $ \rt -> do result <- runFlow rt $ do _ <- setOption TestStringKey "lore ipsum" @@ -221,8 +184,6 @@ spec mbLoggerCfg = do s2 <- getOption TestStringKey2 pure (s1,s2) result `shouldBe` (Just "lore ipsum", Just "lore ipsum2") - - it "Delete Key" $ \rt -> do result <- runFlow rt $ do _ <- setOption TestStringKey "lorem ipsum" @@ -231,55 +192,53 @@ spec mbLoggerCfg = do s2 <- getOption TestStringKey pure (s1, s2) result `shouldBe` (Just "lorem ipsum", Nothing) - it "Different encoding, types & payload" $ \rt -> do testKVals <- runFlow rt $ do - _ <- setOption (TestStringKey ) "mbTestStringKey" - _ <- setOption (TestStringKey2 ) "mbTestStringKey2" - _ <- setOption (TestIntKey ) 1001 - _ <- setOption (TestIntKey2 ) 2002 - _ <- setOption (TestStringKeyAnotherEnc ) "mbTestStringKeyAnotherEnc" - _ <- setOption (TestStringKey2AnotherEnc ) "mbTestStringKey2AnotherEnc" - _ <- setOption (TestKeyWithStringPayload "SP1" ) "mbTestKeyWithStringPayloadS1" - _ <- setOption (TestKeyWithStringPayload "SP2" ) "mbTestKeyWithStringPayloadS2" - _ <- setOption (TestKeyWithIntPayload 1001 ) "mbTestKeyWithIntPayloadS1" - _ <- setOption (TestKeyWithIntPayload 2002 ) "mbTestKeyWithIntPayloadS2" - _ <- setOption (TestKeyWithStringPayloadAnotherEnc "SP1" ) "mbTestKeyWithStringPayloadAnotherEncS1" - _ <- setOption (TestKeyWithStringPayloadAnotherEnc "SP2" ) "mbTestKeyWithStringPayloadAnotherEncS2" - _ <- setOption (TestKeyWithIntPayloadAnotherEnc 1001 ) "mbTestKeyWithIntPayloadAnotherEncS1" - _ <- setOption (TestKeyWithIntPayloadAnotherEnc 2002 ) "mbTestKeyWithIntPayloadAnotherEncS2" - _ <- setOption (NTTestKeyWithStringPayload "SP1" ) "mbNTTestKeyWithStringPayloadS1" - _ <- setOption (NTTestKeyWithStringPayload "SP2" ) "mbNTTestKeyWithStringPayloadS2" - _ <- setOption (NTTestKeyWithIntPayload 1001 ) 2333 - _ <- setOption (NTTestKeyWithIntPayload 2002 ) 3322 - _ <- setOption (NTTestKeyWithStringPayloadAnotherEnc "SP1" ) "mbNTTestKeyWithStringPayloadAnotherEncS1" - _ <- setOption (NTTestKeyWithStringPayloadAnotherEnc "SP2" ) "mbNTTestKeyWithStringPayloadAnotherEncS2" - _ <- setOption (NTTestKeyWithIntPayloadAnotherEnc 1001 ) 9009 - _ <- setOption (NTTestKeyWithIntPayloadAnotherEnc 2002 ) 1001 - + _ <- setOption TestStringKey "mbTestStringKey" + _ <- setOption TestStringKey2 "mbTestStringKey2" + _ <- setOption TestIntKey 1001 + _ <- setOption TestIntKey2 2002 + _ <- setOption TestStringKeyAnotherEnc "mbTestStringKeyAnotherEnc" + _ <- setOption TestStringKey2AnotherEnc "mbTestStringKey2AnotherEnc" + _ <- setOption (TestKeyWithStringPayload "SP1") "mbTestKeyWithStringPayloadS1" + _ <- setOption (TestKeyWithStringPayload "SP2") "mbTestKeyWithStringPayloadS2" + _ <- setOption (TestKeyWithIntPayload 1001) "mbTestKeyWithIntPayloadS1" + _ <- setOption (TestKeyWithIntPayload 2002) "mbTestKeyWithIntPayloadS2" + _ <- setOption (TestKeyWithStringPayloadAnotherEnc "SP1") "mbTestKeyWithStringPayloadAnotherEncS1" + _ <- setOption (TestKeyWithStringPayloadAnotherEnc "SP2") "mbTestKeyWithStringPayloadAnotherEncS2" + _ <- setOption (TestKeyWithIntPayloadAnotherEnc 1001) "mbTestKeyWithIntPayloadAnotherEncS1" + _ <- setOption (TestKeyWithIntPayloadAnotherEnc 2002) "mbTestKeyWithIntPayloadAnotherEncS2" + _ <- setOption (NTTestKeyWithStringPayload "SP1") "mbNTTestKeyWithStringPayloadS1" + _ <- setOption (NTTestKeyWithStringPayload "SP2") "mbNTTestKeyWithStringPayloadS2" + _ <- setOption (NTTestKeyWithIntPayload 1001) 2333 + _ <- setOption (NTTestKeyWithIntPayload 2002) 3322 + _ <- setOption (NTTestKeyWithStringPayloadAnotherEnc "SP1") "mbNTTestKeyWithStringPayloadAnotherEncS1" + _ <- setOption (NTTestKeyWithStringPayloadAnotherEnc "SP2") "mbNTTestKeyWithStringPayloadAnotherEncS2" + _ <- setOption (NTTestKeyWithIntPayloadAnotherEnc 1001) 9009 + _ <- setOption (NTTestKeyWithIntPayloadAnotherEnc 2002) 1001 TestKVals - <$> getOption (TestStringKey ) - <*> getOption (TestStringKey2 ) - <*> getOption (TestIntKey ) - <*> getOption (TestIntKey2 ) - <*> getOption (TestStringKeyAnotherEnc ) - <*> getOption (TestStringKey2AnotherEnc ) - <*> getOption (TestKeyWithStringPayload "SP1" ) - <*> getOption (TestKeyWithStringPayload "SP2" ) - <*> getOption (TestKeyWithIntPayload 1001 ) - <*> getOption (TestKeyWithIntPayload 2002 ) - <*> getOption (TestKeyWithStringPayloadAnotherEnc "SP1" ) - <*> getOption (TestKeyWithStringPayloadAnotherEnc "SP2" ) - <*> getOption (TestKeyWithIntPayloadAnotherEnc 1001 ) - <*> getOption (TestKeyWithIntPayloadAnotherEnc 2002 ) - <*> getOption (NTTestKeyWithStringPayload "SP1" ) - <*> getOption (NTTestKeyWithStringPayload "SP2" ) - <*> getOption (NTTestKeyWithIntPayload 1001 ) - <*> getOption (NTTestKeyWithIntPayload 2002 ) - <*> getOption (NTTestKeyWithStringPayloadAnotherEnc "SP1" ) - <*> getOption (NTTestKeyWithStringPayloadAnotherEnc "SP2" ) - <*> getOption (NTTestKeyWithIntPayloadAnotherEnc 1001 ) - <*> getOption (NTTestKeyWithIntPayloadAnotherEnc 2002 ) + <$> getOption TestStringKey + <*> getOption TestStringKey2 + <*> getOption TestIntKey + <*> getOption TestIntKey2 + <*> getOption TestStringKeyAnotherEnc + <*> getOption TestStringKey2AnotherEnc + <*> getOption (TestKeyWithStringPayload "SP1") + <*> getOption (TestKeyWithStringPayload "SP2") + <*> getOption (TestKeyWithIntPayload 1001) + <*> getOption (TestKeyWithIntPayload 2002) + <*> getOption (TestKeyWithStringPayloadAnotherEnc "SP1") + <*> getOption (TestKeyWithStringPayloadAnotherEnc "SP2") + <*> getOption (TestKeyWithIntPayloadAnotherEnc 1001) + <*> getOption (TestKeyWithIntPayloadAnotherEnc 2002) + <*> getOption (NTTestKeyWithStringPayload "SP1") + <*> getOption (NTTestKeyWithStringPayload "SP2") + <*> getOption (NTTestKeyWithIntPayload 1001) + <*> getOption (NTTestKeyWithIntPayload 2002) + <*> getOption (NTTestKeyWithStringPayloadAnotherEnc "SP1") + <*> getOption (NTTestKeyWithStringPayloadAnotherEnc "SP2") + <*> getOption (NTTestKeyWithIntPayloadAnotherEnc 1001) + <*> getOption (NTTestKeyWithIntPayloadAnotherEnc 2002) testKVals `shouldBe` TestKVals { mbTestStringKey = Just "mbTestStringKey" @@ -305,33 +264,27 @@ spec mbLoggerCfg = do , mbNTTestKeyWithIntPayloadAnotherEncS1 = Just 9009 , mbNTTestKeyWithIntPayloadAnotherEncS2 = Just 1001 } - it "RunSysCmd" $ \rt -> do result <- runFlow rt $ runSysCmd "echo test" result `shouldBe` "test\n" - it "RunSysCmd with bad command" $ \rt -> do result <- E.catch (runFlow rt $ runSysCmd "badEcho test") (\e -> do let err = show (e :: E.SomeException) pure err) result `shouldBe` ("readCreateProcess: badEcho test (exit 127): failed" :: String) - - it "GenerateGUID" $ \rt -> do guid <- runFlow rt generateGUID let maybeGUID = UUID.fromText guid maybeGUID `shouldSatisfy` isJust - it "ThrowException" $ \rt -> do result <- E.catch (runFlow rt $ do - throwException (E.AssertionFailed "Exception message") - pure "Never returned") + _ <- throwException (E.AssertionFailed "Exception message") + pure @_ @Text "Never returned") (\e -> do let err = show (e :: E.AssertionFailed) pure err) result `shouldBe` "Exception message" - describe "ForkFlow" $ do let i :: Int = 101 it "Fork and successful await infinitely" $ \rt -> do @@ -339,64 +292,48 @@ spec mbLoggerCfg = do awaitable <- forkFlow' "101" (pure i) await Nothing awaitable result <- runFlow rt flow - result `shouldBe` (Right 101) - + result `shouldBe` Right 101 it "SafeFlow, fork and successful await infinitely" $ \rt -> do let flow = do awaitable <- forkFlow' "101" $ runSafeFlow (pure i :: Flow Int) await Nothing awaitable result <- runFlow rt flow - result `shouldBe` (Right $ Right 101) - + result `shouldBe` Right (Right 101) it "SafeFlow with exception, fork and successful await infinitely" $ \rt -> do let flow = do awaitable <- forkFlow' "101" (throwException err403 {errBody = "403"} :: Flow Text) await Nothing awaitable result <- runFlow rt flow - result `shouldBe` (Left $ T.ForkedFlowError $ show err403 {errBody = "403"}) - + result `shouldBe` Left (T.ForkedFlowError $ show err403 {errBody = "403"}) it "Safe flow with exception and return power" $ \rt -> do let flow = do void $ runSafeFlow (throwException err403 {errBody = "403"} :: Flow Text) runIO (pure ("hi" :: String)) result <- runFlow rt flow result `shouldBe` "hi" - it "Safe flow, RunSysCmd" $ \rt -> do let flow = do runSafeFlow $ L.runSysCmd $ "echo " <> "safe hello" result <- runFlow rt flow - result `shouldBe` (Right "safe hello\n") - - -- This might or might not happen (race condition) - -- it "Fork and successful await 0" $ \rt -> do - -- let flow = do - -- awaitable <- forkFlow' "101" (pure i) - -- await (Just $ T.Microseconds 0) awaitable - -- result <- runFlow rt flow - -- result `shouldBe` (Just 101) - + result `shouldBe` Right "safe hello\n" it "Fork and successful await with a sufficient timeout 1" $ \rt -> do let flow = do awaitable <- forkFlow' "101" (pure i) await (Just $ T.Microseconds 1000000) awaitable result <- runFlow rt flow - result `shouldBe` (Right 101) - + result `shouldBe` Right 101 it "Fork and successful await with a sufficient timeout 2" $ \rt -> do let flow = do awaitable <- forkFlow' "101" (runIO (threadDelay 1000) >> pure i) await (Just $ T.Microseconds 1000000) awaitable result <- runFlow rt flow - result `shouldBe` (Right 101) - + result `shouldBe` Right 101 it "Fork and successful await with an unsufficient timeout" $ \rt -> do let flow = do awaitable <- forkFlow' "101" (runIO (threadDelay 1000000) >> pure i) await (Just $ T.Microseconds 1000) awaitable result <- runFlow rt flow - result `shouldBe` (Left T.AwaitingTimeout) - + result `shouldBe` Left T.AwaitingTimeout it "Fork and successful await for 2 flows" $ \rt -> do let flow = do awaitable1 <- forkFlow' "101" (runIO (threadDelay 10000) >> pure i) @@ -406,7 +343,6 @@ spec mbLoggerCfg = do pure (mbRes1, mbRes2) result <- runFlow rt flow result `shouldBe` (Right 101, Right 102) - it "Fork and successful await 1 of 2 flows" $ \rt -> do let flow = do awaitable1 <- forkFlow' "101" (runIO (threadDelay 10000) >> pure i) @@ -416,3 +352,30 @@ spec mbLoggerCfg = do pure (mbRes1, mbRes2) result <- runFlow rt flow result `shouldBe` (Right 101, Left T.AwaitingTimeout) + +-- Helpers + +user :: Any +user = unsafeCoerce $ Right $ User "John" "Snow" "00000000-0000-0000-0000-000000000000" + +localGUID :: Any +localGUID = unsafeCoerce ("FFFFFFFF-FFFF-FFFF-FFFF-FFFFFFFFFFFF" :: String) + +lhost :: ByteString +lhost = "localhost" + +scenario1MockedValues :: FlowMockedValues' +scenario1MockedValues = FlowMockedValues' + { mockedCallServantAPI = [user] + , mockedRunIO = [localGUID] + , mockedGetOption = [lhost] + , mockedGenerateGUID = ["00000000-0000-0000-0000-000000000000"] + , mockedRunSysCmd = ["Neo"] + } + +ioActWithException :: IO Text +ioActWithException = do + _ <- E.throw (E.AssertionFailed "Exception from IO") + pure "Text from IO" + + diff --git a/test/EulerHS/Tests/Framework/KVDBArtSpec.hs b/test/EulerHS/Tests/Framework/KVDBArtSpec.hs index 2572a9bf..098dfe53 100644 --- a/test/EulerHS/Tests/Framework/KVDBArtSpec.hs +++ b/test/EulerHS/Tests/Framework/KVDBArtSpec.hs @@ -1,171 +1,170 @@ module EulerHS.Tests.Framework.KVDBArtSpec - ( spec + ( + -- spec ) where -import EulerHS.Prelude - -import Data.Aeson as A -import Test.Hspec - -import qualified Database.Redis as R -import EulerHS.Language as L -import EulerHS.Runtime -import EulerHS.Tests.Framework.Common -import EulerHS.Types as T - -connectInfo :: R.ConnectInfo -connectInfo = R.defaultConnectInfo {R.connectHost = "redis"} - -runWithRedisConn_ :: ResultRecording -> Flow b -> IO b -runWithRedisConn_ = replayRecording - -spec :: Spec -spec = do - describe "ART KVDB tests" $ do - it "get a correct key" $ do - result <- runWithRedisConn_ getKey $ L.runKVDB "redis" $ do - L.set "aaa" "bbb" - res <- L.get "aaa" - L.del ["aaa"] - pure res - result `shouldBe` Right (Just "bbb") - - it "get a wrong key" $ do - result <- runWithRedisConn_ getWrongKey $ L.runKVDB "redis" $ do - L.set "aaa" "bbb" - res <- L.get "aaac" - L.del ["aaa"] - pure res - result `shouldBe` Right Nothing - - it "delete existing keys" $ do - result <- runWithRedisConn_ deleteExisting $ L.runKVDB "redis" $ do - L.set "aaa" "bbb" - L.set "ccc" "ddd" - L.del ["aaa", "ccc"] - result `shouldBe` Right 2 - - it "delete keys (w/ no keys)" $ do - result <- runWithRedisConn_ deleteKeysNoKeys $ L.runKVDB "redis" $ do - L.del [] - result `shouldBe` Right 0 - - it "delete missing keys" $ do - result <- runWithRedisConn_ deleteMissing $ L.runKVDB "redis" $ do - L.del ["zzz", "yyy"] - result `shouldBe` Right 0 - - it "get a correct key from transaction" $ do - result <- runWithRedisConn_ getCorrectFromTx $ L.runKVDB "redis" $ L.multiExec $ do - L.setTx "aaa" "bbb" - res <- L.getTx "aaa" - L.delTx ["aaa"] - pure res - result `shouldBe` Right (T.TxSuccess (Just "bbb")) - - it "get incorrect key from transaction" $ do - result <- runWithRedisConn_ getIncorrectFromTx $ L.runKVDB "redis" $ L.multiExec $ do - res <- L.getTx "aaababababa" - pure res - result `shouldBe` Right (T.TxSuccess Nothing) - - it "setex sets value" $ do - let hour = 60 * 60 - result <- runWithRedisConn_ setExGetKey $ L.runKVDB "redis" $ do - L.setex "aaaex" hour "bbbex" - res <- L.get "aaaex" - L.del ["aaaex"] - pure res - result `shouldBe` Right (Just "bbbex") - - it "setex ttl works" $ do - result <- runWithRedisConn_ setExTtl $ do - L.runKVDB "redis" $ L.setex "aaaex" 1 "bbbex" - L.runIO $ threadDelay (2 * 10 ^ 6) - L.runKVDB "redis" $ do - res <- L.get "aaaex" - L.del ["aaaex"] - pure res - result `shouldBe` Right Nothing - - it "set only if not exist" $ do - result <- runWithRedisConn_ setIfNotExist $ L.runKVDB "redis" $ do - res1 <- L.setOpts "aaa" "bbb" L.NoTTL L.SetIfNotExist - res2 <- L.get "aaa" - res3 <- L.setOpts "aaa" "ccc" L.NoTTL L.SetIfNotExist - res4 <- L.get "aaa" - L.del ["aaa"] - pure (res1, res2, res3, res4) - result `shouldBe` Right (True, Just "bbb", False, Just "bbb") - - it "set only if exist" $ do - result <- runWithRedisConn_ setIfExist $ L.runKVDB "redis" $ do - res1 <- L.setOpts "aaa" "bbb" L.NoTTL L.SetIfExist - res2 <- L.get "aaa" - L.set "aaa" "bbb" - res3 <- L.setOpts "aaa" "ccc" L.NoTTL L.SetIfExist - res4 <- L.get "aaa" - L.del ["aaa"] - pure (res1, res2, res3, res4) - result `shouldBe` Right (False, Nothing, True, Just "ccc") - - it "set px ttl works" $ do - result <- runWithRedisConn_ setPxTtl $ do - L.runKVDB "redis" $ L.setOpts "aaapx" "bbbpx" (L.Milliseconds 500) L.SetAlways - res1 <- L.runKVDB "redis" $ L.get "aaapx" - L.runIO $ threadDelay (10 ^ 6) - res2 <- L.runKVDB "redis" $ L.get "aaapx" - L.runKVDB "redis" $ L.del ["aaapx"] - pure (res1, res2) - result `shouldBe` (Right (Just "bbbpx"), Right Nothing) - - it "xadd create and update stream" $ do - result <- runWithRedisConn_ xaddXlen $ L.runKVDB "redis" $ do - L.xadd "aaas" L.AutoID [("a", "1"), ("b", "2")] - res1 <- L.xlen "aaas" - L.xadd "aaas" L.AutoID [("c", "3")] - res2 <- L.xlen "aaas" - L.del ["aaas"] - res3 <- L.xlen "aaas" - pure (res1, res2, res3) - result `shouldBe` Right (1, 2, 0) - - -getKey :: ResultRecording -getKey = fromJust $ decode "{\"recording\":[{\"_entryName\":\"SetEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonValue\":{\"utf8\":\"bbb\",\"b64\":\"YmJi\"},\"jsonResult\":{\"Right\":{\"tag\":\"Ok\"}},\"jsonKey\":{\"utf8\":\"aaa\",\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"GetEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonResult\":{\"Right\":{\"utf8\":\"bbb\",\"b64\":\"YmJi\"}},\"jsonKey\":{\"utf8\":\"aaa\",\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"DelEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonResult\":{\"Right\":1},\"jsonKeys\":[{\"utf8\":\"aaa\",\"b64\":\"YWFh\"}]},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" - -getWrongKey :: ResultRecording -getWrongKey = fromJust $ decode "{\"recording\":[{\"_entryName\":\"SetEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonValue\":{\"utf8\":\"bbb\",\"b64\":\"YmJi\"},\"jsonResult\":{\"Right\":{\"tag\":\"Ok\"}},\"jsonKey\":{\"utf8\":\"aaa\",\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"GetEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonResult\":{\"Right\":null},\"jsonKey\":{\"utf8\":\"aaac\",\"b64\":\"YWFhYw==\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"DelEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonResult\":{\"Right\":1},\"jsonKeys\":[{\"utf8\":\"aaa\",\"b64\":\"YWFh\"}]},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" - -deleteExisting :: ResultRecording -deleteExisting = fromJust $ decode "{\"recording\":[{\"_entryName\":\"SetEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonValue\":{\"utf8\":\"bbb\",\"b64\":\"YmJi\"},\"jsonResult\":{\"Right\":{\"tag\":\"Ok\"}},\"jsonKey\":{\"utf8\":\"aaa\",\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"SetEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonValue\":{\"utf8\":\"ddd\",\"b64\":\"ZGRk\"},\"jsonResult\":{\"Right\":{\"tag\":\"Ok\"}},\"jsonKey\":{\"utf8\":\"ccc\",\"b64\":\"Y2Nj\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"DelEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonResult\":{\"Right\":2},\"jsonKeys\":[{\"utf8\":\"aaa\",\"b64\":\"YWFh\"},{\"utf8\":\"ccc\",\"b64\":\"Y2Nj\"}]},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" - -deleteKeysNoKeys :: ResultRecording -deleteKeysNoKeys = fromJust $ decode "{\"recording\":[{\"_entryName\":\"DelEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonResult\":{\"Right\":0},\"jsonKeys\":[]},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" - -deleteMissing :: ResultRecording -deleteMissing = fromJust $ decode "{\"recording\":[{\"_entryName\":\"DelEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonResult\":{\"Right\":0},\"jsonKeys\":[{\"utf8\":\"zzz\",\"b64\":\"enp6\"},{\"utf8\":\"yyy\",\"b64\":\"eXl5\"}]},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" - -getCorrectFromTx :: ResultRecording -getCorrectFromTx = fromJust $ decode "{\"recording\":[{\"_entryName\":\"MultiExecEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonResult\":{\"Right\":{\"tag\":\"TxSuccess\",\"contents\":{\"utf8\":\"bbb\",\"b64\":\"YmJi\"}}}},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" - -getIncorrectFromTx :: ResultRecording -getIncorrectFromTx = fromJust $ decode "{\"recording\":[{\"_entryName\":\"MultiExecEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonResult\":{\"Right\":{\"tag\":\"TxSuccess\",\"contents\":null}}},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" - -setExGetKey :: ResultRecording -setExGetKey = fromJust $ decode "{\"recording\":[{\"_entryName\":\"SetExEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonTtl\":3600,\"jsonValue\":{\"utf8\":\"bbbex\",\"b64\":\"YmJiZXg=\"},\"jsonResult\":{\"Right\":{\"tag\":\"Ok\"}},\"jsonKey\":{\"utf8\":\"aaaex\",\"b64\":\"YWFhZXg=\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"GetEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonResult\":{\"Right\":{\"utf8\":\"bbbex\",\"b64\":\"YmJiZXg=\"}},\"jsonKey\":{\"utf8\":\"aaaex\",\"b64\":\"YWFhZXg=\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"DelEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonResult\":{\"Right\":1},\"jsonKeys\":[{\"utf8\":\"aaaex\",\"b64\":\"YWFhZXg=\"}]},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" - -setExTtl :: ResultRecording -setExTtl = fromJust $ decode "{\"recording\":[{\"_entryName\":\"SetExEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonTtl\":1,\"jsonValue\":{\"utf8\":\"bbbex\",\"b64\":\"YmJiZXg=\"},\"jsonResult\":{\"Right\":{\"tag\":\"Ok\"}},\"jsonKey\":{\"utf8\":\"aaaex\",\"b64\":\"YWFhZXg=\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonResult\":[],\"description\":\"\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"GetEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonResult\":{\"Right\":null},\"jsonKey\":{\"utf8\":\"aaaex\",\"b64\":\"YWFhZXg=\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"DelEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonResult\":{\"Right\":0},\"jsonKeys\":[{\"utf8\":\"aaaex\",\"b64\":\"YWFhZXg=\"}]},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" - -setIfNotExist :: ResultRecording -setIfNotExist = fromJust $ decode "{\"recording\":[{\"_entryName\":\"SetOptsEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonTTL\":{\"tag\":\"NoTTL\"},\"jsonValue\":{\"utf8\":\"bbb\",\"b64\":\"YmJi\"},\"jsonCond\":\"SetIfNotExist\",\"jsonResult\":{\"Right\":true},\"jsonKey\":{\"utf8\":\"aaa\",\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"GetEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonResult\":{\"Right\":{\"utf8\":\"bbb\",\"b64\":\"YmJi\"}},\"jsonKey\":{\"utf8\":\"aaa\",\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"SetOptsEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonTTL\":{\"tag\":\"NoTTL\"},\"jsonValue\":{\"utf8\":\"ccc\",\"b64\":\"Y2Nj\"},\"jsonCond\":\"SetIfNotExist\",\"jsonResult\":{\"Right\":false},\"jsonKey\":{\"utf8\":\"aaa\",\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"GetEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonResult\":{\"Right\":{\"utf8\":\"bbb\",\"b64\":\"YmJi\"}},\"jsonKey\":{\"utf8\":\"aaa\",\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"DelEntry\",\"_entryIndex\":4,\"_entryPayload\":{\"jsonResult\":{\"Right\":1},\"jsonKeys\":[{\"utf8\":\"aaa\",\"b64\":\"YWFh\"}]},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" - -setIfExist :: ResultRecording -setIfExist = fromJust $ decode "{\"recording\":[{\"_entryName\":\"SetOptsEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonTTL\":{\"tag\":\"NoTTL\"},\"jsonValue\":{\"utf8\":\"bbb\",\"b64\":\"YmJi\"},\"jsonCond\":\"SetIfExist\",\"jsonResult\":{\"Right\":false},\"jsonKey\":{\"utf8\":\"aaa\",\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"GetEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonResult\":{\"Right\":null},\"jsonKey\":{\"utf8\":\"aaa\",\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"SetEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonValue\":{\"utf8\":\"bbb\",\"b64\":\"YmJi\"},\"jsonResult\":{\"Right\":{\"tag\":\"Ok\"}},\"jsonKey\":{\"utf8\":\"aaa\",\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"SetOptsEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonTTL\":{\"tag\":\"NoTTL\"},\"jsonValue\":{\"utf8\":\"ccc\",\"b64\":\"Y2Nj\"},\"jsonCond\":\"SetIfExist\",\"jsonResult\":{\"Right\":true},\"jsonKey\":{\"utf8\":\"aaa\",\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"GetEntry\",\"_entryIndex\":4,\"_entryPayload\":{\"jsonResult\":{\"Right\":{\"utf8\":\"ccc\",\"b64\":\"Y2Nj\"}},\"jsonKey\":{\"utf8\":\"aaa\",\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"DelEntry\",\"_entryIndex\":5,\"_entryPayload\":{\"jsonResult\":{\"Right\":1},\"jsonKeys\":[{\"utf8\":\"aaa\",\"b64\":\"YWFh\"}]},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" - -setPxTtl :: ResultRecording -setPxTtl = fromJust $ decode "{\"recording\":[{\"_entryName\":\"SetOptsEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonTTL\":{\"tag\":\"Milliseconds\",\"contents\":500},\"jsonValue\":{\"utf8\":\"bbbpx\",\"b64\":\"YmJicHg=\"},\"jsonCond\":\"SetAlways\",\"jsonResult\":{\"Right\":true},\"jsonKey\":{\"utf8\":\"aaapx\",\"b64\":\"YWFhcHg=\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"GetEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonResult\":{\"Right\":{\"utf8\":\"bbbpx\",\"b64\":\"YmJicHg=\"}},\"jsonKey\":{\"utf8\":\"aaapx\",\"b64\":\"YWFhcHg=\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonResult\":[],\"description\":\"\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"GetEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonResult\":{\"Right\":null},\"jsonKey\":{\"utf8\":\"aaapx\",\"b64\":\"YWFhcHg=\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"DelEntry\",\"_entryIndex\":4,\"_entryPayload\":{\"jsonResult\":{\"Right\":0},\"jsonKeys\":[{\"utf8\":\"aaapx\",\"b64\":\"YWFhcHg=\"}]},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" - -xaddXlen :: ResultRecording -xaddXlen = fromJust $ decode "{\"recording\":[{\"_entryName\":\"XAddEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonStream\":{\"utf8\":\"aaas\",\"b64\":\"YWFhcw==\"},\"jsonItems\":[[{\"utf8\":\"a\",\"b64\":\"YQ==\"},{\"utf8\":\"1\",\"b64\":\"MQ==\"}],[{\"utf8\":\"b\",\"b64\":\"Yg==\"},{\"utf8\":\"2\",\"b64\":\"Mg==\"}]],\"jsonResult\":{\"Right\":[1596654345484,0]},\"jsonEntryId\":{\"tag\":\"AutoID\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"XLenEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonStream\":{\"utf8\":\"aaas\",\"b64\":\"YWFhcw==\"},\"jsonResult\":{\"Right\":1}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"XAddEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonStream\":{\"utf8\":\"aaas\",\"b64\":\"YWFhcw==\"},\"jsonItems\":[[{\"utf8\":\"c\",\"b64\":\"Yw==\"},{\"utf8\":\"3\",\"b64\":\"Mw==\"}]],\"jsonResult\":{\"Right\":[1596654345485,0]},\"jsonEntryId\":{\"tag\":\"AutoID\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"XLenEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonStream\":{\"utf8\":\"aaas\",\"b64\":\"YWFhcw==\"},\"jsonResult\":{\"Right\":2}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"DelEntry\",\"_entryIndex\":4,\"_entryPayload\":{\"jsonResult\":{\"Right\":1},\"jsonKeys\":[{\"utf8\":\"aaas\",\"b64\":\"YWFhcw==\"}]},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"XLenEntry\",\"_entryIndex\":5,\"_entryPayload\":{\"jsonStream\":{\"utf8\":\"aaas\",\"b64\":\"YWFhcw==\"},\"jsonResult\":{\"Right\":0}},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" +-- import Common (replayRecording) +-- import Data.Aeson as A +-- import qualified Database.Redis as R +-- import EulerHS.Language as L +-- import EulerHS.Prelude +-- import EulerHS.Runtime +-- import EulerHS.Types as T +-- import Test.Hspec + +-- connectInfo :: R.ConnectInfo +-- -- connectInfo = R.defaultConnectInfo -- fot recording +-- connectInfo = R.defaultConnectInfo {R.connectHost = "redis"} -- for replaying + +-- runWithRedisConn_ :: ResultRecording -> Flow b -> IO b +-- -- runWithRedisConn_ = runWithRedisConn connectInfo -- for recording +-- runWithRedisConn_ = replayRecording + +-- spec :: Spec +-- spec = do +-- describe "ART KVDB tests" $ do +-- it "get a correct key" $ do +-- result <- runWithRedisConn_ getKey $ L.runKVDB "redis" $ do +-- L.set "aaa" "bbb" +-- res <- L.get "aaa" +-- L.del ["aaa"] +-- pure res +-- result `shouldBe` Right (Just "bbb") + +-- it "get a wrong key" $ do +-- result <- runWithRedisConn_ getWrongKey $ L.runKVDB "redis" $ do +-- L.set "aaa" "bbb" +-- res <- L.get "aaac" +-- L.del ["aaa"] +-- pure res +-- result `shouldBe` Right Nothing + +-- it "delete existing keys" $ do +-- result <- runWithRedisConn_ deleteExisting $ L.runKVDB "redis" $ do +-- L.set "aaa" "bbb" +-- L.set "ccc" "ddd" +-- L.del ["aaa", "ccc"] +-- result `shouldBe` Right 2 + +-- it "delete keys (w/ no keys)" $ do +-- result <- runWithRedisConn_ deleteKeysNoKeys $ L.runKVDB "redis" $ do +-- L.del [] +-- result `shouldBe` Right 0 + +-- it "delete missing keys" $ do +-- result <- runWithRedisConn_ deleteMissing $ L.runKVDB "redis" $ do +-- L.del ["zzz", "yyy"] +-- result `shouldBe` Right 0 + +-- it "get a correct key from transaction" $ do +-- result <- runWithRedisConn_ getCorrectFromTx $ L.runKVDB "redis" $ L.multiExec $ do +-- L.setTx "aaa" "bbb" +-- res <- L.getTx "aaa" +-- L.delTx ["aaa"] +-- pure res +-- result `shouldBe` Right (T.TxSuccess (Just "bbb")) + +-- it "get incorrect key from transaction" $ do +-- result <- runWithRedisConn_ getIncorrectFromTx $ L.runKVDB "redis" $ L.multiExec $ L.getTx "aaababababa" +-- result `shouldBe` Right (T.TxSuccess Nothing) + +-- it "setex sets value" $ do +-- let hour = 60 * 60 +-- result <- runWithRedisConn_ setExGetKey $ L.runKVDB "redis" $ do +-- L.setex "aaaex" hour "bbbex" +-- res <- L.get "aaaex" +-- L.del ["aaaex"] +-- pure res +-- result `shouldBe` Right (Just "bbbex") + +-- it "setex ttl works" $ do +-- result <- runWithRedisConn_ setExTtl $ do +-- L.runKVDB "redis" $ L.setex "aaaex" 1 "bbbex" +-- L.runIO $ threadDelay (2 * 10 ^ 6) +-- L.runKVDB "redis" $ do +-- res <- L.get "aaaex" +-- L.del ["aaaex"] +-- pure res +-- result `shouldBe` Right Nothing + +-- it "set only if not exist" $ do +-- result <- runWithRedisConn_ setIfNotExist $ L.runKVDB "redis" $ do +-- res1 <- L.setOpts "aaa" "bbb" L.NoTTL L.SetIfNotExist +-- res2 <- L.get "aaa" +-- res3 <- L.setOpts "aaa" "ccc" L.NoTTL L.SetIfNotExist +-- res4 <- L.get "aaa" +-- L.del ["aaa"] +-- pure (res1, res2, res3, res4) +-- result `shouldBe` Right (True, Just "bbb", False, Just "bbb") + +-- it "set only if exist" $ do +-- result <- runWithRedisConn_ setIfExist $ L.runKVDB "redis" $ do +-- res1 <- L.setOpts "aaa" "bbb" L.NoTTL L.SetIfExist +-- res2 <- L.get "aaa" +-- L.set "aaa" "bbb" +-- res3 <- L.setOpts "aaa" "ccc" L.NoTTL L.SetIfExist +-- res4 <- L.get "aaa" +-- L.del ["aaa"] +-- pure (res1, res2, res3, res4) +-- result `shouldBe` Right (False, Nothing, True, Just "ccc") + +-- it "set px ttl works" $ do +-- result <- runWithRedisConn_ setPxTtl $ do +-- L.runKVDB "redis" $ L.setOpts "aaapx" "bbbpx" (L.Milliseconds 500) L.SetAlways +-- res1 <- L.runKVDB "redis" $ L.get "aaapx" +-- L.runIO $ threadDelay (10 ^ 6) +-- res2 <- L.runKVDB "redis" $ L.get "aaapx" +-- L.runKVDB "redis" $ L.del ["aaapx"] +-- pure (res1, res2) +-- result `shouldBe` (Right (Just "bbbpx"), Right Nothing) + +-- it "xadd create and update stream" $ do +-- result <- runWithRedisConn_ xaddXlen $ L.runKVDB "redis" $ do +-- L.xadd "aaas" L.AutoID [("a", "1"), ("b", "2")] +-- res1 <- L.xlen "aaas" +-- L.xadd "aaas" L.AutoID [("c", "3")] +-- res2 <- L.xlen "aaas" +-- L.del ["aaas"] +-- res3 <- L.xlen "aaas" +-- pure (res1, res2, res3) +-- result `shouldBe` Right (1, 2, 0) + + +-- getKey :: ResultRecording +-- getKey = fromJust $ decode "{\"recording\":[{\"_entryName\":\"SetEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonValue\":{\"b64\":\"YmJi\"},\"jsonResult\":{\"Right\":{\"tag\":\"Ok\"}},\"jsonKey\":{\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"GetEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonResult\":{\"Right\":{\"b64\":\"YmJi\"}},\"jsonKey\":{\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"DelEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonResult\":{\"Right\":1},\"jsonKeys\":[{\"b64\":\"YWFh\"}]},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" + +-- getWrongKey :: ResultRecording +-- getWrongKey = fromJust $ decode "{\"recording\":[{\"_entryName\":\"SetEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonValue\":{\"b64\":\"YmJi\"},\"jsonResult\":{\"Right\":{\"tag\":\"Ok\"}},\"jsonKey\":{\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"GetEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonResult\":{\"Right\":null},\"jsonKey\":{\"b64\":\"YWFhYw==\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"DelEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonResult\":{\"Right\":1},\"jsonKeys\":[{\"b64\":\"YWFh\"}]},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" + +-- deleteExisting :: ResultRecording +-- deleteExisting = fromJust $ decode "{\"recording\":[{\"_entryName\":\"SetEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonValue\":{\"b64\":\"YmJi\"},\"jsonResult\":{\"Right\":{\"tag\":\"Ok\"}},\"jsonKey\":{\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"SetEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonValue\":{\"b64\":\"ZGRk\"},\"jsonResult\":{\"Right\":{\"tag\":\"Ok\"}},\"jsonKey\":{\"b64\":\"Y2Nj\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"DelEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonResult\":{\"Right\":2},\"jsonKeys\":[{\"b64\":\"YWFh\"},{\"b64\":\"Y2Nj\"}]},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" + +-- deleteKeysNoKeys :: ResultRecording +-- deleteKeysNoKeys = fromJust $ decode "{\"recording\":[{\"_entryName\":\"DelEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonResult\":{\"Right\":0},\"jsonKeys\":[]},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" + +-- deleteMissing :: ResultRecording +-- deleteMissing = fromJust $ decode "{\"recording\":[{\"_entryName\":\"DelEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonResult\":{\"Right\":0},\"jsonKeys\":[{\"b64\":\"enp6\"},{\"b64\":\"eXl5\"}]},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" + +-- getCorrectFromTx :: ResultRecording +-- getCorrectFromTx = fromJust $ decode "{\"recording\":[{\"_entryName\":\"MultiExecEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonResult\":{\"Right\":{\"tag\":\"TxSuccess\",\"contents\":{\"b64\":\"YmJi\"}}}},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" + +-- getIncorrectFromTx :: ResultRecording +-- getIncorrectFromTx = fromJust $ decode "{\"recording\":[{\"_entryName\":\"MultiExecEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonResult\":{\"Right\":{\"tag\":\"TxSuccess\",\"contents\":null}}},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" + +-- setExGetKey :: ResultRecording +-- setExGetKey = fromJust $ decode "{\"recording\":[{\"_entryName\":\"SetExEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonTtl\":3600,\"jsonValue\":{\"b64\":\"YmJiZXg=\"},\"jsonResult\":{\"Right\":{\"tag\":\"Ok\"}},\"jsonKey\":{\"b64\":\"YWFhZXg=\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"GetEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonResult\":{\"Right\":{\"b64\":\"YmJiZXg=\"}},\"jsonKey\":{\"b64\":\"YWFhZXg=\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"DelEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonResult\":{\"Right\":1},\"jsonKeys\":[{\"b64\":\"YWFhZXg=\"}]},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" + +-- setExTtl :: ResultRecording +-- setExTtl = fromJust $ decode "{\"recording\":[{\"_entryName\":\"SetExEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonTtl\":1,\"jsonValue\":{\"b64\":\"YmJiZXg=\"},\"jsonResult\":{\"Right\":{\"tag\":\"Ok\"}},\"jsonKey\":{\"b64\":\"YWFhZXg=\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonResult\":[],\"description\":\"\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"GetEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonResult\":{\"Right\":null},\"jsonKey\":{\"b64\":\"YWFhZXg=\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"DelEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonResult\":{\"Right\":0},\"jsonKeys\":[{\"b64\":\"YWFhZXg=\"}]},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" + +-- setIfNotExist :: ResultRecording +-- setIfNotExist = fromJust $ decode "{\"recording\":[{\"_entryName\":\"SetOptsEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonTTL\":{\"tag\":\"NoTTL\"},\"jsonValue\":{\"b64\":\"YmJi\"},\"jsonCond\":\"SetIfNotExist\",\"jsonResult\":{\"Right\":true},\"jsonKey\":{\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"GetEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonResult\":{\"Right\":{\"b64\":\"YmJi\"}},\"jsonKey\":{\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"SetOptsEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonTTL\":{\"tag\":\"NoTTL\"},\"jsonValue\":{\"b64\":\"Y2Nj\"},\"jsonCond\":\"SetIfNotExist\",\"jsonResult\":{\"Right\":false},\"jsonKey\":{\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"GetEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonResult\":{\"Right\":{\"b64\":\"YmJi\"}},\"jsonKey\":{\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"DelEntry\",\"_entryIndex\":4,\"_entryPayload\":{\"jsonResult\":{\"Right\":1},\"jsonKeys\":[{\"b64\":\"YWFh\"}]},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" + +-- setIfExist :: ResultRecording +-- setIfExist = fromJust $ decode "{\"recording\":[{\"_entryName\":\"SetOptsEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonTTL\":{\"tag\":\"NoTTL\"},\"jsonValue\":{\"b64\":\"YmJi\"},\"jsonCond\":\"SetIfExist\",\"jsonResult\":{\"Right\":false},\"jsonKey\":{\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"GetEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonResult\":{\"Right\":null},\"jsonKey\":{\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"SetEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonValue\":{\"b64\":\"YmJi\"},\"jsonResult\":{\"Right\":{\"tag\":\"Ok\"}},\"jsonKey\":{\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"SetOptsEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonTTL\":{\"tag\":\"NoTTL\"},\"jsonValue\":{\"b64\":\"Y2Nj\"},\"jsonCond\":\"SetIfExist\",\"jsonResult\":{\"Right\":true},\"jsonKey\":{\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"GetEntry\",\"_entryIndex\":4,\"_entryPayload\":{\"jsonResult\":{\"Right\":{\"b64\":\"Y2Nj\"}},\"jsonKey\":{\"b64\":\"YWFh\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"DelEntry\",\"_entryIndex\":5,\"_entryPayload\":{\"jsonResult\":{\"Right\":1},\"jsonKeys\":[{\"b64\":\"YWFh\"}]},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" + +-- setPxTtl :: ResultRecording +-- setPxTtl = fromJust $ decode "{\"recording\":[{\"_entryName\":\"SetOptsEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonTTL\":{\"tag\":\"Milliseconds\",\"contents\":500},\"jsonValue\":{\"b64\":\"YmJicHg=\"},\"jsonCond\":\"SetAlways\",\"jsonResult\":{\"Right\":true},\"jsonKey\":{\"b64\":\"YWFhcHg=\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"GetEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonResult\":{\"Right\":{\"b64\":\"YmJicHg=\"}},\"jsonKey\":{\"b64\":\"YWFhcHg=\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonResult\":[],\"description\":\"\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"GetEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonResult\":{\"Right\":null},\"jsonKey\":{\"b64\":\"YWFhcHg=\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"DelEntry\",\"_entryIndex\":4,\"_entryPayload\":{\"jsonResult\":{\"Right\":0},\"jsonKeys\":[{\"b64\":\"YWFhcHg=\"}]},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" + +-- xaddXlen :: ResultRecording +-- xaddXlen = fromJust $ decode "{\"recording\":[{\"_entryName\":\"XAddEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonStream\":{\"b64\":\"YWFhcw==\"},\"jsonItems\":[[{\"b64\":\"YQ==\"},{\"b64\":\"MQ==\"}],[{\"b64\":\"Yg==\"},{\"b64\":\"Mg==\"}]],\"jsonResult\":{\"Right\":[1596654345484,0]},\"jsonEntryId\":{\"tag\":\"AutoID\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"XLenEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonStream\":{\"b64\":\"YWFhcw==\"},\"jsonResult\":{\"Right\":1}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"XAddEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonStream\":{\"b64\":\"YWFhcw==\"},\"jsonItems\":[[{\"b64\":\"Yw==\"},{\"b64\":\"Mw==\"}]],\"jsonResult\":{\"Right\":[1596654345485,0]},\"jsonEntryId\":{\"tag\":\"AutoID\"}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"XLenEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonStream\":{\"b64\":\"YWFhcw==\"},\"jsonResult\":{\"Right\":2}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"DelEntry\",\"_entryIndex\":4,\"_entryPayload\":{\"jsonResult\":{\"Right\":1},\"jsonKeys\":[{\"b64\":\"YWFhcw==\"}]},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"XLenEntry\",\"_entryIndex\":5,\"_entryPayload\":{\"jsonStream\":{\"b64\":\"YWFhcw==\"},\"jsonResult\":{\"Right\":0}},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" diff --git a/test/EulerHS/Tests/Framework/MaskingSpec.hs b/test/EulerHS/Tests/Framework/MaskingSpec.hs new file mode 100644 index 00000000..5ed29a0a --- /dev/null +++ b/test/EulerHS/Tests/Framework/MaskingSpec.hs @@ -0,0 +1,58 @@ +module EulerHS.Tests.Framework.MaskingSpec (spec) where + +import EulerHS.Prelude hiding (readFile) +import qualified Data.ByteString.Lazy as LBS +import qualified EulerHS.Types as CType +import qualified Data.HashSet as HashSet +import Test.Hspec + +spec :: Spec +spec = + describe "Outgoing API call log masking" $ do + it "Should Mask All the blackListed Keys" $ do + let rawRequest = inputJSON + let maskText = "$$$" + let mbMaskConfig = Just $ makeLogMaskingConfig CType.BlackListKey ["id", "url1","a"] maskText + let maskedValue = CType.parseRequestResponseBody (CType.shouldMaskKey mbMaskConfig) maskText Nothing (LBS.toStrict rawRequest) + maskedValue `shouldBe` expectedOutput + it "Should Mask All the blackListed Keys" $ do + let rawRequest = inputJSON + let maskText = "$**$" + let mbMaskConfig = Just $ makeLogMaskingConfig CType.WhiteListKey ["id", "url1","a"] maskText + let maskedValue = CType.parseRequestResponseBody (CType.shouldMaskKey mbMaskConfig) maskText (Just (encodeUtf8 ("application/json" :: Text))) (LBS.toStrict rawRequest) + maskedValue `shouldBe` expectedOutput' + it "Should Not Mask Any Keys" $ do + let rawRequest = inputJSON + let maskText = "$**$" + let mbMaskConfig = Nothing + let maskedValue = CType.parseRequestResponseBody (CType.shouldMaskKey mbMaskConfig) maskText Nothing (LBS.toStrict rawRequest) + maskedValue `shouldBe` expectedOutput'' + it "Should Mask Complete Body for HTML content type" $ do + let rawRequest = inputJSON + let maskText = "$**$" + let mbMaskConfig = Nothing + let maskedValue = CType.parseRequestResponseBody (CType.shouldMaskKey mbMaskConfig) maskText (Just (encodeUtf8 ("application/html" :: Text))) (LBS.toStrict rawRequest) + maskedValue `shouldBe` expectedOutput''' + +expectedOutput :: Text +expectedOutput = "{\"status\":\"INIT\",\"txnId\":\"paypal-tatapay_740-1\",\"txnDetailId\":\"2148428442\",\"responseAttempted\":{\"lastUpdated\":\"2020-09-25T05:58:13Z\",\"gatewayAuthReqParams\":\"{\\\"euler-api-gateway\\\":\\\"fehfioe\\\"}\",\"dateCreated\":\"2020-09-25T05:58:13Z\",\"challengesAttempted\":0,\"canAcceptResponse\":true,\"id\":\"$$$\"},\"version\":0,\"url1\":\"$$$\",\"type\":\"VBV\"}" + +expectedOutput' :: Text +expectedOutput' = "{\"status\":\"$**$\",\"txnId\":\"$**$\",\"txnDetailId\":\"$**$\",\"responseAttempted\":\"$**$\",\"version\":\"$**$\",\"url1\":[{\"a\":\"b\"},\"wefojoefwj\"],\"type\":\"$**$\"}" + +expectedOutput'' :: Text +expectedOutput'' = "{\"status\":\"INIT\",\"txnId\":\"paypal-tatapay_740-1\",\"txnDetailId\":\"2148428442\",\"responseAttempted\":{\"lastUpdated\":\"2020-09-25T05:58:13Z\",\"gatewayAuthReqParams\":\"{\\\"euler-api-gateway\\\":\\\"fehfioe\\\"}\",\"dateCreated\":\"2020-09-25T05:58:13Z\",\"challengesAttempted\":0,\"canAcceptResponse\":true,\"id\":\"2148361678\"},\"version\":0,\"url1\":[{\"a\":\"b\"},\"wefojoefwj\"],\"type\":\"VBV\"}" + +expectedOutput''' :: Text +expectedOutput''' = "Logging Not Support For this content" + +inputJSON :: LBS.ByteString +inputJSON = "{\"version\": 0,\"url1\": [{\"a\":\"b\"},\"wefojoefwj\"],\"type\": \"VBV\",\"txnId\": \"paypal-tatapay_740-1\",\"txnDetailId\": \"2148428442\",\"status\": \"INIT\",\"responseAttempted\": {\"lastUpdated\": \"2020-09-25T05:58:13Z\",\"id\": \"2148361678\",\"gatewayAuthReqParams\": \"{\\\"euler-api-gateway\\\":\\\"fehfioe\\\"}\",\"dateCreated\": \"2020-09-25T05:58:13Z\",\"challengesAttempted\": 0,\"canAcceptResponse\": true}}" + +makeLogMaskingConfig :: CType.MaskKeyType -> [Text] -> Text -> CType.LogMaskingConfig +makeLogMaskingConfig keyType keyList maskText = + CType.LogMaskingConfig + { _maskKeys = HashSet.fromList keyList + , _maskText = Just maskText + , _keyType = keyType + } \ No newline at end of file diff --git a/test/EulerHS/Tests/Framework/PubSubSpec.hs b/test/EulerHS/Tests/Framework/PubSubSpec.hs index eb09ea57..fb6e97d2 100644 --- a/test/EulerHS/Tests/Framework/PubSubSpec.hs +++ b/test/EulerHS/Tests/Framework/PubSubSpec.hs @@ -1,41 +1,39 @@ module EulerHS.Tests.Framework.PubSubSpec - ( spec + ( + -- spec ) where -import EulerHS.Prelude +-- import Common (emptyMVarWithWatchDog, replayRecording) +-- import Data.Aeson +-- import qualified Database.Redis as R +-- import EulerHS.Language as L +-- import EulerHS.Prelude +-- import EulerHS.Types as T +-- import Test.Hspec -import Test.Hspec +-- connectInfo :: R.ConnectInfo +-- connectInfo = R.defaultConnectInfo {R.connectHost = "redis"} -import Data.Aeson -import qualified Database.Redis as R -import EulerHS.Language as L -import EulerHS.Tests.Framework.Common -import EulerHS.Types as T +-- runWithRedisConn_ :: ResultRecording -> Flow b -> IO b +-- runWithRedisConn_ = replayRecording +-- -- runWithRedisConn_ = runWithRedisConn connectInfo -connectInfo :: R.ConnectInfo -connectInfo = R.defaultConnectInfo {R.connectHost = "redis"} +-- spec :: Spec +-- spec = do +-- describe "Publish/Subscribe subsystem tests" $ do +-- it "Callback receives messages from channel it subscribed to" $ do +-- let testMsg = "Hello, Tests" +-- let testCh = "test" +-- (targetMVar, watch, _) <- emptyMVarWithWatchDog 1 +-- result <- runWithRedisConn_ rr1 $ do +-- subscribe [Channel testCh] $ \msg -> L.runIO $ +-- putMVar targetMVar msg -runWithRedisConn_ :: ResultRecording -> Flow b -> IO b -runWithRedisConn_ = replayRecording --- runWithRedisConn_ = runWithRedisConn connectInfo +-- publish (Channel testCh) $ Payload testMsg -spec :: Spec -spec = do - describe "Publish/Subscribe subsystem tests" $ do - it "Callback receives messages from channel it subscribed to" $ do - let testMsg = "Hello, Tests" - let testCh = "test" - (targetMVar, watch, _) <- emptyMVarWithWatchDog 1 - - result <- runWithRedisConn_ rr1 $ do - subscribe [Channel testCh] $ \msg -> L.runIO $ - putMVar targetMVar msg - - publish (Channel testCh) $ Payload testMsg - - L.runIO watch - result `shouldBe` Just testMsg +-- L.runIO watch +-- result `shouldBe` Just testMsg -- TODO: This test is brittle if replayed with pre-recorded ART-traces, -- as this ties it deeply to the implementation; instead we should @@ -63,134 +61,134 @@ spec = do -- result `shouldBe` Just testMsg - it "Callback does not receive messages from channel after unsubscribe (subscribe method)" $ do - let testMsg = "Hello, Tests" - let testCh = "test" - (targetMVar, watch, _) <- emptyMVarWithWatchDog 1 +-- it "Callback does not receive messages from channel after unsubscribe (subscribe method)" $ do +-- let testMsg = "Hello, Tests" +-- let testCh = "test" +-- (targetMVar, watch, _) <- emptyMVarWithWatchDog 1 - result <- runWithRedisConn_ rr3 $ do - unsubscribe <- subscribe [Channel testCh] $ \msg -> L.runIO $ - putMVar targetMVar msg +-- result <- runWithRedisConn_ rr3 $ do +-- unsubscribe <- subscribe [Channel testCh] $ \msg -> L.runIO $ +-- putMVar targetMVar msg - unsubscribe +-- unsubscribe - publish (Channel testCh) $ Payload testMsg +-- publish (Channel testCh) $ Payload testMsg - L.runIO watch +-- L.runIO watch - result `shouldBe` Nothing +-- result `shouldBe` Nothing - it "Callback receives messages from channel it subscribed to, if pattern matches" $ do - let testMsg = "Hello, Tests" - let testCh0 = "0test" - let testCh1 = "1test" - let testPatt = "?test" - (targetMVar, watch, reset) <- emptyMVarWithWatchDog 1 +-- it "Callback receives messages from channel it subscribed to, if pattern matches" $ do +-- let testMsg = "Hello, Tests" +-- let testCh0 = "0test" +-- let testCh1 = "1test" +-- let testPatt = "?test" +-- (targetMVar, watch, reset) <- emptyMVarWithWatchDog 1 - result <- runWithRedisConn_ rr4 $ do - void $ psubscribe [ChannelPattern testPatt] $ \ch msg -> L.runIO $ - putMVar targetMVar (ch, msg) +-- result <- runWithRedisConn_ rr4 $ do +-- void $ psubscribe [ChannelPattern testPatt] $ \ch msg -> L.runIO $ +-- putMVar targetMVar (ch, msg) - L.publish (Channel testCh0) $ Payload testMsg - result0 <- L.runIO $ watch <* reset +-- L.publish (Channel testCh0) $ Payload testMsg +-- result0 <- L.runIO $ watch <* reset - L.publish (Channel testCh1) $ Payload testMsg - result1 <- L.runIO $ watch <* reset +-- L.publish (Channel testCh1) $ Payload testMsg +-- result1 <- L.runIO $ watch <* reset - pure (result0, result1) +-- pure (result0, result1) - result `shouldBe` - ( Just (testCh0, testMsg) - , Just (testCh1, testMsg) - ) +-- result `shouldBe` +-- ( Just (testCh0, testMsg) +-- , Just (testCh1, testMsg) +-- ) - it "Callback does not receive messages from channel after unsubscribe (psubscribe method)" $ do - let testMsg = "Hello, Tests" - let testCh = "ptest" - let testPatt = "?test" - (targetMVar, watch, _) <- emptyMVarWithWatchDog 1 +-- it "Callback does not receive messages from channel after unsubscribe (psubscribe method)" $ do +-- let testMsg = "Hello, Tests" +-- let testCh = "ptest" +-- let testPatt = "?test" +-- (targetMVar, watch, _) <- emptyMVarWithWatchDog 1 - result <- runWithRedisConn_ rr5 $ do - unsubscribe <- psubscribe [ChannelPattern testPatt] $ \ch msg -> L.runIO $ - putMVar targetMVar (ch, msg) +-- result <- runWithRedisConn_ rr5 $ do +-- unsubscribe <- psubscribe [ChannelPattern testPatt] $ \ch msg -> L.runIO $ +-- putMVar targetMVar (ch, msg) - unsubscribe +-- unsubscribe - publish (Channel testCh) $ Payload testMsg +-- publish (Channel testCh) $ Payload testMsg - L.runIO watch +-- L.runIO watch - result `shouldBe` Nothing +-- result `shouldBe` Nothing - it "Callback receive messages from all subscribed channels" $ do - let testMsg0 = "Hello, Tests_0" - let testMsg1 = "Hello, Tests_1" - let testCh0 = "test_0" - let testCh1 = "test_1" - (targetMVar, watch, reset) <- emptyMVarWithWatchDog 1 +-- it "Callback receive messages from all subscribed channels" $ do +-- let testMsg0 = "Hello, Tests_0" +-- let testMsg1 = "Hello, Tests_1" +-- let testCh0 = "test_0" +-- let testCh1 = "test_1" +-- (targetMVar, watch, reset) <- emptyMVarWithWatchDog 1 - result <- runWithRedisConn_ rr6 $ do - void $ L.subscribe [Channel testCh0, Channel testCh1] $ \msg -> L.runIO $ - putMVar targetMVar msg +-- result <- runWithRedisConn_ rr6 $ do +-- void $ L.subscribe [Channel testCh0, Channel testCh1] $ \msg -> L.runIO $ +-- putMVar targetMVar msg - L.publish (Channel testCh0) $ Payload testMsg0 - result0 <- L.runIO $ watch <* reset +-- L.publish (Channel testCh0) $ Payload testMsg0 +-- result0 <- L.runIO $ watch <* reset - L.publish (Channel testCh1) $ Payload testMsg1 - result1 <- L.runIO $ watch <* reset +-- L.publish (Channel testCh1) $ Payload testMsg1 +-- result1 <- L.runIO $ watch <* reset - pure (result0, result1) +-- pure (result0, result1) - result `shouldBe` (Just testMsg0, Just testMsg1) +-- result `shouldBe` (Just testMsg0, Just testMsg1) - it "Unsubscribe unsubscribes from all subscribed channels" $ do - let testMsg0 = "Hello, Tests_0" - let testMsg1 = "Hello, Tests_1" - let testCh0 = "test_0" - let testCh1 = "test_1" - (targetMVar, watch, reset) <- emptyMVarWithWatchDog 1 +-- it "Unsubscribe unsubscribes from all subscribed channels" $ do +-- let testMsg0 = "Hello, Tests_0" +-- let testMsg1 = "Hello, Tests_1" +-- let testCh0 = "test_0" +-- let testCh1 = "test_1" +-- (targetMVar, watch, reset) <- emptyMVarWithWatchDog 1 - result <- runWithRedisConn_ rr7 $ do - unsubscribe <- L.subscribe [Channel testCh0, Channel testCh1] $ \msg -> L.runIO $ - putMVar targetMVar msg +-- result <- runWithRedisConn_ rr7 $ do +-- unsubscribe <- L.subscribe [Channel testCh0, Channel testCh1] $ \msg -> L.runIO $ +-- putMVar targetMVar msg - unsubscribe +-- unsubscribe - L.publish (Channel testCh0) $ Payload testMsg0 - result0 <- L.runIO $ watch <* reset +-- L.publish (Channel testCh0) $ Payload testMsg0 +-- result0 <- L.runIO $ watch <* reset - L.publish (Channel testCh1) $ Payload testMsg1 - result1 <- L.runIO $ watch <* reset +-- L.publish (Channel testCh1) $ Payload testMsg1 +-- result1 <- L.runIO $ watch <* reset - pure (result0, result1) +-- pure (result0, result1) - result `shouldBe` (Nothing, Nothing) +-- result `shouldBe` (Nothing, Nothing) --- Callback receives messages from channel it subscribed to -rr1 :: ResultRecording -rr1 = fromJust $ decode $ "{\"recording\":[{\"_entryName\":\"SubscribeEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonChannels\":[{\"utf8\":\"test\",\"b64\":\"dGVzdA==\"}]},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"PublishEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonChannel\":{\"utf8\":\"test\",\"b64\":\"dGVzdA==\"},\"jsonPayload\":{\"utf8\":\"Hello, Tests\",\"b64\":\"SGVsbG8sIFRlc3Rz\"},\"jsonResult\":{\"Right\":1}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonResult\":{\"utf8\":\"Hello, Tests\",\"b64\":\"SGVsbG8sIFRlc3Rz\"},\"description\":\"\"},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" +-- -- Callback receives messages from channel it subscribed to +-- rr1 :: ResultRecording +-- rr1 = fromJust $ decode $ "{\"recording\":[{\"_entryName\":\"SubscribeEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonChannels\":[{\"b64\":\"dGVzdA==\"}]},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"PublishEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonChannel\":{\"b64\":\"dGVzdA==\"},\"jsonPayload\":{\"b64\":\"SGVsbG8sIFRlc3Rz\"},\"jsonResult\":{\"Right\":1}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonResult\":{\"b64\":\"SGVsbG8sIFRlc3Rz\"},\"description\":\"\"},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" -- Pub/Sub works the same way if run in fork -- rr2 :: ResultRecording -- rr2 = fromJust $ decode $ "{\"recording\":[{\"_entryName\":\"GenerateGUIDEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"guid\":\"c9239b0c-083f-4711-94af-46972f31864d\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"LogMessageEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"tag\":\"\\\"ForkFlow\\\"\",\"msg\":\"Flow forked. Description: Fork GUID: c9239b0c-083f-4711-94af-46972f31864d\",\"level\":\"Info\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"ForkEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"guid\":\"c9239b0c-083f-4711-94af-46972f31864d\",\"description\":\"Fork\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonResult\":[],\"description\":\"\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"PublishEntry\",\"_entryIndex\":4,\"_entryPayload\":{\"jsonChannel\":{\"utf8\":\"test\",\"b64\":\"dGVzdA==\"},\"jsonPayload\":{\"utf8\":\"Hello, Tests\",\"b64\":\"SGVsbG8sIFRlc3Rz\"},\"jsonResult\":{\"Right\":1}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":5,\"_entryPayload\":{\"jsonResult\":{\"utf8\":\"Hello, Tests\",\"b64\":\"SGVsbG8sIFRlc3Rz\"},\"description\":\"\"},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{\"c9239b0c-083f-4711-94af-46972f31864d\":{\"recording\":[{\"_entryName\":\"GenerateGUIDEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"guid\":\"eed089ff-3a93-4768-8b56-c9cb6d7ce26e\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunSafeFlowEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonResult\":{\"Right\":[]},\"guid\":\"eed089ff-3a93-4768-8b56-c9cb6d7ce26e\"},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{\"eed089ff-3a93-4768-8b56-c9cb6d7ce26e\":[{\"_entryName\":\"SubscribeEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonChannels\":[{\"utf8\":\"test\",\"b64\":\"dGVzdA==\"}]},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonResult\":[],\"description\":\"\"},\"_entryReplayMode\":\"Normal\"}]}}},\"safeRecordings\":{}}" -- Callback does not receive messages from channel after unsubscribe (subscribe method) -rr3 :: ResultRecording -rr3 = fromJust $ decode $ "{\"recording\":[{\"_entryName\":\"SubscribeEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonChannels\":[{\"utf8\":\"test\",\"b64\":\"dGVzdA==\"}]},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonResult\":[],\"description\":\"subscribe\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"PublishEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonChannel\":{\"utf8\":\"test\",\"b64\":\"dGVzdA==\"},\"jsonPayload\":{\"utf8\":\"Hello, Tests\",\"b64\":\"SGVsbG8sIFRlc3Rz\"},\"jsonResult\":{\"Right\":1}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonResult\":null,\"description\":\"\"},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" +-- rr3 :: ResultRecording +-- rr3 = fromJust $ decode $ "{\"recording\":[{\"_entryName\":\"SubscribeEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonChannels\":[{\"b64\":\"dGVzdA==\"}]},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonResult\":[],\"description\":\"subscribe\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"PublishEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonChannel\":{\"b64\":\"dGVzdA==\"},\"jsonPayload\":{\"b64\":\"SGVsbG8sIFRlc3Rz\"},\"jsonResult\":{\"Right\":1}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonResult\":null,\"description\":\"\"},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" --- Callback receives messages from channel it subscribed to, if pattern matches -rr4 :: ResultRecording -rr4 = fromJust $ decode $ "{\"recording\":[{\"_entryName\":\"PSubscribeEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonPatterns\":[{\"utf8\":\"?test\",\"b64\":\"P3Rlc3Q=\"}]},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"PublishEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonChannel\":{\"utf8\":\"0test\",\"b64\":\"MHRlc3Q=\"},\"jsonPayload\":{\"utf8\":\"Hello, Tests\",\"b64\":\"SGVsbG8sIFRlc3Rz\"},\"jsonResult\":{\"Right\":1}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonResult\":[{\"utf8\":\"0test\",\"b64\":\"MHRlc3Q=\"},{\"utf8\":\"Hello, Tests\",\"b64\":\"SGVsbG8sIFRlc3Rz\"}],\"description\":\"\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"PublishEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonChannel\":{\"utf8\":\"1test\",\"b64\":\"MXRlc3Q=\"},\"jsonPayload\":{\"utf8\":\"Hello, Tests\",\"b64\":\"SGVsbG8sIFRlc3Rz\"},\"jsonResult\":{\"Right\":1}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":4,\"_entryPayload\":{\"jsonResult\":[{\"utf8\":\"1test\",\"b64\":\"MXRlc3Q=\"},{\"utf8\":\"Hello, Tests\",\"b64\":\"SGVsbG8sIFRlc3Rz\"}],\"description\":\"\"},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" +-- -- Callback receives messages from channel it subscribed to, if pattern matches +-- rr4 :: ResultRecording +-- rr4 = fromJust $ decode $ "{\"recording\":[{\"_entryName\":\"PSubscribeEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonPatterns\":[{\"b64\":\"P3Rlc3Q=\"}]},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"PublishEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonChannel\":{\"b64\":\"MHRlc3Q=\"},\"jsonPayload\":{\"b64\":\"SGVsbG8sIFRlc3Rz\"},\"jsonResult\":{\"Right\":1}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonResult\":[{\"b64\":\"MHRlc3Q=\"},{\"b64\":\"SGVsbG8sIFRlc3Rz\"}],\"description\":\"\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"PublishEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonChannel\":{\"b64\":\"MXRlc3Q=\"},\"jsonPayload\":{\"b64\":\"SGVsbG8sIFRlc3Rz\"},\"jsonResult\":{\"Right\":1}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":4,\"_entryPayload\":{\"jsonResult\":[{\"b64\":\"MXRlc3Q=\"},{\"b64\":\"SGVsbG8sIFRlc3Rz\"}],\"description\":\"\"},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" --- Callback does not receive messages from channel after unsubscribe (psubscribe method) -rr5 :: ResultRecording -rr5 = fromJust $ decode $ "{\"recording\":[{\"_entryName\":\"PSubscribeEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonPatterns\":[{\"utf8\":\"?test\",\"b64\":\"P3Rlc3Q=\"}]},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonResult\":[],\"description\":\"psubscribe\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"PublishEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonChannel\":{\"utf8\":\"ptest\",\"b64\":\"cHRlc3Q=\"},\"jsonPayload\":{\"utf8\":\"Hello, Tests\",\"b64\":\"SGVsbG8sIFRlc3Rz\"},\"jsonResult\":{\"Right\":1}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonResult\":null,\"description\":\"\"},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" +-- -- Callback does not receive messages from channel after unsubscribe (psubscribe method) +-- rr5 :: ResultRecording +-- rr5 = fromJust $ decode $ "{\"recording\":[{\"_entryName\":\"PSubscribeEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonPatterns\":[{\"b64\":\"P3Rlc3Q=\"}]},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonResult\":[],\"description\":\"psubscribe\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"PublishEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonChannel\":{\"b64\":\"cHRlc3Q=\"},\"jsonPayload\":{\"b64\":\"SGVsbG8sIFRlc3Rz\"},\"jsonResult\":{\"Right\":1}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonResult\":null,\"description\":\"\"},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" --- Callback receive messages from all subscribed channels -rr6 :: ResultRecording -rr6 = fromJust $ decode $ "{\"recording\":[{\"_entryName\":\"SubscribeEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonChannels\":[{\"utf8\":\"test_0\",\"b64\":\"dGVzdF8w\"},{\"utf8\":\"test_1\",\"b64\":\"dGVzdF8x\"}]},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"PublishEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonChannel\":{\"utf8\":\"test_0\",\"b64\":\"dGVzdF8w\"},\"jsonPayload\":{\"utf8\":\"Hello, Tests_0\",\"b64\":\"SGVsbG8sIFRlc3RzXzA=\"},\"jsonResult\":{\"Right\":1}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonResult\":{\"utf8\":\"Hello, Tests_0\",\"b64\":\"SGVsbG8sIFRlc3RzXzA=\"},\"description\":\"\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"PublishEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonChannel\":{\"utf8\":\"test_1\",\"b64\":\"dGVzdF8x\"},\"jsonPayload\":{\"utf8\":\"Hello, Tests_1\",\"b64\":\"SGVsbG8sIFRlc3RzXzE=\"},\"jsonResult\":{\"Right\":1}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":4,\"_entryPayload\":{\"jsonResult\":{\"utf8\":\"Hello, Tests_1\",\"b64\":\"SGVsbG8sIFRlc3RzXzE=\"},\"description\":\"\"},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" +-- -- Callback receive messages from all subscribed channels +-- rr6 :: ResultRecording +-- rr6 = fromJust $ decode $ "{\"recording\":[{\"_entryName\":\"SubscribeEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonChannels\":[{\"b64\":\"dGVzdF8w\"},{\"b64\":\"dGVzdF8x\"}]},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"PublishEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonChannel\":{\"b64\":\"dGVzdF8w\"},\"jsonPayload\":{\"b64\":\"SGVsbG8sIFRlc3RzXzA=\"},\"jsonResult\":{\"Right\":1}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonResult\":{\"b64\":\"SGVsbG8sIFRlc3RzXzA=\"},\"description\":\"\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"PublishEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonChannel\":{\"b64\":\"dGVzdF8x\"},\"jsonPayload\":{\"b64\":\"SGVsbG8sIFRlc3RzXzE=\"},\"jsonResult\":{\"Right\":1}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":4,\"_entryPayload\":{\"jsonResult\":{\"b64\":\"SGVsbG8sIFRlc3RzXzE=\"},\"description\":\"\"},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" --- Unsubscribe unsubscribes from all subscribed channels -rr7 :: ResultRecording -rr7 = fromJust $ decode $ "{\"recording\":[{\"_entryName\":\"SubscribeEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonChannels\":[{\"utf8\":\"test_0\",\"b64\":\"dGVzdF8w\"},{\"utf8\":\"test_1\",\"b64\":\"dGVzdF8x\"}]},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonResult\":[],\"description\":\"subscribe\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"PublishEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonChannel\":{\"utf8\":\"test_0\",\"b64\":\"dGVzdF8w\"},\"jsonPayload\":{\"utf8\":\"Hello, Tests_0\",\"b64\":\"SGVsbG8sIFRlc3RzXzA=\"},\"jsonResult\":{\"Right\":1}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonResult\":null,\"description\":\"\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"PublishEntry\",\"_entryIndex\":4,\"_entryPayload\":{\"jsonChannel\":{\"utf8\":\"test_1\",\"b64\":\"dGVzdF8x\"},\"jsonPayload\":{\"utf8\":\"Hello, Tests_1\",\"b64\":\"SGVsbG8sIFRlc3RzXzE=\"},\"jsonResult\":{\"Right\":0}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":5,\"_entryPayload\":{\"jsonResult\":null,\"description\":\"\"},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" +-- -- Unsubscribe unsubscribes from all subscribed channels +-- rr7 :: ResultRecording +-- rr7 = fromJust $ decode $ "{\"recording\":[{\"_entryName\":\"SubscribeEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"jsonChannels\":[{\"b64\":\"dGVzdF8w\"},{\"b64\":\"dGVzdF8x\"}]},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"jsonResult\":[],\"description\":\"subscribe\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"PublishEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"jsonChannel\":{\"b64\":\"dGVzdF8w\"},\"jsonPayload\":{\"b64\":\"SGVsbG8sIFRlc3RzXzA=\"},\"jsonResult\":{\"Right\":1}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonResult\":null,\"description\":\"\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"PublishEntry\",\"_entryIndex\":4,\"_entryPayload\":{\"jsonChannel\":{\"b64\":\"dGVzdF8x\"},\"jsonPayload\":{\"b64\":\"SGVsbG8sIFRlc3RzXzE=\"},\"jsonResult\":{\"Right\":0}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":5,\"_entryPayload\":{\"jsonResult\":null,\"description\":\"\"},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" diff --git a/test/EulerHS/Tests/Framework/SQLArtSpec.hs b/test/EulerHS/Tests/Framework/SQLArtSpec.hs index d61f2b94..298b4484 100644 --- a/test/EulerHS/Tests/Framework/SQLArtSpec.hs +++ b/test/EulerHS/Tests/Framework/SQLArtSpec.hs @@ -2,169 +2,195 @@ {-# LANGUAGE StandaloneDeriving #-} module EulerHS.Tests.Framework.SQLArtSpec - ( spec + ( + -- spec ) where -import EulerHS.Prelude - -import Data.Aeson as A -import Data.Aeson.Encode.Pretty -import qualified Data.Map as Map -import qualified Database.Beam as B -import qualified Database.Beam.Backend.SQL as B -import qualified Database.Beam.Query as B -import Database.Beam.Sqlite.Connection (Sqlite, SqliteM) -import Test.Hspec - -import EulerHS.Interpreters as I -import EulerHS.Language as L -import EulerHS.Runtime -import EulerHS.Tests.Framework.Common -import EulerHS.Tests.Framework.DBSetup -import EulerHS.Types as T - - -run = replayRecording - --- Tests - -spec :: Spec -spec = - around (withEmptyDB) $ do - describe "ART SQL tests" $ do - - it "success to get one correct row" $ \rt -> do - result <- run getRowRecord $ do - conn <- connectOrFail sqliteCfg - L.runDB conn $ do - L.insertRows $ B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates"] - res <- L.findRow $ B.select $ B.filter_ (\u -> _userGUID u B.==. 1) $ B.all_ (users userDB) - L.deleteRows $ B.delete (users userDB) (\u -> _userGUID u B.==. 1) - pure res - result `shouldBe` Right (Just (User {_userGUID = 1, _firstName = "Bill", _lastName = "Gates"})) - - it "fail to get one wrong row" $ \rt -> do - result <- run getWrongRowRecord $ do - conn <- connectOrFail sqliteCfg - L.runDB conn $ do - L.insertRows $ B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates"] - res <- L.findRow $ B.select $ B.filter_ (\u -> _userGUID u B.==. 2) $ B.all_ (users userDB) - L.deleteRows $ B.delete (users userDB) (\u -> _userGUID u B.==. 1) - pure res - result `shouldBe` Right Nothing - - it "success to get correct rows" $ \rt -> do - result <- run getRowsRecord $ do - conn <- connectOrFail sqliteCfg - L.runDB conn $ do - L.insertRows $ B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates", User 2 "Stive" "Jobs"] - res <- L.findRows $ B.select $ B.filter_ (\u -> _userGUID u `B.in_` [1,2]) $ B.all_ (users userDB) - L.deleteRows $ B.delete (users userDB) (\u -> (_userGUID u) `B.in_` [1,2]) - pure res - result `shouldBe` Right - [ User {_userGUID = 1, _firstName = "Bill", _lastName = "Gates"} - , User {_userGUID = 2, _firstName = "Stive", _lastName = "Jobs"} - ] - - it "fail to get an uncorrect rows" $ \rt -> do - result <- run getWrongRowsRecord $ do - conn <- connectOrFail sqliteCfg - L.runDB conn $ do - L.insertRows $ B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates", User 2 "Stive" "Jobs"] - res <- L.findRows $ B.select $ B.filter_ (\u -> _userGUID u `B.in_` [3,4]) $ B.all_ (users userDB) - L.deleteRows $ B.delete (users userDB) (\u -> (_userGUID u) `B.in_` [1,2]) - pure res - result `shouldBe` Right [] - - it "success to delete existing rows" $ \rt -> do - result <- run deleteRowsRecord $ do - conn <- connectOrFail sqliteCfg - L.runDB conn $ do - L.insertRows $ B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates", User 2 "Stive" "Jobs"] - L.deleteRows $ B.delete (users userDB) (\u -> (_userGUID u) `B.in_` [1,2]) - res <- L.findRows $ B.select $ B.filter_ (\u -> _userGUID u `B.in_` [1,2]) $ B.all_ (users userDB) - pure res - result `shouldBe` Right [] - - it "fail to delete wrong rows" $ \rt -> do - result <- run deleteWrongRowsRecord $ do - conn <- connectOrFail sqliteCfg - L.runDB conn $ do - L.insertRows $ B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates", User 2 "Stive" "Jobs"] - L.deleteRows $ B.delete (users userDB) (\u -> (_userGUID u) `B.in_` [3,4]) - res <- L.findRows $ B.select $ B.filter_ (\u -> _userGUID u `B.in_` [1,2]) $ B.all_ (users userDB) - L.deleteRows $ B.delete (users userDB) (\u -> (_userGUID u) `B.in_` [1,2]) - pure res - result `shouldBe` Right - [ User {_userGUID = 1, _firstName = "Bill", _lastName = "Gates"} - , User {_userGUID = 2, _firstName = "Stive", _lastName = "Jobs"} - ] - - it "success to update rows" $ \rt -> do - result <- run updateRowRecord $ do - conn <- connectOrFail sqliteCfg - L.runDB conn $ do - L.insertRows $ B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates", User 2 "Stive" "Jobs"] - L.updateRows $ B.update (users userDB) - (\user -> _firstName user B.<-. B.val_ "Robert") - (\user -> _userGUID user B.==. 1) - res <- L.findRows $ B.select $ B.filter_ (\u -> _userGUID u `B.in_` [1,2]) $ B.all_ (users userDB) - L.deleteRows $ B.delete (users userDB) (\u -> (_userGUID u) `B.in_` [1,2]) - pure res - result `shouldBe` Right - [ User {_userGUID = 1, _firstName = "Robert", _lastName = "Gates"} - , User {_userGUID = 2, _firstName = "Stive", _lastName = "Jobs"} - ] - - it "success to update rows with IO action in between" $ \rt -> do - result <- run updateRowWithDelayRecord $ do - conn <- connectOrFail sqliteCfg - L.runDB conn $ do - L.insertRows $ B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates", User 2 "Stive" "Jobs"] - L.updateRows $ B.update (users userDB) - (\user -> _firstName user B.<-. B.val_ "Robert") - (\user -> _userGUID user B.==. 1) - L.runIO $ threadDelay (2 * 10 ^ 6) - L.runDB conn $ do - res <- L.findRows $ B.select $ B.filter_ (\u -> _userGUID u `B.in_` [1,2]) $ B.all_ (users userDB) - L.deleteRows $ B.delete (users userDB) (\u -> (_userGUID u) `B.in_` [1,2]) - pure res - result `shouldBe` Right - [ User {_userGUID = 1, _firstName = "Robert", _lastName = "Gates"} - , User {_userGUID = 2, _firstName = "Stive", _lastName = "Jobs"} - ] - - --- Use testRecord to generate record log to 'recorder' file -getRowRecord :: ResultRecording -getRowRecord = fromJust $ decode - "{\"recording\":[{\"_entryName\":\"GetSqlDBConnectionEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"getConnResult\":{\"Left\":[{\"tag\":\"ConnectionDoesNotExist\"},\"Connection for SQliteDB does not exists.\"]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"InitSqlDBConnectionEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"initConnResult\":{\"Right\":[]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunDBEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"rawSql\":[\"INSERT INTO \\\"users\\\"(\\\"id\\\", \\\"first_name\\\", \\\"last_name\\\") VALUES (?, ?, ?);\\n-- With values: [SQLInteger 1,SQLText \\\"Bill\\\",SQLText \\\"Gates\\\"]\",\"SELECT \\\"t0\\\".\\\"id\\\" AS \\\"res0\\\", \\\"t0\\\".\\\"first_name\\\" AS \\\"res1\\\", \\\"t0\\\".\\\"last_name\\\" AS \\\"res2\\\" FROM \\\"users\\\" AS \\\"t0\\\" WHERE (\\\"t0\\\".\\\"id\\\")=(?);\\n-- With values: [SQLInteger 1]\",\"DELETE FROM \\\"users\\\" WHERE (\\\"id\\\")=(?);\\n-- With values: [SQLInteger 1]\"],\"jsonResult\":{\"Right\":{\"_userGUID\":1,\"_lastName\":\"Gates\",\"_firstName\":\"Bill\"}}},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" - -getWrongRowRecord :: ResultRecording -getWrongRowRecord = fromJust $ decode - "{\"recording\":[{\"_entryName\":\"GetSqlDBConnectionEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"getConnResult\":{\"Left\":[{\"tag\":\"ConnectionDoesNotExist\"},\"Connection for SQliteDB does not exists.\"]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"InitSqlDBConnectionEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"initConnResult\":{\"Right\":[]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunDBEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"rawSql\":[\"INSERT INTO \\\"users\\\"(\\\"id\\\", \\\"first_name\\\", \\\"last_name\\\") VALUES (?, ?, ?);\\n-- With values: [SQLInteger 1,SQLText \\\"Bill\\\",SQLText \\\"Gates\\\"]\",\"SELECT \\\"t0\\\".\\\"id\\\" AS \\\"res0\\\", \\\"t0\\\".\\\"first_name\\\" AS \\\"res1\\\", \\\"t0\\\".\\\"last_name\\\" AS \\\"res2\\\" FROM \\\"users\\\" AS \\\"t0\\\" WHERE (\\\"t0\\\".\\\"id\\\")=(?);\\n-- With values: [SQLInteger 2]\",\"DELETE FROM \\\"users\\\" WHERE (\\\"id\\\")=(?);\\n-- With values: [SQLInteger 1]\"],\"jsonResult\":{\"Right\":null}},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" - -getRowsRecord :: ResultRecording -getRowsRecord = fromJust $ decode - "{\"recording\":[{\"_entryName\":\"GetSqlDBConnectionEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"getConnResult\":{\"Left\":[{\"tag\":\"ConnectionDoesNotExist\"},\"Connection for SQliteDB does not exists.\"]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"InitSqlDBConnectionEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"initConnResult\":{\"Right\":[]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunDBEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"rawSql\":[\"INSERT INTO \\\"users\\\"(\\\"id\\\", \\\"first_name\\\", \\\"last_name\\\") VALUES (?, ?, ?), (?, ?, ?);\\n-- With values: [SQLInteger 1,SQLText \\\"Bill\\\",SQLText \\\"Gates\\\",SQLInteger 2,SQLText \\\"Stive\\\",SQLText \\\"Jobs\\\"]\",\"SELECT \\\"t0\\\".\\\"id\\\" AS \\\"res0\\\", \\\"t0\\\".\\\"first_name\\\" AS \\\"res1\\\", \\\"t0\\\".\\\"last_name\\\" AS \\\"res2\\\" FROM \\\"users\\\" AS \\\"t0\\\" WHERE (\\\"t0\\\".\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 1,SQLInteger 2]\",\"DELETE FROM \\\"users\\\" WHERE (\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 1,SQLInteger 2]\"],\"jsonResult\":{\"Right\":[{\"_userGUID\":1,\"_lastName\":\"Gates\",\"_firstName\":\"Bill\"},{\"_userGUID\":2,\"_lastName\":\"Jobs\",\"_firstName\":\"Stive\"}]}},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" - -getWrongRowsRecord :: ResultRecording -getWrongRowsRecord = fromJust $ decode - "{\"recording\":[{\"_entryName\":\"GetSqlDBConnectionEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"getConnResult\":{\"Left\":[{\"tag\":\"ConnectionDoesNotExist\"},\"Connection for SQliteDB does not exists.\"]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"InitSqlDBConnectionEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"initConnResult\":{\"Right\":[]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunDBEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"rawSql\":[\"INSERT INTO \\\"users\\\"(\\\"id\\\", \\\"first_name\\\", \\\"last_name\\\") VALUES (?, ?, ?), (?, ?, ?);\\n-- With values: [SQLInteger 1,SQLText \\\"Bill\\\",SQLText \\\"Gates\\\",SQLInteger 2,SQLText \\\"Stive\\\",SQLText \\\"Jobs\\\"]\",\"SELECT \\\"t0\\\".\\\"id\\\" AS \\\"res0\\\", \\\"t0\\\".\\\"first_name\\\" AS \\\"res1\\\", \\\"t0\\\".\\\"last_name\\\" AS \\\"res2\\\" FROM \\\"users\\\" AS \\\"t0\\\" WHERE (\\\"t0\\\".\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 3,SQLInteger 4]\",\"DELETE FROM \\\"users\\\" WHERE (\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 1,SQLInteger 2]\"],\"jsonResult\":{\"Right\":[]}},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" - - -deleteRowsRecord :: ResultRecording -deleteRowsRecord = fromJust $ decode - "{\"recording\":[{\"_entryName\":\"GetSqlDBConnectionEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"getConnResult\":{\"Left\":[{\"tag\":\"ConnectionDoesNotExist\"},\"Connection for SQliteDB does not exists.\"]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"InitSqlDBConnectionEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"initConnResult\":{\"Right\":[]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunDBEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"rawSql\":[\"INSERT INTO \\\"users\\\"(\\\"id\\\", \\\"first_name\\\", \\\"last_name\\\") VALUES (?, ?, ?), (?, ?, ?);\\n-- With values: [SQLInteger 1,SQLText \\\"Bill\\\",SQLText \\\"Gates\\\",SQLInteger 2,SQLText \\\"Stive\\\",SQLText \\\"Jobs\\\"]\",\"DELETE FROM \\\"users\\\" WHERE (\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 1,SQLInteger 2]\",\"SELECT \\\"t0\\\".\\\"id\\\" AS \\\"res0\\\", \\\"t0\\\".\\\"first_name\\\" AS \\\"res1\\\", \\\"t0\\\".\\\"last_name\\\" AS \\\"res2\\\" FROM \\\"users\\\" AS \\\"t0\\\" WHERE (\\\"t0\\\".\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 1,SQLInteger 2]\"],\"jsonResult\":{\"Right\":[]}},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" - -deleteWrongRowsRecord :: ResultRecording -deleteWrongRowsRecord = fromJust $ decode - "{\"recording\":[{\"_entryName\":\"GetSqlDBConnectionEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"getConnResult\":{\"Left\":[{\"tag\":\"ConnectionDoesNotExist\"},\"Connection for SQliteDB does not exists.\"]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"InitSqlDBConnectionEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"initConnResult\":{\"Right\":[]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunDBEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"rawSql\":[\"INSERT INTO \\\"users\\\"(\\\"id\\\", \\\"first_name\\\", \\\"last_name\\\") VALUES (?, ?, ?), (?, ?, ?);\\n-- With values: [SQLInteger 1,SQLText \\\"Bill\\\",SQLText \\\"Gates\\\",SQLInteger 2,SQLText \\\"Stive\\\",SQLText \\\"Jobs\\\"]\",\"DELETE FROM \\\"users\\\" WHERE (\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 3,SQLInteger 4]\",\"SELECT \\\"t0\\\".\\\"id\\\" AS \\\"res0\\\", \\\"t0\\\".\\\"first_name\\\" AS \\\"res1\\\", \\\"t0\\\".\\\"last_name\\\" AS \\\"res2\\\" FROM \\\"users\\\" AS \\\"t0\\\" WHERE (\\\"t0\\\".\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 1,SQLInteger 2]\",\"DELETE FROM \\\"users\\\" WHERE (\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 1,SQLInteger 2]\"],\"jsonResult\":{\"Right\":[{\"_userGUID\":1,\"_lastName\":\"Gates\",\"_firstName\":\"Bill\"},{\"_userGUID\":2,\"_lastName\":\"Jobs\",\"_firstName\":\"Stive\"}]}},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" - -updateRowRecord :: ResultRecording -updateRowRecord = fromJust $ decode - "{\"recording\":[{\"_entryName\":\"GetSqlDBConnectionEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"getConnResult\":{\"Left\":[{\"tag\":\"ConnectionDoesNotExist\"},\"Connection for SQliteDB does not exists.\"]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"InitSqlDBConnectionEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"initConnResult\":{\"Right\":[]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunDBEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"rawSql\":[\"INSERT INTO \\\"users\\\"(\\\"id\\\", \\\"first_name\\\", \\\"last_name\\\") VALUES (?, ?, ?), (?, ?, ?);\\n-- With values: [SQLInteger 1,SQLText \\\"Bill\\\",SQLText \\\"Gates\\\",SQLInteger 2,SQLText \\\"Stive\\\",SQLText \\\"Jobs\\\"]\",\"UPDATE \\\"users\\\" SET \\\"first_name\\\"=? WHERE (\\\"id\\\")=(?);\\n-- With values: [SQLText \\\"Robert\\\",SQLInteger 1]\",\"SELECT \\\"t0\\\".\\\"id\\\" AS \\\"res0\\\", \\\"t0\\\".\\\"first_name\\\" AS \\\"res1\\\", \\\"t0\\\".\\\"last_name\\\" AS \\\"res2\\\" FROM \\\"users\\\" AS \\\"t0\\\" WHERE (\\\"t0\\\".\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 1,SQLInteger 2]\",\"DELETE FROM \\\"users\\\" WHERE (\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 1,SQLInteger 2]\"],\"jsonResult\":{\"Right\":[{\"_userGUID\":1,\"_lastName\":\"Gates\",\"_firstName\":\"Robert\"},{\"_userGUID\":2,\"_lastName\":\"Jobs\",\"_firstName\":\"Stive\"}]}},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" - -updateRowWithDelayRecord :: ResultRecording -updateRowWithDelayRecord = fromJust $ decode - "{\"recording\":[{\"_entryName\":\"GetSqlDBConnectionEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"getConnResult\":{\"Left\":[{\"tag\":\"ConnectionDoesNotExist\"},\"Connection for SQliteDB does not exists.\"]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"InitSqlDBConnectionEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"initConnResult\":{\"Right\":[]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunDBEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"rawSql\":[\"INSERT INTO \\\"users\\\"(\\\"id\\\", \\\"first_name\\\", \\\"last_name\\\") VALUES (?, ?, ?), (?, ?, ?);\\n-- With values: [SQLInteger 1,SQLText \\\"Bill\\\",SQLText \\\"Gates\\\",SQLInteger 2,SQLText \\\"Stive\\\",SQLText \\\"Jobs\\\"]\",\"UPDATE \\\"users\\\" SET \\\"first_name\\\"=? WHERE (\\\"id\\\")=(?);\\n-- With values: [SQLText \\\"Robert\\\",SQLInteger 1]\"],\"jsonResult\":{\"Right\":[]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonResult\":[],\"description\":\"\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunDBEntry\",\"_entryIndex\":4,\"_entryPayload\":{\"rawSql\":[\"SELECT \\\"t0\\\".\\\"id\\\" AS \\\"res0\\\", \\\"t0\\\".\\\"first_name\\\" AS \\\"res1\\\", \\\"t0\\\".\\\"last_name\\\" AS \\\"res2\\\" FROM \\\"users\\\" AS \\\"t0\\\" WHERE (\\\"t0\\\".\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 1,SQLInteger 2]\",\"DELETE FROM \\\"users\\\" WHERE (\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 1,SQLInteger 2]\"],\"jsonResult\":{\"Right\":[{\"_userGUID\":1,\"_lastName\":\"Gates\",\"_firstName\":\"Robert\"},{\"_userGUID\":2,\"_lastName\":\"Jobs\",\"_firstName\":\"Stive\"}]}},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" +-- import Common +-- import DBSetup +-- import Data.Aeson as A +-- import Data.Aeson.Encode.Pretty +-- import qualified Data.Map as Map +-- import qualified Database.Beam as B +-- import qualified Database.Beam.Backend.SQL as B +-- import qualified Database.Beam.Query as B +-- import Database.Beam.Sqlite.Connection (Sqlite, SqliteM) +-- import EulerHS.Interpreters as I +-- import EulerHS.Language as L +-- import EulerHS.Prelude +-- import EulerHS.Runtime +-- import EulerHS.Types as T +-- import Test.Hspec + +-- Write record to file or to stdout. Choose at 'runWithSQLConn' +-- writeRecord :: IO () +-- writeRecord = withEmptyDB $ \rt -> do +-- void $ runWithSQLConn $ do +-- conn <- connectOrFail sqliteCfg +-- L.runDB conn $ do +-- L.insertRows $ B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates"] +-- res <- L.findRow $ B.select $ B.filter_ (\u -> _userGUID u B.==. 1) $ B.all_ (users userDB) +-- L.deleteRows $ B.delete (users userDB) (\u -> _userGUID u B.==. 1) +-- pure res + +-- Record and play scenario. Return result. +-- recordAndPlay :: IO () +-- recordAndPlay = withEmptyDB $ \rt -> do +-- record <- runFlowWithArt $ do +-- conn <- connectOrFail sqliteCfg +-- L.runDB conn $ do +-- L.insertRows $ B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates"] +-- res <- L.findRow $ B.select $ B.filter_ (\u -> _userGUID u B.==. 1) $ B.all_ (users userDB) +-- L.deleteRows $ B.delete (users userDB) (\u -> _userGUID u B.==. 1) +-- pure res +-- putStrLn $ encodePretty record + + +-- run = replayRecording +-- -- run _ = runWithSQLConn + +-- -- Tests + +-- spec :: Spec +-- spec = +-- around (withEmptyDB) $ do +-- describe "ART SQL tests" $ do + +-- it "success to get one correct row" $ \rt -> do +-- result <- run getRowRecord $ do +-- conn <- connectOrFail sqliteCfg +-- L.runDB conn $ do +-- L.insertRows $ B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates"] +-- res <- L.findRow $ B.select $ B.filter_ (\u -> _userGUID u B.==. 1) $ B.all_ (users userDB) +-- L.deleteRows $ B.delete (users userDB) (\u -> _userGUID u B.==. 1) +-- pure res +-- result `shouldBe` Right (Just (User {_userGUID = 1, _firstName = "Bill", _lastName = "Gates"})) + +-- it "fail to get one wrong row" $ \rt -> do +-- result <- run getWrongRowRecord $ do +-- conn <- connectOrFail sqliteCfg +-- L.runDB conn $ do +-- L.insertRows $ B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates"] +-- res <- L.findRow $ B.select $ B.filter_ (\u -> _userGUID u B.==. 2) $ B.all_ (users userDB) +-- L.deleteRows $ B.delete (users userDB) (\u -> _userGUID u B.==. 1) +-- pure res +-- result `shouldBe` Right Nothing + +-- it "success to get correct rows" $ \rt -> do +-- result <- run getRowsRecord $ do +-- conn <- connectOrFail sqliteCfg +-- L.runDB conn $ do +-- L.insertRows $ B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates", User 2 "Stive" "Jobs"] +-- res <- L.findRows $ B.select $ B.filter_ (\u -> _userGUID u `B.in_` [1,2]) $ B.all_ (users userDB) +-- L.deleteRows $ B.delete (users userDB) (\u -> (_userGUID u) `B.in_` [1,2]) +-- pure res +-- result `shouldBe` Right +-- [ User {_userGUID = 1, _firstName = "Bill", _lastName = "Gates"} +-- , User {_userGUID = 2, _firstName = "Stive", _lastName = "Jobs"} +-- ] + +-- it "fail to get an uncorrect rows" $ \rt -> do +-- result <- run getWrongRowsRecord $ do +-- conn <- connectOrFail sqliteCfg +-- L.runDB conn $ do +-- L.insertRows $ B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates", User 2 "Stive" "Jobs"] +-- res <- L.findRows $ B.select $ B.filter_ (\u -> _userGUID u `B.in_` [3,4]) $ B.all_ (users userDB) +-- L.deleteRows $ B.delete (users userDB) (\u -> (_userGUID u) `B.in_` [1,2]) +-- pure res +-- result `shouldBe` Right [] + +-- it "success to delete existing rows" $ \rt -> do +-- result <- run deleteRowsRecord $ do +-- conn <- connectOrFail sqliteCfg +-- L.runDB conn $ do +-- L.insertRows $ B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates", User 2 "Stive" "Jobs"] +-- L.deleteRows $ B.delete (users userDB) (\u -> (_userGUID u) `B.in_` [1,2]) +-- res <- L.findRows $ B.select $ B.filter_ (\u -> _userGUID u `B.in_` [1,2]) $ B.all_ (users userDB) +-- pure res +-- result `shouldBe` Right [] + +-- it "fail to delete wrong rows" $ \rt -> do +-- result <- run deleteWrongRowsRecord $ do +-- conn <- connectOrFail sqliteCfg +-- L.runDB conn $ do +-- L.insertRows $ B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates", User 2 "Stive" "Jobs"] +-- L.deleteRows $ B.delete (users userDB) (\u -> (_userGUID u) `B.in_` [3,4]) +-- res <- L.findRows $ B.select $ B.filter_ (\u -> _userGUID u `B.in_` [1,2]) $ B.all_ (users userDB) +-- L.deleteRows $ B.delete (users userDB) (\u -> (_userGUID u) `B.in_` [1,2]) +-- pure res +-- result `shouldBe` Right +-- [ User {_userGUID = 1, _firstName = "Bill", _lastName = "Gates"} +-- , User {_userGUID = 2, _firstName = "Stive", _lastName = "Jobs"} +-- ] + +-- it "success to update rows" $ \rt -> do +-- result <- run updateRowRecord $ do +-- conn <- connectOrFail sqliteCfg +-- L.runDB conn $ do +-- L.insertRows $ B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates", User 2 "Stive" "Jobs"] +-- L.updateRows $ B.update (users userDB) +-- (\user -> _firstName user B.<-. B.val_ "Robert") +-- (\user -> _userGUID user B.==. 1) +-- res <- L.findRows $ B.select $ B.filter_ (\u -> _userGUID u `B.in_` [1,2]) $ B.all_ (users userDB) +-- L.deleteRows $ B.delete (users userDB) (\u -> (_userGUID u) `B.in_` [1,2]) +-- pure res +-- result `shouldBe` Right +-- [ User {_userGUID = 1, _firstName = "Robert", _lastName = "Gates"} +-- , User {_userGUID = 2, _firstName = "Stive", _lastName = "Jobs"} +-- ] + +-- it "success to update rows with IO action in between" $ \rt -> do +-- result <- run updateRowWithDelayRecord $ do +-- conn <- connectOrFail sqliteCfg +-- L.runDB conn $ do +-- L.insertRows $ B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates", User 2 "Stive" "Jobs"] +-- L.updateRows $ B.update (users userDB) +-- (\user -> _firstName user B.<-. B.val_ "Robert") +-- (\user -> _userGUID user B.==. 1) +-- L.runIO $ threadDelay (2 * 10 ^ 6) +-- L.runDB conn $ do +-- res <- L.findRows $ B.select $ B.filter_ (\u -> _userGUID u `B.in_` [1,2]) $ B.all_ (users userDB) +-- L.deleteRows $ B.delete (users userDB) (\u -> (_userGUID u) `B.in_` [1,2]) +-- pure res +-- result `shouldBe` Right +-- [ User {_userGUID = 1, _firstName = "Robert", _lastName = "Gates"} +-- , User {_userGUID = 2, _firstName = "Stive", _lastName = "Jobs"} +-- ] + + +-- -- Use testRecord to generate record log to 'recorder' file +-- getRowRecord :: ResultRecording +-- getRowRecord = fromJust $ decode +-- "{\"recording\":[{\"_entryName\":\"GetSqlDBConnectionEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/language/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"getConnResult\":{\"Left\":[{\"tag\":\"ConnectionDoesNotExist\"},\"Connection for SQliteDB does not exists.\"]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"InitSqlDBConnectionEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/language/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"initConnResult\":{\"Right\":[]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunDBEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"rawSql\":[\"INSERT INTO \\\"users\\\"(\\\"id\\\", \\\"first_name\\\", \\\"last_name\\\") VALUES (?, ?, ?);\\n-- With values: [SQLInteger 1,SQLText \\\"Bill\\\",SQLText \\\"Gates\\\"]\",\"SELECT \\\"t0\\\".\\\"id\\\" AS \\\"res0\\\", \\\"t0\\\".\\\"first_name\\\" AS \\\"res1\\\", \\\"t0\\\".\\\"last_name\\\" AS \\\"res2\\\" FROM \\\"users\\\" AS \\\"t0\\\" WHERE (\\\"t0\\\".\\\"id\\\")=(?);\\n-- With values: [SQLInteger 1]\",\"DELETE FROM \\\"users\\\" WHERE (\\\"id\\\")=(?);\\n-- With values: [SQLInteger 1]\"],\"jsonResult\":{\"Right\":{\"_userGUID\":1,\"_lastName\":\"Gates\",\"_firstName\":\"Bill\"}}},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" + +-- getWrongRowRecord :: ResultRecording +-- getWrongRowRecord = fromJust $ decode +-- "{\"recording\":[{\"_entryName\":\"GetSqlDBConnectionEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/language/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"getConnResult\":{\"Left\":[{\"tag\":\"ConnectionDoesNotExist\"},\"Connection for SQliteDB does not exists.\"]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"InitSqlDBConnectionEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/language/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"initConnResult\":{\"Right\":[]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunDBEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"rawSql\":[\"INSERT INTO \\\"users\\\"(\\\"id\\\", \\\"first_name\\\", \\\"last_name\\\") VALUES (?, ?, ?);\\n-- With values: [SQLInteger 1,SQLText \\\"Bill\\\",SQLText \\\"Gates\\\"]\",\"SELECT \\\"t0\\\".\\\"id\\\" AS \\\"res0\\\", \\\"t0\\\".\\\"first_name\\\" AS \\\"res1\\\", \\\"t0\\\".\\\"last_name\\\" AS \\\"res2\\\" FROM \\\"users\\\" AS \\\"t0\\\" WHERE (\\\"t0\\\".\\\"id\\\")=(?);\\n-- With values: [SQLInteger 2]\",\"DELETE FROM \\\"users\\\" WHERE (\\\"id\\\")=(?);\\n-- With values: [SQLInteger 1]\"],\"jsonResult\":{\"Right\":null}},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" + +-- getRowsRecord :: ResultRecording +-- getRowsRecord = fromJust $ decode +-- "{\"recording\":[{\"_entryName\":\"GetSqlDBConnectionEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/language/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"getConnResult\":{\"Left\":[{\"tag\":\"ConnectionDoesNotExist\"},\"Connection for SQliteDB does not exists.\"]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"InitSqlDBConnectionEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/language/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"initConnResult\":{\"Right\":[]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunDBEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"rawSql\":[\"INSERT INTO \\\"users\\\"(\\\"id\\\", \\\"first_name\\\", \\\"last_name\\\") VALUES (?, ?, ?), (?, ?, ?);\\n-- With values: [SQLInteger 1,SQLText \\\"Bill\\\",SQLText \\\"Gates\\\",SQLInteger 2,SQLText \\\"Stive\\\",SQLText \\\"Jobs\\\"]\",\"SELECT \\\"t0\\\".\\\"id\\\" AS \\\"res0\\\", \\\"t0\\\".\\\"first_name\\\" AS \\\"res1\\\", \\\"t0\\\".\\\"last_name\\\" AS \\\"res2\\\" FROM \\\"users\\\" AS \\\"t0\\\" WHERE (\\\"t0\\\".\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 1,SQLInteger 2]\",\"DELETE FROM \\\"users\\\" WHERE (\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 1,SQLInteger 2]\"],\"jsonResult\":{\"Right\":[{\"_userGUID\":1,\"_lastName\":\"Gates\",\"_firstName\":\"Bill\"},{\"_userGUID\":2,\"_lastName\":\"Jobs\",\"_firstName\":\"Stive\"}]}},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" + +-- getWrongRowsRecord :: ResultRecording +-- getWrongRowsRecord = fromJust $ decode +-- "{\"recording\":[{\"_entryName\":\"GetSqlDBConnectionEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/language/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"getConnResult\":{\"Left\":[{\"tag\":\"ConnectionDoesNotExist\"},\"Connection for SQliteDB does not exists.\"]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"InitSqlDBConnectionEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/language/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"initConnResult\":{\"Right\":[]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunDBEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"rawSql\":[\"INSERT INTO \\\"users\\\"(\\\"id\\\", \\\"first_name\\\", \\\"last_name\\\") VALUES (?, ?, ?), (?, ?, ?);\\n-- With values: [SQLInteger 1,SQLText \\\"Bill\\\",SQLText \\\"Gates\\\",SQLInteger 2,SQLText \\\"Stive\\\",SQLText \\\"Jobs\\\"]\",\"SELECT \\\"t0\\\".\\\"id\\\" AS \\\"res0\\\", \\\"t0\\\".\\\"first_name\\\" AS \\\"res1\\\", \\\"t0\\\".\\\"last_name\\\" AS \\\"res2\\\" FROM \\\"users\\\" AS \\\"t0\\\" WHERE (\\\"t0\\\".\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 3,SQLInteger 4]\",\"DELETE FROM \\\"users\\\" WHERE (\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 1,SQLInteger 2]\"],\"jsonResult\":{\"Right\":[]}},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" + + +-- deleteRowsRecord :: ResultRecording +-- deleteRowsRecord = fromJust $ decode +-- "{\"recording\":[{\"_entryName\":\"GetSqlDBConnectionEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/language/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"getConnResult\":{\"Left\":[{\"tag\":\"ConnectionDoesNotExist\"},\"Connection for SQliteDB does not exists.\"]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"InitSqlDBConnectionEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/language/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"initConnResult\":{\"Right\":[]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunDBEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"rawSql\":[\"INSERT INTO \\\"users\\\"(\\\"id\\\", \\\"first_name\\\", \\\"last_name\\\") VALUES (?, ?, ?), (?, ?, ?);\\n-- With values: [SQLInteger 1,SQLText \\\"Bill\\\",SQLText \\\"Gates\\\",SQLInteger 2,SQLText \\\"Stive\\\",SQLText \\\"Jobs\\\"]\",\"DELETE FROM \\\"users\\\" WHERE (\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 1,SQLInteger 2]\",\"SELECT \\\"t0\\\".\\\"id\\\" AS \\\"res0\\\", \\\"t0\\\".\\\"first_name\\\" AS \\\"res1\\\", \\\"t0\\\".\\\"last_name\\\" AS \\\"res2\\\" FROM \\\"users\\\" AS \\\"t0\\\" WHERE (\\\"t0\\\".\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 1,SQLInteger 2]\"],\"jsonResult\":{\"Right\":[]}},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" + +-- deleteWrongRowsRecord :: ResultRecording +-- deleteWrongRowsRecord = fromJust $ decode +-- "{\"recording\":[{\"_entryName\":\"GetSqlDBConnectionEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/language/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"getConnResult\":{\"Left\":[{\"tag\":\"ConnectionDoesNotExist\"},\"Connection for SQliteDB does not exists.\"]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"InitSqlDBConnectionEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/language/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"initConnResult\":{\"Right\":[]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunDBEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"rawSql\":[\"INSERT INTO \\\"users\\\"(\\\"id\\\", \\\"first_name\\\", \\\"last_name\\\") VALUES (?, ?, ?), (?, ?, ?);\\n-- With values: [SQLInteger 1,SQLText \\\"Bill\\\",SQLText \\\"Gates\\\",SQLInteger 2,SQLText \\\"Stive\\\",SQLText \\\"Jobs\\\"]\",\"DELETE FROM \\\"users\\\" WHERE (\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 3,SQLInteger 4]\",\"SELECT \\\"t0\\\".\\\"id\\\" AS \\\"res0\\\", \\\"t0\\\".\\\"first_name\\\" AS \\\"res1\\\", \\\"t0\\\".\\\"last_name\\\" AS \\\"res2\\\" FROM \\\"users\\\" AS \\\"t0\\\" WHERE (\\\"t0\\\".\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 1,SQLInteger 2]\",\"DELETE FROM \\\"users\\\" WHERE (\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 1,SQLInteger 2]\"],\"jsonResult\":{\"Right\":[{\"_userGUID\":1,\"_lastName\":\"Gates\",\"_firstName\":\"Bill\"},{\"_userGUID\":2,\"_lastName\":\"Jobs\",\"_firstName\":\"Stive\"}]}},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" + +-- updateRowRecord :: ResultRecording +-- updateRowRecord = fromJust $ decode +-- "{\"recording\":[{\"_entryName\":\"GetSqlDBConnectionEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/language/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"getConnResult\":{\"Left\":[{\"tag\":\"ConnectionDoesNotExist\"},\"Connection for SQliteDB does not exists.\"]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"InitSqlDBConnectionEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/language/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"initConnResult\":{\"Right\":[]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunDBEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"rawSql\":[\"INSERT INTO \\\"users\\\"(\\\"id\\\", \\\"first_name\\\", \\\"last_name\\\") VALUES (?, ?, ?), (?, ?, ?);\\n-- With values: [SQLInteger 1,SQLText \\\"Bill\\\",SQLText \\\"Gates\\\",SQLInteger 2,SQLText \\\"Stive\\\",SQLText \\\"Jobs\\\"]\",\"UPDATE \\\"users\\\" SET \\\"first_name\\\"=? WHERE (\\\"id\\\")=(?);\\n-- With values: [SQLText \\\"Robert\\\",SQLInteger 1]\",\"SELECT \\\"t0\\\".\\\"id\\\" AS \\\"res0\\\", \\\"t0\\\".\\\"first_name\\\" AS \\\"res1\\\", \\\"t0\\\".\\\"last_name\\\" AS \\\"res2\\\" FROM \\\"users\\\" AS \\\"t0\\\" WHERE (\\\"t0\\\".\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 1,SQLInteger 2]\",\"DELETE FROM \\\"users\\\" WHERE (\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 1,SQLInteger 2]\"],\"jsonResult\":{\"Right\":[{\"_userGUID\":1,\"_lastName\":\"Gates\",\"_firstName\":\"Robert\"},{\"_userGUID\":2,\"_lastName\":\"Jobs\",\"_firstName\":\"Stive\"}]}},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" + +-- updateRowWithDelayRecord :: ResultRecording +-- updateRowWithDelayRecord = fromJust $ decode +-- "{\"recording\":[{\"_entryName\":\"GetSqlDBConnectionEntry\",\"_entryIndex\":0,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/language/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"getConnResult\":{\"Left\":[{\"tag\":\"ConnectionDoesNotExist\"},\"Connection for SQliteDB does not exists.\"]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"InitSqlDBConnectionEntry\",\"_entryIndex\":1,\"_entryPayload\":{\"dBConfig\":{\"tag\":\"SQLitePoolConf\",\"contents\":[\"SQliteDB\",\"test/language/EulerHS/TestData/test.db\",{\"resourcesPerStripe\":50,\"stripes\":1,\"keepAlive\":10}]},\"initConnResult\":{\"Right\":[]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunDBEntry\",\"_entryIndex\":2,\"_entryPayload\":{\"rawSql\":[\"INSERT INTO \\\"users\\\"(\\\"id\\\", \\\"first_name\\\", \\\"last_name\\\") VALUES (?, ?, ?), (?, ?, ?);\\n-- With values: [SQLInteger 1,SQLText \\\"Bill\\\",SQLText \\\"Gates\\\",SQLInteger 2,SQLText \\\"Stive\\\",SQLText \\\"Jobs\\\"]\",\"UPDATE \\\"users\\\" SET \\\"first_name\\\"=? WHERE (\\\"id\\\")=(?);\\n-- With values: [SQLText \\\"Robert\\\",SQLInteger 1]\"],\"jsonResult\":{\"Right\":[]}},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunIOEntry\",\"_entryIndex\":3,\"_entryPayload\":{\"jsonResult\":[],\"description\":\"\"},\"_entryReplayMode\":\"Normal\"},{\"_entryName\":\"RunDBEntry\",\"_entryIndex\":4,\"_entryPayload\":{\"rawSql\":[\"SELECT \\\"t0\\\".\\\"id\\\" AS \\\"res0\\\", \\\"t0\\\".\\\"first_name\\\" AS \\\"res1\\\", \\\"t0\\\".\\\"last_name\\\" AS \\\"res2\\\" FROM \\\"users\\\" AS \\\"t0\\\" WHERE (\\\"t0\\\".\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 1,SQLInteger 2]\",\"DELETE FROM \\\"users\\\" WHERE (\\\"id\\\") IN (?, ?);\\n-- With values: [SQLInteger 1,SQLInteger 2]\"],\"jsonResult\":{\"Right\":[{\"_userGUID\":1,\"_lastName\":\"Gates\",\"_firstName\":\"Robert\"},{\"_userGUID\":2,\"_lastName\":\"Jobs\",\"_firstName\":\"Stive\"}]}},\"_entryReplayMode\":\"Normal\"}],\"forkedRecordings\":{},\"safeRecordings\":{}}" + + + diff --git a/test/Main.hs b/test/Main.hs index 40a6d655..5bb34b37 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,42 +1,74 @@ -module Main where +{-# OPTIONS_GHC -Werror #-} -import EulerHS.Prelude -import Test.Hspec +module Main (main) where -import qualified EulerHS.Tests.Framework.ArtSpec as Art -import qualified EulerHS.Tests.Framework.FlowSpec as Framework -import qualified EulerHS.Tests.Framework.KVDBArtSpec as KVDB -import qualified EulerHS.Tests.Framework.PubSubSpec as PubSub -import qualified EulerHS.Tests.Framework.SQLArtSpec as SQL +-- import qualified ArtSpec as Art +-- import Control.Exception.Safe (bracket) +import EulerHS.Prelude hiding (bracket) import qualified EulerHS.Types as T +import qualified EulerHS.Tests.Framework.FlowSpec as Flow +-- import qualified KVDBArtSpec as KVDB +-- import qualified PubSubSpec as PubSub +-- import qualified SQLArtSpec as SQL +import qualified EulerHS.Tests.Framework.MaskingSpec as MaskSpec +-- import qualified CachedDBSpec as CachedSqlDBQuery +-- import System.Directory (createDirectory, getTemporaryDirectory, +-- removePathForcibly) +-- import System.FilePath ((<.>), ()) +-- import System.Process.Typed (proc, startProcess, stopProcess) +-- import System.Random (getStdRandom, random) +import Test.Hspec (hspec) + +main :: IO () +main = do + -- Redis not works on CI + -- withRedis $ + hspec $ do + Flow.spec logsDisabled + MaskSpec.spec + + -- Wait for Redis on CI + -- CachedSqlDBQuery.spec + + -- ART removed and these tests not work anymore + -- Art.spec + -- KVDB.spec + -- SQL.spec + -- PubSub.spec + -import System.Process - -withRedis :: IO () -> IO () -withRedis action = do - cmdHandle <- spawnCommand "redis-server" - action - terminateProcess cmdHandle - -logsEnabled :: Maybe T.LoggerConfig -logsEnabled = Just $ T.LoggerConfig - { T._logToFile = False, - T._logFilePath = "", - T._isAsync = False, - T._logLevel = T.Debug, - T._logToConsole = True, - T._maxQueueSize = 1000, - T._logRawSql = False - } + + +-- Helpers + +-- withRedis :: IO () -> IO () +-- withRedis act = withTempRedisDir $ \redisDir -> +-- withTempRedisConfig redisDir go +-- where +-- go :: FilePath -> IO () +-- go redisConfPath = +-- bracket (startProcess . proc "redis-server" $ [redisConfPath]) +-- stopProcess +-- (const act) logsDisabled :: Maybe T.LoggerConfig logsDisabled = Nothing -main :: IO () -main = do - withRedis $ hspec $ do - Framework.spec logsDisabled - Art.spec - KVDB.spec - SQL.spec - PubSub.spec +-- withTempRedisDir :: (FilePath -> IO a) -> IO a +-- withTempRedisDir act = do +-- rand :: Word <- liftIO . getStdRandom $ random +-- tmp <- liftIO getTemporaryDirectory +-- let tempDir = tmp ("redis" <> show rand) +-- bracket (liftIO . createDirectory $ tempDir) +-- (\_ -> liftIO . removePathForcibly $ tempDir) +-- (\_ -> act tempDir) + +-- withTempRedisConfig :: FilePath -> (FilePath -> IO ()) -> IO () +-- withTempRedisConfig tmpRedisDir act = do +-- let tmpRedisConfPath = tmpRedisDir "redis" <.> "conf" +-- bracket (withFile tmpRedisConfPath WriteMode go) +-- (\_ -> removePathForcibly tmpRedisConfPath) +-- (\_ -> act tmpRedisConfPath) +-- where +-- go :: Handle -> IO () +-- go h = hPutStrLn @String h $ "dir " +| tmpRedisDir |+ "" diff --git a/testDB/KVDB/KVDBSpec.hs b/testDB/KVDB/KVDBSpec.hs index 0e7e8304..dd32512c 100644 --- a/testDB/KVDB/KVDBSpec.hs +++ b/testDB/KVDB/KVDBSpec.hs @@ -8,8 +8,9 @@ import EulerHS.Prelude import EulerHS.Runtime import qualified EulerHS.Types as T -redisCfg :: T.KVDBConfig -redisCfg = T.mkKVDBConfig "eulerKVDB" T.defaultKVDBConnConfig +redisName = "eulerKVDB" + +redisCfg = T.mkKVDBConfig redisName T.defaultKVDBConnConfig spec :: Spec spec = @@ -18,27 +19,26 @@ spec = describe "EulerHS KVDB tests" $ do it "Double connection initialization should fail" $ \rt -> do - eRes :: Either String () <- runFlow rt $ do + eRes <- runFlow rt $ do eConn1 <- L.initKVDBConnection redisCfg eConn2 <- L.initKVDBConnection redisCfg - pure $ case (eConn1, eConn2) of - (Left err, _) -> Left $ "Failed to connect 1st time: " <> show err - (_, Left (T.KVDBError T.KVDBConnectionAlreadyExists _)) -> Right () - (_, Left err) -> Left $ "Unexpected error type on 2nd connect: " <> show err - _ -> Left $ "Unexpected result." + case (eConn1, eConn2) of + (Left err, _) -> pure $ Left $ "Failed to connect 1st time: " <> show err + (_, Left (T.KVDBError T.KVDBConnectionAlreadyExists msg)) -> pure $ Right () + (_, Left err) -> pure $ Left $ "Unexpected error type on 2nd connect: " <> show err eRes `shouldBe` Right () it "Get uninialized connection should fail" $ \rt -> do - eRes :: Either String () <- runFlow rt $ do + eRes <- runFlow rt $ do eConn <- L.getKVDBConnection redisCfg case eConn of - Left (T.KVDBError T.KVDBConnectionDoesNotExist _) -> pure $ Right () + Left (T.KVDBError T.KVDBConnectionDoesNotExist msg) -> pure $ Right () Left err -> pure $ Left $ "Unexpected error: " <> show err Right _ -> pure $ Left "Unexpected connection success" eRes `shouldBe` Right () it "Init and get connection should succeed" $ \rt -> do - eRes :: Either String () <- runFlow rt $ do + eRes <- runFlow rt $ do eConn1 <- L.initKVDBConnection redisCfg eConn2 <- L.getKVDBConnection redisCfg case (eConn1, eConn2) of @@ -48,7 +48,7 @@ spec = eRes `shouldBe` Right () it "Init and double get connection should succeed" $ \rt -> do - eRes :: Either String () <- runFlow rt $ do + eRes <- runFlow rt $ do eConn1 <- L.initKVDBConnection redisCfg eConn2 <- L.getKVDBConnection redisCfg eConn3 <- L.getKVDBConnection redisCfg @@ -59,9 +59,9 @@ spec = _ -> pure $ Right () eRes `shouldBe` Right () - it "getOrInitKVDBConnection should succeed" $ \rt -> do - eRes :: Either String () <- runFlow rt $ do - eConn <- L.getOrInitKVDBConnection redisCfg + it "getOrInitKVDBConn should succeed" $ \rt -> do + eRes <- runFlow rt $ do + eConn <- L.getOrInitKVDBConn redisCfg case eConn of Left err -> pure $ Left $ "Failed to connect: " <> show err _ -> pure $ Right () @@ -74,3 +74,71 @@ spec = void $ runFlow rt $ do eConn <- L.getKVDBConnection redisCfg when (isLeft eConn) $ error "Failed to get prepared connection." + + it "Redis binary strings 1" $ \rt -> do + let key = "a\xfcज" :: ByteString + let value = "bbbex\xfc\xffकखगघङचछज" :: ByteString + result <- runFlow rt $ do + eConn <- L.initKVDBConnection redisCfg + case eConn of + Left err -> + error $ "Failed to get prepared connection: " <> show err + Right conn -> do + let hour = 60 * 60 + L.runKVDB redisName $ do + L.setex key hour value + res <- L.get key + L.del [key] + pure res + result `shouldBe` Right (Just value) + + it "Redis binary strings 2" $ \rt -> do + let key = "a\xfcज" :: ByteString + let value = "bbbex\xfc\xffकखगघङचछज" :: ByteString + result <- runFlow rt $ do + eConn <- L.initKVDBConnection redisCfg + case eConn of + Left err -> + error $ "Failed to get prepared connection: " <> show err + Right conn -> do + L.rSetB redisName key value + L.rGetB redisName key + result `shouldBe` Just value + + it "Redis unicode" $ \rt -> do + let key = "a\xfcज" :: Text + let value = "bbbex\xfc\xffकखगघङचछज" :: Text + result <- runFlow rt $ do + eConn <- L.initKVDBConnection redisCfg + case eConn of + Left err -> + error $ "Failed to get prepared connection: " <> show err + Right conn -> do + L.rSetT redisName key value + L.rGetT redisName key + result `shouldBe` Just value + + it "Redis unicode + json" $ \rt -> do + let key = "a\xfcज" :: Text + let value = "bbbex\xfc\xffकखगघङचछज" :: Text + result <- runFlow rt $ do + eConn <- L.initKVDBConnection redisCfg + case eConn of + Left err -> + error $ "Failed to get prepared connection: " <> show err + Right conn -> do + L.rSet redisName key value + L.rGet redisName key + result `shouldBe` Just value + it "Redis set functions" $ \rt -> do + let key = "abc" :: ByteString + let value = ["hello", "world"] :: [ByteString] + result <- runFlow rt $ do + eConn <- L.initKVDBConnection redisCfg + case eConn of + Left err -> + error $ "Failed to get prepared connection: " <> show err + Right conn -> do + void $ L.rSadd redisName key value + L.rSismember redisName key (head value) + result `shouldBe` (Right True) diff --git a/testDB/Main.hs b/testDB/Main.hs index 6a4e3f0c..a21152f1 100644 --- a/testDB/Main.hs +++ b/testDB/Main.hs @@ -4,21 +4,19 @@ import EulerHS.Prelude import Test.Hspec -import qualified KVDB.KVDBSpec as KVDB -import qualified SQLDB.Tests.SQLiteDBSpec as SQLiteDB -import qualified SQLDB.Tests.QueryExamplesSpec as Ex - --- Prepare your DBs environment and uncomment these lines --- if you need integration testing of DB backents. +-- import qualified KVDB.KVDBSpec as KVDB -- import qualified SQLDB.Tests.PostgresDBSpec as PGDB +import qualified SQLDB.Tests.SQLiteDBSpec as SQLiteDB -- import qualified SQLDB.Tests.PostgresDBPoolSpec as PGDBP -- import qualified SQLDB.Tests.MySQLDBSpec as MySQL +import qualified SQLDB.Tests.QueryExamplesSpec as Ex -main :: IO () main = hspec $ do - KVDB.spec SQLiteDB.spec Ex.spec + + -- Disable until it work here in jenkins + -- KVDB.spec -- PGDB.spec -- PGDBP.spec -- MySQL.spec diff --git a/testDB/SQLDB/TestData/Connections.hs b/testDB/SQLDB/TestData/Connections.hs index 61425f09..0fa0b390 100644 --- a/testDB/SQLDB/TestData/Connections.hs +++ b/testDB/SQLDB/TestData/Connections.hs @@ -37,3 +37,5 @@ withEmptyDB insertValues cfg act = withFlowRuntime Nothing (\rt -> do `finally` error ("Preparing test values failed: " <> show e) Right _ -> act rt `finally` runFlow rt rmTestDB ) + + diff --git a/testDB/SQLDB/TestData/Scenarios/MySQL.hs b/testDB/SQLDB/TestData/Scenarios/MySQL.hs index 528a979d..05cefb7a 100644 --- a/testDB/SQLDB/TestData/Scenarios/MySQL.hs +++ b/testDB/SQLDB/TestData/Scenarios/MySQL.hs @@ -5,6 +5,7 @@ import EulerHS.Prelude import qualified EulerHS.Language as L import qualified EulerHS.Types as T +import SQLDB.TestData.Connections (connectOrFail) import SQLDB.TestData.Types import Database.Beam ((<-.), (==.)) @@ -17,24 +18,22 @@ uniqueConstraintViolationDbScript dbcfg = do econn <- L.getSqlDBConnection dbcfg flip (either $ error "Unable to get connection") econn $ \conn -> do - eRes1 <- L.runDB conn - $ L.insertRows + L.runDB conn $ + L.insertRows $ B.insert (_users eulerDb) $ B.insertValues [User 2 "Rosa" "Rosa"] - eRes2 <- L.runDB conn - $ L.insertRows + L.runDB conn $ + L.insertRows $ B.insert (_users eulerDb) $ B.insertValues [User 2 "Rosa" "Rosa"] - pure $ eRes1 >> eRes2 - uniqueConstraintViolationEveDbScript :: T.DBConfig BM.MySQLM -> L.Flow (T.DBResult ()) uniqueConstraintViolationEveDbScript dbcfg = do econn <- L.getSqlDBConnection dbcfg - flip (either $ error "Unable to get connection") econn $ \conn -> + flip (either $ error "Unable to get connection") econn $ \conn -> do L.runDB conn $ do L.insertRows $ B.insert (_users eulerDb) @@ -49,29 +48,33 @@ uniqueConstraintViolationMickeyDbScript dbcfg = do econn <- L.getSqlDBConnection dbcfg flip (either $ error "Unable to get connection") econn $ \conn -> do - eRes1 <- L.runDB conn $ + L.runDB conn $ L.insertRows $ B.insert (_users eulerDb) $ B.insertValues [User 4 "Mickey" "Mouse"] - eRes2 <- L.runDB conn $ + L.runDB conn $ L.insertRows $ B.insert (_users eulerDb) $ B.insertValues [User 4 "Mickey" "Mouse"] - pure $ eRes1 >> eRes2 + +data MyException = ThisException | ThatException + deriving Show + +instance Exception MyException throwExceptionFlowScript :: T.DBConfig BM.MySQLM -> L.Flow (T.DBResult ()) throwExceptionFlowScript dbcfg = do econn <- L.getSqlDBConnection dbcfg - flip (either $ error "Unable to get connection") econn $ \conn -> + flip (either $ error "Unable to get connection") econn $ \conn -> do L.runDB conn $ do L.insertRows $ B.insert (_users eulerDb) $ B.insertValues [User 6 "Billy" "Evil"] - void $ error "ThisException" + L.sqlThrowException ThisException L.insertRows $ B.insert (_users eulerDb) @@ -82,7 +85,7 @@ insertAndSelectWithinOneConnectionScript :: T.DBConfig BM.MySQLM -> L.Flow (T.DB insertAndSelectWithinOneConnectionScript dbcfg = do econn <- L.getSqlDBConnection dbcfg - flip (either $ error "Unable to get connection") econn $ \conn -> + flip (either $ error "Unable to get connection") econn $ \conn -> do L.runDB conn $ do L.insertRows $ B.insert (_users eulerDb) @@ -128,12 +131,12 @@ selectOneDbScript dbcfg = do econn <- L.getSqlDBConnection dbcfg flip (either $ error "Unable to get connection") econn $ \conn -> do - eRes1 <- L.runDB conn + L.runDB conn $ L.insertRows $ B.insert (_users eulerDb) $ B.insertExpressions (mkUser <$> susers) - eRes2 <- L.runDB conn $ do + L.runDB conn $ do let predicate User {..} = _userFirstName ==. "John" L.findRow @@ -142,8 +145,6 @@ selectOneDbScript dbcfg = do $ B.filter_ predicate $ B.all_ (_users eulerDb) - pure $ eRes1 >> eRes2 - insertReturningScript :: T.DBConfig BM.MySQLM -> L.Flow (T.DBResult [User]) insertReturningScript dbcfg = do diff --git a/testDB/SQLDB/TestData/Scenarios/Postgres.hs b/testDB/SQLDB/TestData/Scenarios/Postgres.hs index 046dd78f..a86b8b54 100644 --- a/testDB/SQLDB/TestData/Scenarios/Postgres.hs +++ b/testDB/SQLDB/TestData/Scenarios/Postgres.hs @@ -5,6 +5,7 @@ import EulerHS.Prelude import qualified EulerHS.Language as L import qualified EulerHS.Types as T +import SQLDB.TestData.Connections (connectOrFail) import SQLDB.TestData.Types import Database.Beam ((<-.), (==.)) @@ -19,18 +20,16 @@ uniqueConstraintViolationDbScript dbcfg = do econn <- L.getSqlDBConnection dbcfg flip (either $ error "Unable to get connection") econn $ \conn -> do - eRes1 <- L.runDB conn + L.runDB conn $ L.insertRows $ B.insert (_users eulerDb) $ B.insertValues [User 2 "Eve" "Beon"] - eRes2 <- L.runDB conn + L.runDB conn $ L.insertRows $ B.insert (_users eulerDb) $ B.insertValues [User 2 "Eve" "Beon"] - pure $ eRes1 >> eRes2 - selectUnknownDbScript :: T.DBConfig BP.Pg -> L.Flow (T.DBResult (Maybe User)) selectUnknownDbScript dbcfg = do @@ -51,12 +50,12 @@ selectOneDbScript dbcfg = do econn <- L.getSqlDBConnection dbcfg flip (either $ error "Unable to get connection") econn $ \conn -> do - eRes1 <- L.runDB conn + L.runDB conn $ L.insertRows $ B.insert (_users eulerDb) $ B.insertExpressions (mkUser <$> susers) - eRes2 <- L.runDB conn $ do + L.runDB conn $ do let predicate User {..} = _userFirstName ==. "John" L.findRow @@ -65,8 +64,6 @@ selectOneDbScript dbcfg = do $ B.filter_ predicate $ B.all_ (_users eulerDb) - pure $ eRes1 >> eRes2 - insertReturningScript :: T.DBConfig BP.Pg -> L.Flow (T.DBResult [User]) insertReturningScript dbcfg = do diff --git a/testDB/SQLDB/TestData/Scenarios/SQLite.hs b/testDB/SQLDB/TestData/Scenarios/SQLite.hs index 4d446ccb..f52cb341 100644 --- a/testDB/SQLDB/TestData/Scenarios/SQLite.hs +++ b/testDB/SQLDB/TestData/Scenarios/SQLite.hs @@ -47,18 +47,16 @@ uniqueConstraintViolationDbScript :: T.DBConfig BS.SqliteM -> L.Flow (T.DBResult uniqueConstraintViolationDbScript cfg = do connection <- connectOrFail cfg - eRes1 <- L.runDB connection + L.runDB connection $ L.insertRows $ B.insert (_users eulerDb) $ B.insertValues [User 1 "Eve" "Beon"] - eRes2 <- L.runDB connection + L.runDB connection $ L.insertRows $ B.insert (_users eulerDb) $ B.insertValues [User 1 "Eve" "Beon"] - pure $ eRes1 >> eRes2 - selectUnknownDbScript :: T.DBConfig BS.SqliteM -> L.Flow (T.DBResult (Maybe User)) selectUnknownDbScript cfg = do connection <- connectOrFail cfg diff --git a/testDB/SQLDB/TestData/Types.hs b/testDB/SQLDB/TestData/Types.hs index e29ca1c4..2740b697 100644 --- a/testDB/SQLDB/TestData/Types.hs +++ b/testDB/SQLDB/TestData/Types.hs @@ -6,8 +6,8 @@ module SQLDB.TestData.Types where import EulerHS.Prelude import qualified EulerHS.Types as T + import qualified Database.Beam as B -import qualified Database.Beam.Backend.SQL as B -- sqlite3 db -- CREATE TABLE users (id INTEGER PRIMARY KEY AUTOINCREMENT, first_name VARCHAR NOT NULL, last_name VARCHAR NOT NULL); @@ -61,7 +61,7 @@ sqliteSequenceDb :: B.DatabaseSettings be SqliteSequenceDb sqliteSequenceDb = B.defaultDbSettings -data SimpleUser = SimpleUser {firstN :: Text, lastN :: Text} +data SimpleUser = SimpleUser {first :: Text, last :: Text} susers :: [SimpleUser] susers = @@ -69,17 +69,10 @@ susers = , SimpleUser "Doe" "John" ] -mkUser - :: ( B.BeamSqlBackend be - , B.SqlValable (B.Columnar f Text) - , B.Columnar f Int ~ B.QGenExpr ctxt be s a - , B.HaskellLiteralForQExpr (B.Columnar f Text) ~ Text - ) - => SimpleUser - -> UserT f -mkUser SimpleUser {..} = User B.default_ (B.val_ firstN) (B.val_ lastN) +mkUser SimpleUser {..} = User B.default_ (B.val_ first) (B.val_ last) someUser :: Text -> Text -> T.DBResult (Maybe User) -> Bool someUser f l (Right (Just u)) = _userFirstName u == f && _userLastName u == l someUser _ _ _ = False + diff --git a/testDB/SQLDB/Tests/MySQLDBSpec.hs b/testDB/SQLDB/Tests/MySQLDBSpec.hs index 29dbba22..1deace99 100644 --- a/testDB/SQLDB/Tests/MySQLDBSpec.hs +++ b/testDB/SQLDB/Tests/MySQLDBSpec.hs @@ -3,17 +3,20 @@ module SQLDB.Tests.MySQLDBSpec where import EulerHS.Prelude import EulerHS.Interpreters -import EulerHS.Runtime (withFlowRuntime) -import EulerHS.Types +import EulerHS.Runtime (FlowRuntime, withFlowRuntime) +import EulerHS.Types hiding (error) +import SQLDB.TestData.Connections (connectOrFail) import SQLDB.TestData.Scenarios.MySQL import SQLDB.TestData.Types -import qualified Database.Beam.MySQL as BM import Test.Hspec hiding (runIO) +import qualified Database.Beam.MySQL as BM +import Database.MySQL.Base import EulerHS.Language import qualified EulerHS.Types as T +import System.Process import EulerHS.Extra.Test @@ -31,6 +34,7 @@ mySQLCfg = T.MySQLConfig , connectOptions = [T.CharsetName "utf8"] , connectPath = "" , connectSSL = Nothing + , connectCharset = Latin1 } mySQLRootCfg :: T.MySQLConfig @@ -44,18 +48,15 @@ mySQLRootCfg = where T.MySQLConfig {..} = mySQLCfg -mkMysqlConfig :: T.MySQLConfig -> T.DBConfig BM.MySQLM mkMysqlConfig = T.mkMySQLConfig "eulerMysqlDB" -poolConfig :: T.PoolConfig poolConfig = T.PoolConfig { stripes = 1 , keepAlive = 10 , resourcesPerStripe = 50 } -mkMysqlPoolConfig :: T.MySQLConfig -> DBConfig BM.MySQLM -mkMysqlPoolConfig cfg = mkMySQLPoolConfig "eulerMysqlDB" cfg poolConfig +mkMysqlPoolConfig mySQLCfg = mkMySQLPoolConfig "eulerMysqlDB" mySQLCfg poolConfig spec :: Spec spec = do @@ -138,3 +139,5 @@ spec = do around (prepare mkMysqlPoolConfig) $ describe "EulerHS MySQL DB tests. Pool" $ test $ mkMysqlPoolConfig mySQLCfg + + diff --git a/testDB/SQLDB/Tests/PostgresDBSpec.hs b/testDB/SQLDB/Tests/PostgresDBSpec.hs index fa34b7c3..ce1c44fc 100644 --- a/testDB/SQLDB/Tests/PostgresDBSpec.hs +++ b/testDB/SQLDB/Tests/PostgresDBSpec.hs @@ -4,20 +4,25 @@ import EulerHS.Prelude import EulerHS.Interpreters import EulerHS.Runtime (withFlowRuntime) +import EulerHS.Types hiding (error) import qualified EulerHS.Types as T -import SQLDB.TestData.Scenarios.Postgres (uniqueConstraintViolationDbScript, - selectUnknownDbScript, selectOneDbScript, updateAndSelectDbScript) +import SQLDB.TestData.Connections (connectOrFail) +import SQLDB.TestData.Scenarios.Postgres import SQLDB.TestData.Types import qualified Database.Beam.Postgres as BP +import Database.PostgreSQL.Simple (execute_) import EulerHS.Extra.Test +import EulerHS.Language +import EulerHS.Runtime (FlowRuntime, withFlowRuntime) +import System.Process import Test.Hspec hiding (runIO) -- Configurations -pgCfg' :: T.PostgresConfig -pgCfg' = T.PostgresConfig +pgCfg :: T.PostgresConfig +pgCfg = T.PostgresConfig { connectHost = "postgres" --String , connectPort = 5432 --Word16 , connectUser = "cloud" -- String @@ -35,20 +40,17 @@ pgRootCfg = , .. } where - T.PostgresConfig {..} = pgCfg' + T.PostgresConfig {..} = pgCfg -mkPgCfg :: T.PostgresConfig -> T.DBConfig BP.Pg -mkPgCfg = T.mkPostgresConfig "eulerPGDB" +mkPgCfg = mkPostgresConfig "eulerPGDB" -poolConfig :: T.PoolConfig poolConfig = T.PoolConfig { stripes = 1 , keepAlive = 10 , resourcesPerStripe = 50 } -mkPgPoolCfg :: T.PostgresConfig -> T.DBConfig BP.Pg -mkPgPoolCfg cfg = T.mkPostgresPoolConfig "eulerPGDB" cfg poolConfig +mkPgPoolCfg cfg = mkPostgresPoolConfig "eulerPGDB" cfg poolConfig -- Tests @@ -60,11 +62,11 @@ spec = do eRes <- runFlow rt $ uniqueConstraintViolationDbScript pgCfg eRes `shouldBe` - ( Left $ T.DBError - ( T.SQLError $ T.PostgresError $ - T.PostgresSqlError + ( Left $ DBError + ( SQLError $ PostgresError $ + PostgresSqlError { sqlState = "23505" - , sqlExecStatus = T.PostgresFatalError + , sqlExecStatus = PostgresFatalError , sqlErrorMsg = "duplicate key value violates unique constraint \"users_pkey\"" , sqlErrorDetail = "Key (id)=(2) already exists." , sqlErrorHint = "" @@ -89,12 +91,12 @@ spec = do preparePostgresDB "testDB/SQLDB/TestData/PostgresDBSpec.sql" pgRootCfg - pgCfg' + pgCfg pgCfgToDbCfg (withFlowRuntime Nothing) around (prepare mkPgCfg) $ - describe "EulerHS Postgres DB tests" $ test $ mkPgCfg pgCfg' + describe "EulerHS Postgres DB tests" $ test $ mkPgCfg pgCfg around (prepare mkPgPoolCfg) $ - describe "EulerHS Postgres DB tests. Pool" $ test $ mkPgPoolCfg pgCfg' + describe "EulerHS Postgres DB tests. Pool" $ test $ mkPgPoolCfg pgCfg diff --git a/testDB/SQLDB/Tests/SQLiteDBSpec.hs b/testDB/SQLDB/Tests/SQLiteDBSpec.hs index e1ba9024..627de9aa 100644 --- a/testDB/SQLDB/Tests/SQLiteDBSpec.hs +++ b/testDB/SQLDB/Tests/SQLiteDBSpec.hs @@ -24,8 +24,8 @@ import Test.Hspec hiding (runIO) -- Configurations -sqliteCfg' :: DBConfig BS.SqliteM -sqliteCfg' = T.mkSQLiteConfig "eulerSQliteDB" testDBName +sqliteCfg :: DBConfig BS.SqliteM +sqliteCfg = T.mkSQLiteConfig "eulerSQliteDB" testDBName poolConfig :: T.PoolConfig poolConfig = T.PoolConfig @@ -45,7 +45,7 @@ spec = do let test sqliteCfg = do it "Double connection initialization should fail" $ \rt -> do - eRes :: Either String () <- runFlow rt $ do + eRes <- runFlow rt $ do eConn1 <- L.initSqlDBConnection sqliteCfg eConn2 <- L.initSqlDBConnection sqliteCfg case (eConn1, eConn2) of @@ -56,7 +56,7 @@ spec = do eRes `shouldBe` Right () it "Get uninialized connection should fail" $ \rt -> do - eRes :: Either String () <- runFlow rt $ do + eRes <- runFlow rt $ do eConn <- L.getSqlDBConnection sqliteCfg case eConn of Left (T.DBError T.ConnectionDoesNotExist msg) @@ -66,7 +66,7 @@ spec = do eRes `shouldBe` Right () it "Init and get connection should succeed" $ \rt -> do - eRes :: Either String () <- runFlow rt $ do + eRes <- runFlow rt $ do eConn1 <- L.initSqlDBConnection sqliteCfg eConn2 <- L.getSqlDBConnection sqliteCfg case (eConn1, eConn2) of @@ -76,7 +76,7 @@ spec = do eRes `shouldBe` Right () it "Init and double get connection should succeed" $ \rt -> do - eRes :: Either String () <- runFlow rt $ do + eRes <- runFlow rt $ do eConn1 <- L.initSqlDBConnection sqliteCfg eConn2 <- L.getSqlDBConnection sqliteCfg eConn3 <- L.getSqlDBConnection sqliteCfg @@ -87,9 +87,9 @@ spec = do _ -> pure $ Right () eRes `shouldBe` Right () - it "getOrInitSqlConnection should succeed" $ \rt -> do - eRes :: Either String () <- runFlow rt $ do - eConn <- L.getOrInitSqlConnection sqliteCfg + it "getOrInitSqlConn should succeed" $ \rt -> do + eRes <- runFlow rt $ do + eConn <- L.getOrInitSqlConn sqliteCfg case eConn of Left err -> pure $ Left $ "Failed to connect: " <> show err _ -> pure $ Right () @@ -145,8 +145,8 @@ spec = do _userFirstName u2 `shouldBe` "Doe" _userLastName u2 `shouldBe` "John" - around (withEmptyDB insertTestValues sqliteCfg') $ - describe "EulerHS SQLite DB tests" $ test sqliteCfg' + around (withEmptyDB insertTestValues sqliteCfg) $ + describe "EulerHS SQLite DB tests" $ test sqliteCfg around (withEmptyDB insertTestValues sqlitePoolCfg) $ describe "EulerHS SQLite DB tests. Pool cfg." $ test sqlitePoolCfg diff --git a/update.sh b/update.sh new file mode 100755 index 00000000..0bfbc543 --- /dev/null +++ b/update.sh @@ -0,0 +1,94 @@ +#!/usr/bin/env nix-shell +#! nix-shell -i bash -p jq -p yq +# +# Update euler-* dependencies in the nix/sources.json file +# + +set -euf -o pipefail + +usage() { + >&2 echo "Usage: $0 [-f ] [-s] [-r ] [-h]" + >&2 echo "-h: print this help" + >&2 echo "-f: path to project folder (default is .)" + >&2 echo "-s: use stack extra-deps format (default is 'false')" + >&2 echo "-r: a nix set specifying refs to be changed (default is '{}')" + >&2 echo + >&2 echo "Example:" + >&2 echo "$0 -f ../euler-api-gateway -r '{euler-hs = \"staging\";}'" + >&2 echo +} + +REFS='{}' +FOLDER=$(pwd -P) +USE_STACK='false' + +SOURCES_FILE="nix/sources.json" + +abs_path() { + local path="$1" + + if [[ $path == "." ]]; then + echo $(pwd -P) + elif [[ -d $path ]]; then + echo $(cd $path; pwd -P) + else + >&2 echo "Folder ${path} does not exist" + exit 1 + fi +} + +check_nix_set() { + local input_expr="${1-}" + [[ -z $input_expr ]] && >&2 echo "Empty refs passed" && exit 1 + + local check_expr=$(cat <<-EXPR +{x}: if builtins.isAttrs x +then x +else throw "Not a valid nix attrset" +EXPR + ) + + >&2 echo "Overriding refs:" + >&2 nix-instantiate --eval --strict --readonly-mode -E "${check_expr}" --arg x $input_expr || exit 1 +} + +[[ $# -eq 0 ]] && usage && >&2 echo "Running with defaults" + +while getopts "hsf:r:" opt; do + case $opt in + h) usage + exit 0 + ;; + s) USE_STACK='true' + ;; + f) FOLDER="$(abs_path $OPTARG)" + [[ ! -f "${FOLDER}/${SOURCES_FILE}" ]] && >&2 echo "No sources.json file" && exit 1 + ;; + r) REFS=$OPTARG + check_nix_set $REFS + ;; + *) usage + exit 1 + ;; + esac +done +shift $((OPTIND -1)) + +>&2 echo "Using path: ${FOLDER}" + +SOURCES_PATH="${FOLDER}/${SOURCES_FILE}" + +SOURCES=$(cat "${SOURCES_PATH}") + +NEW_SOURCES=$(nix-instantiate --tarball-ttl 0 --eval --strict nix/update.nix --arg refs "${REFS}" --argstr rawSources "${SOURCES}" --arg forStack $USE_STACK --show-trace --json) + +echo >&2 + +if [[ $USE_STACK == 'true' ]]; then + echo "${NEW_SOURCES}" | yq . --yaml-output +else + FORMATTED_SOURCE=$(echo "${NEW_SOURCES}" | jq .) + cat <<< "${FORMATTED_SOURCE}" > "${SOURCES_PATH}" + >&2 echo "Wrote the following to ${SOURCES_PATH}:" + echo "${FORMATTED_SOURCE}" | jq . -C +fi