diff --git a/euler-hs.cabal b/euler-hs.cabal index ee883984..532bae3e 100644 --- a/euler-hs.cabal +++ b/euler-hs.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: euler-hs -version: 2.6.0.1 +version: 3.3.2.0 synopsis: The Flow framework for web backends license: Apache-2.0 author: Juspay Technologies Pvt Ltd @@ -8,42 +8,43 @@ maintainer: opensource@juspay.in copyright: (C) Juspay Technologies Pvt Ltd 2019-2022 category: Euler build-type: Simple -tested-with: GHC ==8.8.3 +tested-with: GHC ==8.8.4 || ==8.10.7 +source-repository head + type: git + location: https://github.com/juspay/euler-hs common common-lang ghc-options: -Wall -Wcompat -Wincomplete-record-updates - -Wincomplete-uni-patterns -Wredundant-constraints + -Wincomplete-uni-patterns -Wredundant-constraints -Werror + -fplugin=RecordDotPreprocessor + + build-depends: + , base + , record-dot-preprocessor + , record-hasfield + , euler-events-hs - build-depends: base >=4.13 && <5 default-extensions: NoImplicitPrelude - ConstraintKinds DataKinds - DefaultSignatures DeriveFunctor DeriveGeneric DuplicateRecordFields - ExplicitNamespaces + EmptyCase FlexibleContexts FlexibleInstances - FunctionalDependencies - GADTs + GeneralizedNewtypeDeriving + InstanceSigs LambdaCase MultiParamTypeClasses - MultiWayIf - NamedFieldPuns OverloadedLabels OverloadedStrings - PatternSynonyms - RankNTypes - RecordWildCards - ScopedTypeVariables TupleSections TypeApplications TypeFamilies - TypeOperators - ViewPatterns + TypeSynonymInstances + UndecidableInstances default-language: Haskell2010 @@ -52,89 +53,126 @@ library exposed-modules: EulerHS.CachedSqlDBQuery EulerHS.Extra.AltValidation + EulerHS.Extra.Aeson + EulerHS.Extra.Combinators EulerHS.Extra.Test + EulerHS.Extra.Time EulerHS.Extra.Validation EulerHS.Interpreters EulerHS.Language EulerHS.Prelude EulerHS.Runtime EulerHS.Types + EulerHS.SqlDB.Language + EulerHS.KVConnector.DBSync + EulerHS.KVConnector.Encoding + EulerHS.KVConnector.Flow + EulerHS.KVConnector.Metrics + EulerHS.KVConnector.Types + EulerHS.Logger.Types + EulerHS.KVConnector.InMemConfig.Types + EulerHS.KVConnector.Utils + EulerHS.Extra.Regex + EulerHS.Masking + EulerHS.Extra.URLSanitization + EulerHS.Extra.Snowflakes.Types + EulerHS.Extra.Snowflakes.Flow + EulerHS.Extra.Monitoring.Types + EulerHS.Extra.Monitoring.Flow + EulerHS.KVConnector.InMemConfig.Flow + EulerHS.ART.Utils + EulerHS.ART.EnvVars + EulerHS.ART.FlowUtils + EulerHS.ART.Types + EulerHS.ApiHelpers + EulerHS.ART.ReplayFunctions + EulerHS.PIIEncryption other-modules: - EulerHS.Core.Api - EulerHS.Core.Interpreters - EulerHS.Core.KVDB.Interpreter - EulerHS.Core.KVDB.Language - EulerHS.Core.Language - EulerHS.Core.Logger.Impl.TinyLogger - EulerHS.Core.Logger.Interpreter - EulerHS.Core.Logger.Language - EulerHS.Core.Masking - EulerHS.Core.PubSub.Interpreter - EulerHS.Core.PubSub.Language - EulerHS.Core.Runtime - EulerHS.Core.SqlDB.Interpreter - EulerHS.Core.SqlDB.Language - EulerHS.Core.Types - EulerHS.Core.Types.BinaryString - EulerHS.Core.Types.Common - EulerHS.Core.Types.DB - EulerHS.Core.Types.Exceptions - EulerHS.Core.Types.HttpAPI - EulerHS.Core.Types.KVDB - EulerHS.Core.Types.Logger - EulerHS.Core.Types.MySQL - EulerHS.Core.Types.Options - EulerHS.Core.Types.Postgres - EulerHS.Core.Types.Serializable - EulerHS.Extra.Aeson + EulerHS.Api + EulerHS.ART.DBReplay + EulerHS.BinaryString + EulerHS.Common EulerHS.Extra.Language - EulerHS.Framework.Flow.Interpreter - EulerHS.Framework.Flow.Language - EulerHS.Framework.Interpreters + EulerHS.Framework.Interpreter EulerHS.Framework.Language EulerHS.Framework.Runtime + EulerHS.HttpAPI + EulerHS.KVDB.Interpreter + EulerHS.KVDB.Language + EulerHS.KVDB.Types + EulerHS.Logger.Interpreter + EulerHS.Logger.Language + EulerHS.Logger.Runtime + EulerHS.Logger.TinyLogger + EulerHS.Options + EulerHS.PubSub.Interpreter + EulerHS.PubSub.Language + EulerHS.SqlDB.Interpreter + EulerHS.SqlDB.MySQL + EulerHS.SqlDB.Postgres + EulerHS.SqlDB.Types + EulerHS.Extra.Orphans build-depends: + , QuickCheck , aeson + , aeson-pretty , base64-bytestring - , base64-bytestring-type - , beam-core ^>=0.9.0.0 - , beam-mysql ^>=1.2.1.0 - , beam-postgres ^>=0.5.0.0 - , beam-sqlite ^>=0.5.0.0 - , binary + , beam-core + , beam-mysql + , beam-postgres + , beam-sqlite , bytestring , case-insensitive + , casing , cereal , connection , containers + , cryptostore + , ctrie , data-default + , directory , dlist , exceptions , extra , fmt + , formatting , free + , generic-deriving , generic-lens - , hedis + , hedis + , http-api-data , http-client , http-client-tls , http-media , http-types - , lens - , mason - , mysql-haskell ^>=0.8.4.2 + , juspay-extra + , lrucache + , lrucaching + , mysql-haskell , named , newtype-generics + , nonempty-containers + , nonempty-vector + , optics-core + , pem , postgresql-simple , process , profunctors + , random + , reflection , resource-pool - , sequelize ^>=1.1.0.0 - , servant-client ^>=0.18.1 - , servant-client-core ^>=0.18.1 + , safe + , scientific + , sequelize + , servant + , servant-client + , servant-client-core + , servant-server , sqlite-simple , stm + , store , string-conversions , text , time @@ -147,7 +185,18 @@ library , utf8-string , uuid , validation + , validation-selective , vector + , x509 + , x509-store + , x509-system + , x509-validation + , safe-exceptions + , pcre-heavy + , pcre-light + , attoparsec + , tasty-hunit + , mtl hs-source-dirs: src @@ -156,127 +205,75 @@ test-suite language type: exitcode-stdio-1.0 main-is: Main.hs other-modules: - EulerHS.Core.Api - EulerHS.Core.Interpreters - EulerHS.Core.KVDB.Interpreter - EulerHS.Core.KVDB.Language - EulerHS.Core.Language - EulerHS.Core.Logger.Impl.TinyLogger - EulerHS.Core.Logger.Interpreter - EulerHS.Core.Logger.Language - EulerHS.Core.Masking - EulerHS.Core.PubSub.Interpreter - EulerHS.Core.PubSub.Language - EulerHS.Core.Runtime - EulerHS.Core.SqlDB.Interpreter - EulerHS.Core.SqlDB.Language - EulerHS.Core.Types - EulerHS.Core.Types.BinaryString - EulerHS.Core.Types.Common - EulerHS.Core.Types.DB - EulerHS.Core.Types.Exceptions - EulerHS.Core.Types.HttpAPI - EulerHS.Core.Types.KVDB - EulerHS.Core.Types.Logger - EulerHS.Core.Types.MySQL - EulerHS.Core.Types.Options - EulerHS.Core.Types.Postgres - EulerHS.Core.Types.Serializable - EulerHS.Extra.Aeson - EulerHS.Extra.Language - EulerHS.Framework.Flow.Interpreter - EulerHS.Framework.Flow.Language - EulerHS.Framework.Interpreters - EulerHS.Framework.Language - EulerHS.Framework.Runtime - EulerHS.Interpreters - EulerHS.Language - EulerHS.Prelude - EulerHS.Runtime - EulerHS.TestData.API.Client - EulerHS.TestData.Scenarios.Scenario1 + ArtSpec + -- CachedDBSpec + Client + Common + DBSetup EulerHS.TestData.Types EulerHS.Testing.Flow.Interpreter EulerHS.Testing.Types - EulerHS.Tests.Framework.ArtSpec - EulerHS.Tests.Framework.Common - EulerHS.Tests.Framework.DBSetup - EulerHS.Tests.Framework.FlowSpec - EulerHS.Tests.Framework.KVDBArtSpec - EulerHS.Tests.Framework.PubSubSpec - EulerHS.Tests.Framework.SQLArtSpec - EulerHS.Types - EulerHS.Tests.Framework.CachedDBSpec - EulerHS.Tests.Framework.MaskingSpec + HttpAPISpec + FlowSpec + KVDBArtSpec + MaskingSpec + PubSubSpec + Scenario1 + SQLArtSpec build-depends: , aeson , aeson-pretty , async - , base64-bytestring - , base64-bytestring-type , beam-core - , beam-mysql ^>=1.2.1.0 - , beam-postgres ^>=0.5.0.0 , beam-sqlite + , beam-mysql , bytestring - , case-insensitive - , cereal - , connection , containers , data-default , directory - , dlist , euler-hs - , exceptions , extra , filepath - , fmt - , free , generic-arbitrary , generic-lens , hedis , hspec , http-client , http-client-tls - , http-media - , http-types - , lens , named - , newtype-generics - , mysql-haskell ^>=0.8.4.2 - , postgresql-simple , process - , profunctors , QuickCheck , quickcheck-instances , random - , resource-pool , 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 + , servant + , servant-client + , servant-mock + , servant-server , string-conversions , text - , time - , tinylog , tls - , transformers , typed-process - , unagi-chan - , universum , unordered-containers - , utf8-string , uuid , vector , warp + , warp-tls + , x509-store + , tls + , connection + , time + , tinylog + , template-haskell + , casing + , scientific + , hspec-core + , cereal - hs-source-dirs: test src + ghc-options: -threaded -O2 + hs-source-dirs: test/language test-suite db import: common-lang @@ -311,3 +308,26 @@ test-suite db , time hs-source-dirs: testDB + +test-suite extra + import: common-lang + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Options + SnowflakesSpec + + build-depends: + , aeson + , euler-hs + , hspec + , bytestring + , containers + , unordered-containers + , async + , tinylog + , directory + , text + , time + + hs-source-dirs: test/extra, test/common \ No newline at end of file diff --git a/flake.lock b/flake.lock index d13eb461..29efe64f 100644 --- a/flake.lock +++ b/flake.lock @@ -20,17 +20,17 @@ "beam-mysql": { "flake": false, "locked": { - "lastModified": 1604096494, - "narHash": "sha256-+mCbshr1YSJzLrEb+JpSQaH5EODAZ0Sm8sstztKAZq0=", + "lastModified": 1675165348, + "narHash": "sha256-sFOtfvAeFwIaMpMK8vD5usE71/jTHwDCdbf++h4jOqQ=", "owner": "juspay", "repo": "beam-mysql", - "rev": "4c876ea2eae60bf3402d6f5c1ecb60a386fe3ace", + "rev": "b4dbc91276f6a8b5356633492f89bdac34ccd9a1", "type": "github" }, "original": { "owner": "juspay", "repo": "beam-mysql", - "rev": "4c876ea2eae60bf3402d6f5c1ecb60a386fe3ace", + "rev": "b4dbc91276f6a8b5356633492f89bdac34ccd9a1", "type": "github" } }, @@ -75,6 +75,23 @@ "type": "github" } }, + "cereal": { + "flake": false, + "locked": { + "lastModified": 1668616659, + "narHash": "sha256-FkwxTJzY4A2CaGnQ+YBdEKZr+apEBK8Awcxrfp4uIvE=", + "owner": "juspay", + "repo": "cereal", + "rev": "213f145ccbd99e630ee832d2f5b22894c810d3cc", + "type": "github" + }, + "original": { + "owner": "juspay", + "repo": "cereal", + "rev": "213f145ccbd99e630ee832d2f5b22894c810d3cc", + "type": "github" + } + }, "common": { "inputs": { "cachix-push": "cachix-push", @@ -91,11 +108,11 @@ "treefmt-nix": "treefmt-nix" }, "locked": { - "lastModified": 1685470074, - "narHash": "sha256-0vdewKY4Vmx476Qg5qd2voyuL7ZssqOUlQeNJCuvs3Q=", + "lastModified": 1687365764, + "narHash": "sha256-T67Dr9TvZYfXEOuFPfdDnNKTc1Kqy6xyhFjXEXHu1Dc=", "owner": "nammayatri", "repo": "common", - "rev": "9b0393630068e688795bedd46c49df1a0bbc7c0a", + "rev": "5f16f3ebf64a4523eb8c1b20dadcb65cef5146ab", "type": "github" }, "original": { @@ -146,6 +163,31 @@ "type": "github" } }, + "euler-events-hs": { + "inputs": { + "flake-parts": "flake-parts_2", + "haskell-flake": [ + "common", + "haskell-flake" + ], + "nixpkgs": "nixpkgs_6", + "prometheus-haskell": "prometheus-haskell" + }, + "locked": { + "lastModified": 1690219299, + "narHash": "sha256-YXz1EjpFkgFAC3txAj/9ItuO0SQBKrOwykBmc9w4qXs=", + "owner": "juspay", + "repo": "euler-events-hs", + "rev": "214d436a83113c04b6f937c68488abf53beea4e8", + "type": "github" + }, + "original": { + "owner": "juspay", + "ref": "main", + "repo": "euler-events-hs", + "type": "github" + } + }, "flake-compat": { "flake": false, "locked": { @@ -196,6 +238,60 @@ "type": "github" } }, + "flake-parts_2": { + "inputs": { + "nixpkgs-lib": "nixpkgs-lib_2" + }, + "locked": { + "lastModified": 1683560683, + "narHash": "sha256-XAygPMN5Xnk/W2c1aW0jyEa6lfMDZWlQgiNtmHXytPc=", + "owner": "hercules-ci", + "repo": "flake-parts", + "rev": "006c75898cf814ef9497252b022e91c946ba8e17", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "flake-parts", + "type": "github" + } + }, + "flake-parts_3": { + "inputs": { + "nixpkgs-lib": "nixpkgs-lib_3" + }, + "locked": { + "lastModified": 1683560683, + "narHash": "sha256-XAygPMN5Xnk/W2c1aW0jyEa6lfMDZWlQgiNtmHXytPc=", + "owner": "hercules-ci", + "repo": "flake-parts", + "rev": "006c75898cf814ef9497252b022e91c946ba8e17", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "flake-parts", + "type": "github" + } + }, + "flake-parts_4": { + "inputs": { + "nixpkgs-lib": "nixpkgs-lib_4" + }, + "locked": { + "lastModified": 1683560683, + "narHash": "sha256-XAygPMN5Xnk/W2c1aW0jyEa6lfMDZWlQgiNtmHXytPc=", + "owner": "hercules-ci", + "repo": "flake-parts", + "rev": "006c75898cf814ef9497252b022e91c946ba8e17", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "flake-parts", + "type": "github" + } + }, "flake-root": { "locked": { "lastModified": 1680210152, @@ -306,18 +402,17 @@ "hedis": { "flake": false, "locked": { - "lastModified": 1681138785, - "narHash": "sha256-e3JLqLMtIYUoRMbt4E9SHfIok1WkrQqzn11OOi8JfUM=", - "owner": "juspay", - "repo": "hedis", - "rev": "22d814672d8476a6f8fb43047af2897afbf77ac6", - "type": "github" + "lastModified": 1685620412, + "narHash": "sha256-cPRZRbR76M7fBNSXcrSOqLlIcs2KSj/Ynf0AdZ46qrE=", + "rev": "92a3d5ab73dcb0ea11139a01d6f2950a8b8e7e0e", + "revCount": 712, + "type": "git", + "url": "https://github.com/juspay/hedis" }, "original": { - "owner": "juspay", - "repo": "hedis", - "rev": "22d814672d8476a6f8fb43047af2897afbf77ac6", - "type": "github" + "rev": "92a3d5ab73dcb0ea11139a01d6f2950a8b8e7e0e", + "type": "git", + "url": "https://github.com/juspay/hedis" } }, "hnix-store-core": { @@ -337,6 +432,29 @@ "type": "github" } }, + "juspay-extra": { + "inputs": { + "flake-parts": "flake-parts_4", + "haskell-flake": [ + "common", + "haskell-flake" + ], + "nixpkgs": "nixpkgs_8" + }, + "locked": { + "lastModified": 1686322580, + "narHash": "sha256-EDdBN4Nfm/u+QRDZRv+vb8RfcJZpoToSr9pSBGc9vBI=", + "owner": "juspay", + "repo": "euler-haskell-common", + "rev": "4892071b7af07e5faa085e7917ab12110399f0e5", + "type": "github" + }, + "original": { + "owner": "juspay", + "repo": "euler-haskell-common", + "type": "github" + } + }, "lowdown-src": { "flake": false, "locked": { @@ -477,6 +595,60 @@ "type": "github" } }, + "nixpkgs-lib_2": { + "locked": { + "dir": "lib", + "lastModified": 1682879489, + "narHash": "sha256-sASwo8gBt7JDnOOstnps90K1wxmVfyhsTPPNTGBPjjg=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "da45bf6ec7bbcc5d1e14d3795c025199f28e0de0", + "type": "github" + }, + "original": { + "dir": "lib", + "owner": "NixOS", + "ref": "nixos-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-lib_3": { + "locked": { + "dir": "lib", + "lastModified": 1682879489, + "narHash": "sha256-sASwo8gBt7JDnOOstnps90K1wxmVfyhsTPPNTGBPjjg=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "da45bf6ec7bbcc5d1e14d3795c025199f28e0de0", + "type": "github" + }, + "original": { + "dir": "lib", + "owner": "NixOS", + "ref": "nixos-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-lib_4": { + "locked": { + "dir": "lib", + "lastModified": 1682879489, + "narHash": "sha256-sASwo8gBt7JDnOOstnps90K1wxmVfyhsTPPNTGBPjjg=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "da45bf6ec7bbcc5d1e14d3795c025199f28e0de0", + "type": "github" + }, + "original": { + "dir": "lib", + "owner": "NixOS", + "ref": "nixos-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, "nixpkgs-regression": { "locked": { "lastModified": 1643052045, @@ -589,6 +761,54 @@ "type": "github" } }, + "nixpkgs_6": { + "locked": { + "lastModified": 1684879512, + "narHash": "sha256-BoAOf19Dshtfu6BDPznrKO97oeCkXlYfa1Hyt0Qv8VU=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "e6e049b7a24decd1f0caee8b035913795697c699", + "type": "github" + }, + "original": { + "owner": "nixos", + "ref": "nixpkgs-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs_7": { + "locked": { + "lastModified": 1683657389, + "narHash": "sha256-jx91UqqoBneE8QPAKJA29GANrU/Z7ULghoa/JE0+Edw=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "9524f57dd5b3944c819dd594aed8ed941932ef56", + "type": "github" + }, + "original": { + "owner": "nixos", + "ref": "nixpkgs-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs_8": { + "locked": { + "lastModified": 1684879512, + "narHash": "sha256-BoAOf19Dshtfu6BDPznrKO97oeCkXlYfa1Hyt0Qv8VU=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "e6e049b7a24decd1f0caee8b035913795697c699", + "type": "github" + }, + "original": { + "owner": "nixos", + "ref": "nixpkgs-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, "pre-commit-hooks": { "inputs": { "flake-compat": [ @@ -647,11 +867,11 @@ }, "process-compose-flake": { "locked": { - "lastModified": 1680797953, - "narHash": "sha256-lFYbfId1IX6jh/wUf+gt3LyvE9HblS4hcBQcougSzX0=", + "lastModified": 1687298948, + "narHash": "sha256-7Lu4/odCkkwrzR8Mo+3D+URv4oLap8WWLESzi/75eb0=", "owner": "Platonic-Systems", "repo": "process-compose-flake", - "rev": "aee1b8d126a5efe5945513eb2fb343f3d68dca4b", + "rev": "5bdb90b85642901cf9a5dccfe8c907091c261604", "type": "github" }, "original": { @@ -660,11 +880,37 @@ "type": "github" } }, + "prometheus-haskell": { + "inputs": { + "flake-parts": "flake-parts_3", + "haskell-flake": [ + "euler-events-hs", + "haskell-flake" + ], + "nixpkgs": "nixpkgs_7" + }, + "locked": { + "lastModified": 1687373886, + "narHash": "sha256-KWxG4SyXo39yG+7b1H0ULKzVu8Z1Hj8KCqS0rQKw3qU=", + "owner": "juspay", + "repo": "prometheus-haskell", + "rev": "f1d996bb317d0a50450ace2b4ae08b5afdf22955", + "type": "github" + }, + "original": { + "owner": "juspay", + "ref": "more-proc-metrics", + "repo": "prometheus-haskell", + "type": "github" + } + }, "root": { "inputs": { "beam": "beam", "beam-mysql": "beam-mysql", + "cereal": "cereal", "common": "common", + "euler-events-hs": "euler-events-hs", "flake-parts": [ "common", "flake-parts" @@ -674,6 +920,7 @@ "haskell-flake" ], "hedis": "hedis", + "juspay-extra": "juspay-extra", "mysql-haskell": "mysql-haskell", "nixpkgs": [ "common", @@ -685,17 +932,17 @@ "sequelize": { "flake": false, "locked": { - "lastModified": 1657529023, - "narHash": "sha256-su4fGXqcrxC1kDlomt7dqmU3HAlkcd9MYaLPyK1vXXc=", + "lastModified": 1688647938, + "narHash": "sha256-F7nixhDpXNRrpgxRH3xtnN+FkB2HS44VMrnoq1VfBnI=", "owner": "juspay", "repo": "haskell-sequelize", - "rev": "3abc8fe10edde3fd1c9a776ede81d057dc590341", + "rev": "dc01b0f9e6ba5a51dd8f9d0744a549dc9c0ba244", "type": "github" }, "original": { "owner": "juspay", - "ref": "beckn-compatible", "repo": "haskell-sequelize", + "rev": "dc01b0f9e6ba5a51dd8f9d0744a549dc9c0ba244", "type": "github" } }, diff --git a/flake.nix b/flake.nix index d5e11518..e7d5ddbb 100644 --- a/flake.nix +++ b/flake.nix @@ -7,15 +7,27 @@ haskell-flake.follows = "common/haskell-flake"; # Haskell dependencies - sequelize.url = "github:juspay/haskell-sequelize/beckn-compatible"; + cereal.url = "github:juspay/cereal/213f145ccbd99e630ee832d2f5b22894c810d3cc"; + cereal.flake = false; + + juspay-extra.url = "github:juspay/euler-haskell-common"; + juspay-extra.inputs.haskell-flake.follows = "common/haskell-flake"; + + euler-events-hs.url = "github:juspay/euler-events-hs/main"; + euler-events-hs.inputs.haskell-flake.follows = "common/haskell-flake"; + + sequelize.url = "github:juspay/haskell-sequelize/dc01b0f9e6ba5a51dd8f9d0744a549dc9c0ba244"; sequelize.flake = false; - beam.url = "github:srid/beam/ghc810"; # https://github.com/juspay/beam/pull/14 + + beam.url = "github:srid/beam/ghc810"; beam.flake = false; - beam-mysql.url = "github:juspay/beam-mysql/4c876ea2eae60bf3402d6f5c1ecb60a386fe3ace"; + + beam-mysql.url = "github:juspay/beam-mysql/b4dbc91276f6a8b5356633492f89bdac34ccd9a1"; beam-mysql.flake = false; + mysql-haskell.url = "github:juspay/mysql-haskell/788022d65538db422b02ecc0be138b862d2e5cee"; # https://github.com/winterland1989/mysql-haskell/pull/38 mysql-haskell.flake = false; - hedis.url = "github:juspay/hedis/22d814672d8476a6f8fb43047af2897afbf77ac6"; + hedis.url = "git+https://github.com/juspay/hedis?rev=92a3d5ab73dcb0ea11139a01d6f2950a8b8e7e0e"; hedis.flake = false; }; outputs = inputs@{ nixpkgs, flake-parts, ... }: @@ -29,6 +41,10 @@ packages.default = self'.packages.euler-hs; haskellProjects.default = { projectFlakeName = "euler-hs"; + imports = [ + inputs.euler-events-hs.haskellFlakeProjectModules.output + inputs.juspay-extra.haskellFlakeProjectModules.output + ]; basePackages = config.haskellProjects.ghc810.outputs.finalPackages; packages = { beam-core.source = inputs.beam + /beam-core; @@ -39,6 +55,7 @@ hedis.source = inputs.hedis; mysql-haskell.source = inputs.mysql-haskell; sequelize.source = inputs.sequelize; + cereal.source = inputs.cereal; }; settings = { beam-core.jailbreak = true; @@ -61,8 +78,33 @@ jailbreak = true; }; sequelize.check = false; + + cereal = { + check = false; + jailbreak = true; + }; + euler-events-hs = { + check = false; + jailbreak = true; + }; + juspay-extra = { + check = false; + jailbreak = true; + }; + nonempty-containers = { + jailbreak = true; + }; + servant-client = { + jailbreak = true; + }; + servant-client-core = { + jailbreak = true; + }; + servant-server = { + jailbreak = true; + }; }; }; }; }; -} +} \ No newline at end of file diff --git a/src/EulerHS/ART/DBReplay.hs b/src/EulerHS/ART/DBReplay.hs new file mode 100644 index 00000000..3ab2f279 --- /dev/null +++ b/src/EulerHS/ART/DBReplay.hs @@ -0,0 +1,281 @@ +{- | +Module : EulerHS.ART.DBReplay +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +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. +-} + +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module EulerHS.ART.DBReplay where + +import qualified Data.Aeson as A +import Data.Either.Extra (mapLeft) +import Data.Time.Clock.POSIX (getPOSIXTime) +import qualified Database.Beam as B +import qualified EulerHS.Language as L +import EulerHS.Prelude +import qualified EulerHS.SqlDB.Language as DB +import EulerHS.Types (DBConfig) +import qualified EulerHS.Types as T +import EulerHS.KVConnector.InMemConfig.Flow (searchInMemoryCache) +import Sequelize (Model, Set (..), Where) +import qualified Servant as S +import qualified Data.Serialize as Serialize +import EulerHS.ART.FlowUtils (addRecToState) +import qualified EulerHS.ART.EnvVars as Env +import EulerHS.KVConnector.Types (KVConnector(..), MeshResult, MeshMeta(..), tableName, Source(..)) +import EulerHS.ART.Types (RunDBEntry(..), RecordingEntry(..),RunInMemEntry(..)) +import EulerHS.KVConnector.Utils +import EulerHS.KVConnector.DBSync (whereClauseToJson) +import EulerHS.SqlDB.Types (BeamRunner, BeamRuntime) +import qualified EulerHS.ART.ReplayFunctions as ER +import EulerHS.KVDB.Types (MeshError(..)) +import EulerHS.PIIEncryption (PII(..)) +import qualified Data.ByteString.Lazy as BS + +getCurrentDateInMillis :: (L.MonadFlow m) => m Int +getCurrentDateInMillis = L.runIO $ do + t <- (* 1000) <$> getPOSIXTime + pure . floor $ t + +getLatencyInMicroSeconds :: Integer -> Integer +getLatencyInMicroSeconds execTime = execTime `div` 1000000 + +parseDataReplayList ::(FromJSON b,L.MonadFlow m) => BS.ByteString -> m (Either T.DBError [b]) +parseDataReplayList res = do + let eReply = A.eitherDecode res :: (FromJSON b) => Either String (Either T.DBError [b]) + case eReply of + Left err -> do + let errorMessage = "Failed to decode response: " <> encodeUtf8 err + L.throwException $ S.err400 {S.errBody = errorMessage} + Right reply -> pure reply + +parseDataReplay ::(FromJSON b, L.MonadFlow m) => BS.ByteString -> m (Either MeshError b) +parseDataReplay res = do + let eReply = A.eitherDecode res :: (FromJSON b) => Either String (Either MeshError b) + case eReply of + Left err -> do + let errorMessage = "Failed to decode response: " <> encodeUtf8 err + L.throwException $ S.err400 {S.errBody = errorMessage} + Right reply -> pure reply + +runWithArtFindALL :: + forall be beM table m. + (Model be table + , FromJSON (table Identity) + , ToJSON (table Identity) + , KVConnector (table Identity) + , MeshMeta be table + , L.MonadFlow m + ) => + DBConfig beM -> + Where be table -> + Text -> + m (Either T.DBError [table Identity]) -> + m (Either T.DBError [table Identity]) +runWithArtFindALL _dbConf whereClause method hsDbFunc = do + do + if Env.isArtReplayEnabled + then do + recTimestamp <- L.getCurrentTimeUTC + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayDB (RunDBEntryT (RunDBEntry method A.Null (whereClauseToJson whereClause) (tableName @(table Identity)) (A.Null) recTimestamp)) msessionId + parseDataReplayList resp + else do + tmp_res <- hsDbFunc + when Env.isArtRecEnabled $ do + recTimestamp <- L.getCurrentTimeUTC + addRecToState $ RunDBEntryT (RunDBEntry method A.Null (whereClauseToJson whereClause) (tableName @(table Identity)) (toJSON tmp_res) recTimestamp) + pure tmp_res + +runWithArtFindAllExtended :: + forall be beM table m. + (Model be table + , FromJSON (table Identity) + , ToJSON (table Identity) + , KVConnector (table Identity) + , MeshMeta be table + , L.MonadFlow m + ) => + DBConfig beM -> + DB.SqlDB beM [table Identity] -> + Where be table -> + Text -> + m (Either T.DBError [table Identity]) -> + m (Either T.DBError [table Identity]) +runWithArtFindAllExtended _dbConf _query whereClause method hsDbFunc = do + do + if Env.isArtReplayEnabled + then do + recTimestamp <- L.getCurrentTimeUTC + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayDB (RunDBEntryT (RunDBEntry method A.Null (whereClauseToJson whereClause) (tableName @(table Identity)) (A.Null) recTimestamp)) msessionId + parseDataReplayList resp + else do + tmp_res <- hsDbFunc + when Env.isArtRecEnabled $ do + recTimestamp <- L.getCurrentTimeUTC + addRecToState $ RunDBEntryT (RunDBEntry method A.Null (whereClauseToJson whereClause) (tableName @(table Identity)) (toJSON tmp_res) recTimestamp) + pure tmp_res + +runWithArtFind :: + forall be beM table m. + (Model be table + , KVConnector (table Identity) + , FromJSON (table Identity) + , ToJSON (table Identity) + , MeshMeta be table + , L.MonadFlow m + ) => + DBConfig beM -> + Where be table -> + Text -> + m (Either T.DBError (Maybe (table Identity))) -> + m (MeshResult (Maybe (table Identity))) +runWithArtFind _dbConf whereClause method hsDbFunc = do + do + if Env.isArtReplayEnabled + then do + recTimestamp <- L.getCurrentTimeUTC + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayDB (RunDBEntryT (RunDBEntry method A.Null (whereClauseToJson whereClause) (tableName @(table Identity)) (A.Null) recTimestamp)) msessionId + pure $ + case A.decode resp of + Just val -> val + Nothing -> Right Nothing + else do + res <- hsDbFunc + when Env.isArtRecEnabled $ do + recTimestamp <- L.getCurrentTimeUTC + addRecToState $ RunDBEntryT (RunDBEntry method A.Null (whereClauseToJson whereClause) (tableName @(table Identity)) (toJSON res) recTimestamp) + pure $ mapLeft MDBError $ res + +runWithArtUpdate :: + forall be beM a table m. + (Model be table + , FromJSON a + , ToJSON a + , KVConnector (table Identity) + , MeshMeta be table + , L.MonadFlow m + ) => + DBConfig beM -> + [Set be table] -> + Where be table -> + Text -> + m (T.DBResult a) -> + m (MeshResult a) +runWithArtUpdate _ setClause whereClause method hsDbFunc = do + do + if Env.isArtReplayEnabled + then do + recTimestamp <- L.getCurrentTimeUTC + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayDB (RunDBEntryT (RunDBEntry method (toJSON (jsonKeyValueUpdates setClause)) (whereClauseToJson whereClause) (tableName @(table Identity)) (A.Null) recTimestamp)) msessionId + parseDataReplay resp + else do + tmp_res <- hsDbFunc + when Env.isArtRecEnabled $ do + recTimestamp <- L.getCurrentTimeUTC + addRecToState $ RunDBEntryT (RunDBEntry method (toJSON (jsonKeyValueUpdates setClause)) (whereClauseToJson whereClause) (tableName @(table Identity)) (toJSON tmp_res) recTimestamp) + pure $ mapLeft MDBError $ tmp_res + +runWithArtCreatemSQl :: + forall beM a table m. + ( ToJSON (table Identity) + , FromJSON a + , ToJSON a + , KVConnector (table Identity) + , L.MonadFlow m + ) => + DBConfig beM -> + table Identity -> + Text -> + m (T.DBResult a) -> + m (MeshResult a) +runWithArtCreatemSQl _ value method hsDbFunc = do + do + if Env.isArtReplayEnabled + then do + recTimestamp <- L.getCurrentTimeUTC + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayDB (RunDBEntryT (RunDBEntry method (toJSON value) A.Null (tableName @(table Identity)) (A.Null) recTimestamp)) msessionId + parseDataReplay resp + else do + tmp_res <- hsDbFunc + when Env.isArtRecEnabled $ do + recTimestamp <- L.getCurrentTimeUTC + addRecToState $ RunDBEntryT (RunDBEntry method (toJSON value) A.Null (tableName @(table Identity)) (toJSON tmp_res) recTimestamp) + pure $ mapLeft MDBError $ tmp_res + +runWithArtDelete :: + forall be beM a table m. + (Model be table + , FromJSON a + , ToJSON a + , KVConnector (table Identity) + , MeshMeta be table + , L.MonadFlow m + ) => + DBConfig beM -> + Where be table -> + Text -> + m (T.DBResult a) -> + m (MeshResult a) +runWithArtDelete _ whereClause method hsDbFunc = do + do + if Env.isArtReplayEnabled + then do + recTimestamp <- L.getCurrentTimeUTC + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayDB (RunDBEntryT (RunDBEntry method A.Null (whereClauseToJson whereClause) (tableName @(table Identity)) (A.Null) recTimestamp)) msessionId + parseDataReplay resp + else do + tmp_res <- hsDbFunc + when Env.isArtRecEnabled $ do + recTimestamp <- L.getCurrentTimeUTC + addRecToState $ RunDBEntryT (RunDBEntry method A.Null (whereClauseToJson whereClause) (tableName @(table Identity)) (toJSON tmp_res) recTimestamp) + pure $ mapLeft MDBError $ tmp_res + +searchInMemoryCacheRecRepWrapper :: forall be beM table m. + ( + BeamRuntime be beM, + BeamRunner beM, + B.HasQBuilder be, + HasCallStack, + KVConnector (table Identity), + ToJSON (table Identity), + Show (table Identity), + Serialize.Serialize (table Identity), + FromJSON (table Identity), + Model be table, + MeshMeta be table, + PII table, + L.MonadFlow m + ) => Text -> + DBConfig beM -> + Where be table -> + m (Source, MeshResult (Maybe (table Identity))) +searchInMemoryCacheRecRepWrapper method dbConf whereClause = do + if Env.isArtReplayEnabled + then do + recTimestamp <- L.getCurrentTimeUTC + let recInmem = RunInMemEntryT (RunInMemEntry method A.Null (whereClauseToJson whereClause) (toJSON $ tableName @(table Identity)) (Left A.Null) recTimestamp) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayDB recInmem msessionId + meshRes <- parseDataReplay resp + pure (IN_MEM,meshRes) + else do + (src,meshResult) <- searchInMemoryCache dbConf whereClause + when Env.isArtRecEnabled $ do + recTimestamp <- L.getCurrentTimeUTC + addRecToState $ RunInMemEntryT (RunInMemEntry method A.Null (whereClauseToJson whereClause) (toJSON $ tableName @(table Identity)) (either (Left . toJSON) (Right . toJSON) meshResult) recTimestamp) + pure (src,meshResult) diff --git a/src/EulerHS/ART/EnvVars.hs b/src/EulerHS/ART/EnvVars.hs new file mode 100644 index 00000000..cf8c783a --- /dev/null +++ b/src/EulerHS/ART/EnvVars.hs @@ -0,0 +1,34 @@ +{- | +Module : EulerHS.ART.EnvVars +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable + +This module contains functions to read environment variables +eg : RECORD_FORK_FLOW, IS_REPLAY_ENABLED, RUNNING_MODE, MOCK_SERVER_URL +to be used in ART +-} + +{-# LANGUAGE ScopedTypeVariables #-} + +module EulerHS.ART.EnvVars where + +import qualified Juspay.Extra.Config as Conf +import EulerHS.Prelude + +getDirPath :: Text +getDirPath = fromMaybe "/" $ Conf.lookupEnvT "RECORDER_RECORDINGS_DIR" + +shouldRecordForkFLow :: Bool +shouldRecordForkFLow = Just True == (readMaybe =<< Conf.lookupEnvT "RECORD_FORK_FLOW") + +isArtReplayEnabled :: Bool +isArtReplayEnabled = Just True == (readMaybe =<< Conf.lookupEnvT "IS_REPLAY_ENABLED") + +isArtRecEnabled :: Bool +isArtRecEnabled = Just True == (readMaybe =<< Conf.lookupEnvT "RUNNING_MODE") + +mockServerURL :: Text +mockServerURL = fromMaybe "http://localhost:7777" $ readMaybe =<< Conf.lookupEnvT "MOCK_SERVER_URL" diff --git a/src/EulerHS/ART/FlowUtils.hs b/src/EulerHS/ART/FlowUtils.hs new file mode 100644 index 00000000..79061410 --- /dev/null +++ b/src/EulerHS/ART/FlowUtils.hs @@ -0,0 +1,189 @@ +{- | +Module : EulerHS.ART.FlowUtils +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable + +-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + + + + +module EulerHS.ART.FlowUtils + ( getDirPath, + dateTimeFormatSeparatedBy_, + defaultHTTPrequest, + addRecToState, + writeRecToFile, + shouldRecordForkFLow, + getResponseHttp, + getRecording, + readRecordingsAndWriteToFile, + readRecordingsAndWriteToFileForkFLow + ) where + +import qualified Data.Aeson as A +import qualified Data.Aeson.Text as A +import qualified Data.ByteString.Lazy as BS +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import EulerHS.ART.Types +import qualified EulerHS.ART.Types as ART +import qualified EulerHS.Language as L +import EulerHS.Prelude +import qualified EulerHS.Types as ET +import qualified Data.Text.Lazy as TL +import qualified Servant as S +import qualified Data.Map as Map +import EulerHS.ART.EnvVars + +dateTimeFormatSeparatedBy_ :: String +dateTimeFormatSeparatedBy_ = "%F_%H-%M-%S" + +addRecToState :: (L.MonadFlow m) => ART.RecordingEntry -> m () +addRecToState newRecording = if isArtRecEnabled then L.appendRecordingLocal newRecording else pure () + +writeRecToFile :: (L.MonadFlow m) => Text -> ART.MethodRecordingDescription -> m () +writeRecToFile reqId mrd = do + case removeTrailingSlash getDirPath of + Just dirPath -> do + let fileName = dirPath <> "/" <> reqId <> ".json" + res <- L.runIO $ tryWriteFile fileName + case res of + Right _ -> pure () + Left err -> L.logErrorT "Recording Failed" (T.pack $ displayException err) + Nothing -> L.logErrorT "The directory path seems to be wrong" getDirPath + where + tryWriteFile :: Text -> IO (Either SomeException ()) + tryWriteFile fileName = catch (Right <$> BS.writeFile (T.unpack $ fileName) (A.encode mrd)) (return . Left) + + removeTrailingSlash :: T.Text -> Maybe T.Text + removeTrailingSlash text = + case T.unsnoc text of + Just (initText, lastChar) + | lastChar == '/' -> removeTrailingSlash initText + | otherwise -> Just text + Nothing -> Nothing + +readRecordingsAndWriteToFileForkFLow :: Text -> Text -> L.Flow () +readRecordingsAndWriteToFileForkFLow desc guId = do + entriesList :: [RecordingEntry] <- L.getRecordingLocal + msessionId <- L.getLoggerContext "x-request-id" + let methodRecordingEnties = loopOverEntriesWithIndex 0 entriesList [] + let recordings = + MethodRecording + { jsonRequest = A.Null, + jsonResponse = A.Null, + entries = methodRecordingEnties, + methodConfigs = Nothing, + sessionId = fromMaybe "NO_REQUEST_ID" msessionId, + guid = Just guId , + parameters = HM.singleton "description" desc + } + recordingDescription = + MethodRecordingDescription + { methodName = "FORK-FLOW", + methodRecording = recordings + } + L.delRecordingLocal + writeRecToFile (guId) recordingDescription + +readRecordingsAndWriteToFile :: ET.HTTPMethod -> ET.HTTPRequest -> ET.HTTPResponse -> Text -> Maybe Text -> HM.HashMap Text Text -> L.Flow () +readRecordingsAndWriteToFile _method request response sId mUrl rps = do + entriesList :: [RecordingEntry] <- L.getRecordingLocal + let methodRecordingEnties = loopOverEntriesWithIndex 0 entriesList [] + let recordings = + MethodRecording + { jsonRequest = toJSON request, + jsonResponse = toJSON response, + entries = methodRecordingEnties, + methodConfigs = Nothing, + sessionId = sId, + guid = Nothing , + parameters = rps + } + recordingDescription = + MethodRecordingDescription + { methodName = fromMaybe "NO_URL" mUrl, + methodRecording = recordings + } + writeRecToFile sId recordingDescription + +loopOverEntriesWithIndex :: Int -> [RecordingEntry] -> [MethodRecordingEntry] -> [MethodRecordingEntry] +loopOverEntriesWithIndex _ [] res = res +loopOverEntriesWithIndex i (x:xs) res = loopOverEntriesWithIndex (i + 1) xs ([convertToMethodRecordingEntry x i] <> res) + +convertToMethodRecordingEntry :: RecordingEntry -> Int -> MethodRecordingEntry +convertToMethodRecordingEntry (RunInMemEntryT runInMemEntryT) i = + MethodRecordingEntry { + index = i + 1, + entryName = "RunInMemEntry", + entry = TL.toStrict . A.encodeToLazyText $ runInMemEntryT + } +convertToMethodRecordingEntry (ForkFlowEntryT forkFlowEntry) i = + MethodRecordingEntry { + index = i + 1, + entryName = "ForkFlowEntry", + entry = TL.toStrict . A.encodeToLazyText $ forkFlowEntry + } +convertToMethodRecordingEntry (CallAPIEntryT callApiEntry) i = + MethodRecordingEntry { + index = i + 1, + entryName = "CallAPIEntry", + entry = TL.toStrict . A.encodeToLazyText $ callApiEntry + } +convertToMethodRecordingEntry (RunDBEntryT runDBEntry) i = + MethodRecordingEntry { + index = i + 1, + entryName = "RunDBEntry", + entry = TL.toStrict . A.encodeToLazyText $ runDBEntry + } +convertToMethodRecordingEntry (RunKVDBEntryT runKVDBEntry) i = + MethodRecordingEntry { + index = i + 1, + entryName = "RunKVDBEntry", + entry = TL.toStrict . A.encodeToLazyText $ runKVDBEntry + } + +defaultHTTPrequest :: ET.HTTPRequest +defaultHTTPrequest = + ET.HTTPRequest{ getRequestMethod = ET.Get + , getRequestHeaders = Map.empty + , getRequestBody = Nothing + , getRequestURL = "http://localhost:8080/" + , getRequestTimeout = Just ET.defaultTimeout + , getRequestRedirects = Just 10 + } + +getResponseHttp :: (ToJSON a,L.MonadFlow m) => Either S.ServerError a -> m ET.HTTPResponse +getResponseHttp val = do + let defResponse = ET.HTTPResponse + { getResponseBody = ET.LBinaryString $ A.encode $ toJSON $ T.pack "jsonNull", + getResponseCode = 0, + getResponseHeaders = Map.empty, + getResponseStatus = "" + } + case val of + Left _ -> pure defResponse + Right b -> do + pure $ ET.HTTPResponse { + getResponseBody = ET.LBinaryString $ A.encode $ toJSON b, + getResponseCode = 0, + getResponseHeaders = Map.empty, + getResponseStatus = "" + } + +getRecording :: (ToJSON a )=> ET.HTTPRequest -> Either S.ServerError a -> Bool -> Text -> L.Flow () +getRecording reqHttp res runningMode sessId = do + let reqMethod = ET.getRequestMethod reqHttp + reqUrl = ET.getRequestURL reqHttp + reqHeaders = ET.getRequestHeaders reqHttp + resHttP <- getResponseHttp res + when (runningMode && isArtRecEnabled) $ do + readRecordingsAndWriteToFile reqMethod reqHttp resHttP sessId (Just reqUrl) (HM.fromList $ Map.toList reqHeaders) diff --git a/src/EulerHS/ART/ReplayFunctions.hs b/src/EulerHS/ART/ReplayFunctions.hs new file mode 100644 index 00000000..5d0d28d4 --- /dev/null +++ b/src/EulerHS/ART/ReplayFunctions.hs @@ -0,0 +1,71 @@ +{- | +Module : EulerHS.ART.ReplayFunctions +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveAnyClass #-} + +module EulerHS.ART.ReplayFunctions + ( callBrahmaReplayR, + callBrahmaReplayDB + ) where + +import Data.Aeson as A +import EulerHS.Prelude hiding (Proxy) +import EulerHS.Types () +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as Text +import qualified EulerHS.Options () +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Client as NC +import EulerHS.ART.EnvVars +import Data.Maybe (fromJust) +import Control.Exception + +getApiHIT :: HTTP.Request -> IO (HTTP.Response LBS.ByteString) +getApiHIT httpReq = do + let manager = NC.defaultManagerSettings + mang <- HTTP.newManager manager + HTTP.httpLbs httpReq mang + +data ReplayDecodeException = ReplayDecodeException String deriving (Show, Exception) + +data LOG = LOG { + req :: ByteString + , resp :: ByteString +} + deriving (Generic,Show) + deriving anyclass (ToJSON) + +data MissingSessionID = MissingSessionID Text + deriving (Generic,Show) + deriving anyclass (ToJSON,Exception) + +callBrahmaReplayR :: (ToJSON b) => b -> Maybe Text-> IO LBS.ByteString +callBrahmaReplayR recEntry sessionId = do + _ <- maybe (throw (MissingSessionID "Missing session-id" )) pure sessionId + let url = mockServerURL <> "/mockRedis?guuid=" <> fromJust sessionId + httpRequest <- HTTP.parseRequest $ Text.unpack url + let finalRequest = httpRequest {HTTP.requestBody = HTTP.RequestBodyLBS (A.encode recEntry), + HTTP.method = "POST"} + eResponse <- getApiHIT finalRequest + _ <- putStr $ A.encode $ LOG {req = LBS.toStrict $ A.encode recEntry,resp = LBS.toStrict $ HTTP.responseBody eResponse } + pure $ HTTP.responseBody eResponse + +callBrahmaReplayDB :: (ToJSON b) => b -> Maybe Text-> IO LBS.ByteString +callBrahmaReplayDB recEntry sessionId = do + _ <- maybe (throw (MissingSessionID "Missing session-id" )) pure sessionId + let url = mockServerURL <> "/mockDB?guuid=" <> fromJust sessionId + httpRequest <- HTTP.parseRequest $ Text.unpack url + let finalRequest = httpRequest {HTTP.requestBody = HTTP.RequestBodyLBS (A.encode recEntry), + HTTP.method = "POST"} + eResponse <- getApiHIT finalRequest + _ <- putStr $ A.encode $ LOG {req = LBS.toStrict $A.encode recEntry,resp = LBS.toStrict $ HTTP.responseBody eResponse } + pure $ HTTP.responseBody eResponse diff --git a/src/EulerHS/ART/Types.hs b/src/EulerHS/ART/Types.hs new file mode 100644 index 00000000..325d1ff9 --- /dev/null +++ b/src/EulerHS/ART/Types.hs @@ -0,0 +1,596 @@ +{- | +Module : EulerHS.ART.Types +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable + +This module contains types for ART recording. +Import this module qualified as import EulerHS.ART.Types as ART +-} + +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# LANGUAGE DeriveAnyClass #-} + +module EulerHS.ART.Types where + +import EulerHS.Prelude +import qualified Data.Aeson as A +import qualified Data.HashMap.Strict as HM +import Data.Time (LocalTime) +import qualified EulerHS.Options as T +import EulerHS.Types + + +data MethodRecording = MethodRecording + { jsonRequest :: A.Value + , jsonResponse :: A.Value + , entries :: [MethodRecordingEntry] + , methodConfigs :: Maybe MethodConfigs + , sessionId :: Text + , guid :: Maybe Text + , parameters :: HM.HashMap Text Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data Header = Header Text Text + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data MethodRecordingEntry = MethodRecordingEntry + { index :: Int + , entryName :: Text + , entry :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data MethodConfigs = MethodConfigs + { rawBody :: Text + , queryParams :: HM.HashMap Text Text + , routeParams :: HM.HashMap Text Text + , headers :: Either Text [Header] + , rawHeaders :: HM.HashMap Text Text + , methodUrl :: Text + , sourceIP :: Text + , userAgent :: Text + , authenticationParams :: HM.HashMap Text Text + , flowOptions :: HM.HashMap Text Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data MethodRecordingDescription = MethodRecordingDescription + { methodName :: Text + , methodRecording :: MethodRecording + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RecordingEntry + = CallAPIEntryT CallAPIEntry + | RunDBEntryT RunDBEntry + | RunKVDBEntryT RunKVDBEntry + | RunInMemEntryT RunInMemEntry + | ForkFlowEntryT ForkFlowEntry + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data ErrorPayload = ErrorPayload + { isError :: Bool + , errorMessage :: Text + , userMessage :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data CallAPIEntry = CallAPIEntry + { jsonRequest :: HTTPRequest + , jsonResult :: Either ErrorPayload A.Value + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data ForkFlowEntry = ForkFlowEntry + { description :: Text + , guid :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RunDBEntry = RunDBEntry + { dbMethod :: Text + , setClauseRecording :: A.Value + , whereClauseRecording :: A.Value + , model :: Text + , jsonResult :: A.Value + , timestamp :: LocalTime + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RunInMemEntry = RunInMemEntry + { + dbMethod :: Text + , setClauseRecording :: A.Value + , whereClauseRecording :: A.Value + , model :: A.Value + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RunKVDBEntry = + RExpireBT RExpireB + | RDelBT RDelB + | RExistsBT RExistsB + | RHGetT RHGet + | RGetBT RGetB + | RHSetBT RHSetB + | RSetBT RSetB + | RIncrBT RIncrB + | RSetexBT RSetexB + | RSetexBulkBT RSetexBulkB + | RSetOptsBT RSetOptsB + | RXreadBT RXreadB + | RXrevrangeBT RXrevrangeB + | RSaddT RSadd + | RSismemberT RSismember + | RZAddT RZAdd + | RZRangeByScoreT RZRangeByScore + | RZRangeByScoreWithLimitT RZRangeByScoreWithLimit + | RZRemRangeByScoreT RZRemRangeByScore + | RZRemT RZRem + | RZCardT RZCard + | RXaddBT RXaddB + | RSRemBT RSRemB + | RSmembersBT RSmembersB + | RXLenBT RXLenB + | RXDelBT RXDelB + | RXGroupCreateBT RXGroupCreateB + | RXReadGroupBT RXReadGroupB + | RXReadOptsBT RXReadOptsB + | RXRevRangeBT RXRevRangeB + | RSAddBT RSAddB + | RZAddBT RZAddB + | RZRangeBT RZRangeB + | RLRangeBT RLRangeB + | RLPushBT RLPushB + | RSMoveBT RSMoveB + | RSMemBT RSMemB + | RRawBT RRawB + | RPingBT RPingB + | RMultiExecWithHashT RMultiExecWithHash + | RMultiExecT RMultiExec + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RRawB = RRawB + { + args :: [ByteString] + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RPingB = RPingB + { + jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RSMemB = RSMemB { + key1 :: ByteString + , key2 :: ByteString + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RSMoveB = RSMoveB { + key1 :: ByteString + , key2 :: ByteString + , value :: ByteString + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RLPushB = RLPushB { + key :: ByteString + , value :: [ByteString] + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text +} + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RLRangeB = RLRangeB { + key :: ByteString + , start :: Integer + , stop :: Integer + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RZRangeB = RZRangeB { + key :: ByteString + , startRank :: Integer + , stopRank :: Integer + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RSAddB = RSAddB { + key :: ByteString + , value :: [ByteString] + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RZAddB = RZAddB { + key :: ByteString + , value :: [(Double, ByteString)] + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RXRevRangeB = RXRevRangeB { + streamName :: ByteString + , streamEnd :: A.Value + , streamStart :: A.Value + , count :: Maybe Integer + , jsonResult :: Either A.Value Integer + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RXReadOptsB = RXReadOptsB { + strObjs :: A.Value + , readOpts :: A.Value + , jsonResult :: Either A.Value Integer + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RXReadGroupB = RXReadGroupB { + groupName :: A.Value + , consumerName :: A.Value + , streamsAndIds :: [(ByteString,ByteString)] + , readOpts :: A.Value + , jsonResult :: Either A.Value Integer + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RXDelB = RXDelB { + streamName :: ByteString + , streamEntryID :: A.Value + , jsonResult :: Either A.Value Integer + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RXGroupCreateB = RXGroupCreateB { + streamName :: ByteString + , groupName :: A.Value + , recordId :: A.Value + , jsonResult :: Either A.Value Integer + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RXLenB = RXLenB { + streamName :: ByteString + , jsonResult :: Either A.Value Integer + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RSRemB = RSRemB { + key :: ByteString + , pKeyList :: [ByteString] + , jsonResult :: Either A.Value Integer + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RSmembersB = RSmembersB { + key :: ByteString + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RXaddB = RXaddB { + streamName :: ByteString + , streamEntry :: ByteString + , streamItem :: A.Value + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RZCard = RZCard { + key :: ByteString + , jsonResult :: Either A.Value Integer + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RZRem = RZRem { + key :: ByteString + , value :: [ByteString] + , jsonResult :: Either A.Value Integer + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RZRemRangeByScore = RZRemRangeByScore { + key :: ByteString + , minScore :: Double + , maxScore :: Double + , jsonResult :: Either A.Value Integer + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RZRangeByScoreWithLimit = RZRangeByScoreWithLimit { + key :: ByteString + , minScore :: Double + , maxScore :: Double + , offset :: Integer + , count :: Integer + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RZRangeByScore = RZRangeByScore { + key :: ByteString + , minScore :: Double + , maxScore :: Double + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RZAdd = RZAdd { + key :: ByteString + , value :: [(Double,ByteString)] + , jsonResult :: Either A.Value Integer + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RSismember = RSismember { + key :: ByteString + , value :: ByteString + , jsonResult :: Either A.Value Bool + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RSadd = RSadd { + key :: ByteString + , value :: [ByteString] + , jsonResult :: Either A.Value Integer + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RXrevrangeB = RXrevrangeB { + stream :: ByteString + , send :: ByteString + , sstart :: ByteString + , count :: Maybe Integer + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RXreadB = RXreadB { + stream :: ByteString + , entryId :: ByteString + , jsonResult :: Either A.Value (Maybe A.Value) + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RSetOptsB = RSetOptsB { + key :: ByteString + , value :: A.Value + , ttl :: A.Value + , setCondition :: A.Value + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RSetexBulkB = RSetexBulkB { + kvMap :: A.Value + , ttl :: Integer + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RIncrB = RIncrB { + key :: ByteString + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RSetexB = RSetexB { + key :: ByteString + , ttl :: Integer + , value :: A.Value + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RSetB = RSetB { + key :: ByteString + , value :: A.Value + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RHSetB = RHSetB { + key :: ByteString + , field :: A.Value + , value :: A.Value + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RHGet = RHGet { + key :: ByteString + , field :: A.Value + , jsonResult :: Maybe A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RGetB = RGetB { + key :: ByteString + , jsonResult :: Maybe A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RDelB = RDelB { + key :: [ByteString] + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RExistsB = RExistsB { + key :: ByteString + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RExpireB = RExpireB { + key :: ByteString + , ttl :: Integer + , jsonResult :: Either A.Value A.Value + , timestamp :: LocalTime + , redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RMultiExecWithHash = RMultiExecWithHash { + key :: ByteString, + jsonResult :: Either A.Value A.Value, + timestamp :: LocalTime, + redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data RMultiExec = RMultiExec { + jsonResult :: Either A.Value A.Value, + timestamp :: LocalTime, + redisName :: Text + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON,FromJSON) + +data WaiRequest = WaiRequest + deriving stock (Show, Generic) + deriving anyclass (ToJSON) + +instance T.OptionEntity WaiRequest HTTPRequest diff --git a/src/EulerHS/ART/Utils.hs b/src/EulerHS/ART/Utils.hs new file mode 100644 index 00000000..9667c5cb --- /dev/null +++ b/src/EulerHS/ART/Utils.hs @@ -0,0 +1,96 @@ +{- | +Module : EulerHS.ART.Utils +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable + +This module contains utility functions for ART +-} + +{-# LANGUAGE ScopedTypeVariables #-} + +module EulerHS.ART.Utils where + +import qualified Data.ByteString.Lazy as LBS +import qualified Data.CaseInsensitive as CI +import EulerHS.ART.Types +import EulerHS.Prelude +import qualified Servant.Client.Core as SCC +import Data.Sequence (fromList) +import qualified Data.ByteString.Builder as BB +import qualified Data.Map as Map +import qualified Data.Text.Lazy.Encoding as TL +import EulerHS.BinaryString (LBinaryString (LBinaryString),getLBinaryString) +import EulerHS.HttpAPI +import qualified Network.HTTP.Types as HTTP +import qualified Network.HTTP.Types.Status as HTTPS +import qualified Network.HTTP.Types.Version as HTTPV + +fromServantRequest :: SCC.Request -> HTTPRequest +fromServantRequest req' = let + method' = case decodeUtf8 $ SCC.requestMethod req' of + ("GET" :: Text) -> Get + ("PUT" :: Text) -> Put + ("POST" :: Text) -> Post + ("DELETE" :: Text) -> Delete + ("HEAD" :: Text) -> Head + ("TRACE" :: Text) -> Trace + ("CONNECT" :: Text) -> Connect + ("OPTIONS" :: Text) -> Options + ("PATCH" :: Text) -> Patch + _ -> error "Invalid HTTP method" + in HTTPRequest method' req_headers' req_body' req_path' Nothing Nothing + where + + req_body' :: Maybe LBinaryString + req_body' = case SCC.requestBody req' of + Just (reqbody, _) -> + case reqbody of + SCC.RequestBodyBS s -> Just $ LBinaryString $ LBS.fromStrict s + SCC.RequestBodyLBS s -> Just $ LBinaryString s + SCC.RequestBodySource sr -> Just $ LBinaryString $ TL.encodeUtf8 $ show $ SCC.RequestBodySource sr + Nothing -> Just $ LBinaryString $ TL.encodeUtf8 "body = (empty)" + + req_headers' :: Map.Map Text Text + req_headers' = headersToJson + $ (bimap (decodeUtf8 . CI.original) decodeUtf8) <$> SCC.requestHeaders req' + + req_path' :: Text + req_path' = decodeUtf8 . LBS.toStrict . BB.toLazyByteString $ SCC.requestPath req' + + headersToJson :: Seq (Text, Text) -> Map.Map Text Text + headersToJson = foldl' (\m (k,v) -> Map.insert k v m) Map.empty + +fromServantResponse :: SCC.Response -> HTTPResponse +fromServantResponse res = HTTPResponse res_body' res_code' res_headers' "" + where + res_body' :: LBinaryString + res_body' = LBinaryString $ SCC.responseBody res + + res_code' :: Int + res_code' = HTTP.statusCode $ SCC.responseStatusCode res + + res_headers' :: Map.Map Text Text + res_headers' = headersToJson + $ (bimap (decodeUtf8 . CI.original) decodeUtf8) <$> SCC.responseHeaders res + + headersToJson :: Seq (Text, Text) -> Map.Map Text Text + headersToJson = foldl' (\m (k,v) -> Map.insert k v m) Map.empty + +toServantResponse :: HTTPResponse -> SCC.Response +toServantResponse httpResponse = + SCC.Response + { responseStatusCode = HTTPS.mkStatus (httpResponse.getResponseCode) (encodeUtf8 httpResponse.getResponseStatus) + , responseHeaders = fromList ((\(headerName, val) -> (CI.mk (encodeUtf8 headerName), encodeUtf8 val))<$> Map.toList httpResponse.getResponseHeaders) + , responseHttpVersion = HTTPV.http11 + , responseBody = getLBinaryString $ getResponseBody httpResponse + } + +toErrorPayload :: Text -> ErrorPayload +toErrorPayload errMsg = ErrorPayload + { isError = True + , errorMessage = errMsg + , userMessage = " Something went wrong." + } diff --git a/src/EulerHS/Api.hs b/src/EulerHS/Api.hs new file mode 100644 index 00000000..c9b89f56 --- /dev/null +++ b/src/EulerHS/Api.hs @@ -0,0 +1,82 @@ +{- | +Module : EulerHS.Api +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable + +This module contains the definition of the `EulerClient` type, which is a wrapper around `Servant.Client.Client` type. +It also contains the definition of the `ApiTag` type, which is used to tag API calls in the logs. +-} + +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} + +module EulerHS.Api where + + +import qualified Data.Aeson as A +import GHC.Generics () +import EulerHS.Prelude +import Servant.Client.Core.RunClient (RunClient) +import qualified Servant.Client.Free as SCF +import qualified EulerHS.Options as T +import qualified EulerHS.Logger.Types as Log +import qualified Servant.Client as SC +import qualified Servant.Client.Core as SCC + +newtype EulerClient a = EulerClient (Free SCF.ClientF a) + deriving newtype (Functor, Applicative, Monad, RunClient) + -- deriving stock (Show,Generic) + +client :: SC.HasClient EulerClient api => Proxy api -> SC.Client EulerClient api +client api = SCC.clientIn api $ Proxy @EulerClient + +data LogServantRequest + = LogServantRequest + { url :: String + , method :: Text + , body :: A.Value + , headers :: Seq (Text, Text) + , queryString :: Seq (Text, Maybe Text) + } + deriving stock (Show,Generic) + deriving anyclass A.ToJSON + +data LogServantResponse + = LogServantResponse + { statusCode :: String + , headers :: Seq (Text,Text) + , httpVersion :: String + , body :: A.Value + } + deriving stock (Show,Generic) + deriving anyclass A.ToJSON + +data ServantApiCallLogEntry = ServantApiCallLogEntry + { url :: String + , method :: Text + , req_headers :: A.Value + , req_body :: A.Value + , res_code :: Int + , res_body :: A.Value + , res_headers :: A.Value + , latency :: Maybe Integer + , req_query_params :: A.Value + , api_tag :: Maybe Text + , error_info :: Maybe Log.ErrorInfo + } + deriving stock (Show,Generic) + +instance ToJSON ServantApiCallLogEntry where + toJSON = A.genericToJSON A.defaultOptions { A.omitNothingFields = True } + +data ApiTag = ApiTag + deriving stock (Eq, Show, Generic, Ord) + deriving anyclass (ToJSON, FromJSON) + +instance T.OptionEntity ApiTag Text diff --git a/src/EulerHS/ApiHelpers.hs b/src/EulerHS/ApiHelpers.hs new file mode 100644 index 00000000..96e80d16 --- /dev/null +++ b/src/EulerHS/ApiHelpers.hs @@ -0,0 +1,237 @@ +{- | +Module : EulerHS.ApiHelpers +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module EulerHS.ApiHelpers where + +import EulerHS.Masking +import Control.Monad.Error.Class (catchError) +import Data.Aeson as A +import Data.ByteString.Builder (toLazyByteString) +import Data.List (init, isSuffixOf) +import Data.Time.Clock (diffTimeToPicoseconds) +import Data.Time.Clock.System (getSystemTime, systemToTAITime) +import Data.Time.Clock.TAI (diffAbsoluteTime) +import EulerHS.Api +import EulerHS.ART.Types +import EulerHS.ART.Utils +import EulerHS.ART.EnvVars +import EulerHS.Prelude +import qualified Control.Exception as Exception +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.UTF8 as LBS +import qualified Data.CaseInsensitive as CI +import qualified Data.HashMap.Strict as HM +import qualified Data.Map as Map +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Encoding +import qualified Data.Text.Encoding as TE +import qualified EulerHS.BinaryString as T +import qualified EulerHS.HttpAPI as InternalHttp +import qualified EulerHS.Logger.Types as Log +import qualified EulerHS.Options () +import qualified Network.HTTP.Types as HTTP +import qualified Network.HTTP.Types.Status as HttpStatus +import qualified Servant.Client as SC +import qualified Servant.Client.Core as SCC +import qualified Servant.Client.Free as SCF +import qualified Servant.Client.Internal.HttpClient as SCIHC +import qualified Data.Sequence as Seq + +mkServantApiCallLogEntry :: (Show apiTag) => Maybe Log.LogMaskingConfig -> SCF.BaseUrl -> SCC.Request -> SCC.Response -> Integer -> apiTag -> Maybe Log.ErrorInfo -> ServantApiCallLogEntry +mkServantApiCallLogEntry mbMaskConfig bUrl req res lat apiTag errInfo = do + let (url, req_headers', req_body', queryParams) = getRequestInfoToLog mbMaskConfig bUrl req + ServantApiCallLogEntry + { url = url + , method = method' + , req_headers = req_headers' + , req_body = req_body' + , res_code = res_code' + , res_body = res_body' + , res_headers = res_headers' + , latency = Just lat + , req_query_params = queryParams + , api_tag = Just $ show apiTag + , error_info = errInfo + } + where + method' = TE.decodeUtf8 $ SCC.requestMethod req + + res_code' = HttpStatus.statusCode $ SCC.responseStatusCode res + res_body' = parseRequestResponseBody (shouldMaskKey mbMaskConfig) getMaskText (getContentTypeForServant . toList $ SCC.responseHeaders res) + . LBS.toStrict + $ SCC.responseBody res + res_headers' = headersToJson + $ fmap (bimap (TE.decodeUtf8 . CI.original) TE.decodeUtf8) + $ maskServantHeaders (shouldMaskKey mbMaskConfig) getMaskText + $ SCC.responseHeaders res + getMaskText :: Text + getMaskText = maybe defaultMaskText (fromMaybe defaultMaskText . Log._maskText) mbMaskConfig + + headersToJson :: Seq (Text, Text) -> A.Value + headersToJson = A.toJSON . foldl' (\m (k,v) -> HM.insert k v m) HM.empty + +client :: SC.HasClient EulerClient api => Proxy api -> SC.Client EulerClient api +client api = SCC.clientIn api $ Proxy @EulerClient + +interpretClientF :: (Show apiTag) => (forall msg. A.ToJSON msg => Log.LogLevel -> Log.Action -> Maybe Log.ErrorL -> Maybe Log.Latency -> Maybe Log.RespCode -> msg -> IO()) -> (LBS.ByteString -> Maybe Log.ErrorInfo) + -> Maybe Log.LogMaskingConfig -> MVar (Map Text Any) -> MVar ([RecordingEntry]) -> SCC.BaseUrl -> apiTag -> Maybe Text -> SCF.ClientF a -> SC.ClientM a +interpretClientF _ _ _ _ _ _ _ _ (SCF.Throw e) = throwM e +interpretClientF log errFunc mbMaskConfig _ recordingLocal bUrl apiTag mHostValue (SCF.RunRequest req' next) = do + start <- liftIO $ systemToTAITime <$> getSystemTime + validRes <- catchError (SCC.runRequestAcceptStatus Nothing req) (errorHandler start) + when (isArtRecEnabled) $ do + m <- takeMVar recordingLocal + let apiEntry = CallAPIEntryT $ CallAPIEntry { + jsonRequest = fromServantRequest req, + jsonResult = Right $ A.toJSON $ fromServantResponse validRes} + putMVar recordingLocal $ m <> [apiEntry] + end <- liftIO $ systemToTAITime <$> getSystemTime + let errInfo = errFunc $ SCC.responseBody validRes + lat = div (diffTimeToPicoseconds $ diffAbsoluteTime end start) picoMilliDiff + updatedRes = addErrorInfoToResponseHeaders validRes errInfo + logEntry = mkServantApiCallLogEntry mbMaskConfig bUrl req updatedRes lat apiTag errInfo + errLog = mkErrorLog =<< errInfo + liftIO $ log Log.Info (decodeUtf8 $ SCC.requestMethod req) errLog (Just lat) (Just $ HttpStatus.statusCode $ SCC.responseStatusCode updatedRes) logEntry + pure $ next updatedRes + where + req = maybe req' (\ hostValue -> SCC.addHeader "x-tenant-host" hostValue req') mHostValue + errorHandler startTime err = do + endTime <- liftIO $ systemToTAITime <$> getSystemTime + let lat = div (diffTimeToPicoseconds $ diffAbsoluteTime endTime startTime) picoMilliDiff + case err of + SC.FailureResponse _ resp -> + either (defaultErrorLogger reqMethod lat) (\x -> logJsonError ("FailureResponse" :: Text) reqMethod lat (InternalHttp.getResponseCode x) (getErrorResponseWithRequest x)) (translateResponseFHttpResponse resp) + SC.DecodeFailure txt resp -> + either (defaultErrorLogger reqMethod lat) (\x -> logJsonError (("DecodeFailure: " :: Text) <> txt) reqMethod lat (InternalHttp.getResponseCode x) (getErrorResponseWithRequest x)) (translateResponseFHttpResponse resp) + SC.UnsupportedContentType mediaType resp -> + either (defaultErrorLogger reqMethod lat) (\x -> logJsonError (("UnsupportedContentType: " :: Text) <> (show @Text mediaType)) reqMethod lat (InternalHttp.getResponseCode x) (getErrorResponseWithRequest x)) (translateResponseFHttpResponse resp) + SC.InvalidContentTypeHeader resp -> + either (defaultErrorLogger reqMethod lat) (\x -> logJsonError ("InvalidContentTypeHeader" :: Text) reqMethod lat (InternalHttp.getResponseCode x) (getErrorResponseWithRequest x)) (translateResponseFHttpResponse resp) + SC.ConnectionError exception -> defaultErrorLogger reqMethod lat $ displayException exception + throwM err + + picoMilliDiff :: Integer + picoMilliDiff = 1000000000 + + reqMethod = decodeUtf8 $ SCC.requestMethod req + + logJsonError :: Text -> Text -> Integer -> Int -> ServantApiCallLogEntry -> SC.ClientM () + logJsonError err method latency responseCode res = + let errorBody = Log.ErrorL Nothing "API_ERROR" err + in liftIO $ log Log.Error method (Just errorBody) (Just latency) (Just responseCode) res + + defaultErrorLogger :: forall msg. A.ToJSON msg => Text -> Integer -> msg -> SC.ClientM () + defaultErrorLogger method latency msg = liftIO $ log Log.Error method Nothing (Just latency) (Just (-1)) msg + + mkErrorLog :: Log.ErrorInfo -> Maybe Log.ErrorL + mkErrorLog errInfo = Just $ Log.ErrorL (Just errInfo.error_code) errInfo.error_category errInfo.error_message + + getErrorResponseWithRequest x = + let (url, req_headers, req_body, req_query_params) = getRequestInfoToLog mbMaskConfig bUrl req' + response = InternalHttp.maskHTTPResponse mbMaskConfig x Nothing + in + ServantApiCallLogEntry + { url = url + , method = TE.decodeUtf8 $ SCC.requestMethod req + , req_headers = req_headers + , req_body = req_body + , req_query_params = req_query_params + , res_code = response.getResponseCode + , res_body = response.getResponseBody + , res_headers = A.toJSON $ response.getResponseHeaders + , error_info = Nothing + , latency = Nothing + , api_tag = Nothing + } + +getRequestInfoToLog :: Maybe Log.LogMaskingConfig -> SCF.BaseUrl -> SCC.Request -> (String,A.Value, A.Value,A.Value) +getRequestInfoToLog mbMaskConfig bUrl req = + (baseUrl <> LBS.toString (toLazyByteString (SCC.requestPath req)) + , req_headers' + , req_body' + , queryParams + ) + where + queryParams = queryToJson + $ fmap (bimap TE.decodeUtf8 (TE.decodeUtf8 <$>)) + $ maskQueryStrings (shouldMaskKey mbMaskConfig) getMaskText + $ SCC.requestQueryString req + + req_headers' = headersToJson + $ fmap (bimap (TE.decodeUtf8 . CI.original) TE.decodeUtf8) + $ maskServantHeaders (shouldMaskKey mbMaskConfig) getMaskText + $ SCC.requestHeaders req + + req_body' = case SCC.requestBody req of + Just (reqbody, _) -> + case reqbody of + SCC.RequestBodyBS s -> parseRequestResponseBody (shouldMaskKey mbMaskConfig) getMaskText (getContentTypeForServant . toList $ SCC.requestHeaders req) s + SCC.RequestBodyLBS s -> parseRequestResponseBody (shouldMaskKey mbMaskConfig) getMaskText (getContentTypeForServant . toList $ SCC.requestHeaders req) $ LBS.toStrict s + SCC.RequestBodySource sr -> A.String $ show $ SCC.RequestBodySource sr + Nothing -> A.String "body = (empty)" + + baseUrlString = SCF.showBaseUrl bUrl + baseUrl = if "/" `isSuffixOf` baseUrlString then init baseUrlString else baseUrlString + + getMaskText :: Text + getMaskText = maybe defaultMaskText (fromMaybe defaultMaskText . Log._maskText) mbMaskConfig + + queryToJson :: Seq (Text, Maybe Text) -> A.Value + queryToJson = A.toJSON . foldl' (\m (k,v) -> HM.insert k v m) HM.empty + + headersToJson :: Seq (Text, Text) -> A.Value + headersToJson = A.toJSON . foldl' (\m (k,v) -> HM.insert k v m) HM.empty + + +addErrorInfoToResponseHeaders :: SCC.Response -> Maybe Log.ErrorInfo -> SCC.Response +addErrorInfoToResponseHeaders validRes@SCC.Response{..} (Just errorInfo) = + let errorHeaders = [("x-error_code", encodeUtf8 $ errorInfo.error_code) + , ("x-error_message", encodeUtf8 errorInfo.error_message) + , ("x-error_category", encodeUtf8 errorInfo.error_category) + , ("x-unified_error_code", encodeUtf8 errorInfo.unified_error_code) + , ("x-unified_error_message", encodeUtf8 $ errorInfo.unified_error_message)] + modifiedHeaders = Seq.fromList errorHeaders + in validRes {SCC.responseHeaders = responseHeaders <> modifiedHeaders} +addErrorInfoToResponseHeaders responseHeaders Nothing = responseHeaders + +runEulerClient :: (Show apiTag) => (forall msg. A.ToJSON msg => Log.LogLevel -> Log.Action -> Maybe Log.ErrorL -> Maybe Log.Latency -> Maybe Log.RespCode -> msg -> IO())-> (LBS.ByteString -> Maybe Log.ErrorInfo) + -> Maybe Log.LogMaskingConfig -> MVar (Map Text Any) -> MVar ([RecordingEntry]) -> SCC.BaseUrl -> EulerClient a -> apiTag -> Maybe Text -> SCIHC.ClientM a +runEulerClient log errFunc mbMaskConfig optionsLocal recordingLocal bUrl (EulerClient f) apiTag mHostValue = foldFree (interpretClientF log errFunc mbMaskConfig optionsLocal recordingLocal bUrl apiTag mHostValue) f + +translateResponseFHttpResponse :: SC.Response -> Either Text InternalHttp.HTTPResponse +translateResponseFHttpResponse SC.Response{..} = do + headers <- translateResponseHeaders $ toList responseHeaders + status <- translateResponseStatusMessage $ HTTP.statusMessage responseStatusCode + pure $ InternalHttp.HTTPResponse + { getResponseBody = T.LBinaryString responseBody + , getResponseCode = HTTP.statusCode responseStatusCode + , getResponseHeaders = headers + , getResponseStatus = status + } + +translateResponseHeaders + :: [(CI.CI Strict.ByteString, Strict.ByteString)] + -> Either Text (Map.Map Text.Text Text.Text) +translateResponseHeaders httpLibHeaders = do + let + result = do + headerNames <- mapM (Encoding.decodeUtf8' . CI.original . fst) httpLibHeaders + headerValues <- mapM (Encoding.decodeUtf8' . snd) httpLibHeaders + return $ zip (map Text.toLower headerNames) headerValues + headers <- displayEitherException "Error decoding HTTP response headers: " result + pure $ Map.fromList headers + +translateResponseStatusMessage :: Strict.ByteString -> Either Text Text +translateResponseStatusMessage = displayEitherException "Error decoding HTTP response status message: " . Encoding.decodeUtf8' + +displayEitherException :: Exception e => Text -> Either e a -> Either Text a +displayEitherException prefix = either (Left . (prefix <>) . Text.pack . Exception.displayException) Right diff --git a/src/EulerHS/BinaryString.hs b/src/EulerHS/BinaryString.hs new file mode 100644 index 00000000..f8e0da81 --- /dev/null +++ b/src/EulerHS/BinaryString.hs @@ -0,0 +1,105 @@ +{- | +Module : EulerHS.BinaryString +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +module EulerHS.BinaryString +( BinaryString(..) +, LBinaryString(..) +, base64Encode +, base64Decode +) where + +import qualified Control.Monad.Fail as MonadFail +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Lazy as Lazy +import qualified Data.String.Conversions as Conversions +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Encoding +import EulerHS.Prelude +import Text.Read (read) + + + +-------------------------------------------------------------------------- +-- Base64 encoding/decoding helpers +-------------------------------------------------------------------------- + +newtype BinaryString + = BinaryString + { getBinaryString :: Strict.ByteString } + deriving (Show, Eq, Ord) + +instance ToJSON BinaryString where + toJSON val = toJSON ((decodeUtf8 $ getBinaryString val) :: Text) + +instance FromJSON BinaryString where + parseJSON val = do + bs <- parseJSON val + pure $ BinaryString $ read bs + +instance Conversions.ConvertibleStrings Strict.ByteString BinaryString where + convertString = BinaryString + +instance Conversions.ConvertibleStrings BinaryString Strict.ByteString where + convertString = getBinaryString + +instance Conversions.ConvertibleStrings Lazy.ByteString BinaryString where + convertString = BinaryString . Conversions.convertString + +instance Conversions.ConvertibleStrings BinaryString Lazy.ByteString where + convertString = Conversions.convertString . getBinaryString + +-------------------------------------------------------------------------- +-- Lazy BinaryString +-------------------------------------------------------------------------- + +newtype LBinaryString + = LBinaryString + { getLBinaryString :: Lazy.ByteString } + deriving (Show, Eq, Ord) + +instance ToJSON LBinaryString where + toJSON val = toJSON (decodeUtf8 (getLBinaryString val) :: Text) + +instance FromJSON LBinaryString where + parseJSON val = do + lbs <- parseJSON val + pure $ LBinaryString $ Lazy.fromStrict $ encodeUtf8 @String @ByteString lbs + +instance Conversions.ConvertibleStrings Lazy.ByteString LBinaryString where + convertString = LBinaryString + +instance Conversions.ConvertibleStrings LBinaryString Lazy.ByteString where + convertString = getLBinaryString + +instance Conversions.ConvertibleStrings Strict.ByteString LBinaryString where + convertString = LBinaryString . Conversions.convertString + +instance Conversions.ConvertibleStrings LBinaryString Strict.ByteString where + convertString = Conversions.convertString . getLBinaryString + +-------------------------------------------------------------------------- +-- Base64 encoding/decoding helpers +-------------------------------------------------------------------------- + +-- | Base64 encode a bytestring +-- +-- NOTE: Decoding to UTF-8 cannot fail so is safe +-- +base64Encode :: Strict.ByteString -> Text.Text +base64Encode = Encoding.decodeUtf8 . B64.encode + +-- | Base64 decode a Base64-encoded string +-- +-- NOTE: This may fail if the string is malformed using MonadFail +-- +base64Decode :: MonadFail.MonadFail m => Text.Text -> m Strict.ByteString +base64Decode s = case B64.decode (Encoding.encodeUtf8 s) of + Left err -> fail err + Right res -> return res diff --git a/src/EulerHS/CachedSqlDBQuery.hs b/src/EulerHS/CachedSqlDBQuery.hs index 8ffbd7a3..ad69ed19 100644 --- a/src/EulerHS/CachedSqlDBQuery.hs +++ b/src/EulerHS/CachedSqlDBQuery.hs @@ -1,39 +1,76 @@ -{-# LANGUAGE OverloadedStrings #-} +{- | +Module : EulerHS.CachedSqlDBQuery +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable + +This module contains the function to create, update, delete and find rows in the database. +This module has functions which are being used in Flows for KVDB operations. + +-} + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# OPTIONS_GHC -Wno-error=unused-top-binds #-} +{-# LANGUAGE NamedFieldPuns #-} module EulerHS.CachedSqlDBQuery ( create , createSql + , createSqlWoReturing , updateOne , updateOneWoReturning , updateOneSql , updateOneSqlWoReturning + , updateAllSql , updateExtended , findOne , findOneSql , findAll , findAllSql , findAllExtended + , findAllExtended' + , deleteSql + , deleteExtended + , deleteWithReturningPG + , createMultiSql + , createMultiSqlWoReturning + , runQuery + , countRows + , findDecryptUtility + , createSqlWithConn + , createMultiSqlWithConn + , updateSqlWithConn + , deleteSqlWithConn + , findAllWithConn + , findOneWithConn , SqlReturning(..) ) where +import EulerHS.PIIEncryption import Data.Aeson (encode) import qualified Data.ByteString.Lazy as BSL +import qualified Data.Text as T 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 Database.Beam.Backend.SQL.BeamExtensions as BExt +import EulerHS.Extra.Language (getOrInitSqlConn, rGet, rSetB, rDel) import qualified EulerHS.Framework.Language as L import EulerHS.Prelude +import qualified EulerHS.SqlDB.Language as DB +import EulerHS.SqlDB.Types (BeamRunner, BeamRuntime, DBConfig(..), + DBError (DBError), + DBErrorType (UnexpectedResult, PIIError), DBResult, NativeSqlConn) import Named (defaults, (!)) -import Sequelize - --- TODO: What KVDB should be used +import Sequelize (Model, Set, Where, mkExprWithDefault, mkMultiExprWithDefault, + modelTableEntity, sqlSelect, sqlUpdate, sqlDelete, sqlCount, modelTableName) +import EulerHS.Logger.Types (ErrorL(..)) +import qualified Data.HashMap.Strict as HM cacheName :: String cacheName = "eulerKVDB" @@ -45,10 +82,11 @@ cacheName = "eulerKVDB" class SqlReturning (beM :: Type -> Type) (be :: Type) where createReturning :: forall (table :: (Type -> Type) -> Type) - (m :: Type -> Type) . + m. ( HasCallStack, BeamRuntime be beM, BeamRunner beM, + PII table, B.HasQBuilder be, Model be table, ToJSON (table Identity), @@ -59,66 +97,108 @@ class SqlReturning (beM :: Type -> Type) (be :: Type) where DBConfig beM -> table Identity -> Maybe Text -> + Maybe (PIIEncryptionKeyId, PIIEncryptionKey) -> m (Either DBError (table Identity)) + deleteAllReturning :: + forall (table :: (Type -> Type) -> Type) + m. + ( 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 -> + Where be table -> + m (Either DBError [table Identity]) + + instance SqlReturning BM.MySQLM BM.MySQL where createReturning = createMySQL + deleteAllReturning = deleteAllMySQL instance SqlReturning BP.Pg BP.Postgres where createReturning = create + deleteAllReturning = deleteAll instance SqlReturning BS.SqliteM BS.Sqlite where createReturning = create + deleteAllReturning = deleteAll create :: forall (be :: Type) (beM :: Type -> Type) (table :: (Type -> Type) -> Type) - (m :: Type -> Type) . + m. ( HasCallStack, BeamRuntime be beM, BeamRunner beM, B.HasQBuilder be, Model be table, + PII table, ToJSON (table Identity), - FromJSON (table Identity), Show (table Identity), L.MonadFlow m ) => DBConfig beM -> table Identity -> Maybe Text -> + Maybe (PIIEncryptionKeyId, PIIEncryptionKey) -> 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 - +create dbConf value mCacheKey mbKeyConfig = do + updatedValue <- maybe (pure $ Right value) (\(kid, key) -> encryptRow value kid key) mbKeyConfig + case updatedValue of + Left err -> return $ Left $ DBError PIIError err + Right encResult -> do + res <- createSql dbConf encResult + setPrimaryKeyUtility value mCacheKey res + createMySQL :: forall (table :: (Type -> Type) -> Type) - (m :: Type -> Type) . + m. ( HasCallStack, Model BM.MySQL table, ToJSON (table Identity), - FromJSON (table Identity), + PII table, Show (table Identity), L.MonadFlow m ) => DBConfig BM.MySQLM -> table Identity -> Maybe Text -> + Maybe (PIIEncryptionKeyId, PIIEncryptionKey) -> 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 +createMySQL dbConf value mCacheKey mbKeyConfig = do + updatedValue <- maybe (pure $ Right value) (\(kid, key) -> encryptRow value kid key) mbKeyConfig + case updatedValue of + Left err -> return $ Left $ DBError PIIError err + Right mbEncValue -> do + res <- createSqlMySQL dbConf mbEncValue + setPrimaryKeyUtility value mCacheKey res + +setPrimaryKeyUtility :: --- to do can we optimize this? + ( ToJSON (table Identity), + PII table, + L.MonadFlow m + ) => + table Identity -> + Maybe Text -> + (Either DBError (table Identity)) -> + m (Either DBError (table Identity)) +setPrimaryKeyUtility value mbCacheKey eitherDbRes = do + case eitherDbRes of + Right mbEncResult -> do + let updatedDbRes = setPrimaryKey value mbEncResult + whenJust mbCacheKey (`cacheWithKey` updatedDbRes) + return $ Right $ updatedDbRes + Left dbError -> return $ Left $ dbError + -- | Update an element matching the query to the new value. -- Cache the value at the given key if the DB update succeeds. @@ -129,8 +209,8 @@ updateOne :: Model be table, B.HasQBuilder be, ToJSON (table Identity), - FromJSON (table Identity), Show (table Identity), + PIIUpdate be table, L.MonadFlow m ) => DBConfig beM -> @@ -149,22 +229,19 @@ updateOneWoReturning :: BeamRuntime be beM, BeamRunner beM, Model be table, + PIIUpdate 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 -> + (Maybe (PIIEncryptionKeyId, PIIEncryptionKey)) -> 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 +updateOneWoReturning dbConf (Just _) newVals whereClause maybeKeyConfig = do + updateOneSqlWoReturning dbConf newVals whereClause maybeKeyConfig +updateOneWoReturning dbConf Nothing value whereClause maybeKeyConfig = updateOneSqlWoReturning dbConf value whereClause maybeKeyConfig updateOneSqlWoReturning :: forall m be beM table. @@ -172,30 +249,33 @@ updateOneSqlWoReturning :: BeamRuntime be beM, BeamRunner beM, Model be table, + PIIUpdate 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 -> + Maybe (PIIEncryptionKeyId, PIIEncryptionKey) -> 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 +updateOneSqlWoReturning dbConf newVals whereClause mbKeyConfig = do + setClause' <- maybe (pure $ Right newVals) (\(x, y)-> transformSetClause newVals x y) mbKeyConfig + case setClause' of + Left err -> return $ Left $ DBError PIIError err + Right setClause -> do + let updateQuery = DB.updateRows $ sqlUpdate + ! #set setClause + ! #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.logErrorWithCategory @Text "create" message + -- return $ Left $ DBError UnexpectedResult message + Left e -> return $ Left e updateOneSql :: forall m be beM table. @@ -204,9 +284,8 @@ updateOneSql :: BeamRunner beM, Model be table, B.HasQBuilder be, - FromJSON (table Identity), - ToJSON (table Identity), Show (table Identity), + PIIUpdate be table, L.MonadFlow m ) => DBConfig beM -> @@ -214,17 +293,51 @@ updateOneSql :: 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 + let tName = (modelTableName @table) + eitherPiiKeys <- getEncryptionKey tName + case eitherPiiKeys of + Left err -> pure $ Left err + Right mbKeyConfig -> do + setClause' <- maybe (pure $ Right newVals) (\(x, y)-> transformSetClause newVals x y) mbKeyConfig + case setClause' of + Left e -> pure $ Left $ DBError PIIError e + Right setClause -> do + let updateQuery = DB.updateRowsReturningList $ sqlUpdate + ! #set setClause + ! #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.logErrorWithCategory @Text "create" message $ ErrorL Nothing "SQL_ERROR" message + return $ Left $ DBError UnexpectedResult message + Left e -> return $ Left e + +updateAllSql :: + forall m be beM table. + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + Model be table, + B.HasQBuilder be, + PIIUpdate be table, + L.MonadFlow m + ) => + DBConfig beM -> + [Set be table] -> + Where be table -> + Maybe (PIIEncryptionKeyId, PIIEncryptionKey) -> + m (DBResult ()) +updateAllSql dbConf newVals whereClause mbVal = do + updatedClause <- maybe (pure $ Right newVals) (\(x, y)-> transformSetClause newVals x y) mbVal + case updatedClause of + Left e -> pure $ Left $ DBError PIIError e + Right val -> do + let updateQuery = DB.updateRows $ sqlUpdate + ! #set val + ! #where_ whereClause + runQuery dbConf updateQuery -- | Perform an arbitrary 'SqlUpdate'. This will cache if successful. updateExtended :: (HasCallStack, L.MonadFlow m, BeamRunner beM, BeamRuntime be beM) => @@ -234,6 +347,21 @@ updateExtended dbConf mKey upd = do maybe (pure ()) (`cacheWithKey` res) mKey pure res +-- | Find No of Rows +countRows :: + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + Model be table, + B.HasQBuilder be, + L.MonadFlow m, + B.FromBackendRow be Int + ) => + DBConfig beM -> + Where be table -> + m (Either DBError Int) +countRows = countSql + -- | Find an element matching the query. Only uses the DB if the cache is empty. -- Caches the result using the given key. findOne :: @@ -244,11 +372,12 @@ findOne :: B.HasQBuilder be, ToJSON (table Identity), FromJSON (table Identity), + PII table, L.MonadFlow m ) => DBConfig beM -> Maybe Text -> - Where be table -> + Where be table -> m (Either DBError (Maybe (table Identity))) findOne dbConf (Just cacheKey) whereClause = do mRes <- rGet (T.pack cacheName) cacheKey @@ -256,9 +385,31 @@ findOne dbConf (Just cacheKey) whereClause = do (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 + findDecryptUtility mDBRes (Just cacheKey) +findOne dbConf Nothing whereClause = do + mDBRes <- findOneSql dbConf whereClause + findDecryptUtility mDBRes Nothing + +findDecryptUtility :: + ( ToJSON (table Identity), + PII table, + L.MonadFlow m + ) => + (Either DBError (Maybe (table Identity))) -> + Maybe Text -> + m (Either DBError (Maybe (table Identity))) +findDecryptUtility mDBRes mbCacheKey = do + case mDBRes of + Right (Just encResult) -> do + decryptResult <- decryptRow encResult Nothing + case decryptResult of + Left err -> return $ Left $ DBError PIIError err + Right decryptedRes -> do + whenJust mbCacheKey (`cacheWithKey` decryptedRes) + return $ Right $ Just $ decryptedRes + Right Nothing -> return $ Right $ Nothing + Left dbError -> return $ Left $ dbError + -- | Find all elements matching the query. Only uses the DB if the cache is empty. -- Caches the result using the given key. @@ -270,12 +421,13 @@ findAll :: Model be table, B.HasQBuilder be, ToJSON (table Identity), + PII table, FromJSON (table Identity), L.MonadFlow m ) => DBConfig beM -> Maybe Text -> - Where be table -> + Where be table -> m (Either DBError [table Identity]) findAll dbConf (Just cacheKey) whereClause = do mRes <- rGet (T.pack cacheName) cacheKey @@ -283,9 +435,30 @@ findAll dbConf (Just cacheKey) whereClause = do (Just res) -> return $ Right res Nothing -> do mDBRes <- findAllSql dbConf whereClause - whenRight mDBRes (cacheWithKey cacheKey) - return mDBRes -findAll dbConf Nothing whereClause = findAllSql dbConf whereClause + findAllDecryptUtility mDBRes (Just cacheKey) +findAll dbConf Nothing whereClause = do + mDBRes <- findAllSql dbConf whereClause + findAllDecryptUtility mDBRes Nothing + +findAllDecryptUtility :: + ( PII table, + ToJSON (table Identity), + L.MonadFlow m + ) => + (Either DBError [table Identity]) -> + Maybe Text -> + m (Either DBError [table Identity]) +findAllDecryptUtility mDBRes mbCacheKey = do + case mDBRes of + Right encResult -> do + let emptyKeyConfig = replicate (length encResult) (Nothing, Nothing) + eitherDecryptedRes <- decryptOrEncryptAllUtility encResult emptyKeyConfig False + case eitherDecryptedRes of + Right res -> do + whenJust mbCacheKey (`cacheWithKey` res) + return $ Right $ res + Left decErr -> return $ Left $ decErr + Left dbError -> return $ Left $ dbError -- | Like 'findAll', but takes an explicit 'SqlSelect'. findAllExtended :: forall beM be table m . @@ -294,6 +467,7 @@ findAllExtended :: forall beM be table m . B.FromBackendRow be (table Identity), BeamRunner beM, BeamRuntime be beM, + PII table, FromJSON (table Identity), ToJSON (table Identity)) => DBConfig beM -> @@ -301,50 +475,130 @@ findAllExtended :: forall beM be table m . B.SqlSelect be (table Identity) -> m (Either DBError [table Identity]) findAllExtended dbConf mKey sel = case mKey of - Nothing -> go + Nothing -> do + res <- go + findAllDecryptUtility res Nothing 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 + findAllDecryptUtility dbRes (Just k) + where + go :: m (Either DBError [table Identity]) + go = do + eConn <- getOrInitSqlConn dbConf + rows <- join <$> traverse (\conn -> L.runDB conn . DB.findRows $ sel) eConn + case rows of + Left err -> L.incrementDbMetric err dbConf *> pure rows + Right _ -> pure rows + +findAllExtended' :: forall beM be table m . + (HasCallStack, + L.MonadFlow m, + BeamRunner beM, + BeamRuntime be beM, + PII table, + ToJSON (table Identity)) => + DBConfig beM -> + DB.SqlDB beM [(table Identity)] -> + m (Either DBError [table Identity]) +findAllExtended' dbConf sel = do + dbRes <- go + findAllDecryptUtility dbRes Nothing where go :: m (Either DBError [table Identity]) go = do eConn <- getOrInitSqlConn dbConf - join <$> traverse (\conn -> L.runDB conn . DB.findRows $ sel) eConn + rows <- join <$> traverse (\conn -> L.runDB conn $ sel) eConn + case rows of + Left err -> L.incrementDbMetric err dbConf *> pure rows + Right _ -> pure rows + +deleteExtended :: forall beM be table m . + (HasCallStack, + L.MonadFlow m, + BeamRunner beM, + BeamRuntime be beM) => + DBConfig beM -> + Maybe Text -> + B.SqlDelete be table -> + m (Either DBError ()) +deleteExtended dbConf mKey delQuery = case mKey of + Nothing -> go + Just k -> do + rDel (T.pack cacheName) [k] *> go + where + go = runQuery dbConf (DB.deleteRows delQuery) + +deleteWithReturningPG :: forall table m . + (HasCallStack, + B.Beamable table, + B.FromBackendRow BP.Postgres (table Identity), + L.MonadFlow m) => + DBConfig BP.Pg -> + Maybe Text -> + B.SqlDelete BP.Postgres table -> + m (Either DBError [table Identity]) +deleteWithReturningPG dbConf mKey delQuery = case mKey of + Nothing -> go + Just k -> do + rDel (T.pack cacheName) [k] *> go + where + go = runQuery dbConf (DB.deleteRowsReturningListPG delQuery) ------------ 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 + Right c -> do + result <- L.runDB c query + case result of + Right _ -> pure result + Left err -> do + L.incrementDbMetric err dbConf + pure result 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 + Right c -> do + rows <- L.runTransaction c query + case rows of + Left err -> L.incrementDbMetric err dbConf *> pure rows + Right _ -> pure rows Left e -> return $ Left e +runQueryWithConn :: + ( HasCallStack, + BeamRuntime be beM, BeamRunner beM, + L.MonadFlow m + ) => + DBConfig beM -> NativeSqlConn -> DB.SqlDB beM a -> m (Either DBError a) +runQueryWithConn dbConf c query = do + result <- L.runDBWithConn c query + case result of + Right _ -> pure result + Left err -> do + L.incrementDbMetric err dbConf + pure result + sqlCreate :: forall be table. - (HasCallStack, B.HasQBuilder be, Model be table) => + (B.HasQBuilder be, Model be table) => table Identity -> B.SqlInsert be table sqlCreate value = B.insert modelTableEntity (mkExprWithDefault value) @@ -356,8 +610,6 @@ createSql :: BeamRunner beM, B.HasQBuilder be, Model be table, - ToJSON (table Identity), - FromJSON (table Identity), Show (table Identity), L.MonadFlow m ) => @@ -370,7 +622,7 @@ createSql dbConf value = do Right [val] -> return $ Right val Right xs -> do let message = "DB returned \"" <> show xs <> "\" after inserting \"" <> show value <> "\"" - L.logError @Text "create" message + L.logErrorWithCategory @Text "create" message $ ErrorL Nothing "SQL_ERROR" message return $ Left $ DBError UnexpectedResult message Left e -> return $ Left e @@ -378,8 +630,6 @@ createSqlMySQL :: forall m table. ( HasCallStack, Model BM.MySQL table, - ToJSON (table Identity), - FromJSON (table Identity), Show (table Identity), L.MonadFlow m ) => @@ -392,18 +642,51 @@ createSqlMySQL dbConf value = do 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 + L.logErrorWithCategory @Text "createSqlMySQL" message $ ErrorL Nothing "SQL_ERROR" message + return $ Left $ DBError UnexpectedResult message -- do we add metric here ? Left e -> return $ Left e +createSqlWoReturing :: + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + Model be table, + B.HasQBuilder be, + PII table, + L.MonadFlow m + ) => + DBConfig beM -> + table Identity -> + Maybe (PIIEncryptionKeyId, PIIEncryptionKey) -> + m (Either DBError ()) +createSqlWoReturing dbConf value (Just (kid , key)) = do + updatedValue <- encryptRow value kid key + case updatedValue of + Left err -> return $ Left $ DBError PIIError err + Right encResult -> runQuery dbConf $ DB.insertRows $ sqlCreate encResult +createSqlWoReturing dbConf value Nothing = runQuery dbConf $ DB.insertRows $ sqlCreate value + +countSql :: + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + Model be table, + B.HasQBuilder be, + L.MonadFlow m, + B.FromBackendRow be Int + ) => + DBConfig beM -> + Where be table -> + m (Either DBError Int) +countSql dbConf whereClause = runQuery dbConf findQuery + where findQuery = DB.countRows (sqlCount ! #where_ whereClause ! defaults) + findOneSql :: ( HasCallStack, BeamRuntime be beM, BeamRunner beM, Model be table, B.HasQBuilder be, - ToJSON (table Identity), - FromJSON (table Identity), L.MonadFlow m ) => DBConfig beM -> @@ -418,7 +701,6 @@ findAllSql :: BeamRunner beM, Model be table, B.HasQBuilder be, - JSONEx (table Identity), L.MonadFlow m ) => DBConfig beM -> @@ -427,9 +709,289 @@ findAllSql :: findAllSql dbConf whereClause = do let findQuery = DB.findRows (sqlSelect ! #where_ whereClause ! defaults) sqlConn <- getOrInitSqlConn dbConf - join <$> mapM (`L.runDB` findQuery) sqlConn + rows <- join <$> mapM (`L.runDB` findQuery) sqlConn + case rows of + Right _ -> pure rows + Left err -> L.incrementDbMetric err dbConf *> pure rows 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) + + +sqlMultiCreate :: + forall be table. + (BExt.BeamHasInsertOnConflict be, Model be table) => + [table Identity] -> + B.SqlInsert be table +sqlMultiCreate value = B.insert modelTableEntity (mkMultiExprWithDefault value) + +sqlMultiCreateIgnoringDuplicates :: + forall be table. + (BExt.BeamHasInsertOnConflict be, Model be table) => + [table Identity] -> + B.SqlInsert be table +sqlMultiCreateIgnoringDuplicates value = BExt.insertOnConflict modelTableEntity (mkMultiExprWithDefault value) BExt.anyConflict BExt.onConflictDoNothing + +createMultiSql :: + forall m be beM table. + ( HasCallStack, + BExt.BeamHasInsertOnConflict be, + BeamRuntime be beM, + BeamRunner beM, + Model be table, + PII table, + L.MonadFlow m + ) => + DBConfig beM -> + [table Identity] -> + Bool -> + [(Maybe PIIEncryptionKeyId, Maybe PIIEncryptionKey)] -> + m (Either DBError [table Identity]) +createMultiSql dbConf value ignoreDuplicates arrKeys = do + maybeUpdatedValue <- decryptOrEncryptAllUtility value arrKeys True + case maybeUpdatedValue of + Left err -> return $ Left $ err + Right updatedValue -> do + res <- runQuery dbConf $ DB.insertRowsReturningList $ bool sqlMultiCreate sqlMultiCreateIgnoringDuplicates ignoreDuplicates updatedValue + setPrimaryKeyAllUtility res value + +createMultiSqlWoReturning :: + ( HasCallStack, + BExt.BeamHasInsertOnConflict be, + BeamRuntime be beM, + BeamRunner beM, + PII table, + Model be table, + L.MonadFlow m + ) => + DBConfig beM -> + [table Identity] -> + Bool -> + [(Maybe PIIEncryptionKeyId, Maybe PIIEncryptionKey)] -> + m (Either DBError ()) +createMultiSqlWoReturning dbConf value ignoreDuplicates arrKeys = do + maybeUpdatedValue <- decryptOrEncryptAllUtility value arrKeys True + case maybeUpdatedValue of + Left err -> return $ Left $ err + Right updatedValue -> runQuery dbConf $ DB.insertRows $ bool sqlMultiCreate sqlMultiCreateIgnoringDuplicates ignoreDuplicates updatedValue + +setPrimaryKeyAllUtility :: + ( PII table, + L.MonadFlow m + ) => + (Either DBError [table Identity]) -> + [table Identity] -> + m (Either DBError [table Identity]) +setPrimaryKeyAllUtility eitherDbRes unencrytpedRows = do + case eitherDbRes of + Right encResult ->return $ Right $ map (\(plainTextRow, dbRow) -> setPrimaryKey plainTextRow dbRow) $ zip unencrytpedRows encResult + Left dbError -> return $ Left $ dbError + +decryptOrEncryptAllUtility :: (L.MonadFlow m, PII table) => [table Identity] -> [(Maybe PIIEncryptionKeyId, Maybe PIIEncryptionKey)] -> Bool -> m (Either DBError [table Identity]) +decryptOrEncryptAllUtility [] _ _ = pure $ Right [] +decryptOrEncryptAllUtility listRow mayKeyConfiglist shouldEncrypt = do + eithResList <- foldM doEncryptDecrypt [] $ zip listRow mayKeyConfiglist + case eithResList of + [Left err] -> do + L.logError @Text "PII error : decryptOrEncryptAllUtility" $ if shouldEncrypt then "encryption failed" else "decryption failed" + pure $ Left err + _ -> pure $ Right $ foldl (\acc row -> either (const $ acc) (\rw -> rw : acc) row) [] eithResList + + where + -- doEncryptDecrypt : for any Left case, directly return [Left err] + doEncryptDecrypt :: (L.MonadFlow m, PII table) => [Either DBError (table Identity)] -> ((table Identity), (Maybe PIIEncryptionKeyId, Maybe PIIEncryptionKey)) -> m [Either DBError (table Identity)] + doEncryptDecrypt [Left e] _ = pure [Left e] + doEncryptDecrypt _ (_, (Just _, Nothing)) = pure [Left $ DBError PIIError "tableT does not have a correspoding key config"] + doEncryptDecrypt _ (_, (Nothing, Just _)) = pure [Left $ DBError PIIError "tableT does not have a correspoding keyId config"] + doEncryptDecrypt acc (row, (mayEncKeyId, mayEncKey)) = do + eithRes <- case (shouldEncrypt, mayEncKeyId, mayEncKey) of + (True, Just encKeyId, Just encKey) -> encryptRow row encKeyId encKey + (False, Just PIIEncryptionKeyId{encKeyId}, Just PIIEncryptionKey{encKey}) -> decryptRow row $ Just $ HM.singleton encKeyId encKey + (False, _, _) -> decryptRow row Nothing + (_, _, _) -> return $ Right row + case eithRes of + Left e -> pure [Left $ DBError PIIError e] + Right rowRes -> pure ((Right rowRes) : acc) + +deleteSql :: + forall m be beM table. + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + B.HasQBuilder be, + Model be table, + L.MonadFlow m + ) => + DBConfig beM -> + Where be table -> + m (Either DBError ()) +deleteSql dbConf value = do + runQuery dbConf $ DB.deleteRows $ (sqlDelete ! #where_ value ! defaults) + +deleteAllSql :: + forall m be beM table. + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + B.HasQBuilder be, + Model be table, + L.MonadFlow m + ) => + DBConfig beM -> + Where be table -> + m (Either DBError [table Identity]) +deleteAllSql dbConf value = do + res <- runQuery dbConf $ DB.deleteRowsReturningList (sqlDelete ! #where_ value ! defaults) + return res + +deleteAllSqlMySQL :: + forall m be beM table. + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + B.HasQBuilder be, + Model be table, + L.MonadFlow m + ) => + DBConfig beM -> + Where be table -> + m (Either DBError [table Identity]) +deleteAllSqlMySQL dbConf value = do + findRes <- findAllSql dbConf value + case findRes of + Left err -> return $ Left err + Right res -> do + delRes <- runQuery dbConf $ DB.deleteRows $ (sqlDelete ! #where_ value ! defaults) + case delRes of + Left err -> return $ Left err + Right _ -> return $ Right res + +deleteAllMySQL :: + forall m be beM table. + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + B.HasQBuilder be, + Model be table, + L.MonadFlow m + ) => + DBConfig beM -> + Where be table -> + m (Either DBError [table Identity]) +deleteAllMySQL = deleteAllSqlMySQL + +deleteAll :: + forall m be beM table. + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + B.HasQBuilder be, + Model be table, + L.MonadFlow m + ) => + DBConfig beM -> + Where be table -> + m (Either DBError [table Identity]) +deleteAll = deleteAllSql + +createSqlWithConn :: + forall m be beM table. + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + B.HasQBuilder be, + Model be table, + Show (table Identity), + L.MonadFlow m + ) => + DBConfig beM -> + NativeSqlConn -> + table Identity -> + m (Either DBError (table Identity)) +createSqlWithConn dbConf conn value = do + res <- runQueryWithConn dbConf conn $ 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.logErrorWithCategory @Text "create" message $ ErrorL Nothing "SQL_ERROR" message + return $ Left $ DBError UnexpectedResult message + Left e -> return $ Left e + +createMultiSqlWithConn :: + forall m be beM table. + ( HasCallStack, + BExt.BeamHasInsertOnConflict be, + BeamRuntime be beM, + BeamRunner beM, + Model be table, + L.MonadFlow m + ) => + DBConfig beM -> + NativeSqlConn -> + [table Identity] -> + Bool -> + m (Either DBError [table Identity]) +createMultiSqlWithConn dbConf conn value ignoreDuplicates = runQueryWithConn dbConf conn $ DB.insertRowsReturningList $ bool sqlMultiCreate sqlMultiCreateIgnoringDuplicates ignoreDuplicates value + +updateSqlWithConn :: + forall m be beM table. + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + B.HasQBuilder be, + Model be table, + L.MonadFlow m + ) => + DBConfig beM -> + NativeSqlConn -> + [Set be table] -> + Where be table -> + m (Either DBError ()) +updateSqlWithConn dbConf conn newVals whereClause = runQueryWithConn dbConf conn $ DB.updateRows (sqlUpdate ! #set newVals ! #where_ whereClause) + +deleteSqlWithConn :: + forall m be beM table. + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + B.HasQBuilder be, + Model be table, + L.MonadFlow m + ) => + DBConfig beM -> + NativeSqlConn -> + Where be table -> + m (Either DBError [table Identity]) +deleteSqlWithConn dbConf conn value = runQueryWithConn dbConf conn $ DB.deleteRowsReturningList (sqlDelete ! #where_ value ! defaults) + +findOneWithConn :: + forall m be beM table. + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + B.HasQBuilder be, + Model be table, + L.MonadFlow m + ) => + DBConfig beM -> + NativeSqlConn -> + Where be table -> + m (Either DBError (Maybe (table Identity))) +findOneWithConn dbConf conn whereClause = runQueryWithConn dbConf conn $ DB.findRow (sqlSelect ! #where_ whereClause ! defaults) + +findAllWithConn :: + forall m be beM table. + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + B.HasQBuilder be, + Model be table, + L.MonadFlow m + ) => + DBConfig beM -> + NativeSqlConn -> + Where be table -> + m (Either DBError [table Identity]) +findAllWithConn dbConf conn whereClause = runQueryWithConn dbConf conn $ DB.findRows (sqlSelect ! #where_ whereClause ! defaults) \ No newline at end of file diff --git a/src/EulerHS/Common.hs b/src/EulerHS/Common.hs new file mode 100644 index 00000000..f7623953 --- /dev/null +++ b/src/EulerHS/Common.hs @@ -0,0 +1,43 @@ +{- | +Module : EulerHS.Common +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +This module contains common types and functions used in EulerHS. +-} + +{-# LANGUAGE DerivingVia #-} + +module EulerHS.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 + +import qualified Data.Word as W +import EulerHS.Prelude + +type FlowGUID = Text +type ForkGUID = Text +type SafeFlowGUID = Text + +newtype ManagerSelector = ManagerSelector Text + deriving (Eq, IsString) via Text + deriving stock (Show) + +type Description = Text +data Awaitable s = Awaitable (MVar s) +data Microseconds = Microseconds W.Word32 -- Max timeout ~71 minutes with Word32 diff --git a/src/EulerHS/Core/Api.hs b/src/EulerHS/Core/Api.hs index 523d6019..d57ef472 100644 --- a/src/EulerHS/Core/Api.hs +++ b/src/EulerHS/Core/Api.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - {- | Module : EulerHS.Core.Api Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 @@ -14,6 +11,9 @@ This module contains implementation of the low-level HTTP client subsystem. This is an internal module. Import EulerHS.Types instead. -} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module EulerHS.Core.Api where import EulerHS.Prelude diff --git a/src/EulerHS/Core/KVDB/Interpreter.hs b/src/EulerHS/Core/KVDB/Interpreter.hs index 94ea14f9..d63f588a 100644 --- a/src/EulerHS/Core/KVDB/Interpreter.hs +++ b/src/EulerHS/Core/KVDB/Interpreter.hs @@ -1,3 +1,16 @@ +{- | +Module : EulerHS.Core.KVDB.Interpreter +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable + +This module contains interpreter for KVDB language and used in KVDB runtime +Also this is to interpret the KVDB language and convert it to +redis commands and execute them +-} + {-# LANGUAGE AllowAmbiguousTypes #-} module EulerHS.Core.KVDB.Interpreter ( @@ -140,8 +153,6 @@ interpretKeyValueTxF (L.XAdd stream entryId items next) = makeStreamEntryId L.AutoID = "*" 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 diff --git a/src/EulerHS/Core/KVDB/Language.hs b/src/EulerHS/Core/KVDB/Language.hs index fbcff370..bcf73244 100644 --- a/src/EulerHS/Core/KVDB/Language.hs +++ b/src/EulerHS/Core/KVDB/Language.hs @@ -1,7 +1,3 @@ -{-# OPTIONS_GHC -Werror #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE MultiParamTypeClasses #-} - {- | Module : EulerHS.Core.KVDB.Language Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 @@ -19,6 +15,10 @@ This module is internal and should not imported in the projects. Import 'EulerHS.Language' instead. -} +{-# OPTIONS_GHC -Werror #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} + module EulerHS.Core.KVDB.Language ( -- * KVDB language diff --git a/src/EulerHS/Core/Logger/Impl/TinyLogger.hs b/src/EulerHS/Core/Logger/Impl/TinyLogger.hs index 7a0bc553..42f3e807 100644 --- a/src/EulerHS/Core/Logger/Impl/TinyLogger.hs +++ b/src/EulerHS/Core/Logger/Impl/TinyLogger.hs @@ -1,3 +1,14 @@ +{- | +Module : EulerHS.Core.Logger.Impl.TinyLogger +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable + +This module contains implementation of TinyLogger +-} + module EulerHS.Core.Logger.Impl.TinyLogger ( -- * TinyLogger Implementation diff --git a/src/EulerHS/Core/Logger/Interpreter.hs b/src/EulerHS/Core/Logger/Interpreter.hs index 13589763..2341383f 100644 --- a/src/EulerHS/Core/Logger/Interpreter.hs +++ b/src/EulerHS/Core/Logger/Interpreter.hs @@ -1,3 +1,16 @@ +{- | +Module : EulerHS.Core.Logger.Interpreter +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable + +This module contains interpreter for Logger language and used in Logger runtime +Also this is to interpret the Logger language and convert it to +logger commands and execute them +-} + {-# LANGUAGE BangPatterns #-} module EulerHS.Core.Logger.Interpreter diff --git a/src/EulerHS/Core/Logger/Language.hs b/src/EulerHS/Core/Logger/Language.hs index 0e7f10d6..2dfa8878 100644 --- a/src/EulerHS/Core/Logger/Language.hs +++ b/src/EulerHS/Core/Logger/Language.hs @@ -1,3 +1,12 @@ +{- | +Module : EulerHS.Core.Logger.Language +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + {-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskell #-} diff --git a/src/EulerHS/Core/Masking.hs b/src/EulerHS/Core/Masking.hs index 95fbaf6e..4f69c42e 100644 --- a/src/EulerHS/Core/Masking.hs +++ b/src/EulerHS/Core/Masking.hs @@ -1,3 +1,12 @@ +{- | +Module : EulerHS.Core.Masking +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + module EulerHS.Core.Masking where diff --git a/src/EulerHS/Core/PubSub/Interpreter.hs b/src/EulerHS/Core/PubSub/Interpreter.hs index d135253e..5daf7a82 100644 --- a/src/EulerHS/Core/PubSub/Interpreter.hs +++ b/src/EulerHS/Core/PubSub/Interpreter.hs @@ -1,3 +1,12 @@ +{- | +Module : EulerHS.Core.PubSub.Interpreter +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + module EulerHS.Core.PubSub.Interpreter where import EulerHS.Prelude diff --git a/src/EulerHS/Core/PubSub/Language.hs b/src/EulerHS/Core/PubSub/Language.hs index dde53f93..544375f9 100644 --- a/src/EulerHS/Core/PubSub/Language.hs +++ b/src/EulerHS/Core/PubSub/Language.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveFunctor #-} - {- | Module : EulerHS.Core.PubSub.Language Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 @@ -14,6 +12,8 @@ This module is internal and should not imported in the projects. Import 'EulerHS.Language' instead. -} +{-# LANGUAGE DeriveFunctor #-} + module EulerHS.Core.PubSub.Language where import EulerHS.Prelude diff --git a/src/EulerHS/Core/Runtime.hs b/src/EulerHS/Core/Runtime.hs index 62066566..977f07d6 100644 --- a/src/EulerHS/Core/Runtime.hs +++ b/src/EulerHS/Core/Runtime.hs @@ -45,7 +45,7 @@ import EulerHS.Core.Types.DB as X (withTransaction) import qualified System.Logger as Log --- TODO: add StaticLoggerRuntimeContext if we'll need more than a single Bool + data LoggerRuntime = LoggerRuntime { _flowFormatter :: T.FlowFormatter @@ -62,12 +62,6 @@ data CoreRuntime = CoreRuntime { _loggerRuntime :: LoggerRuntime } --- 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 = diff --git a/src/EulerHS/Core/SqlDB/Interpreter.hs b/src/EulerHS/Core/SqlDB/Interpreter.hs index 1212aa9a..90b510ae 100644 --- a/src/EulerHS/Core/SqlDB/Interpreter.hs +++ b/src/EulerHS/Core/SqlDB/Interpreter.hs @@ -1,3 +1,12 @@ +{- | +Module : EulerHS.Core.SqlDB.Interpreter +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + module EulerHS.Core.SqlDB.Interpreter ( -- * SQL DB Interpreter @@ -11,7 +20,6 @@ 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 ()) diff --git a/src/EulerHS/Core/SqlDB/Language.hs b/src/EulerHS/Core/SqlDB/Language.hs index 5328fde6..eb29741d 100644 --- a/src/EulerHS/Core/SqlDB/Language.hs +++ b/src/EulerHS/Core/SqlDB/Language.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - {- | Module : EulerHS.Core.SqlDB.Language Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 @@ -19,6 +14,11 @@ This module is internal and should not imported in the projects. Import 'EulerHS.Language' instead. -} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + module EulerHS.Core.SqlDB.Language ( -- * SQLDB language diff --git a/src/EulerHS/Core/Types/BinaryString.hs b/src/EulerHS/Core/Types/BinaryString.hs index 688fe4ce..8224a4ae 100644 --- a/src/EulerHS/Core/Types/BinaryString.hs +++ b/src/EulerHS/Core/Types/BinaryString.hs @@ -1,3 +1,12 @@ +{- | +Module : EulerHS.Core.Types.BinaryString +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + -- {-# LANGUAGE GeneralizedNewtypeDeriving #-} module EulerHS.Core.Types.BinaryString @@ -17,7 +26,7 @@ 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/DB.hs b/src/EulerHS/Core/Types/DB.hs index 441219b7..c83265aa 100644 --- a/src/EulerHS/Core/Types/DB.hs +++ b/src/EulerHS/Core/Types/DB.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE RecordWildCards #-} {- | Module : EulerHS.Core.Types.DB @@ -23,6 +19,11 @@ Types and helpers for specific databases can be found in separate modules: 'EulerHS.Core.Types.Postgres' -} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RecordWildCards #-} + module EulerHS.Core.Types.DB ( -- * Core DB @@ -96,7 +97,6 @@ class (B.BeamSqlBackend be, B.MonadBeam be beM) => BeamRuntime be 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 () --- TODO: move somewhere (it's implementation) instance BeamRuntime BS.Sqlite BS.SqliteM where rtSelectReturningList = B.runSelectReturningList rtSelectReturningOne = B.runSelectReturningOne @@ -106,7 +106,6 @@ instance BeamRuntime BS.Sqlite BS.SqliteM where rtUpdateReturningList = error "Not implemented" rtDelete = B.runDelete --- TODO: move somewhere (it's implementation) instance BeamRuntime BP.Postgres BP.Pg where rtSelectReturningList = B.runSelectReturningList rtSelectReturningOne = B.runSelectReturningOne @@ -449,7 +448,6 @@ postgresErrorToDbError descr e = DBError (SQLError $ PostgresError $ toPostgresS ---------------------------------------------------------------------- --- TODO: more informative typed error. -- | Represents failures that may occur while working with the database data DBErrorType = ConnectionFailed diff --git a/src/EulerHS/Core/Types/Exceptions.hs b/src/EulerHS/Core/Types/Exceptions.hs index c3e890b4..a661036f 100644 --- a/src/EulerHS/Core/Types/Exceptions.hs +++ b/src/EulerHS/Core/Types/Exceptions.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} - {- | Module : EulerHS.Core.Types.Exceptions Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 @@ -14,6 +12,7 @@ This module is internal and should not imported in the projects. Import 'EulerHS.Types' instead. -} +{-# LANGUAGE DeriveAnyClass #-} module EulerHS.Core.Types.Exceptions ( -- * Exceptions HttpManagerNotFound(..) diff --git a/src/EulerHS/Core/Types/HttpAPI.hs b/src/EulerHS/Core/Types/HttpAPI.hs index 4f14a224..9135691a 100644 --- a/src/EulerHS/Core/Types/HttpAPI.hs +++ b/src/EulerHS/Core/Types/HttpAPI.hs @@ -170,7 +170,6 @@ 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 diff --git a/src/EulerHS/Core/Types/KVDB.hs b/src/EulerHS/Core/Types/KVDB.hs index 8f0ec85a..11840ce3 100644 --- a/src/EulerHS/Core/Types/KVDB.hs +++ b/src/EulerHS/Core/Types/KVDB.hs @@ -1,3 +1,12 @@ +{- | +Module : EulerHS.Core.Types.KVDB +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RecordWildCards #-} @@ -60,7 +69,7 @@ type KVDBKey = Text -- Key-value database connection data KVDBConn - = Mocked Text -- TODO swap Text with ConnTag type + = Mocked Text | Redis Text RD.Connection -- ^ Real connection. deriving (Generic) diff --git a/src/EulerHS/Core/Types/MySQL.hs b/src/EulerHS/Core/Types/MySQL.hs index 31fa251f..8b111344 100644 --- a/src/EulerHS/Core/Types/MySQL.hs +++ b/src/EulerHS/Core/Types/MySQL.hs @@ -1,3 +1,12 @@ +{- | +Module : EulerHS.Core.Types.MySQL +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + {-# OPTIONS_GHC -Werror #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} @@ -50,20 +59,13 @@ data MySqlOption = ConnectTimeout Word | Compress | NamedPipe - -- | InitCommand ByteString -- TODO | ReadDefaultFile FilePath - -- | ReadDefaultGroup ByteString -- TODO | CharsetDir FilePath | CharsetName String | LocalInFile Bool | Protocol MySqlProtocol - -- | SharedMemoryBaseName ByteString -- TODO | ReadTimeout Word | WriteTimeout Word - -- | UseRemoteConnection - -- | UseEmbeddedConnection - -- | GuessConnection - -- | ClientIP ByteString | SecureAuth Bool | ReportDataTruncation Bool | Reconnect Bool diff --git a/src/EulerHS/Core/Types/Serializable.hs b/src/EulerHS/Core/Types/Serializable.hs index 930d79a2..114ecd4b 100644 --- a/src/EulerHS/Core/Types/Serializable.hs +++ b/src/EulerHS/Core/Types/Serializable.hs @@ -1,3 +1,12 @@ +{- | +Module : EulerHS.Core.Types.Serializable +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} diff --git a/src/EulerHS/Extra/Aeson.hs b/src/EulerHS/Extra/Aeson.hs index d531e44d..48cf2580 100644 --- a/src/EulerHS/Extra/Aeson.hs +++ b/src/EulerHS/Extra/Aeson.hs @@ -1,26 +1,87 @@ +{- | +Module : EulerHS.Extra.Aeson +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable + +This module contains utility functions for munging JSON data with Aeson. +-} + +{-# LANGUAGE TypeApplications #-} + +-- | Utility functions for munging JSON data with Aeson. module EulerHS.Extra.Aeson -( stripLensPrefixOptions -, stripAllLensPrefixOptions -, jsonSetField -, encodeJSON -, decodeJSON -) where + ( -- * Common utility functions + obfuscate + + -- * Aeson options presets + , aesonOmitNothingFields + , stripAllLensPrefixOptions + , stripLensPrefixOptions + , unaryRecordOptions + , untaggedOptions + , aesonOptions + , aesonOmitNothingOption + ) where +import Data.Aeson (Options (..), SumEncoding (..), Value (..), + defaultOptions) import Prelude -import Data.Aeson (FromJSON, ToJSON, Options, defaultOptions, fieldLabelModifier) -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Text as Aeson -import qualified Data.ByteString.Lazy as LazyByteString -import qualified Data.HashMap.Strict as HashMap -import Data.Text (Text) -import qualified Data.Text.Encoding as Text -import qualified Data.Text.Lazy as LazyText +{------------------------------------------------------------------------------- + Common utility functions +-------------------------------------------------------------------------------} -stripLensPrefixOptions :: Options -stripLensPrefixOptions = defaultOptions { fieldLabelModifier = drop 1 } +-- | Rip away all __simple__ values from a JSON Value. +obfuscate :: Value -> Value +obfuscate v = go v where + go (Object o) = Object $ go <$> o + go (Array a) = Array $ go <$> a + go (String _) = String "***" + go (Number _) = Number 0 + go (Bool _) = Bool False + go Null = Null + + + +{- | Use it to omit 'Nothing' fields. + +Also previously known as @aesonOrderCreateOptions@, @aesonOmitNothingOption@ and +broken @aesonOptions@. The latter is broken because of using @omitNothingFields = False@, +which is default in Aeson. + +If you want to show 'Nothing' fields then please just use stock 'defaultOptions'! + +>>> encode $ Person "Omar" Nothing +"{\"name\":\"Omar\"}" + +whereas the default behavior is: + +>>> encode $ Person "Omar" Nothing +"{\"age\":null,\"name\":\"Omar\"}" + +-} +aesonOmitNothingFields :: Options +aesonOmitNothingFields = defaultOptions + { omitNothingFields = True + } +{- | Drops all leading characters while they are the same. + +@ +data Wooolf = Wooolf + { cccName :: Text + , cccColour :: Maybe Text + } +@ + +>>> encode $ Wooolf "Boooss" (Just "grey") +"{\"Name\":\"Boooss\",\"Colour\":\"grey\"}" + +-} stripAllLensPrefixOptions :: Options stripAllLensPrefixOptions = defaultOptions { fieldLabelModifier = dropPrefix} where @@ -29,22 +90,39 @@ stripAllLensPrefixOptions = defaultOptions { fieldLabelModifier = dropPrefix} then dropWhile (== head field) field else field --- utility functions - --- | Set a field inside a JSON Object -jsonSetField :: ToJSON a => Text -> a -> Aeson.Value -> Aeson.Value -jsonSetField fieldName fieldValue obj = case obj of - Aeson.Object fields -> - Aeson.Object $ HashMap.insert fieldName (Aeson.toJSON fieldValue) fields - _ -> - error $ "This should be an object... got " <> show obj - --- | Encode a value to JSON Text --- --- Note: the name `jsonEncode` is already taken by Aeson -encodeJSON :: ToJSON a => a -> Text -encodeJSON = LazyText.toStrict . Aeson.encodeToLazyText - --- | Parse JSON Text into a value -decodeJSON :: FromJSON a => Text -> Maybe a -decodeJSON = Aeson.decode . LazyByteString.fromStrict . Text.encodeUtf8 +{- | Strips lens-style one-character prefixes (usually @_@) from field names. + +@ +data Dog = Dog + { cName :: Text + , cColour :: Maybe Text + } +@ + +>>> encode $ Dog "Buddy" (Just "white") +"{\"Name\":\"Buddy\",\"Colour\":\"white\"}" + +-} +stripLensPrefixOptions :: Options +stripLensPrefixOptions = defaultOptions { fieldLabelModifier = drop 1 } + + +unaryRecordOptions :: Options +unaryRecordOptions = defaultOptions + { unwrapUnaryRecords = True + } + + +untaggedOptions :: Options +untaggedOptions = defaultOptions { sumEncoding = UntaggedValue } + +aesonOptions :: Options +aesonOptions = defaultOptions + { omitNothingFields = False + } + +aesonOmitNothingOption :: Options +aesonOmitNothingOption = defaultOptions + { omitNothingFields = True + } + diff --git a/src/EulerHS/Extra/AltValidation.hs b/src/EulerHS/Extra/AltValidation.hs index 2ceb225c..d3248144 100644 --- a/src/EulerHS/Extra/AltValidation.hs +++ b/src/EulerHS/Extra/AltValidation.hs @@ -1,5 +1,17 @@ +{- | +Module : EulerHS.Extra.AltValidation +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable + + +-} + {-# OPTIONS -fno-warn-deprecations #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} module EulerHS.Extra.AltValidation ( @@ -15,6 +27,7 @@ module EulerHS.Extra.AltValidation , Errors , VErrorPayload(..) , module X + , withField' , withField , runParser , extractJust @@ -27,18 +40,16 @@ module EulerHS.Extra.AltValidation , parValidate ) where -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 -import Data.Validation -import Data.Validation as X -import GHC.TypeLits -import Type.Reflection - +import Data.Validation (Validation, fromEither, toEither) +import qualified Data.Validation as X +import EulerHS.Prelude hiding (or, pred) +import qualified Data.Generics.Product.Fields as GL (HasField', getField) +import GHC.Records.Compat (HasField, getField) +import GHC.TypeLits (KnownSymbol, Symbol) +import qualified Prelude as P +import Type.Reflection (typeRep) data VErrorPayload = VErrorPayload { status :: Text @@ -64,7 +75,6 @@ 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. @@ -86,7 +96,7 @@ mkValidator msg pred v = ReaderT (\ctx -> if not $ pred v -- | Make a validator using a particular error message, original -- errors are ignored withCustomError :: VErrorPayload -> Validator a -> Validator a -withCustomError err v a = ReaderT (\ctx -> mapLeft (\_ -> [err]) $ runReaderT (v a) ctx) +withCustomError err v a = ReaderT (mapLeft (P.const [err]) . runReaderT (v a)) -- | Takes error message and predicate and returns validation function -- using custom error @@ -106,22 +116,20 @@ 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 . (Data t, Read t) => Transformer Text t -decode v = ReaderT (\ctx -> case (readMaybe $ toString v) of +decode :: forall 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 . (Data t, Read t) => VErrorPayload -> Transformer Text t -decodeCustom err v = ReaderT (\_ -> case (readMaybe $ toString v) of +decodeCustom :: forall 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 :: Show a => VErrorPayload -> (a -> Maybe b) -> Transformer a b + +mkTransformer :: VErrorPayload -> (a -> Maybe b) -> Transformer a b mkTransformer err f v = ReaderT (\_ -> case f v of Just x -> Right x Nothing -> Left [ err ]) @@ -146,11 +154,21 @@ extractMaybeWithDefault :: a -> Transformer (Maybe a) a extractMaybeWithDefault d r = ReaderT (\_ -> maybe (Right d) Right r) -- | Extract value and run validators on it +-- This function is not working with HasField +-- New withField without lens +withField' + :: forall (f :: Symbol) v r a + . (HasField f r v, KnownSymbol f) + => r -> Transformer v a -> Validation Errors a +withField' rec pav = fromEither $ runReaderT (pav $ getField @f rec) $ fieldName_ @f + +-- | Extract value and run validators on it +-- Old withField with lens withField :: forall (f :: Symbol) v r a - . (Generic r, HasField' f r v, KnownSymbol f) + . (GL.HasField' f r v, KnownSymbol f) => r -> Transformer v a -> Validation Errors a -withField rec pav = fromEither $ runReaderT (pav $ getField @f rec) $ fieldName_ @f +withField rec pav = fromEither $ runReaderT (pav $ GL.getField @f rec) $ fieldName_ @f -- | Run a custom parser runParser @@ -160,19 +178,8 @@ 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" fieldName_ :: forall (f :: Symbol) . KnownSymbol f => Text -fieldName_ = T.pack $ ((filter (/='"'))) $ P.show $ typeRep @f +fieldName_ = T.pack $ filter (/='"') $ P.show $ typeRep @f parValidate :: [Validator a] -> Validator a parValidate vals a = ReaderT (\ctx -> toEither $ foldr (*>) (pure a) $ fmap (mapper ctx) vals) diff --git a/src/EulerHS/Extra/Combinators.hs b/src/EulerHS/Extra/Combinators.hs new file mode 100644 index 00000000..8c5028ac --- /dev/null +++ b/src/EulerHS/Extra/Combinators.hs @@ -0,0 +1,109 @@ +{- | +Module : EulerHS.Extra.Combinators +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE TypeOperators #-} + +module EulerHS.Extra.Combinators +( toDomain +, toDomainAll +, throwOnDBError +, throwOnParseError +, extractDBResult +) +where + +import Control.Exception (Exception) +import Control.Monad (void) +import Data.Text (Text, pack) +import Juspay.Extra.Parsing (Parsed (Failed, Result)) +import EulerHS.Language (MonadFlow, logErrorWithCategory, throwException) +import GHC.Generics (Generic) +import GHC.Stack (HasCallStack) +import Named (NamedF (Arg), type (:!)) +import Prelude hiding (id) +import EulerHS.Logger.Types (ErrorL(..)) + + +toDomain + :: (HasCallStack, MonadFlow m, Show err) + => Either err a + -> (a -> Parsed b) + -> "function_name" :! Text -- Name of query function for error log + -> "parser_name" :! Text + -> m b +toDomain eitherRes parser functionName parserName = do + res <- extractDBResult eitherRes functionName + throwOnParseError (parser res) parserName + +{- | For traversable responses. +Maybe a, [a], etc. +-} +toDomainAll + :: (HasCallStack, MonadFlow m, Traversable f, Show err) + => Either err (f a) + -> (a -> Parsed b) + -> "function_name" :! Text + -> "parser_name" :! Text + -> m (f b) +toDomainAll eitherRes parser functionName parserName = do + res <- extractDBResult eitherRes functionName + throwOnParseError (traverse parser res) parserName + +throwOnDBError + :: (HasCallStack, MonadFlow m, Show err) + => Either err () + -> "function_name" :! Text + -> m () +throwOnDBError res = void . extractDBResult res + +throwOnParseError + :: (HasCallStack, MonadFlow m) + => Parsed a + -> "parser_name" :! Text + -> m a +throwOnParseError parseResult (Arg parserName) = case parseResult of + Result c -> pure c + Failed e -> do + let errMsg = pack . show $ e + logErrorWithCategory @Text ("Domain type parse error in " <> parserName) errMsg $ ErrorL Nothing "PARSE_ERROR" errMsg + throwException $ DomainTypeParseError errMsg + +----------------------------------------------------------------------------- +-- Helpers +----------------------------------------------------------------------------- + +extractDBResult + :: (HasCallStack, MonadFlow m, Show err) + => Either err a + -> "function_name" :! Text + -> m a +extractDBResult eitherResult (Arg functionName) = case eitherResult of + Right res -> pure res + Left err -> do + let errMsg = pack . show $ err + logErrorWithCategory @Text ("Database error from function " <> functionName) errMsg $ ErrorL Nothing "DATABASE_ERROR" errMsg + throwException $ DatabaseError errMsg + +----------------------------------------------------------------------------- +-- Errors +----------------------------------------------------------------------------- + +newtype DatabaseError = DatabaseError + { errorMessage :: Text + } + deriving (Eq, Show, Generic) + +instance Exception DatabaseError + +newtype DomainTypeParseError = DomainTypeParseError + { errorMessage :: Text + } + deriving (Eq, Show, Generic) + +instance Exception DomainTypeParseError diff --git a/src/EulerHS/Extra/Language.hs b/src/EulerHS/Extra/Language.hs index 1fe3183c..a7717129 100644 --- a/src/EulerHS/Extra/Language.hs +++ b/src/EulerHS/Extra/Language.hs @@ -5,13 +5,14 @@ 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. -} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + module EulerHS.Extra.Language ( getOrInitSqlConn , getOrInitKVDBConn @@ -21,7 +22,7 @@ module EulerHS.Extra.Language , rDelB , rExists , rExistsB - , rExistsT -- alias for rExists (back compat) + , rExistsT , rHget , rHgetB , rHset @@ -29,35 +30,93 @@ module EulerHS.Extra.Language , rIncr , rIncrB , rSet - , rSetT -- alias for rSet (back compat) + , rSetT , rSetB , rGet , rGetB - , rGetT -- alias for rGet (back compat) + , rGetT , rSetex , rSetexB - , rSetexT -- alias for rSetex (back compat) + , rSetexT + , rXreadB + , rXreadT + , rXrevrangeT + , rXrevrangeB + , rSetexBulk + , rSetexBulkB , rSetOpts , rSetOptsB , rSetOptsT , keyToSlot , rSadd , rSismember + , rZAdd + , rZRangeByScore + , rZRangeByScoreWithLimit + , rZRem + , rZRemRangeByScore + , rZCard + , rXaddB + , rGetBEither + , rSmembersB + , sRemB + , rMultiExec + , AppException(..) + , throwOnFailedWithLog + , checkFailedWithLog , updateLoggerContext - , withLoggerContext + , logInfoT + , logWarningT + , logErrorT + , logDebugT + , getCurrentTimeUTC + , getCurrentDateInSeconds + , getCurrentDateInMillis + , getCurrentDateStringWithSecOffset + , withDB + , withDBTransaction + , insertRow + , unsafeInsertRow + , insertRowMySQL + , unsafeInsertRowMySQL + , generateSnowflake ) where -import EulerHS.Prelude hiding (get, id) - import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A import qualified Data.ByteString.Lazy as BSL +import Data.Either.Extra (fromEither, mapLeft) +import qualified Data.Map as Map +import qualified Data.Text as Text import qualified Data.Text.Encoding as TE +import Data.Time (LocalTime, addUTCTime, defaultTimeLocale, + formatTime, getCurrentTime, utc, utcToZonedTime, + zonedTimeToLocalTime) +import Data.Time.Clock.POSIX (getPOSIXTime) +import Database.Beam (Beamable, FromBackendRow, SqlInsert) +import Database.Beam.MySQL (MySQL, MySQLM) import Database.Redis (keyToSlot) -import qualified EulerHS.Core.KVDB.Language as L -import qualified EulerHS.Core.Types as T +import EulerHS.Extra.Aeson (obfuscate) +import EulerHS.Extra.Snowflakes.Types (StackID (..), PodID (..), Snowflake, SnowflakeError(Fatal)) import qualified EulerHS.Framework.Language as L -import EulerHS.Runtime (CoreRuntime (..), FlowRuntime (..), - LoggerRuntime (..)) +import qualified EulerHS.KVDB.Language as L +import EulerHS.KVDB.Types (KVDBAnswer, KVDBConfig, KVDBConn, + KVDBReply, KVDBReplyF (..), KVDBError(..), + KVDBStatus,TxResult (..)) +import EulerHS.Logger.Types (LogContext,ErrorL(..)) +import EulerHS.Prelude hiding (get, id) +import EulerHS.Runtime ( FlowRuntime (..)) +import EulerHS.Logger.Runtime ( LoggerRuntime (..), CoreRuntime(..)) +import EulerHS.SqlDB.Language (SqlDB, insertRowReturningMySQL, + insertRowsReturningList) +import qualified EulerHS.SqlDB.Types as T +import Servant (err500) +import EulerHS.ART.Types +import qualified Data.HashMap.Strict as HM +import qualified Database.Redis as R +import qualified EulerHS.ART.ReplayFunctions as ER +import qualified Servant as S +import EulerHS.ART.EnvVars (isArtReplayEnabled, isArtRecEnabled) type RedisName = Text type TextKey = Text @@ -66,255 +125,564 @@ type ByteKey = ByteString type ByteField = ByteString type ByteValue = ByteString +-- | Retrieves the current UTC time, but as a 'LocalTime'. +-- +-- @since 2.1.0.1 +getCurrentTimeUTC :: (L.MonadFlow m) => m LocalTime +getCurrentTimeUTC = L.runIO' "getCurrentTimeUTC" go + where + go :: IO LocalTime + go = zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + +-- | Retrieves the current POSIX time, rounded to seconds. +-- +-- @since 2.1.0.1 +getCurrentDateInSeconds :: (L.MonadFlow m) => m Int +getCurrentDateInSeconds = L.runIO' "getCurrentDateInSeconds" (floor <$> getPOSIXTime) + +-- | Retrieves the current POSIX time, rounded to milliseconds. +-- +-- @since 2.1.0.1 +getCurrentDateInMillis :: (L.MonadFlow m) => m Int +getCurrentDateInMillis = L.runIO' "getCurrentDateInMillis" $ do + t <- (* 1000) <$> getPOSIXTime + pure . floor $ t + +-- | Given a number of seconds as an offset, return a date string, in the format +-- YYYY-MM-ddTHH:MM:SSZ, representing the current time, offset by the specified +-- number of seconds. +-- +-- @since 2.1.0.1 +getCurrentDateStringWithSecOffset :: (L.MonadFlow m) => Int -> m Text +getCurrentDateStringWithSecOffset secs = do + now <- L.runIO' "getCurrentDateStringWithSecOffset" getCurrentTime + let offset = addUTCTime (realToFrac secs) now + pure . Text.pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" $ offset + +-- | An app-specific exception. +-- +-- @since 2.1.0.1 +data AppException = + SqlDBConnectionFailedException Text | + KVDBConnectionFailedException Text + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (ToJSON, FromJSON) + +instance Exception AppException + +-- | Transforms a 'Left' result into an exception, logging this outcome. Does +-- nothing on a 'Right'. +-- +-- @since 2.1.0.1 +throwOnFailedWithLog :: (HasCallStack, Show e, L.MonadFlow m) => + Either e a -> (Text -> AppException) -> Text -> m () +throwOnFailedWithLog res mkException msg = case res of + Left err -> do + let errMsg = msg <> " " <> show err + L.logErrorWithCategory @Text "" errMsg $ ErrorL Nothing "" errMsg + L.throwException . mkException $ errMsg + Right _ -> pure () + +checkFailedWithLog :: (HasCallStack, Show e, L.MonadFlow m) => Either e a -> Text -> m () +checkFailedWithLog (Left err) msg = L.logErrorWithCategory @Text "" (msg <> " " <> show err <> "") $ ErrorL Nothing "" (msg <> " " <> show err <> "") +checkFailedWithLog _ _ = pure () + +-- | As 'logInfo', but specialized for logging 'Text' tags. +-- +-- @since 2.1.0.1 +logInfoT :: forall (m :: Type -> Type) . + (HasCallStack, L.MonadFlow m) => Text -> Text -> m () +logInfoT = L.logInfo @Text + +-- | As 'L.logError', but specialized for logging 'Text' tags. +-- +-- @since 2.1.0.1 +logErrorT :: forall (m :: Type -> Type) . + (HasCallStack, L.MonadFlow m) => Text -> Text -> m () +logErrorT = L.logError @Text + +-- | As 'logDebug', but specialized for logging 'Text' tags. +-- +-- @since 2.1.0.1 +logDebugT :: forall (m :: Type -> Type) . + (HasCallStack, L.MonadFlow m) => Text -> Text -> m () +logDebugT = L.logDebug @Text + +-- | As 'logWarning', but specialized for logging 'Text' tags. +-- +-- @since 2.1.0.1 +logWarningT :: forall (m :: Type -> Type) . + (HasCallStack, L.MonadFlow m) => Text -> Text -> m () +logWarningT = L.logWarning @Text + +-- | Creates a connection and runs a DB operation. Throws on connection failure +-- or if the operation fails; this will log if either of these things happens. +-- +-- NOTE: This does /not/ run inside a transaction. +-- +-- @since 2.1.0.1 +withDB :: (HasCallStack, L.MonadFlow m, T.BeamRunner beM, T.BeamRuntime be beM) => + T.DBConfig beM -> SqlDB beM a -> m a +withDB = withDB' L.runDB + +-- | As 'withDB', but runs inside a transaction. +-- +-- @since 2.1.0.1 +withDBTransaction :: (HasCallStack, L.MonadFlow m, T.BeamRunner beM, T.BeamRuntime be beM) => + T.DBConfig beM -> SqlDB beM a -> m a +withDBTransaction = withDB' L.runTransaction + +-- Internal helper +withDB' :: (HasCallStack, L.MonadFlow m) => + (T.SqlConn beM -> SqlDB beM a -> m (T.DBResult a)) -> + T.DBConfig beM -> + SqlDB beM a -> + m a +withDB' run conf act = do + mConn <- L.getSqlDBConnection conf + case mConn of + Left err -> do + let errorReason = show err + L.logErrorWithCategory @Text "SqlDB connect" errorReason $ ErrorL Nothing "MYSQL_EXCEPTION" errorReason + L.throwException err500 + Right conn -> do + res <- run conn act + case res of + Left err -> do + L.incrementDbMetric err conf + L.logErrorWithCategory @Text "SqlDB interaction" (show err) $ ErrorL Nothing "MYSQL_EXCEPTION" (show err) + L.throwException err500 + Right val -> pure val + +-- | Inserts several rows, returning the first successful inserted result. Use +-- this function with care: if your insert ends up inserting nothing +-- successfully, this will return a 'Left'. +-- +-- @since 2.1.0.1 +insertRow :: + (HasCallStack, + L.MonadFlow m, + T.BeamRunner beM, + T.BeamRuntime be beM, + Beamable table, + FromBackendRow be (table Identity)) => + T.DBConfig beM -> SqlInsert be table -> m (Either Text (table Identity)) +insertRow conf ins = do + results <- withDBTransaction conf . insertRowsReturningList $ ins + pure $ case results of + [] -> Left "Unexpected empty result." + (x : _) -> Right x + +-- | As 'insertRow', but instead throws the provided exception on failure. Will +-- also log in such a case. +-- +-- @since 2.1.0.1 +unsafeInsertRow :: + (HasCallStack, + L.MonadFlow m, + T.BeamRunner beM, + T.BeamRuntime be beM, + Beamable table, + FromBackendRow be (table Identity), + Exception e) => + e -> T.DBConfig beM -> SqlInsert be table -> m (table Identity) +unsafeInsertRow err conf ins = do + res <- insertRow conf ins + case res of + Left err' -> do + L.logErrorWithCategory @Text "unsafeInsertRow" err' $ ErrorL Nothing "DB_EXCEPTION" err' + L.throwException err + Right x -> pure x + +-- | MySQL-specific version of 'insertRow'. +-- +-- @since 2.1.0.1 +insertRowMySQL :: + (HasCallStack, + L.MonadFlow m, + FromBackendRow MySQL (table Identity)) => + T.DBConfig MySQLM -> SqlInsert MySQL table -> m (Either Text (table Identity)) +insertRowMySQL conf ins = do + results <- withDBTransaction conf . insertRowReturningMySQL $ ins + pure $ case results of + Nothing -> Left "Unexpected empty result." + Just x -> Right x + +-- | MySQL-specific version of 'unsafeInsertRow'. +-- +-- @since 2.1.0.1 +unsafeInsertRowMySQL :: + (HasCallStack, + L.MonadFlow m, + FromBackendRow MySQL (table Identity), + Exception e) => + e -> T.DBConfig MySQLM -> SqlInsert MySQL table -> m (table Identity) +unsafeInsertRowMySQL err conf ins = do + res <- insertRowMySQL conf ins + case res of + Left err' -> do + L.logErrorWithCategory @Text "unsafeInsertRowMySQL" err' $ ErrorL Nothing "MYSQL_EXCEPTION" err' + L.throwException err + Right x -> pure x + -- | Get existing SQL connection, or init a new connection. getOrInitSqlConn :: (HasCallStack, L.MonadFlow m) => T.DBConfig beM -> m (T.DBResult (T.SqlConn beM)) getOrInitSqlConn cfg = do eConn <- L.getSqlDBConnection cfg case eConn of - Left (T.DBError T.ConnectionDoesNotExist _) -> L.initSqlDBConnection cfg + Left err -> do + L.incrementDbMetric err cfg + newCon <- L.initSqlDBConnection cfg + case newCon of + Left err' -> L.incrementDbMetric err' cfg *> pure newCon + val -> pure val res -> pure res -- | Get existing Redis connection, or init a new connection. -getOrInitKVDBConn :: (HasCallStack, L.MonadFlow m) => T.KVDBConfig -> m (T.KVDBAnswer T.KVDBConn) +getOrInitKVDBConn :: (HasCallStack, L.MonadFlow m) => KVDBConfig -> m (KVDBAnswer KVDBConn) getOrInitKVDBConn cfg = do conn <- L.getKVDBConnection cfg case conn of - Left (T.KVDBError T.KVDBConnectionDoesNotExist _) -> L.initKVDBConnection cfg - res -> pure res + Left (KVDBError 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 + RedisName -> TextKey -> t -> m (Either KVDBReply Bool) +rExpire cName k = rExpireB cName (TE.encodeUtf8 k) --- | 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) + RedisName -> ByteKey -> t -> m (Either KVDBReply Bool) rExpireB cName k t = do - res <- L.runKVDB cName $ L.expire k $ toInteger t - case res of - Right _ -> do - -- L.logInfo @Text "Redis expire" $ show r - pure res - Left err -> do - L.logError @Text "Redis expire" $ show err + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RExpireBT $ (RExpireB (k) (toInteger t) (Left A.Null) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right (reply :: Either KVDBReply Bool) -> pure reply + else do + res <-rExpireB' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RExpireBT $ (RExpireB (k) (toInteger t) (either (Left . toJSON) (Right . toJSON) res) recTimestamp cName) pure res + + where + rExpireB' :: (HasCallStack, L.MonadFlow m) => m (Either KVDBReply Bool) + rExpireB' = do + res <- L.runKVDB cName $ L.expire k $ toInteger t + case res of + Right _ -> do + -- L.logInfo @Text "Redis expire" $ show r + pure res + Left err -> do + L.logErrorWithCategory @Text "Redis expire" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (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) + RedisName -> [TextKey] -> m (Either 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) + RedisName -> [ByteKey] -> m (Either KVDBReply Integer) rDelB cName ks = do - res <- L.runKVDB cName $ L.del ks - case res of - Right _ -> do - -- L.logInfo @Text "Redis del" $ show r - pure res - Left err -> do - L.logError @Text "Redis del" $ show err - pure res + + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RDelBT $ (RDelB (ks) (Left A.Null) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right (reply :: Either KVDBReply Integer) -> pure reply + else do + + res <- rDelB' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RDelBT $ (RDelB (ks) (either (Left . toJSON) (Right . toJSON) res) recTimestamp cName) + pure res + where + rDelB' :: (HasCallStack, L.MonadFlow m) => m (Either KVDBReply Integer) + rDelB' = do + res <- L.runKVDB cName $ L.del ks + case res of + Right _ -> do + pure res + Left err -> do + L.logErrorWithCategory @Text "Redis del" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (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) + RedisName -> TextKey -> m (Either 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) + RedisName -> ByteKey -> m (Either KVDBReply Bool) rExistsB cName k = do - res <- L.runKVDB cName $ L.exists k - case res of - Right _ -> do - -- L.logInfo @Text "Redis exists" $ show r - pure res - Left err -> do - L.logError @Text "Redis exists" $ show err - pure res + + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RExistsBT $ (RExistsB (k) (Left A.Null) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right (reply :: Either KVDBReply Bool) -> pure reply + else do + + res <- rExistsB' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RExistsBT $ (RExistsB (k) (either (Left . toJSON) (Right . toJSON) res) recTimestamp cName) + pure res + where + rExistsB' :: (HasCallStack, L.MonadFlow m) => m (Either KVDBReply Bool) + rExistsB' = do + res <- L.runKVDB cName $ L.exists k + case res of + Right _ -> do + pure res + Left err -> do + L.logErrorWithCategory @Text "Redis exists" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (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) + RedisName -> TextKey -> m (Either 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) +rHget :: (HasCallStack, ToJSON v, FromJSON v, L.MonadFlow m) => RedisName -> TextKey -> TextField -> m (Maybe v) rHget cName k f = do - let k' = TE.encodeUtf8 k - let f' = TE.encodeUtf8 f - r <- L.runKVDB cName $ L.hget k' f' - case r of - Right (Just val) -> do - let v = A.eitherDecode $ BSL.fromStrict val - case v of - Left err -> do - L.logError @Text "Decoding error: " $ show err + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RHGetT $ (RHGet (encodeUtf8 k) (toJSON f) (Nothing) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + let errorMessage = encodeUtf8 $ err + L.throwException $ S.err400 {S.errBody = errorMessage} + Right (reply :: Maybe v) -> pure reply + else rHGetWithART + where + rHGetWithART :: (HasCallStack, ToJSON v, FromJSON v, L.MonadFlow m) => m (Maybe v) + rHGetWithART = do + let k' = TE.encodeUtf8 k + let f' = TE.encodeUtf8 f + r <- L.runKVDB cName $ L.hget k' f' + res <- case r of + Right (Just val) -> do + let v = A.eitherDecode $ BSL.fromStrict val + case v of + Left err -> do + L.logErrorWithCategory @Text "Decoding error: " (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) + pure Nothing + Right v' -> do + -- L.logDebug @Text "Decoded value" $ show v' + pure $ Just v' + Right Nothing -> pure Nothing + Left err -> do + L.logErrorWithCategory @Text "Decoding error: " (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) pure Nothing - 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 + + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + + L.appendRecordingLocal $ RunKVDBEntryT $ RHGetT $ (RHGet (encodeUtf8 k) (toJSON f) (maybe (Nothing) (Just . toJSON) res) recTimestamp cName) + pure res --- | 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 - res <- L.runKVDB cName $ L.hget k f - case res of - Right (Just val) -> pure $ Just val - Right Nothing -> pure Nothing - Left err -> do - L.logError @Text "Redis hget" $ show err - pure Nothing +rHgetB cName k f = do + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RHGetT $ (RHGet (k) (toJSON f) (Nothing) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + let errorMessage = encodeUtf8 $ err + L.throwException $ S.err400 {S.errBody = errorMessage} + Right (reply :: Maybe ByteValue) -> pure reply + else rHgetBWithART + where + rHgetBWithART :: (HasCallStack, L.MonadFlow m) => m (Maybe ByteValue) + rHgetBWithART = do + r <- L.runKVDB cName $ L.hget k f + res <- case r of + Right (Just val) -> pure $ Just val + Right Nothing -> pure $ Nothing + Left err -> do + L.logErrorWithCategory @Text "Redis hget" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) + pure $ Nothing + + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RHGetT $ (RHGet (k) (toJSON f) (maybe (Nothing) (Just . toJSON) res) recTimestamp cName) + pure res + + -- ---------------------------------------------------------------------------- --- | 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) + => RedisName -> TextKey -> TextField -> v -> m (Either KVDBReply Integer) rHset cName k f v = rHsetB cName k' f' v' where k' = TE.encodeUtf8 k 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) + => RedisName -> ByteKey -> ByteField -> ByteValue -> m (Either KVDBReply Integer) rHsetB cName k f v = do - res <- L.runKVDB cName $ - L.hset k f v - case res of - Right _ -> do - -- L.logInfo @Text "Redis hset" $ show r - pure res - Left err -> do - L.logError @Text "Redis hset" $ show err + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RHSetBT $ (RHSetB (k) (toJSON f) (toJSON v) (Left A.Null) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right (reply :: Either KVDBReply Integer) -> pure reply + else do + + res <- rHsetB' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RHSetBT $ (RHSetB (k) (toJSON f) (toJSON v) (either (Left . toJSON) (Right . toJSON) res) recTimestamp cName) pure res + where + rHsetB' :: (HasCallStack, L.MonadFlow m) => m (Either KVDBReply Integer) + rHsetB' = do + res <- L.runKVDB cName $ L.hset k f v + case res of + Right _ -> do + -- L.logInfo @Text "Redis hset" $ show r + pure res + Left err -> do + L.logErrorWithCategory @Text "Redis hset" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (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) + RedisName -> TextKey -> m (Either 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) + RedisName -> ByteKey -> m (Either KVDBReply Integer) rIncrB cName k = do - res <- L.runKVDB cName $ L.incr k - case res of - Right _ -> do - -- L.logInfo @Text "Redis incr" $ show r - pure res - Left err -> do - L.logError @Text "Redis incr" $ show err - pure res + + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RIncrBT $ (RIncrB (k) (Left A.Null) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right (reply :: Either KVDBReply Integer) -> pure reply + else do + + res <- rIncrB' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RIncrBT $ (RIncrB (k) (either (Left . toJSON) (Right . toJSON) res) recTimestamp cName) + pure res + where + rIncrB' :: (HasCallStack, L.MonadFlow m) => m (Either KVDBReply Integer) + rIncrB' = do + res <- L.runKVDB cName $ L.incr k + case res of + Right _ -> do + -- L.logInfo @Text "Redis incr" $ show r + pure res + Left err -> do + L.logErrorWithCategory @Text "Redis incr" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (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) + RedisName -> TextKey -> v -> m (Either KVDBReply KVDBStatus) rSet cName k v = rSetB cName k' v' where 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 _ -> do - -- L.logInfo @Text "Redis set" $ show r - pure res - Left err -> do - L.logError @Text "Redis set" $ show err - pure res + Text -> ByteKey -> ByteValue -> m (Either KVDBReply KVDBStatus) +rSetB cName k v = do + + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RSetBT $ (RSetB (k) (toJSON v) (Left A.Null) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right (reply :: Either KVDBReply KVDBStatus) -> pure reply + else do + + res <- rSetB' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RSetBT $ (RSetB (k) (toJSON v) (either (Left . toJSON) (Right . toJSON) res) recTimestamp cName) + pure res + where + rSetB' :: (HasCallStack, L.MonadFlow m) => m (Either KVDBReply KVDBStatus) + rSetB' = do + res <- L.runKVDB cName $ L.set k v + case res of + Right _ -> do + -- L.logInfo @Text "Redis set" $ show r + pure res + Left err -> do + L.logErrorWithCategory @Text "Redis set" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) + pure res --- | Set the value of a key. --- Key is a text string. --- --- mtl version of the original function. rSetT :: (HasCallStack, L.MonadFlow m) => - RedisName -> TextKey -> Text -> m (Either T.KVDBReply T.KVDBStatus) + RedisName -> TextKey -> Text -> m (Either KVDBReply KVDBStatus) rSetT cName k v = rSetB cName k' v' where k' = TE.encodeUtf8 k @@ -322,43 +690,92 @@ rSetT cName k v = rSetB cName k' v' -- ---------------------------------------------------------------------------- --- | 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 - mv <- L.runKVDB cName $ L.get k - case mv of - Right mval -> pure mval - Left err -> do - L.logError @Text "Redis get" $ show err - pure Nothing + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RGetBT $ (RGetB (k) (Nothing) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp :: Either String (Maybe ByteValue) + case maybeReply of + Left err -> do + let errorMessage = encodeUtf8 $ err + L.throwException $ S.err400 {S.errBody = errorMessage} + Right (reply :: Maybe ByteValue) -> pure reply + else do + res <- rGetB' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RGetBT $ (RGetB (k) (maybe (Nothing) (Just . toJSON) res) recTimestamp cName) + pure res + where + rGetB' :: (HasCallStack, L.MonadFlow m) => m (Maybe ByteValue) + rGetB' = do + mv <- L.runKVDB cName $ L.get k + case mv of + Right mval -> pure mval + Left err -> do + L.logErrorWithCategory @Text "Redis get" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) + pure Nothing --- | 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. +rGetBEither :: (HasCallStack, L.MonadFlow m) => + RedisName -> ByteKey -> m (Either KVDBReply (Maybe ByteValue)) -- Binary.decode? +rGetBEither cName k = do + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RGetBT $ (RGetB (k) (Nothing) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp :: Either String (Maybe ByteValue) + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right reply -> pure $ Right reply + else do + res <- rGetB' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RGetBT $ (RGetB (k) (either (\_ -> Nothing) (maybe (Nothing) (Just . toJSON)) res) recTimestamp cName) + pure res + where + rGetB' :: (HasCallStack, L.MonadFlow m) => m (Either KVDBReply (Maybe ByteValue)) + rGetB' = do + mv <- L.runKVDB cName $ L.get k + case mv of + Right _ -> pure mv + Left err -> do + L.logErrorWithCategory @Text "Redis get" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) + pure mv +--doubt rGet :: (HasCallStack, FromJSON v, L.MonadFlow m) => RedisName -> TextKey -> m (Maybe v) rGet cName k = do + -- L.logDebug @Text "rGet" $ "looking up key: " <> k <> " in redis: " <> cName mv <- rGetB cName (TE.encodeUtf8 k) case mv of - Just val -> case A.eitherDecode' $ BSL.fromStrict val of + Just val -> case A.eitherDecode' @A.Value $ BSL.fromStrict val of Left err -> do - L.logError @Text "Redis rGet json decodeEither error" $ show err + let errReason = "error: '" <> toText err + <> "' while decoding value: " + <> (fromEither $ mapLeft (toText . displayException) $ TE.decodeUtf8' val) + L.logErrorWithCategory @Text "rGet value is not a valid JSON" errReason $ ErrorL Nothing "REDIS_EXCEPTION" errReason pure Nothing - Right resp -> pure $ Just resp + Right value -> do + case (A.parseEither A.parseJSON value) of + Left err -> do + let errReason = "error: '" <> toText err + <> "' while decoding value: " + <> (TE.decodeUtf8 . BSL.toStrict . A.encode . obfuscate) value + L.logErrorWithCategory @Text "rGet value cannot be decoded to target type" errReason $ ErrorL Nothing "REDIS_EXCEPTION" errReason + pure Nothing + Right v -> pure $ Just v Nothing -> pure Nothing --- | Get the value of a key. --- Key is a text string. --- --- mtl version of the original function. rGetT :: (HasCallStack, L.MonadFlow m) => Text -> Text -> m (Maybe Text) rGetT cName k = do @@ -367,7 +784,7 @@ rGetT cName k = do Just val -> case TE.decodeUtf8' val of Left err -> do - L.logError @Text "Redis rGetT unicode decode error" (show err) + L.logErrorWithCategory @Text "Redis rGetT unicode decode error" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) pure Nothing Right x -> pure $ Just x @@ -375,43 +792,94 @@ rGetT cName k = do -- ---------------------------------------------------------------------------- --- | 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 + RedisName -> TextKey -> v -> t -> m (Either KVDBReply KVDBStatus) +rSetex cName k v = rSetexB cName k' v' where 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) + RedisName -> ByteKey -> ByteValue -> t -> m (Either KVDBReply KVDBStatus) rSetexB cName k v t = do - res <- L.runKVDB cName $ L.setex k (toInteger t) v - case res of - Right _ -> do - -- L.logInfo @Text "Redis setex" $ show r - pure res - Left err -> do - L.logError @Text "Redis setex" $ show err - pure res + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RSetexBT $ (RSetexB (k) (toInteger t) (toJSON v) (Left A.Null) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right (reply :: Either KVDBReply KVDBStatus) -> pure reply + else do + res <- rSetexB' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RSetexBT $ (RSetexB (k) (toInteger t) (toJSON v) (either (Left . toJSON) (Right . toJSON) res) recTimestamp cName) + pure res + where + rSetexB' :: (HasCallStack, L.MonadFlow m) => m (Either KVDBReply KVDBStatus) + rSetexB' = do + res <- L.runKVDB cName $ L.setex k (toInteger t) v + case res of + Right _ -> do + -- L.logInfo @Text "Redis setex" $ show r + pure res + Left err -> do + L.logErrorWithCategory @Text "Redis setex" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (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) + RedisName -> TextKey -> v -> t -> m (Either KVDBReply KVDBStatus) rSetexT = rSetex +rSetexBulk :: (HasCallStack, ToJSON v, Integral t, L.MonadFlow m) => + RedisName -> Map TextKey v -> t -> m (Either KVDBReply ()) +rSetexBulk cName kvMap = rSetexBulkB cName kvMap' + where + encodeKey = TE.encodeUtf8 + encodeVal = BSL.toStrict . A.encode + kvMap' = + Map.fromList . map (\(k, v) -> (encodeKey k, encodeVal v)) $ Map.toList kvMap + +rSetexBulkB :: (HasCallStack, Integral t, L.MonadFlow m) => + RedisName -> Map ByteKey ByteValue -> t -> m (Either KVDBReply ()) +rSetexBulkB cName kvMap t = do + let kvMap' = A.Object $ HM.fromList $ foldl' (\acc (k,v) -> acc <> ([(decodeUtf8 k,A.String $ decodeUtf8 v)])) [] $ Map.toList kvMap + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RSetexBulkBT $ (RSetexBulkB (kvMap') (toInteger t) (Left A.Null) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right (reply :: Either KVDBReply ()) -> pure reply + else do + res <- rSetexBulkB' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RSetexBulkBT $ (RSetexBulkB (kvMap') (toInteger t) (either (Left . toJSON) (Right . toJSON) res) recTimestamp cName) + pure res + where + rSetexBulkB' :: (HasCallStack, L.MonadFlow m) => m (Either KVDBReply ()) + rSetexBulkB' = do + let t' = toInteger t + res <- L.runKVDB cName $ forM_ (Map.toList kvMap) $ \(k, v) -> L.setex k t' v + case res of + Right _ -> do + -- L.logInfo @Text "Redis setexBulk" $ show r + pure res + Left err -> do + L.logErrorWithCategory @Text "Redis setexBulk" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) + pure res + -- ---------------------------------------------------------------------------- rSetOpts @@ -421,8 +889,8 @@ rSetOpts -> v -> L.KVDBSetTTLOption -> L.KVDBSetConditionOption - -> m (Either T.KVDBReply Bool) -rSetOpts cName k v ttl cond = rSetOptsB cName k' v' ttl cond + -> m (Either KVDBReply Bool) +rSetOpts cName k v = rSetOptsB cName k' v' where k' = TE.encodeUtf8 k v' = BSL.toStrict $ A.encode v @@ -434,14 +902,35 @@ rSetOptsB -> ByteValue -> L.KVDBSetTTLOption -> L.KVDBSetConditionOption - -> m (Either T.KVDBReply Bool) + -> m (Either 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 + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RSetOptsBT $ (RSetOptsB (k) (toJSON v) (toJSON ttl) (toJSON cond) (Left A.Null) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right (reply :: Either KVDBReply Bool) -> pure reply + else do + res <- rSetOptsB' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RSetOptsBT $ (RSetOptsB (k) (toJSON v) (toJSON ttl) (toJSON cond) (either (Left . toJSON) (Right . toJSON) res) recTimestamp cName) pure res + where + rSetOptsB' :: (HasCallStack, L.MonadFlow m) => m (Either KVDBReply Bool) + rSetOptsB' = do + res <- L.runKVDB cName $ L.setOpts k v ttl cond + case res of + Right _ -> pure res + Left err -> do + L.logErrorWithCategory @Text "Redis setOpts" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) + pure res rSetOptsT :: (HasCallStack, L.MonadFlow m) @@ -450,43 +939,507 @@ rSetOptsT -> Text -> L.KVDBSetTTLOption -> L.KVDBSetConditionOption - -> m (Either T.KVDBReply Bool) -rSetOptsT cName k v ttl cond = rSetOptsB cName k' v' ttl cond + -> m (Either KVDBReply Bool) +rSetOptsT cName k v = rSetOptsB cName k' v' + where + k' = TE.encodeUtf8 k + v' = TE.encodeUtf8 v + +rXreadT + :: (HasCallStack, L.MonadFlow m) + => RedisName + -> Text + -> Text + -> m (Either KVDBReply (Maybe [L.KVDBStreamReadResponse])) +rXreadT cName k v = rXreadB cName k' v' where k' = TE.encodeUtf8 k v' = TE.encodeUtf8 v +rXreadB :: (HasCallStack, L.MonadFlow m) => + RedisName -> L.KVDBStream -> L.RecordID -> m (Either KVDBReply (Maybe [L.KVDBStreamReadResponse])) +rXreadB cName strm entryId = do + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RXreadBT $ (RXreadB (strm) (entryId) (Left A.Null) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right (reply :: Either KVDBReply (Maybe [L.KVDBStreamReadResponse])) -> pure reply + else do + res <- rXreadB' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RXreadBT $ (RXreadB (strm) (entryId) (either (Left . toJSON) (Right . maybe (Nothing) (Just . toJSON)) res) recTimestamp cName) + pure res + where + rXreadB' :: (HasCallStack, L.MonadFlow m) => m (Either KVDBReply (Maybe [L.KVDBStreamReadResponse])) + rXreadB' = do + res <- L.runKVDB cName $ L.xread strm entryId + _ <- case res of + Left err -> + L.logErrorWithCategory @Text "Redis xread" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) + Right _ -> pure () + pure res + +rXrevrangeT :: (HasCallStack,L.MonadFlow m) => + RedisName -> Text -> Text -> Text -> Maybe Integer -> m (Either KVDBReply ([L.KVDBStreamReadResponseRecord])) +rXrevrangeT cName strm send sstart count = rXrevrangeB cName s' se' ss' count + where + s' = TE.encodeUtf8 strm + se' = TE.encodeUtf8 send + ss' = TE.encodeUtf8 sstart + +rXrevrangeB :: (HasCallStack,L.MonadFlow m) => + RedisName -> L.KVDBStream -> L.KVDBStreamEnd -> L.KVDBStreamStart -> Maybe Integer -> m (Either KVDBReply ([L.KVDBStreamReadResponseRecord])) +rXrevrangeB cName strm send sstart count = do + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RXrevrangeBT $ (RXrevrangeB (strm) (send) (sstart) (count) (Left A.Null) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right (reply :: Either KVDBReply ([L.KVDBStreamReadResponseRecord])) -> pure reply + else do + res <- rXrevrangeB' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RXrevrangeBT $ (RXrevrangeB (strm) (send) (sstart) (count) (either (Left . toJSON) (Right . toJSON) res) recTimestamp cName) + pure res + where + rXrevrangeB' :: (HasCallStack,L.MonadFlow m) => m (Either KVDBReply ([L.KVDBStreamReadResponseRecord])) + rXrevrangeB' = do + res <- L.runKVDB cName $ L.xrevrange strm send sstart count + _ <- case res of + Left err -> + L.logErrorWithCategory @Text "Redis xrevrange" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) + Right _ -> pure () + pure res -- ------------------------------------------------------------------------------ rSadd :: (HasCallStack, L.MonadFlow m) => - RedisName -> L.KVDBKey -> [L.KVDBValue] -> m (Either T.KVDBReply Integer) + RedisName -> L.KVDBKey -> [L.KVDBValue] -> m (Either 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 + res <- rSadd' + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RSaddT $ (RSadd k v (Left A.Null) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp :: Either String Integer + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right reply -> pure $ Right reply + else do + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RSaddT $ (RSadd k v (either (Left . toJSON) (Right) res) recTimestamp cName) + pure res + where + rSadd' :: (HasCallStack, L.MonadFlow m) => m (Either KVDBReply Integer) + rSadd' = do + res <- L.runKVDB cName $ L.sadd k v + case res of + Right _ -> pure res + Left err -> do + L.logErrorWithCategory @Text "Redis sadd" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) + pure res rSismember :: (HasCallStack, L.MonadFlow m) => - RedisName -> L.KVDBKey -> L.KVDBValue -> m (Either T.KVDBReply Bool) + RedisName -> L.KVDBKey -> L.KVDBValue -> m (Either 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 + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RSismemberT $ (RSismember k v (Left A.Null) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right (reply :: Either KVDBReply Bool) -> pure reply + else do + res <- rSismember' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RSismemberT $ (RSismember k v (either (Left . toJSON) (Right) res) recTimestamp cName) pure res + where + rSismember' :: (HasCallStack, L.MonadFlow m) => m (Either KVDBReply Bool) + rSismember' = do + res <- L.runKVDB cName $ L.sismember k v + case res of + Right _ -> pure res + Left err -> do + L.logErrorWithCategory @Text "Redis sismember" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) + pure res -withLoggerContext :: (HasCallStack, L.MonadFlow m) => (T.LogContext -> T.LogContext) -> L.Flow a -> m a -withLoggerContext updateLCtx = L.withModifiedRuntime (updateLoggerContext updateLCtx) +-- withLoggerContext :: (HasCallStack, L.MonadFlow m) => (LogContext -> LogContext) -> L.Flow a -> m a +-- withLoggerContext updateLCtx = L.withModifiedRuntime (updateLoggerContext updateLCtx) +updateLoggerContext :: (IORef LogContext -> IO (IORef LogContext)) -> FlowRuntime -> IO (FlowRuntime) +updateLoggerContext updateLCtx rt@FlowRuntime{..} = do + newLrt <- newLrtIO + pure $ rt { _coreRuntime = _coreRuntime {_loggerRuntime = newLrt} } + where + newLrtIO :: IO LoggerRuntime + newLrtIO = case _loggerRuntime _coreRuntime of + MemoryLoggerRuntime a lc b c d -> do + newCtx <- updateLCtx lc + pure $ MemoryLoggerRuntime a newCtx b c d + -- the next line is courtesy to Kyrylo Havryliuk ;-) + LoggerRuntime{_logContext, ..} -> do + newCtx <- updateLCtx _logContext + pure $ LoggerRuntime {_logContext = newCtx, ..} + +generateSnowflake :: (L.MonadFlow m) => String -> m (Either SnowflakeError Snowflake) +generateSnowflake key = do + mbStackID <- L.getOption StackID + mbPodID <- L.getOption PodID + case (mbStackID, mbPodID) of + (Just stackId, Just podId) -> L.getSnowflakeID stackId podId key + (Nothing, Just _) -> return . Left . Fatal $ "StackID not set in options" + (Just _, Nothing) -> return . Left . Fatal $ "PodID not set in options" + _ -> return . Left . Fatal $ "PodID and StackID not set in options" + +rZAdd :: (HasCallStack, L.MonadFlow m) => + RedisName + -> L.KVDBKey + -> [(Double,ByteValue)] + -> m (Either KVDBReply Integer) +rZAdd cName k v = do + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RZAddT $ (RZAdd k v (Left A.Null) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right (reply :: Either KVDBReply Integer) -> pure reply + else do + res <- rZAdd' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RZAddT $ (RZAdd k v (either (Left . toJSON) (Right) res) recTimestamp cName) + pure res + where + rZAdd' :: (HasCallStack, L.MonadFlow m) => m (Either KVDBReply Integer) + rZAdd' = do + res <- L.runKVDB cName $ L.zadd k v + case res of + Right _ -> pure res + Left err -> do + L.logErrorWithCategory @Text "Redis setOpts" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) + pure res -updateLoggerContext :: HasCallStack => (T.LogContext -> T.LogContext) -> FlowRuntime -> FlowRuntime -updateLoggerContext updateLCtx rt@FlowRuntime{..} = rt {_coreRuntime = _coreRuntime {_loggerRuntime = newLrt}} +rZRangeByScore :: (HasCallStack, L.MonadFlow m) => + RedisName + -> L.KVDBKey + -> Double + -> Double + -> m (Either KVDBReply [L.KVDBValue]) +rZRangeByScore cName k minScore maxScore = do + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RZRangeByScoreT $ (RZRangeByScore k minScore maxScore (Left A.Null) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right (reply :: Either KVDBReply [L.KVDBValue]) -> pure reply + else do + res <- rZRangeByScore' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RZRangeByScoreT $ (RZRangeByScore k minScore maxScore (either (Left . toJSON) (Right . toJSON) res) recTimestamp cName) + pure res 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 + rZRangeByScore' :: (HasCallStack, L.MonadFlow m) => m (Either KVDBReply [L.KVDBValue]) + rZRangeByScore' = do + res <- L.runKVDB cName $ L.zrangebyscore k minScore maxScore + case res of + Right _ -> pure res + Left err -> do + L.logErrorWithCategory @Text "Redis rZRangeByScore" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) + pure res + +rZRangeByScoreWithLimit :: (HasCallStack, L.MonadFlow m) => + RedisName + -> L.KVDBKey + -> Double + -> Double + -> Integer + -> Integer + -> m (Either KVDBReply [L.KVDBValue]) +rZRangeByScoreWithLimit cName k minScore maxScore offset count = do + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RZRangeByScoreWithLimitT $ (RZRangeByScoreWithLimit k minScore maxScore offset count (Left A.Null) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right (reply :: Either KVDBReply [L.KVDBValue]) -> pure reply + else do + res <- rZRangeByScoreWithLimit' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RZRangeByScoreWithLimitT $ (RZRangeByScoreWithLimit k minScore maxScore offset count (either (Left . toJSON) (Right . toJSON) res) recTimestamp cName) + pure res + where + rZRangeByScoreWithLimit' :: (HasCallStack, L.MonadFlow m) => m (Either KVDBReply [L.KVDBValue]) + rZRangeByScoreWithLimit' = do + res <- L.runKVDB cName $ L.zrangebyscorewithlimit k minScore maxScore offset count + case res of + Right _ -> pure res + Left err -> do + L.logErrorWithCategory @Text "Redis rZRangeByScoreWithLimit" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) + pure res + +rZRem :: (HasCallStack, L.MonadFlow m) => + RedisName + -> L.KVDBKey + -> [L.KVDBValue] + -> m (Either KVDBReply Integer) +rZRem cName k v = do + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RZRemT $ (RZRem k v (Left A.Null) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right (reply :: Either KVDBReply Integer) -> pure reply + else do + res <- rZRem' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RZRemT $ (RZRem k v (either (Left . toJSON) (Right) res) recTimestamp cName) + pure res + where + rZRem' :: (HasCallStack, L.MonadFlow m) => m (Either KVDBReply Integer) + rZRem' = do + res <- L.runKVDB cName $ L.zrem k v + case res of + Right _ -> pure res + Left err -> do + L.logErrorWithCategory @Text "Redis rZRem" (show err ) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) + pure res + +rZRemRangeByScore :: (HasCallStack, L.MonadFlow m) => + RedisName + -> L.KVDBKey + -> Double + -> Double + -> m (Either KVDBReply Integer) +rZRemRangeByScore cName k minScore maxScore = do + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RZRemRangeByScoreT $ (RZRemRangeByScore k minScore maxScore (Left A.Null) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right (reply :: Either KVDBReply Integer) -> pure reply + else do + res <- rZRemRangeByScore' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RZRemRangeByScoreT $ (RZRemRangeByScore k minScore maxScore (either (Left . toJSON) (Right) res) recTimestamp cName) + pure res + where + rZRemRangeByScore' :: (HasCallStack, L.MonadFlow m) => m (Either KVDBReply Integer) + rZRemRangeByScore' = do + res <- L.runKVDB cName $ L.zremrangebyscore k minScore maxScore + case res of + Right _ -> pure res + Left err -> do + L.logErrorWithCategory @Text "Redis rZRemRangeByScore" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) + pure res + +rZCard :: (HasCallStack, L.MonadFlow m) => + RedisName + -> L.KVDBKey + -> m (Either KVDBReply Integer) +rZCard cName k = do + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RZCardT $ (RZCard k (Left A.Null) recTimestamp cName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right (reply :: Either KVDBReply Integer) -> pure reply + else do + res <- rZCard' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RZCardT $ (RZCard k (either (Left . toJSON) (Right) res) recTimestamp cName) + pure res + where + rZCard' :: (HasCallStack, L.MonadFlow m) => m (Either KVDBReply Integer) + rZCard' = do + res <- L.runKVDB cName $ L.zcard k + case res of + Right _ -> pure res + Left err -> do + L.logErrorWithCategory @Text "Redis rZCard" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) + pure res + +rXaddB :: (HasCallStack, L.MonadFlow m) => RedisName -> L.KVDBStream -> ByteString -> ByteString -> m (KVDBAnswer L.KVDBStreamEntryID) +rXaddB redisName streamName streamEntry streamItem = do + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RXaddBT $ (RXaddB streamName streamEntry (toJSON streamItem) (Left A.Null) recTimestamp redisName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right (reply :: KVDBAnswer L.KVDBStreamEntryID) -> pure reply + else do + res <- rXaddB' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RXaddBT $ (RXaddB streamName streamEntry (toJSON streamItem) (either (Left . toJSON) (Right . toJSON) res) recTimestamp redisName) + pure res + where + rXaddB' :: (HasCallStack, L.MonadFlow m) => m (KVDBAnswer L.KVDBStreamEntryID) + rXaddB' = do + res <- L.runKVDB redisName $ L.xadd (streamName) L.AutoID [(streamEntry,streamItem)] + case res of + Right _ -> pure res + Left err -> do + L.logErrorWithCategory @Text "Redis rXaddB" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) + pure res + +rSmembersB :: (HasCallStack, L.MonadFlow m) => RedisName -> ByteString -> m (KVDBAnswer [ByteString]) +rSmembersB redisName k = do + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RSmembersBT $ (RSmembersB k (Left A.Null) recTimestamp redisName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp :: Either String (KVDBAnswer [ByteString]) + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right (reply :: KVDBAnswer [ByteString]) -> pure $ reply + else do + res <- rSmembersB' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RSmembersBT $ (RSmembersB k (either (Left . toJSON) (Right . toJSON) res) recTimestamp redisName) + pure res + where + rSmembersB' :: (HasCallStack, L.MonadFlow m) => m (KVDBAnswer [ByteString]) + rSmembersB' = do + res <- L.runKVDB redisName $ L.smembers k + case res of + Right _ -> pure res + Left err -> do + L.logErrorWithCategory @Text "Redis rSmembersB" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) + pure res + +sRemB :: (HasCallStack, L.MonadFlow m) => RedisName -> L.KVDBKey -> [L.KVDBValue] -> m (KVDBAnswer Integer) +sRemB redisName oldSKey pKeyList = do + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RSRemBT $ (RSRemB oldSKey pKeyList (Left A.Null) recTimestamp redisName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + let errorMessage = err + pure $ Left (ExceptionMessage errorMessage) + Right (reply :: KVDBAnswer Integer) -> pure reply + else do + res <- sRemB' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RSRemBT $ (RSRemB oldSKey pKeyList (either (Left . toJSON) (Right) res) recTimestamp redisName) + pure res + where + sRemB' :: (HasCallStack, L.MonadFlow m) => m (KVDBAnswer Integer) + sRemB' = do + res <- L.runKVDB redisName $ L.srem oldSKey pKeyList + case res of + Right _ -> pure res + Left err -> do + L.logErrorWithCategory @Text "Redis sRemB" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) + pure res + +rMultiExec :: (HasCallStack, L.MonadFlow m, ToJSON a ,FromJSON a) => RedisName -> L.KVDBTx (R.Queued a) -> m (KVDBAnswer (TxResult a)) +rMultiExec redisName tx = + if isArtReplayEnabled + then do + recTimestamp <- getCurrentTimeUTC + let replayKVDBEntry = RunKVDBEntryT $ RMultiExecT $ (RMultiExec (Left A.Null) recTimestamp redisName) + msessionId <- L.getLoggerContext "x-request-id" + resp <- L.runIO $ ER.callBrahmaReplayR replayKVDBEntry msessionId + let maybeReply = A.eitherDecode resp + case maybeReply of + Left err -> do + pure $ Left (ExceptionMessage err) + Right (reply :: KVDBAnswer (TxResult a)) -> pure reply + else do + + res <- multiExecWithHash' + when isArtRecEnabled $ do + recTimestamp <- getCurrentTimeUTC + L.appendRecordingLocal $ RunKVDBEntryT $ RMultiExecT $ (RMultiExec (either (Left . toJSON) (Right . toJSON) res) recTimestamp redisName) + pure res + where + multiExecWithHash' = do + res <- L.runKVDB redisName $ L.multiExec tx + case res of + Right _ -> pure res + Left err -> do + L.logErrorWithCategory @Text "Redis multiExec" (show err) $ ErrorL Nothing "REDIS_EXCEPTION" (show err) + pure res diff --git a/src/EulerHS/Extra/Monitoring/Flow.hs b/src/EulerHS/Extra/Monitoring/Flow.hs new file mode 100644 index 00000000..7f79cfe9 --- /dev/null +++ b/src/EulerHS/Extra/Monitoring/Flow.hs @@ -0,0 +1,140 @@ +{- | +Module : EulerHS.Extra.Monitoring.Flow +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} + +module EulerHS.Extra.Monitoring.Flow where + +import GHC.Float (int2Double) +import EulerHS.Prelude +import qualified Data.Aeson as A +import qualified EulerHS.Framework.Language as L +import qualified EulerHS.Logger.Language as L +import qualified EulerHS.Framework.Runtime as R +import qualified EulerHS.Logger.Runtime as R +import qualified EulerHS.Extra.Monitoring.Types as EEMT +import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.Time.Clock (nominalDiffTimeToSeconds) +import Data.Fixed (Fixed (MkFixed)) +import qualified Juspay.Extra.Config as Conf +import qualified Data.Map as Map +import EulerHS.Api (ApiTag(..)) +import EulerHS.KVConnector.Types (MerchantID(..)) +import Unsafe.Coerce (unsafeCoerce) +import EulerHS.Options (OptionEntity, mkOptionKey) +import Euler.Events.MetricApi.MetricApi +import EulerHS.Logger.Types (LogLevel(Info), Message(..)) +import EulerHS.Logger.Interpreter (runLogger) + +isLatencyMetricEnabled :: Bool +isLatencyMetricEnabled = fromMaybe False $ readMaybe =<< Conf.lookupEnvT "LATENCY_METRIC_ENABLED" + +isLatencyPromMetricEnabled :: Bool +isLatencyPromMetricEnabled = fromMaybe False $ readMaybe =<< Conf.lookupEnvT "LATENCY_PROM_METRIC_ENABLED" + +withMonitoringIO :: EEMT.LatencyHandle -> R.FlowRuntime -> IO a -> IO a +withMonitoringIO lantencyHandle flowRt func = + if isLatencyMetricEnabled + then do + tick <- getCurrentDateInMillisIO + val <- func + tock <- getCurrentDateInMillisIO + case lantencyHandle of + EEMT.REDIS -> incrementRedisLatencyMetric flowRt (tock-tick) + EEMT.DB -> incrementDBLatencyMetric flowRt (tock-tick) + EEMT.API -> incrementAPILatencyMetric flowRt (tock-tick) + pure val + else func + +getCurrentDateInMillisIO :: IO Double +getCurrentDateInMillisIO = do + t <- getPOSIXTime + let (MkFixed i) = nominalDiffTimeToSeconds t + pure $ fromInteger i * 1e-9 + +defaultLatencyMetric :: EEMT.LatencyInfo +defaultLatencyMetric = EEMT.LatencyInfo 0 0 + +getOptionLocalIO :: forall k v. (OptionEntity k v) => R.FlowRuntime -> k -> IO (Maybe v) +getOptionLocalIO R.FlowRuntime{..} k = do + m <- readMVar _optionsLocal + let valAny = Map.lookup (mkOptionKey @k @v k) m + pure $ unsafeCoerce valAny + +setOptionLocalIO :: forall k v. (OptionEntity k v) => R.FlowRuntime -> k -> v -> IO () +setOptionLocalIO R.FlowRuntime{..} k v = do + m <- takeMVar _optionsLocal + let newMap = Map.insert (mkOptionKey @k @v k) (unsafeCoerce @_ @Any v) m + putMVar _optionsLocal newMap + +incrementDBLatencyMetric :: R.FlowRuntime -> Double -> IO () +incrementDBLatencyMetric flowRt latency = when isLatencyMetricEnabled $ do + (EEMT.LatencyInfo oldLatency count) <- maybe defaultLatencyMetric (\(EEMT.DBMetricInfo x) -> x) <$> getOptionLocalIO flowRt EEMT.DBMetricInfoKey + setOptionLocalIO flowRt EEMT.DBMetricInfoKey $ EEMT.DBMetricInfo (EEMT.LatencyInfo (oldLatency + latency) (count + 1)) + +incrementRedisLatencyMetric :: R.FlowRuntime -> Double -> IO () +incrementRedisLatencyMetric flowRt latency = when isLatencyMetricEnabled $ do + when (latency > 500) $ + runLogger (Nothing) (R._loggerRuntime . R._coreRuntime $ flowRt) + . L.masterLogger Info ("REDIS_METRIC" :: String) "DOMAIN" (Just "REDIS_METRIC") (Nothing) Nothing (Just $ round latency) (Nothing) $ Message Nothing (Just $ A.toJSON latency) + (EEMT.LatencyInfo oldLatency count) <- maybe defaultLatencyMetric (\(EEMT.RedisMetricInfo x) -> x) <$> getOptionLocalIO flowRt EEMT.RedisMetricInfoKey + setOptionLocalIO flowRt EEMT.RedisMetricInfoKey $ EEMT.RedisMetricInfo (EEMT.LatencyInfo (oldLatency + latency) (count + 1)) + +incrementAPILatencyMetric :: R.FlowRuntime -> Double -> IO () +incrementAPILatencyMetric flowRt latency = when isLatencyMetricEnabled $ do + (EEMT.LatencyInfo oldLatency count) <- maybe defaultLatencyMetric (\(EEMT.APIMetricInfo x) -> x) <$> getOptionLocalIO flowRt EEMT.APIMetricInfoKey + setOptionLocalIO flowRt EEMT.APIMetricInfoKey $ EEMT.APIMetricInfo (EEMT.LatencyInfo (oldLatency + latency) (count + 1)) + +logLatencyMetricLog :: (HasCallStack, L.MonadFlow m) => m () +logLatencyMetricLog = when isLatencyMetricEnabled $ do + dbMetric <- L.getOptionLocal EEMT.DBMetricInfoKey <&> ((\(EEMT.DBMetricInfo x) -> x) <$>) >>= extractAndIncrementLatencyMetric EEMT.DB <&> fromMaybe A.Null + redisMetric <- L.getOptionLocal EEMT.RedisMetricInfoKey <&> ((\(EEMT.RedisMetricInfo x) -> x) <$>) >>= extractAndIncrementLatencyMetric EEMT.REDIS <&> fromMaybe A.Null + apiMetric <- L.getOptionLocal EEMT.APIMetricInfoKey <&> ((\(EEMT.APIMetricInfo x) -> x) <$>) >>= extractAndIncrementLatencyMetric EEMT.API <&> fromMaybe A.Null + L.logInfoV ("LATENCY_METRIC" :: Text) (A.object $ [("dbMetric",dbMetric),("redisMetric",redisMetric),("apiMetric",apiMetric)]) + where + extractAndIncrementLatencyMetric latencyHandle = \case + (Just (latencyInfo)) -> incrementKVMetric latencyHandle latencyInfo *> pure (Just $ A.toJSON latencyInfo) + Nothing -> pure Nothing + + +incrementKVMetric :: (HasCallStack, L.MonadFlow m) => EEMT.LatencyHandle -> EEMT.LatencyInfo -> m () +incrementKVMetric latencyHandle latencyInfo = do + mHandle <- L.getOption EEMT.LatencyMetricCfg + maybe (pure ()) (\handle -> do + mid <- fromMaybe "UNKNOWN" <$> L.getOptionLocal MerchantID + tag <- fromMaybe "UNKNOWN" <$> L.getOptionLocal ApiTag + L.runIO $ ((EEMT.latencyCounter handle) (latencyHandle, mid, tag, latencyInfo))) mHandle + +mkIOLatencyMetricHandler :: IO EEMT.LatencyMetricHandler +mkIOLatencyMetricHandler = do + metrics <- register collectionLock + pure $ EEMT.LatencyMetricHandler $ \case + (latencyHandle, tag, mid, EEMT.LatencyInfo{..}) -> do + observe (metrics #io_count_observe) (int2Double _requests) latencyHandle tag mid + observe (metrics #io_latency_observe) _latency latencyHandle tag mid + +io_count_observe = histogram #io_count_observe + .& lbl @"io_handle" @EEMT.LatencyHandle + .& lbl @"tag" @Text + .& lbl @"mid" @Text + .& build + +io_latency_observe = histogram #io_latency_observe + .& lbl @"io_handle" @EEMT.LatencyHandle + .& lbl @"tag" @Text + .& lbl @"mid" @Text + .& build + +collectionLock = + io_count_observe + .> io_latency_observe + .> MNil \ No newline at end of file diff --git a/src/EulerHS/Extra/Monitoring/Types.hs b/src/EulerHS/Extra/Monitoring/Types.hs new file mode 100644 index 00000000..88a9a86c --- /dev/null +++ b/src/EulerHS/Extra/Monitoring/Types.hs @@ -0,0 +1,78 @@ +{- | +Module : EulerHS.Extra.Monitoring.Types +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE RecordWildCards #-} + +module EulerHS.Extra.Monitoring.Types where + +import EulerHS.Prelude +import qualified Data.Aeson as A +import EulerHS.Types (OptionEntity) + + +data DBMetricInfo = DBMetricInfo { + _latencyInfo :: LatencyInfo +} + deriving stock (Show) + +data RedisMetricInfo = RedisMetricInfo { + _latencyInfo :: LatencyInfo +} + deriving stock (Show) + +data APIMetricInfo = APIMetricInfo { + _latencyInfo :: LatencyInfo +} + deriving stock (Show) + +data LatencyInfo = LatencyInfo { + _latency :: Double +, _requests :: Int +} + deriving stock (Show) + +instance ToJSON LatencyInfo where + toJSON (LatencyInfo {..}) = A.object [ + ("latency", A.toJSON _latency) + , ("requests", A.toJSON _requests) + ] + +data DBMetricInfoKey = DBMetricInfoKey + deriving stock (Eq, Show, Generic, Ord) + deriving anyclass (FromJSON, ToJSON) + + +data RedisMetricInfoKey = RedisMetricInfoKey + deriving stock (Eq, Show, Generic, Ord) + deriving anyclass (FromJSON, ToJSON) + +data APIMetricInfoKey = APIMetricInfoKey + deriving stock (Eq, Show, Generic, Ord) + deriving anyclass (FromJSON, ToJSON) + +instance OptionEntity DBMetricInfoKey DBMetricInfo + +instance OptionEntity RedisMetricInfoKey RedisMetricInfo + +instance OptionEntity APIMetricInfoKey APIMetricInfo + +data LatencyHandle = DB | REDIS | API + deriving stock (Show) + +data LatencyMetricHandler = LatencyMetricHandler + { latencyCounter :: (LatencyHandle, Text, Text, LatencyInfo) -> IO () + } + +data LatencyMetricCfg = LatencyMetricCfg + deriving stock (Generic, Typeable, Show, Eq) + deriving anyclass (ToJSON, FromJSON) + +instance OptionEntity LatencyMetricCfg LatencyMetricHandler diff --git a/src/EulerHS/Extra/Orphans.hs b/src/EulerHS/Extra/Orphans.hs new file mode 100644 index 00000000..12c8f251 --- /dev/null +++ b/src/EulerHS/Extra/Orphans.hs @@ -0,0 +1,49 @@ +{- | +Module : EulerHS.Extra.Orphans +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# OPTIONS -fno-warn-orphans #-} +{-# LANGUAGE RecordWildCards #-} + +module EulerHS.Extra.Orphans where + +import Data.Aeson as A +import Prelude +import Data.Text +import Data.ByteString +import Universum +import qualified Data.HashMap.Strict as HM +import qualified Database.Redis as R +import qualified Data.Text as T +import Data.Scientific + +instance ToJSON ByteString where + toJSON x = A.String (decodeUtf8 x) + +instance FromJSON ByteString where + parseJSON (A.String val) = pure $ encodeUtf8 val + parseJSON val = (pure . encodeUtf8) (decodeUtf8 . A.encode $ val :: Text) + +instance ToJSON R.XReadOpts where + toJSON R.XReadOpts{..} = A.Object $ HM.fromList [("block", toJSON block),("recordCount",toJSON recordCount)] + +instance FromJSON R.XReadOpts where + parseJSON (A.Object hm) = do + let block = toInteger' (HM.lookup "block" hm) + recordCount = toInteger' (HM.lookup "recordCount" hm) + noAck' = toBoolean (HM.lookup "recordCount" hm) + pure (R.XReadOpts block recordCount noAck') + where + toBoolean (Just (A.String v)) = Just True == (readMaybe $ T.unpack v) + toBoolean (Just (A.Bool v)) = v + toBoolean _ = False + + toInteger' (Just (A.String v)) = readMaybe $ T.unpack v + toInteger' (Just (A.Number v)) = Just $ coefficient v + toInteger' _ = Nothing + parseJSON _ = pure R.defaultXreadOpts diff --git a/src/EulerHS/Extra/Regex.hs b/src/EulerHS/Extra/Regex.hs new file mode 100644 index 00000000..7edf9e1b --- /dev/null +++ b/src/EulerHS/Extra/Regex.hs @@ -0,0 +1,51 @@ +{- | +Module : EulerHS.Extra.Regex +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +module EulerHS.Extra.Regex where + +import Data.String.Conversions hiding ((<>)) +import Data.Text.Encoding (encodeUtf8,decodeUtf8) +import Prelude +import qualified Control.Exception as CE +import qualified Data.ByteString as BT +import qualified Data.Maybe as DM +import qualified Data.Text as T +import qualified Text.Regex.PCRE.Heavy as PCRE +import qualified Text.Regex.PCRE.Light.Char8 as TRPLC + +data RegExException = RegExException T.Text + deriving Show + +instance CE.Exception RegExException + +regex' :: BT.ByteString -> Either T.Text PCRE.Regex +regex' re = + case PCRE.compileM formatRe [] of + Right val -> Right val + Left err -> CE.throw $ RegExException $ (T.pack $ err) <> " " <> (T.pack $ show re) + where + formatRe = encodeUtf8 $ T.replace "[^]" "[^-]" (decodeUtf8 re) + +regex :: T.Text -> Either T.Text PCRE.Regex +regex str = regex' (encodeUtf8 $ T.replace "[^]" "[^-]" str) + +replace :: PCRE.Regex -> SBS -> T.Text -> T.Text +replace cRegex to str = PCRE.gsub cRegex to str + +test :: PCRE.Regex -> T.Text -> Bool +test r str = + case TRPLC.match r (T.unpack str) [] of + Nothing -> False + DM.Just _ -> True + +match :: PCRE.Regex -> T.Text -> Maybe [Maybe T.Text] +match r str = + case (TRPLC.match r (T.unpack str) []) of + Nothing -> Nothing + DM.Just val -> DM.Just $ fmap (DM.Just . T.pack) $ val \ No newline at end of file diff --git a/src/EulerHS/Extra/Snowflakes/Flow.hs b/src/EulerHS/Extra/Snowflakes/Flow.hs new file mode 100644 index 00000000..4947553e --- /dev/null +++ b/src/EulerHS/Extra/Snowflakes/Flow.hs @@ -0,0 +1,65 @@ +{- | +Module : EulerHS.Extra.Snowflakes.Flow +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE ScopedTypeVariables #-} + +module EulerHS.Extra.Snowflakes.Flow where + +import Data.Bits +import Data.Either.Extra (mapRight) +import Data.Word +import Data.Text as Text +import Data.Time.Clock.POSIX as Time +import Control.Applicative +import Prelude +import Data.Bifunctor (first, second) +import Data.Map.Strict as Map +import Control.Concurrent.MVar +import EulerHS.Extra.Snowflakes.Types + + + + +getSnowflakeGenerator :: IO SnowflakeGenerator +getSnowflakeGenerator = newMVar Map.empty + +generateSnowflake' :: Word8 -> Word16 -> String -> SnowflakeGenerator -> IO (Either SnowflakeError Snowflake) +generateSnowflake' stackID podID key generator = do + let + firstJan2023Midnight = 1672511400 :: Word32 -- 1st Jan 2023, 12:00 AM (GMT + 5:30) + keyText = Text.pack key + currentPosixTime :: Word32 <- round <$> Time.getPOSIXTime -- Current Posix time (GMT + 5:30) + eUpdatedPayload <- modifyMVar generator (\snowflakeMetadataMap -> do + pure $ case snowflakeMetadataMap !? keyText of + Just value -> updateSnowflakeMetadata currentPosixTime keyText value snowflakeMetadataMap + Nothing -> createMetadataAgainstKey keyText currentPosixTime snowflakeMetadataMap + ) + return $ (flip mapRight) eUpdatedPayload (\updatedPayload -> + let + timeElapsed :: Word64 = fromIntegral $ currentPosixTime - firstJan2023Midnight + timeElapsedSetAt64 :: Word64 = shiftL timeElapsed 34 + stackIDSetAt64 :: Word64 = shiftL (fromIntegral (stackID .&. 127) :: Word64) 27 + podIDSetAt64 :: Word64 = shiftL (fromIntegral (podID .&. 32767) :: Word64) 12 + updatedPayloadAt64 :: Word64 = fromIntegral updatedPayload + in timeElapsedSetAt64 .|. stackIDSetAt64 .|. podIDSetAt64 .|. updatedPayloadAt64) + + where + createMetadataAgainstKey :: Text -> Word32 -> Map Text SnowflakeMetadata -> (Map Text SnowflakeMetadata, Either SnowflakeError Word16) + createMetadataAgainstKey key' currentPosixTime = second Right . first (insert key' (SnowflakeMetadata currentPosixTime 0)) . (, 0) + + updateSnowflakeMetadata :: Word32 -> Text -> SnowflakeMetadata -> Map Text SnowflakeMetadata -> (Map Text SnowflakeMetadata, Either SnowflakeError Word16) + updateSnowflakeMetadata currentPosixTime key' currentMetadata snowflakeMetadataMap = + let + updatedIncrementalPayload = if (currentPosixTime - currentMetadata.lastCalledAt) > 0 then 0 else (currentMetadata.incrementalPayload + 1) .&. 4095 + currentIncrementalPayload = incrementalPayload currentMetadata + errorString :: Text + errorString = "generateSnowflake':: Incremental Payload reached limit for timeStamp: " <> (pack . show $ currentPosixTime) <> ", key: " <> key' + in if currentIncrementalPayload == 4095 + then second Left (snowflakeMetadataMap, NonFatal errorString) + else second Right (insert key' (SnowflakeMetadata currentPosixTime updatedIncrementalPayload) snowflakeMetadataMap, updatedIncrementalPayload) \ No newline at end of file diff --git a/src/EulerHS/Extra/Snowflakes/Types.hs b/src/EulerHS/Extra/Snowflakes/Types.hs new file mode 100644 index 00000000..1570a22a --- /dev/null +++ b/src/EulerHS/Extra/Snowflakes/Types.hs @@ -0,0 +1,47 @@ +{- | +Module : EulerHS.Extra.Snowflakes.Types +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveAnyClass #-} + +module EulerHS.Extra.Snowflakes.Types where + +import Data.Aeson as A +import Data.Word +import Prelude +import Data.Map.Strict as Map +import Control.Concurrent.MVar +import EulerHS.Prelude +import EulerHS.Options (OptionEntity) + + + + +data SnowflakeMetadata = SnowflakeMetadata { + lastCalledAt :: Word32, + incrementalPayload :: Word16 +} + +type SnowflakeGenerator = MVar (Map Text SnowflakeMetadata) +type Snowflake = Word64 + +data SnowflakeError = NonFatal Text | Fatal Text + deriving stock (Eq, Show, Generic) + +data StackID = StackID + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) +instance OptionEntity StackID Word8 + + +data PodID = PodID + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) +instance OptionEntity PodID Word16 diff --git a/src/EulerHS/Extra/Test.hs b/src/EulerHS/Extra/Test.hs index 9a3942aa..53f91b81 100644 --- a/src/EulerHS/Extra/Test.hs +++ b/src/EulerHS/Extra/Test.hs @@ -1,20 +1,34 @@ -{-# LANGUAGE OverloadedStrings #-} +{- | +Module : EulerHS.Extra.Test +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} -module EulerHS.Extra.Test where +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -import EulerHS.Prelude + + +module EulerHS.Extra.Test where import qualified Database.Beam.Postgres as BP import qualified Database.MySQL.Base as MySQL import qualified Database.PostgreSQL.Simple as PG (execute_) import EulerHS.Interpreters import EulerHS.Language +import EulerHS.Prelude import EulerHS.Runtime (FlowRuntime) import EulerHS.Types import qualified EulerHS.Types as T import System.Process - mwhen :: Monoid m => Bool -> m -> m mwhen True = id mwnen False = const mempty @@ -24,7 +38,7 @@ withMysqlDb :: String -> String -> MySQLConfig -> IO a -> IO a withMysqlDb dbName filePath msRootCfg next = bracket_ (dropTestDbIfExist >> createTestDb) - (dropTestDbIfExist) + dropTestDbIfExist (loadMySQLDump >> next) where T.MySQLConfig @@ -78,11 +92,10 @@ 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) - (dropTestDbIfExist) + dropTestDbIfExist (loadPgDump >> prepareDBConnections flowRt >> next flowRt) where prepareDBConnections :: FlowRuntime -> IO () diff --git a/src/EulerHS/Extra/Time.hs b/src/EulerHS/Extra/Time.hs new file mode 100644 index 00000000..d5d6b498 --- /dev/null +++ b/src/EulerHS/Extra/Time.hs @@ -0,0 +1,49 @@ +{- | +Module : EulerHS.Extra.Time +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +module EulerHS.Extra.Time + ( readToLocalTime + , convertLocalToUTC + , junkUTC + , getCurrentTimeUTC + , getCurrentDateInMillis + , getCurrentDateInSeconds + ) where + +import Data.Time (Day (ModifiedJulianDay), LocalTime, + UTCTime (UTCTime), localTimeToUTC, utc, + utcToLocalTime, zonedTimeToLocalTime, getCurrentTime, utcToZonedTime) +import Data.Time.Clock.POSIX (getPOSIXTime) + +import EulerHS.Prelude +import EulerHS.Language (MonadFlow, runIO) + + +readToLocalTime :: Maybe UTCTime -> Maybe LocalTime +readToLocalTime = fmap (utcToLocalTime utc) + +convertLocalToUTC :: LocalTime -> UTCTime +convertLocalToUTC = localTimeToUTC utc + +junkUTC :: UTCTime +junkUTC = UTCTime (ModifiedJulianDay 0) 0 + +getCurrentTimeUTC :: (MonadFlow m) => m LocalTime +getCurrentTimeUTC = runIO go + where + go :: IO LocalTime + go = zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + +getCurrentDateInMillis :: (MonadFlow m) => m Int +getCurrentDateInMillis = runIO $ do + t <- (* 1000) <$> getPOSIXTime + pure . floor $ t + +getCurrentDateInSeconds :: (MonadFlow m) => m Int +getCurrentDateInSeconds = runIO $ floor <$> getPOSIXTime diff --git a/src/EulerHS/Extra/URLSanitization.hs b/src/EulerHS/Extra/URLSanitization.hs new file mode 100644 index 00000000..f1345f14 --- /dev/null +++ b/src/EulerHS/Extra/URLSanitization.hs @@ -0,0 +1,133 @@ +{- | +Module : EulerHS.Extra.URLSanitization +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +module EulerHS.Extra.URLSanitization where + +import Data.Maybe (fromMaybe) +import Prelude +import qualified Data.HashSet as HS +import qualified Data.Text as Text +import qualified Data.Attoparsec.Text as DAT +import Test.Tasty.HUnit ((@?=)) + + +sanitizeMetricURL :: Text.Text -> Maybe (HS.HashSet Text.Text) -> IO Text.Text +sanitizeMetricURL url allowedKeywords = do + splitByQuestion <- runParserForURLPathAndQueryParams url + let queryParamsCheck = + case splitByQuestion of + DAT.Done left right -> [right,(Text.drop 1 $ left)] + _ -> [url] + urlPath = Text.splitOn ("/" :: Text.Text) (lookupNthElement queryParamsCheck 0) + maskedPath = map (mask) urlPath + return $ (Text.intercalate ("/" :: Text.Text) maskedPath) <> (if length queryParamsCheck > 1 then ("?" :: Text.Text) <> (sanitizeQP $ lookupNthElement queryParamsCheck 1) else ("" :: Text.Text)) + where + sanitizeQP :: Text.Text -> Text.Text + sanitizeQP a = Text.drop 1 $ foldl (\acc x -> acc <> ("&" :: Text.Text) <> (splitByEq x)) ("" :: Text.Text) $ Text.splitOn ("&" :: Text.Text) a + + splitByEq :: Text.Text -> Text.Text + splitByEq x = + let k = Text.splitOn ("=" :: Text.Text) x + fstEle = lookupNthElement k 0 + sndEle = lookupNthElement k 1 + in if fstEle /= "" then fstEle <> (if checkIfAllowed fstEle then if sndEle /= "" then ("=" :: Text.Text) <> sndEle else ("" :: Text.Text) else ("=" :: Text.Text) <> ("#masked" :: Text.Text)) else ("" :: Text.Text) + + lookupNthElement :: [Text.Text] -> Int -> Text.Text + lookupNthElement xs k = + case drop k xs of + x:_ -> x + [] -> ("" :: Text.Text) + + runParserForURLPathAndQueryParams :: Text.Text -> IO (DAT.Result Text.Text) + runParserForURLPathAndQueryParams str = return $ DAT.parse parseURLPath str + + parseURLPath :: DAT.Parser Text.Text + parseURLPath = DAT.takeTill (=='?') + + mask :: Text.Text -> Text.Text + mask "" = "" + mask x = if checkIfAllowed x then x else "#masked" + + checkIfAllowed :: Text.Text -> Bool + checkIfAllowed x = HS.member x $ fromMaybe getKeywords allowedKeywords + + -- These are moved from euler-ps + getKeywords :: HS.HashSet Text.Text + getKeywords = HS.fromList [] + + + +sanitizeMetricURL' :: Text.Text -> Maybe (HS.HashSet Text.Text) -> Text.Text +sanitizeMetricURL' url allowedKeywords = do + let queryParamsCheck = Text.splitOn ("?" :: Text.Text) url + urlPath = Text.splitOn ("/" :: Text.Text) (lookupNthElement queryParamsCheck 0) + maskedPath = map (mask) urlPath + (Text.intercalate ("/" :: Text.Text) maskedPath) <> (if length queryParamsCheck > 1 then ("?" :: Text.Text) <> (sanitizeQP $ lookupNthElement queryParamsCheck 1) else ("" :: Text.Text)) + where + sanitizeQP :: Text.Text -> Text.Text + sanitizeQP a = Text.drop 1 $ foldl (\acc x -> acc <> ("&" :: Text.Text) <> (splitByEq x)) ("" :: Text.Text) $ Text.splitOn ("&" :: Text.Text) a + + splitByEq :: Text.Text -> Text.Text + splitByEq x = + let k = Text.splitOn ("=" :: Text.Text) x + fstEle = lookupNthElement k 0 + sndEle = lookupNthElement k 1 + in if fstEle /= "" then fstEle <> (if checkIfAllowed fstEle then if sndEle /= "" then ("=" :: Text.Text) <> sndEle else ("" :: Text.Text) else ("=" :: Text.Text) <> ("#masked" :: Text.Text)) else ("" :: Text.Text) + + lookupNthElement :: [Text.Text] -> Int -> Text.Text + lookupNthElement xs k = + case drop k xs of + x:_ -> x + [] -> ("" :: Text.Text) + + mask :: Text.Text -> Text.Text + mask "" = "" + mask x = if checkIfAllowed x then x else "#masked" + + checkIfAllowed :: Text.Text -> Bool + checkIfAllowed x = HS.member x $ fromMaybe getKeywords allowedKeywords + + -- These are moved from euler-ps + getKeywords :: HS.HashSet Text.Text + getKeywords = HS.fromList [] + +unit_sanitizeMetricURL :: IO [Text.Text] +unit_sanitizeMetricURL = g getURLListInput getResultList + where + g :: [Text.Text] -> [Text.Text] -> IO [Text.Text] + g (x:xs) (y:ys) = do + r <- (sanitizeMetricURL x Nothing) + s <- g xs ys + r @?= y + pure $ [r] ++ s + g _ _ = pure [] + + getURLListInput :: [Text.Text] + getURLListInput = [ + ("/v1/payments/#id/otp/submit" :: Text.Text) + , ("/v1/payments/#id/otp/resend" :: Text.Text) + , ("/v1/payments/#paymentId" :: Text.Text) + , ("/v1/orders/#order_id/payments" :: Text.Text) + , ("/api/v1/fetchBinDetail?mid=#mid&orderId=#orderId" :: Text.Text) + , ("/api/v1/processTransaction?mid=#mid&orderId=#orderId" :: Text.Text) + , ("/api/v1/initiateTransaction?mid=#mid&orderId=#orderId" :: Text.Text) + ] + + getResultList :: [Text.Text] + getResultList = [ + ("/v1/payments/#masked/otp/submit" :: Text.Text) + , ("/v1/payments/#masked/otp/resend" :: Text.Text) + , ("/v1/payments/#masked" :: Text.Text) + , ("/v1/orders/#masked/payments" :: Text.Text) + , ("/api/v1/fetchBinDetail?mid=#masked&orderId=#masked" :: Text.Text) + , ("/api/v1/processTransaction?mid=#masked&orderId=#masked" :: Text.Text) + , ("/api/v1/initiateTransaction?mid=#masked&orderId=#masked" :: Text.Text) + ] \ No newline at end of file diff --git a/src/EulerHS/Extra/Validation.hs b/src/EulerHS/Extra/Validation.hs index 3a664d2f..d7c57b08 100644 --- a/src/EulerHS/Extra/Validation.hs +++ b/src/EulerHS/Extra/Validation.hs @@ -1,5 +1,14 @@ -{-# OPTIONS -fno-warn-deprecations #-} +{- | +Module : EulerHS.Extra.Validation +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} module EulerHS.Extra.Validation ( @@ -12,6 +21,7 @@ module EulerHS.Extra.Validation , V , Errors , module X + , withField' , withField , runParser , extractJust @@ -22,23 +32,20 @@ module EulerHS.Extra.Validation , parValidate ) where -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 import Data.Validation as X -import GHC.TypeLits -import Type.Reflection - +import EulerHS.Prelude hiding (or, pred) +import qualified Data.Generics.Product.Fields as GL (HasField', getField) +import GHC.Records.Compat (HasField, getField) +import GHC.TypeLits (KnownSymbol, Symbol) +import qualified Prelude as P +import Type.Reflection (typeRep) 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. @@ -61,10 +68,9 @@ guarded err pred | pred = ReaderT (\_ -> pure ()) | otherwise = ReaderT (\ctx -> Left [ctx <> " " <> err]) -- | Trying to decode Text to target type -decode :: forall t . (Data t, Read t) => Transformer Text t -decode v = ReaderT (\ctx -> case (readMaybe $ toString v) of +decode :: forall 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 @@ -85,11 +91,19 @@ extractMaybeWithDefault :: a -> Transformer (Maybe a) a extractMaybeWithDefault d r = ReaderT (\_ -> maybe (Right d) Right r) -- | Extract value and run validators on it +-- New One +withField' + :: forall (f :: Symbol) v r a + . (HasField f r v, KnownSymbol f) + => r -> Transformer v a -> Validation Errors a +withField' rec pav = fromEither $ runReaderT (pav $ getField @f rec) $ fieldName_ @f + +-- Old One with generic-lens withField :: forall (f :: Symbol) v r a - . (Generic r, HasField' f r v, KnownSymbol f) + . (GL.HasField' f r v, KnownSymbol f) => r -> Transformer v a -> Validation Errors a -withField rec pav = fromEither $ runReaderT (pav $ getField @f rec) $ fieldName_ @f +withField rec pav = fromEither $ runReaderT (pav $ GL.getField @f rec) $ fieldName_ @f -- | Run parser runParser @@ -111,7 +125,7 @@ runParser p msg = fromEither $ runReaderT p msg -- >>> fieldName @"userId" -- "userId" fieldName_ :: forall (f :: Symbol) . KnownSymbol f => Text -fieldName_ = T.pack $ ((filter (/='"'))) $ P.show $ typeRep @f +fieldName_ = T.pack $ filter (/='"') $ P.show $ typeRep @f parValidate :: [Validator a] -> Validator a parValidate vals a = ReaderT (\ctx -> toEither $ foldr (*>) (pure a) $ fmap (mapper ctx) vals) diff --git a/src/EulerHS/Framework/Flow/Interpreter.hs b/src/EulerHS/Framework/Flow/Interpreter.hs index 872184e6..06699847 100644 --- a/src/EulerHS/Framework/Flow/Interpreter.hs +++ b/src/EulerHS/Framework/Flow/Interpreter.hs @@ -1,3 +1,12 @@ +{- | +Module : EulerHS.Framework.Flow.Interpreter +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + module EulerHS.Framework.Flow.Interpreter ( -- * Flow Interpreter @@ -101,7 +110,6 @@ getHttpLibRequest request = do in \req -> req { HTTP.requestBody = HTTP.RequestBodyLBS body' } Nothing -> id - -- TODO: Respect "Content-Transfer-Encoding" header let headers :: HTTP.RequestHeaders = T.getRequestHeaders request & Map.toList @@ -151,8 +159,6 @@ translateResponseHeaders httpLibHeaders = do headerValues <- mapM (Encoding.decodeUtf8' . snd) httpLibHeaders return $ zip (map Text.toLower headerNames) headerValues - -- TODO: Look up encoding and use some thread-safe unicode package to decode - -- headers -- let encoding -- = List.findIndex (\name -> name == "content-transfer-encoding") headerNames headers <- displayEitherException "Error decoding HTTP response headers: " result @@ -217,7 +223,6 @@ 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 @@ -396,7 +401,6 @@ interpretFlowMethod mbFlowGuid flowRt (L.RunDB conn sqlDbMethod runInTransaction 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) $ fmap connPoolExceptionWrapper $ tryAny $ case runInTransaction of True -> case conn of diff --git a/src/EulerHS/Framework/Flow/Language.hs b/src/EulerHS/Framework/Flow/Language.hs index 80b28ef4..4f6352f6 100644 --- a/src/EulerHS/Framework/Flow/Language.hs +++ b/src/EulerHS/Framework/Flow/Language.hs @@ -1,3 +1,12 @@ +{- | +Module : EulerHS.Framework.Flow.Language +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -1110,11 +1119,6 @@ instance (MonadFlow m, Monoid w) => MonadFlow (RWST r w s m) where {-# INLINEABLE withModifiedRuntime #-} withModifiedRuntime f = lift . withModifiedRuntime f --- TODO: save a builder in some state for using `hPutBuilder`? --- --- Doubts: --- Is it the right place to put it? --- Should the type be more generic than IO ()? logCallStack :: (HasCallStack, MonadFlow m) => m () logCallStack = logDebug ("CALLSTACK" :: Text) $ Text.pack $ prettyCallStack callStack diff --git a/src/EulerHS/Framework/Interpreter.hs b/src/EulerHS/Framework/Interpreter.hs new file mode 100644 index 00000000..8be5f38c --- /dev/null +++ b/src/EulerHS/Framework/Interpreter.hs @@ -0,0 +1,802 @@ +{- | +Module : EulerHS.Framework.Interpreter +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module EulerHS.Framework.Interpreter + ( -- * Flow Interpreter + runFlow + , runFlow' + , modify302RedirectionResponse + ) where + +import Control.Concurrent.MVar (modifyMVar) +import Control.Exception (throwIO) +import qualified Control.Exception as Exception +import qualified Control.Concurrent.Map as CMap +import qualified Data.Aeson as A +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as Lazy +import qualified Data.CaseInsensitive as CI +import qualified Data.DList as DL +import Data.Either.Extra (mapLeft) +import qualified Data.HashMap.Strict as HM +import Data.IORef (readIORef, writeIORef) +import qualified Data.LruCache as LRU +import qualified Data.Cache.LRU as SimpleLRU +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 Data.Time.Clock (diffTimeToPicoseconds) +import Data.Time.Clock.System (getSystemTime, systemToTAITime) +import Data.Time.Clock.TAI (diffAbsoluteTime) +import qualified Data.UUID as UUID (toText) +import qualified Data.UUID.V4 as UUID (nextRandom) +import EulerHS.Api ( EulerClient(..)) +import EulerHS.ApiHelpers ( runEulerClient) +import EulerHS.BinaryString (LBinaryString (LBinaryString), + getLBinaryString) +import EulerHS.Common (Awaitable (Awaitable), FlowGUID, + ManagerSelector (ManagerSelector), + Microseconds (Microseconds)) +import EulerHS.Extra.Snowflakes.Flow (generateSnowflake') +import EulerHS.Extra.Snowflakes.Types (SnowflakeError(Fatal), Snowflake) +import qualified EulerHS.Framework.Language as L +import qualified EulerHS.Framework.Runtime as R +import EulerHS.HttpAPI (HTTPIOException (HTTPIOException), + HTTPMethod (Connect, Delete, Get, Head, Options, Patch, Post, Put, Trace), + HTTPRequest(..), HTTPRequestMasked, + HTTPResponse (..), buildSettings, AwaitingError(..), RequestType(..), + defaultTimeout, getRequestBody, + getRequestHeaders, getRequestMethod, + getRequestRedirects, getRequestTimeout, + getRequestURL, getResponseBody, + getResponseCode, getResponseHeaders, + getResponseStatus, maskHTTPRequest,maskHTTPResponse, + mkHttpApiCallLogEntry, shouldBypassProxy, withOptionalHeader) +import EulerHS.KVDB.Interpreter (runKVDB) +import EulerHS.KVDB.Types (KVDBAnswer, + KVDBConfig (KVDBClusterConfig, KVDBConfig), + KVDBConn (Redis), + KVDBError (KVDBConnectionAlreadyExists, KVDBConnectionDoesNotExist, KVDBConnectionFailed), + KVDBReplyF (KVDBError), kvdbToNative, + mkRedisConn, nativeToKVDB) +import EulerHS.Logger.Interpreter (runLogger) +import qualified EulerHS.Logger.Language as L +import qualified EulerHS.Logger.Runtime as R +import EulerHS.Logger.Types (LogLevel (Debug, Error, Info), + Message (Message), Action , Entity, ErrorL(..), Latency, RespCode, ErrorInfo(..)) +import EulerHS.Prelude hiding (readIORef, writeIORef) +import EulerHS.PubSub.Interpreter (runPubSub) +import EulerHS.SqlDB.Interpreter (runSqlDB) +import EulerHS.SqlDB.Types (ConnTag, + DBConfig (MySQLPoolConf, PostgresPoolConf, SQLitePoolConf), + DBError (DBError), + DBErrorType (ConnectionAlreadyExists, ConnectionDoesNotExist, ConnectionFailed, UnrecognizedError), + DBResult, + NativeSqlConn (NativeMySQLConn, NativePGConn, NativeSQLiteConn), + SqlConn (MySQLPool, PostgresPool, SQLitePool), + bemToNative, mkSqlConn, + mysqlErrorToDbError, nativeToBem, + postgresErrorToDbError, + sqliteErrorToDbError) +import GHC.Conc (labelThread) +import qualified Network.HTTP.Client as HTTP +import Network.HTTP.Client.Internal +import qualified Network.HTTP.Types as HTTP +import qualified Servant.Client as S +import System.Process (readCreateProcess, shell) +import Unsafe.Coerce (unsafeCoerce) +import qualified EulerHS.Extra.Monitoring.Flow as EEMF +import qualified EulerHS.Extra.Monitoring.Types as EEMT +import qualified Data.Bool as Bool +import EulerHS.ART.Types +import EulerHS.ART.Utils (toErrorPayload) +import EulerHS.ART.EnvVars (isArtRecEnabled, isArtReplayEnabled) +import EulerHS.ART.FlowUtils (readRecordingsAndWriteToFileForkFLow, shouldRecordForkFLow) +-- import System.IO.Unsafe (unsafePerformIO) + +connect :: DBConfig be -> IO (DBResult (SqlConn be)) +connect cfg = do + eConn <- try $ mkSqlConn cfg + case eConn of + Left (e :: SomeException) -> pure $ Left $ DBError ConnectionFailed $ show e + Right conn -> pure $ Right conn + +connectRedis :: KVDBConfig -> IO (KVDBAnswer KVDBConn) +connectRedis cfg = do + eConn <- try $ mkRedisConn cfg + case eConn of + Left (e :: SomeException) -> pure $ Left $ KVDBError KVDBConnectionFailed $ show e + Right conn -> pure $ Right conn + +disconnect :: SqlConn beM -> IO () +disconnect (PostgresPool _ pool) = DP.destroyAllResources pool +disconnect (MySQLPool _ pool) = DP.destroyAllResources pool +disconnect (SQLitePool _ pool) = DP.destroyAllResources pool + +awaitMVarWithTimeout :: MVar (Either Text a) -> Int -> IO (Either AwaitingError a) +awaitMVarWithTimeout mvar mcs | mcs <= 0 = go 0 + | otherwise = go mcs + where + portion = (mcs `div` 10) + 1 + go rest + | rest <= 0 = do + mValue <- tryReadMVar mvar + pure $ case mValue of + Nothing -> Left AwaitingTimeout + Just (Right val) -> Right val + Just (Left err) -> Left $ ForkedFlowError err + | otherwise = do + tryReadMVar mvar >>= \case + Just (Right val) -> pure $ Right val + Just (Left err) -> pure $ Left $ ForkedFlowError err + Nothing -> threadDelay portion >> go (rest - portion) + +-- | Utility function to convert HttpApi HTTPRequests to http-client HTTP +-- requests +getHttpLibRequest :: MonadThrow m => HTTPRequest -> m HTTP.Request +getHttpLibRequest request = do + let url = Text.unpack $ getRequestURL request + httpLibRequest <- HTTP.parseRequest url + let + requestMethod = case getRequestMethod request of + Get -> "GET" + Put -> "PUT" + Post -> "POST" + Delete -> "DELETE" + Head -> "HEAD" + Trace -> "TRACE" + Connect -> "CONNECT" + Options -> "OPTIONS" + Patch -> "PATCH" + let + setBody = case getRequestBody request of + Just body -> + let body' = getLBinaryString body + in \req -> req { HTTP.requestBody = HTTP.RequestBodyLBS body' } + Nothing -> id + + let + headers :: HTTP.RequestHeaders = getRequestHeaders request + & Map.toList + & map (\(x, y) -> (CI.mk (Encoding.encodeUtf8 x), Encoding.encodeUtf8 y)) + + let + setTimeout = case getRequestTimeout request <|> getFromCustomTimeoutHeader of + Just x -> setRequestTimeout x + Nothing -> setRequestTimeout defaultTimeout + + let + setRedirects = case getRequestRedirects request of + Just x -> \req -> req {HTTP.redirectCount = x} + Nothing -> id + + pure $ setRedirects . setTimeout . setBody $ + httpLibRequest + { HTTP.method = requestMethod + , HTTP.requestHeaders = headers + } + where + getFromCustomTimeoutHeader = + (A.decodeStrict' . Encoding.encodeUtf8) =<< (Map.lookup "x-custom-timeout-millis" $ getRequestHeaders request) +-- | 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 HTTPResponse +translateHttpResponse response = do + headers <- translateResponseHeaders $ HTTP.responseHeaders response + status <- translateResponseStatusMessage . HTTP.statusMessage . HTTP.responseStatus $ response + pure $ HTTPResponse + { getResponseBody = LBinaryString $ HTTP.responseBody response + , getResponseCode = HTTP.statusCode $ HTTP.responseStatus response + , getResponseHeaders = headers + , getResponseStatus = status + } + +modify302RedirectionResponse :: HTTPResponse -> HTTPResponse +modify302RedirectionResponse resp = do + let contentType = Map.lookup "content-type" (getResponseHeaders resp) + case (getResponseCode resp, contentType) of + (302 , Just "text/plain") -> do + let lbs = getLBinaryString $ getResponseBody resp + case A.decode lbs :: Maybe Text of + Nothing -> resp + Just val -> maybe resp (\correctUrl -> resp { getResponseBody = (LBinaryString . A.encode) correctUrl }) (modifyRedirectingUrl val) + (_ , _ ) -> resp + + where + status = getResponseStatus resp + modifyRedirectingUrl = Text.stripPrefix (status <> ". Redirecting to ") + + +translateResponseHeaders + :: [(CI.CI Strict.ByteString, Strict.ByteString)] + -> Either Text (Map.Map Text.Text Text.Text) +translateResponseHeaders httpLibHeaders = do + let + result = do + headerNames <- mapM (Encoding.decodeUtf8' . CI.original . fst) httpLibHeaders + headerValues <- mapM (Encoding.decodeUtf8' . snd) httpLibHeaders + return $ zip (map Text.toLower headerNames) headerValues + + + -- let encoding + -- = List.findIndex (\name -> name == "content-transfer-encoding") headerNames + headers <- displayEitherException "Error decoding HTTP response headers: " result + pure $ Map.fromList headers + +translateResponseStatusMessage :: Strict.ByteString -> Either Text Text +translateResponseStatusMessage = displayEitherException "Error decoding HTTP response status message: " . Encoding.decodeUtf8' + +displayEitherException :: Exception e => Text -> Either e a -> Either Text a +displayEitherException prefix = either (Left . (prefix <>) . Text.pack . Exception.displayException) Right + +-- translateHeaderName :: CI.CI Strict.ByteString -> Text.Text +-- translateHeaderName = Encoding.decodeUtf8' . CI.original + +interpretFlowMethod :: Maybe FlowGUID -> R.FlowRuntime -> L.FlowMethod a -> IO a +interpretFlowMethod _ R.FlowRuntime {_httpClientManagers, _defaultHttpClientManager} (L.LookupHTTPManager mbMgrSel next) = + pure $ next $ case mbMgrSel of + Just (ManagerSelector mngrName) -> HM.lookup mngrName _httpClientManagers + Nothing -> Just _defaultHttpClientManager + +interpretFlowMethod mbFlowGuid flowRt@R.FlowRuntime {..} (L.CallServantAPI mngr bUrl apiTag errFunc (EulerClient f) next) = + EEMF.withMonitoringIO EEMT.API flowRt $ fmap next $ do + mHostValue <- runFlow flowRt $ L.getOptionLocal L.XTenantHostHeader + let S.ClientEnv manager baseUrl cookieJar makeClientRequest = S.mkClientEnv mngr bUrl + clientE = S.ClientEnv manager baseUrl cookieJar (\url -> getResponseTimeout . makeClientRequest url) + eitherResult <- tryRunClient $! S.runClientM (runEulerClient (if shouldLogAPI + then dbgLogger (show apiTag) + else emptyLogger + ) errFunc getLoggerMaskConfig _optionsLocal _recordingLocal bUrl (EulerClient f) apiTag mHostValue) clientE + case eitherResult of + Left err -> do + pure $ Left err + Right response -> + pure $ Right response + where + emptyLogger _ _ _ _ _ _ = return () + + customHeader :: CI.CI ByteString + customHeader = CI.mk $ encodeUtf8 @Text "x-custom-timeout-millis" + + getResponseTimeout req = do + let (modHeaders, maybeCustomTimeOut) = foldl (\(arr, m) (headerName, v) -> if customHeader == headerName then (arr, Just (headerName, v)) else ([(headerName, v)] <> arr, m)) ([], Nothing) $ requestHeaders req + case maybeCustomTimeOut >>= convertMilliSecondToMicro of + Just value -> req {HTTP.responseTimeout = HTTP.responseTimeoutMicro value, HTTP.requestHeaders = modHeaders} + Nothing -> if HTTP.responseTimeout req == HTTP.responseTimeoutNone + then setRequestTimeout defaultTimeout req + else req {HTTP.responseTimeout = mResponseTimeout mngr} + + convertMilliSecondToMicro :: (a, ByteString) -> Maybe Int + convertMilliSecondToMicro (_, value) = (*) 1000 <$> A.decodeStrict value + + dbgLogger :: forall msg . A.ToJSON msg => Entity -> LogLevel -> Action -> Maybe ErrorL -> Maybe Latency -> Maybe RespCode -> msg -> IO() + dbgLogger entity logLevel action maybeError maybeLatency maybeRespCode msg = + runLogger mbFlowGuid (R._loggerRuntime . R._coreRuntime $ flowRt) + . L.masterLogger logLevel ("CallServantAPI impl" :: String) "OUTGOING_API" (Just action) (Just entity) maybeError maybeLatency maybeRespCode $ Message Nothing (Just $ A.toJSON msg) + + shouldLogAPI = + R.shouldLogAPI . R._loggerRuntime . R._coreRuntime $ flowRt + getLoggerMaskConfig = + R.getLogMaskingConfig . R._loggerRuntime . R._coreRuntime $ flowRt + tryRunClient :: IO (Either S.ClientError a) -> IO (Either S.ClientError a) + tryRunClient act = do + res :: Either S.ClientError (Either S.ClientError a) <- try act + pure $ join res + +interpretFlowMethod _ R.FlowRuntime {..} (L.GetHTTPManager settings next) = + fmap next $ do + modifyMVar _dynHttpClientManagers $ \_cache -> do + let mCacheMgr = LRU.lookup settings _cache + case mCacheMgr of + Just (mgr, cache) -> pure (cache, mgr) + Nothing -> do + mgr <- HTTP.newManager $ buildSettings settings + pure (LRU.insert settings mgr _cache, mgr) + + +interpretFlowMethod _ flowRt@R.FlowRuntime {..} (L.CallHTTP request' apiTag errFunc manager mbMaskReqResBody next) = do + val <- EEMF.withMonitoringIO EEMT.API flowRt $ fmap next $ do + mHostValue <- runFlow flowRt $ L.getOptionLocal L.XTenantHostHeader + let request = withOptionalHeader "x-tenant-host" mHostValue request' + httpLibRequest <- getHttpLibRequest request + start <- systemToTAITime <$> getSystemTime + eResponse <- try $! HTTP.httpLbs httpLibRequest manager + end <- liftIO $ systemToTAITime <$> getSystemTime + let lat = div (diffTimeToPicoseconds $ diffAbsoluteTime end start) picoMilliDiff + httpRequestMethod = decodeUtf8 $ method httpLibRequest + eresp <- case eResponse of + Left (err :: SomeException) -> do + let errMsg = Text.pack $ displayException err + when shouldLogAPI $ logJsonError errMsg httpRequestMethod 0 lat (maskHTTPRequest getLoggerMaskConfig request mbMaskReqResBody) + pure $ Left errMsg + Right httpResponse -> do + case (modify302RedirectionResponse <$> translateHttpResponse httpResponse) of + Left errMsg -> do + when shouldLogAPI $ logJsonError errMsg httpRequestMethod (HTTP.statusCode . HTTP.responseStatus $ httpResponse) lat (maskHTTPRequest getLoggerMaskConfig request mbMaskReqResBody) + pure $ Left errMsg + Right response -> do + let errInfo = errFunc response + errLog = mkErrorLog =<< errInfo + updatedRes = addErrorInfoToResponseHeaders response errInfo + when shouldLogAPI $ do + let logEntry = mkHttpApiCallLogEntry lat (Just $ maskHTTPRequest getLoggerMaskConfig request mbMaskReqResBody) (Just $ maskHTTPResponse getLoggerMaskConfig updatedRes mbMaskReqResBody) (Bool.bool EXTERNAL INTERNAL ( (shouldBypassProxy . Just . decodeUtf8 . host $ httpLibRequest) || isArtReplayEnabled ) ) apiTag errInfo + logJson Info httpRequestMethod (show apiTag) errLog lat (getResponseCode updatedRes) logEntry + pure $ Right updatedRes + when (isArtRecEnabled) $ do + m <- takeMVar _recordingLocal + let apiEntry = case eresp of + Right resp -> CallAPIEntryT $ CallAPIEntry { + jsonRequest = request, + jsonResult = Right $ A.toJSON resp} + Left errMsg -> CallAPIEntryT $ CallAPIEntry { + jsonRequest = request, + jsonResult = Left $ toErrorPayload errMsg} + putMVar _recordingLocal $ m <> [apiEntry] + pure eresp + pure val + where + picoMilliDiff :: Integer + picoMilliDiff = 1000000000 + logJsonError :: Text -> Text -> Int -> Integer -> HTTPRequestMasked -> IO () + logJsonError err method statusCode latency req = + let errM = ErrorL Nothing "API_ERROR" err + in logJson Error method (show apiTag) (Just errM) latency statusCode $ HTTPIOException err req (show apiTag) latency + logJson :: ToJSON a => LogLevel -> Action -> Entity -> Maybe ErrorL -> Latency -> RespCode -> a -> IO () + logJson level action entity maybeError lat respCode msg = + runLogger (Just "API CALL:") (R._loggerRuntime . R._coreRuntime $ flowRt) + . L.masterLogger level ("callHTTP" :: String) "OUTGOING_API" (Just action) (Just entity) maybeError (Just lat) (Just respCode) $ Message Nothing (Just $ A.toJSON msg) + + shouldLogAPI = + R.shouldLogAPI . R._loggerRuntime . R._coreRuntime $ flowRt + getLoggerMaskConfig = + R.getLogMaskingConfig . R._loggerRuntime . R._coreRuntime $ flowRt + + mkErrorLog :: ErrorInfo -> Maybe ErrorL + mkErrorLog errInfo = Just (ErrorL (Just errInfo.error_code) errInfo.error_category errInfo.error_message) + +interpretFlowMethod mbFlowGuid R.FlowRuntime {..} (L.EvalLogger loggerAct next) = + next <$> runLogger mbFlowGuid (R._loggerRuntime _coreRuntime) loggerAct + +interpretFlowMethod _ _ (L.RunIO _ ioAct next) = + next <$> ioAct + +interpretFlowMethod _ flowRt (L.WithRunFlow ioAct) = + ioAct (runFlow flowRt) + +interpretFlowMethod _ R.FlowRuntime {..} (L.GetOption k next) = + 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 $ do + m <- takeMVar _options + let newMap = Map.insert k (unsafeCoerce @_ @Any v) m + putMVar _options newMap + +interpretFlowMethod _ R.FlowRuntime {..} (L.SetLoggerContext k v next) = + fmap next $ do + m <- readIORef $ R._logContext . R._loggerRuntime $ _coreRuntime + let newMap = HM.insert k v m + writeIORef (R._logContext . R._loggerRuntime $ _coreRuntime) newMap + +interpretFlowMethod _ R.FlowRuntime {..} (L.GetLoggerContext k next) = + fmap next $ do + m <- readIORef $ R._logContext . R._loggerRuntime $ _coreRuntime + pure $ HM.lookup k m + +interpretFlowMethod _ R.FlowRuntime {..} (L.SetLoggerContextMap newMap next) = + fmap next $ do + oldMap <- readIORef $ R._logContext . R._loggerRuntime $ _coreRuntime + writeIORef (R._logContext . R._loggerRuntime $ _coreRuntime) (HM.union newMap oldMap) + +interpretFlowMethod _ R.FlowRuntime {..} (L.ModifyOption k fn next) = + fmap next $ do + modifyMVar _options modifyAndCallFn + where + modifyAndCallFn curOptions = do + let valAny = Map.lookup k curOptions + case valAny of + Nothing -> pure (curOptions,(Nothing,Nothing)) + Just val -> do + let oldVal = unsafeCoerce val + modifiedVal = fn oldVal + pure (Map.insert k (unsafeCoerce @_ @Any modifiedVal) curOptions, + (Just oldVal, Just modifiedVal) + ) + +interpretFlowMethod _ R.FlowRuntime {..} (L.DelOption k next) = + fmap next $ do + m <- takeMVar _options + let newMap = Map.delete k m + putMVar _options newMap + +interpretFlowMethod _ R.FlowRuntime {..} (L.GetOptionLocal k next) = + fmap next $ do + m <- readMVar _optionsLocal + pure $ do + valAny <- Map.lookup k m + pure $ unsafeCoerce valAny + +interpretFlowMethod _ R.FlowRuntime {..} (L.SetOptionLocal k v next) = + fmap next $ do + m <- takeMVar _optionsLocal + let newMap = Map.insert k (unsafeCoerce @_ @Any v) m + putMVar _optionsLocal newMap + +interpretFlowMethod _ R.FlowRuntime {..} (L.DelOptionLocal k next) = + fmap next $ do + m <- takeMVar _optionsLocal + let newMap = Map.delete k m + putMVar _optionsLocal newMap + +interpretFlowMethod _ R.FlowRuntime {..} (L.GetRecordingLocal next) = + fmap next $ do + m <- readMVar _recordingLocal + pure m + +interpretFlowMethod _ R.FlowRuntime {..} (L.AppendRecordingLocal v next) = + fmap next $ do + when isArtRecEnabled $ do + m <- takeMVar _recordingLocal + putMVar _recordingLocal (m <> [v]) + +interpretFlowMethod _ R.FlowRuntime {..} (L.DelRecordingLocal next) = + fmap next $ do + putMVar _recordingLocal mempty + +interpretFlowMethod _ R.FlowRuntime {..} (L.GetConfig k next) = + fmap next $ do + config <- readIORef _configCache + let res = snd $ SimpleLRU.lookup k config + return res + +interpretFlowMethod _ R.FlowRuntime {..} (L.SetConfig k v next) = + fmap next $ do + atomicModifyIORef' _configCache (modifyConfig k v) + where + modifyConfig :: Text -> R.ConfigEntry -> (SimpleLRU.LRU Text R.ConfigEntry) -> (SimpleLRU.LRU Text R.ConfigEntry, ()) + modifyConfig key val configLRU = + let m' = SimpleLRU.insert key val configLRU + in (m', ()) + +interpretFlowMethod _ R.FlowRuntime {..} (L.ModifyConfig k entryMod next) = do + fmap next $ atomicModifyIORef' _configCache (modifyConfig k entryMod) + where + modifyConfig :: Text -> (Maybe R.ConfigEntry -> R.ConfigEntry) -> (SimpleLRU.LRU Text R.ConfigEntry) -> (SimpleLRU.LRU Text R.ConfigEntry, ()) + modifyConfig key modification configLRU = + let + (lru', val) = SimpleLRU.lookup k configLRU + lru'' = flip (SimpleLRU.insert key) lru' $ modification val + in (, ()) lru'' + -- in (lru'', ()) + +interpretFlowMethod _ R.FlowRuntime {..} (L.DelConfig k next) = + fmap next $ do + atomicModifyIORef' _configCache (deleteConfig k) + where + deleteConfig :: Text -> (SimpleLRU.LRU Text R.ConfigEntry) -> (SimpleLRU.LRU Text R.ConfigEntry, ()) + deleteConfig key configLRU = + let m' = SimpleLRU.delete key configLRU + in (fst m', ()) + +interpretFlowMethod _ R.FlowRuntime {..} (L.TrySetConfig k v next) = + fmap next $ do + atomicModifyIORef' _configCache (modifyConfig k v) + where + modifyConfig :: Text -> R.ConfigEntry -> (SimpleLRU.LRU Text R.ConfigEntry) -> (SimpleLRU.LRU Text R.ConfigEntry, Maybe ()) + modifyConfig key val configLRU = + let m' = SimpleLRU.insert key val configLRU + in (m', Just ()) + +interpretFlowMethod _ R.FlowRuntime {..} (L.AcquireConfigLock k next) = + fmap next $ do + m <- takeMVar _configCacheLock + didAcquire <- CMap.insertIfAbsent k () m + putMVar _configCacheLock m + return didAcquire + +interpretFlowMethod _ R.FlowRuntime {..} (L.ReleaseConfigLock k next) = + fmap next $ do + m <- takeMVar _configCacheLock + didDelete <- CMap.delete k m + putMVar _configCacheLock m + return didDelete + +interpretFlowMethod _ _ (L.GenerateGUID next) = do + next <$> (UUID.toText <$> UUID.nextRandom) + +interpretFlowMethod _ _ (L.RunSysCmd cmd next) = + next <$> readCreateProcess (shell cmd) "" + +---------------------------------------------------------------------- +interpretFlowMethod mbFlowGuid rt@R.FlowRuntime {..} (L.Fork desc newFlowGUID flow next) = do + awaitableMVar <- newEmptyMVar + when (isArtRecEnabled) $ do + m <- takeMVar _recordingLocal + putMVar _recordingLocal $ m <> [ForkFlowEntryT $ ForkFlowEntry desc newFlowGUID] + when (not isArtReplayEnabled) $ do + tid <- forkIO $ do + rt' <- if isArtRecEnabled + then do + newRecordingLocal <- newMVar ([]) + R.forkFlowWithNewRecordingLocal rt newRecordingLocal + else pure rt + res <- runFlow' mbFlowGuid rt' $ do + res' <- L.runSafeFlow flow + when (shouldRecordForkFLow && isArtRecEnabled) $ readRecordingsAndWriteToFileForkFLow desc newFlowGUID + pure res' + case res of + Left (err :: Text) -> + runLogger mbFlowGuid (R._loggerRuntime . R._coreRuntime $ rt) $ + L.masterLogger + Error + ("Exception while executing Fork function" :: Text) + "ERROR" + Nothing + Nothing + (Just $ ErrorL Nothing "FORK_ERROR" $ "Exception : " <> err) + Nothing + Nothing + (Message (Just $ A.toJSON ("Exception : " <> err <> (" , Stack Trace ") <> (Text.pack $ prettyCallStack callStack))) Nothing) + Right _ -> pure () + putMVar awaitableMVar res + labelThread tid $ "euler-Fork:" ++ Text.unpack desc + pure $ next $ Awaitable awaitableMVar + +---------------------------------------------------------------------- + +interpretFlowMethod _ _ (L.Await mbMcs (Awaitable awaitableMVar) next) = do + let act = case mbMcs of + Nothing -> do + val <- readMVar awaitableMVar + case val of + Left err -> pure $ Left $ ForkedFlowError err + Right res -> pure $ Right res + Just (Microseconds mcs) -> awaitMVarWithTimeout awaitableMVar $ fromIntegral mcs + next <$> act + +interpretFlowMethod _ _ (L.ThrowException ex _) = do + throwIO ex + +interpretFlowMethod mbFlowGuid rt (L.CatchException comp handler cont) = + cont <$> catch (runFlow' mbFlowGuid rt comp) (runFlow' mbFlowGuid rt . handler) + +-- 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'))) + +interpretFlowMethod mbFlowGuid rt (L.UninterruptibleMask cb cont) = + cont <$> uninterruptibleMask + (\cb' -> runFlow' mbFlowGuid rt (cb (dimap (runFlow' mbFlowGuid rt) (L.runIO' "UninterruptibleMask") cb'))) + +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') + +interpretFlowMethod mbFlowGuid rt (L.RunSafeFlow _ flow next) = fmap next $ do + fl <- try @_ @SomeException $ runFlow' mbFlowGuid rt flow + pure $ mapLeft show fl + +---------------------------------------------------------------------- + +interpretFlowMethod _ R.FlowRuntime {..} (L.InitSqlDBConnection cfg next) = + fmap next $ do + let connTag = dbConfigToTag cfg + connMap <- takeMVar _sqldbConnections + res <- case Map.lookup connTag connMap of + Just _ -> pure $ Left $ DBError ConnectionAlreadyExists $ "Connection for " <> connTag <> " already created." + Nothing -> connect cfg + case res of + Right conn -> putMVar _sqldbConnections $ Map.insert connTag (bemToNative conn) connMap + Left _ -> putMVar _sqldbConnections connMap + pure res + +interpretFlowMethod _ R.FlowRuntime {..} (L.DeInitSqlDBConnection conn next) = + fmap next $ do + let connTag = sqlConnToTag conn + connMap <- takeMVar _sqldbConnections + case Map.lookup connTag connMap of + Nothing -> putMVar _sqldbConnections connMap + Just _ -> do + disconnect conn + putMVar _sqldbConnections $ Map.delete connTag connMap + +interpretFlowMethod _ R.FlowRuntime {..} (L.GetSqlDBConnection cfg next) = + fmap next $ do + let connTag = dbConfigToTag cfg + connMap <- readMVar _sqldbConnections + pure $ case Map.lookup connTag connMap of + Just conn -> Right $ nativeToBem connTag conn + Nothing -> Left $ DBError ConnectionDoesNotExist $ "Connection for " <> connTag <> " does not exists." + +interpretFlowMethod _ R.FlowRuntime {..} (L.InitKVDBConnection cfg next) = + fmap next $ do + let connTag = kvdbConfigToTag cfg + connections <- takeMVar _kvdbConnections + res <- case Map.lookup connTag connections of + Just _ -> pure $ Left $ KVDBError KVDBConnectionAlreadyExists $ "Connection for " +|| connTag ||+ " already created." + Nothing -> connectRedis cfg + case res of + Left _ -> putMVar _kvdbConnections connections + Right conn -> putMVar _kvdbConnections + $ Map.insert connTag (kvdbToNative conn) connections + pure res + +interpretFlowMethod _ R.FlowRuntime {..} (L.DeInitKVDBConnection conn next) = + fmap next $ do + let connTag = kvdbConnToTag conn + connections <- takeMVar _kvdbConnections + case Map.lookup connTag connections of + Nothing -> putMVar _kvdbConnections connections + Just _ -> do + R.kvDisconnect $ kvdbToNative conn + putMVar _kvdbConnections $ Map.delete connTag connections + +interpretFlowMethod _ R.FlowRuntime {..} (L.GetKVDBConnection cfg next) = + fmap next $ do + let connTag = kvdbConfigToTag cfg + connMap <- readMVar _kvdbConnections + pure $ case Map.lookup connTag connMap of + Just conn -> Right $ nativeToKVDB connTag conn + Nothing -> Left $ KVDBError KVDBConnectionDoesNotExist $ "Connection for " +|| connTag ||+ " does not exists." + +interpretFlowMethod mbFlowGuid flowRt (L.RunDB conn (L.SqlDBFlow sqlDbMethod runInTransaction) next) = do + let dbgLogger msg = + if R.shouldFlowLogRawSql flowRt + then runLogger mbFlowGuid (R._loggerRuntime . R._coreRuntime $ flowRt) + . L.masterLogger Debug ("RunDB Impl" :: String) "DB" Nothing Nothing Nothing Nothing Nothing $ Message (Just $ A.toJSON msg) Nothing + else 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 + EEMF.withMonitoringIO EEMT.DB flowRt $ fmap (next . fst . connPoolExceptionWrapper) $ tryAny $ if runInTransaction + then do + eRes <- R.withTransaction conn $ \nativeConn -> runSqlDB nativeConn dbgLogAction sqlDbMethod + eRes' <- case eRes of + Left exception -> Left <$> wrapException mbFlowGuid flowRt exception + Right x -> pure $ Right x + rawSql <- DL.toList <$> readTVarIO rawSqlTVar + pure (eRes', rawSql) + else do + eRes <- try @_ @SomeException $ + case conn of + PostgresPool _ pool -> + DP.withResource pool $ \conn' -> + runSqlDB (NativePGConn conn') dbgLogAction $ sqlDbMethod + MySQLPool _ pool -> + DP.withResource pool $ \conn' -> + runSqlDB (NativeMySQLConn conn') dbgLogAction $ sqlDbMethod + SQLitePool _ pool -> + DP.withResource pool $ \conn' -> + runSqlDB (NativeSQLiteConn conn') dbgLogAction $ sqlDbMethod + wrapAndSend rawSqlTVar eRes + where + wrapAndSend rawSqlLoc eResult = do + rawSql <- DL.toList <$> readTVarIO rawSqlLoc + eResult' <- case eResult of + Left exception -> Left <$> wrapException mbFlowGuid flowRt exception + Right x -> pure $ Right x + pure (eResult', rawSql) + +interpretFlowMethod mbFlowGuid flowRt (L.RunDB conn (L.TransactionFlow f) next) = do + fmap next $ do + eRes <- R.withTransaction conn $ runFlow' mbFlowGuid flowRt . f + case eRes of + Left exception -> Left <$> wrapException mbFlowGuid flowRt exception + Right x -> pure $ Right x + +interpretFlowMethod mbFlowGuid flowRt@(R.FlowRuntime {..}) (L.RunKVDB cName act next) = do + EEMF.withMonitoringIO EEMT.REDIS flowRt $ next <$> runKVDB mbFlowGuid flowRt cName _kvdbConnections act + +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 <$> runPubSub _pubSubController conn + (L.unpackLanguagePubSub act $ runFlow' mbFlowGuid rt) + +interpretFlowMethod mbFlowGuid flowRt (L.RunDBWithConn conn sqlDbMethod next) = do + EEMF.withMonitoringIO EEMT.DB flowRt $ do + let dbgLogger msg = + if R.shouldFlowLogRawSql flowRt + then runLogger mbFlowGuid (R._loggerRuntime . R._coreRuntime $ flowRt) + . L.masterLogger Debug ("RunDB Impl" :: String) "DB" Nothing Nothing Nothing Nothing Nothing $ Message (Just $ A.toJSON msg) Nothing + else 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 + val <- fmap (next . fst . connPoolExceptionWrapper) $ tryAny $ do + eRes <- try @_ @SomeException $ runSqlDB conn dbgLogAction $ sqlDbMethod + wrapAndSend rawSqlTVar eRes + pure val + where + wrapAndSend rawSqlLoc eResult = do + rawSql <- DL.toList <$> readTVarIO rawSqlLoc + eResult' <- case eResult of + Left exception -> Left <$> wrapException mbFlowGuid flowRt exception + Right x -> pure $ Right x + pure (eResult', rawSql) + +interpretFlowMethod _ rt (L.WithModifiedRuntime f flow next) = next <$> runFlow (f rt) flow + +interpretFlowMethod _ R.FlowRuntime {..} (L.GetSnowflakeID sId pId k next) = next . either handleException id <$> (try @_ @SomeException $ generateSnowflake' sId pId k _snowflakeGenerator) + where + handleException :: SomeException -> Either SnowflakeError Snowflake + handleException = Left . Fatal . Text.pack . show + +runFlow' :: Maybe 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 = runFlow' Nothing + +-- Helpers + +wrapException :: HasCallStack => Maybe Text -> R.FlowRuntime -> SomeException -> IO DBError +wrapException mbFlowGuid flowRt exception = do + let exception' = (wrapException' exception) + runFlow' mbFlowGuid flowRt $ L.logException exception + pure exception' + +wrapException' :: SomeException -> DBError +wrapException' e = fromMaybe (DBError UnrecognizedError $ show e) + (sqliteErrorToDbError (show e) <$> fromException e <|> + mysqlErrorToDbError (show e) <$> fromException e <|> + postgresErrorToDbError (show e) <$> fromException e) + +connPoolExceptionWrapper :: Either SomeException (Either DBError _a1, [Text]) -> (Either DBError _a1, [Text]) +connPoolExceptionWrapper (Left e) = (Left $ DBError ConnectionFailed $ show e, []) +connPoolExceptionWrapper (Right r) = r + +dbConfigToTag :: DBConfig beM -> ConnTag +dbConfigToTag = \case + PostgresPoolConf t _ _ -> t + MySQLPoolConf t _ _ -> t + SQLitePoolConf t _ _ -> t + +sqlConnToTag :: SqlConn beM -> ConnTag +sqlConnToTag = \case + PostgresPool t _ -> t + MySQLPool t _ -> t + SQLitePool t _ -> t + +kvdbConfigToTag :: KVDBConfig -> Text +kvdbConfigToTag = \case + KVDBConfig t _ -> t + KVDBClusterConfig t _ -> t + +kvdbConnToTag :: KVDBConn -> Text +kvdbConnToTag (Redis t _) = t + +addErrorInfoToResponseHeaders :: HTTPResponse -> Maybe ErrorInfo -> HTTPResponse +addErrorInfoToResponseHeaders validRes (Just errorInfo) = + let errorHeaders = Map.fromList [("x-error_code", errorInfo.error_code) + , ("x-error_message", errorInfo.error_message) + , ("x-error_category", errorInfo.error_category) + , ("x-unified_error_code", errorInfo.unified_error_code) + , ("x-unified_error_message", errorInfo.unified_error_message)] + in validRes {getResponseHeaders = validRes.getResponseHeaders <> errorHeaders} +addErrorInfoToResponseHeaders validRes Nothing = validRes diff --git a/src/EulerHS/Framework/Language.hs b/src/EulerHS/Framework/Language.hs index 40488bca..aada992c 100644 --- a/src/EulerHS/Framework/Language.hs +++ b/src/EulerHS/Framework/Language.hs @@ -1,35 +1,2167 @@ {- | -Module : EulerHS.Core.Types +Module : EulerHS.Framework.Language Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 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. +{-# OPTIONS_GHC -fclear-plugins #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} -This is an internal module. Import EulerHS.Language instead. --} +{-# OPTIONS_GHC -Wno-missing-signatures -Wno-orphans #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} module EulerHS.Framework.Language - ( X.Flow, - X.FlowMethod (..), - X.MonadFlow (..), - X.ReaderFlow, - X.logCallStack, - X.logExceptionCallStack, - X.logInfo, - X.logError, - X.logDebug, - X.logWarning, - X.callAPI, - X.callAPI', - X.callHTTP, - X.runIO, - X.forkFlow, - X.forkFlow', - X.unpackLanguagePubSub, - X.foldFlow + ( + -- * Flow language + Flow(..) + , FlowMethod(..) + , MonadFlow(..) + , ReaderFlow + , HttpManagerNotFound(..) + -- ** Extra methods + -- *** Logging + , logCallStack + , logExceptionCallStack + , logInfo + , logErrorWithCategoryV + , logErrorWithCategory + , logError + , logDebug + , logWarning + , logM + , log + , logV + , logInfoM + , logInfoV + , logErrorM + , logErrorV + , logDebugM + , logDebugV + , logWarningM + , logWarningV + , logException + -- *** PublishSubscribe + , unpackLanguagePubSub + -- *** Working with external services + , callAPI + , callAPI' + , callHTTP + , callHTTP' + -- *** Legacy + , callHTTPWithCert + , callHTTPWithManager + , callHTTPWithCert' + , callHTTPWithManager' + -- *** Others + , runIO + , withRunFlow + , forkFlow + , forkFlow' + , forkFlow'' + -- ** Interpretation + , foldFlow + , getMySQLConnection + -- ** DBAndRedisMetric + , incrementDbAndRedisMetric + , DBAndRedisMetricHandler + , DBAndRedisMetric (..) + , mkDBAndRedisMetricHandler + , isDBMetricEnabled + , DBMetricCfg (..) + , XTenantHostHeader(..) + , incrementDbMetric + , RunDBInfo(..) ) where -import qualified EulerHS.Framework.Flow.Language as X +import Control.Monad.Catch (ExitCase, MonadCatch (catch), + MonadThrow (throwM)) +import Control.Monad.Free.Church (MonadFree) +import Control.Monad.Trans.Except (withExceptT) +import Control.Monad.Trans.RWS.Strict (RWST) +import Control.Monad.Trans.Writer (WriterT) +import qualified Data.Aeson as A +import qualified Data.ByteString.Lazy as LBS +import Data.Maybe (fromJust) +import qualified Data.Text as Text +import Network.HTTP.Client (Manager) +import Servant.Client (BaseUrl, ClientError (ConnectionError)) + +import EulerHS.Api (EulerClient) +import EulerHS.Common (Awaitable, Description, ForkGUID, + ManagerSelector (ManagerSelector), + Microseconds, SafeFlowGUID) +import EulerHS.Extra.Snowflakes.Types (Snowflake, SnowflakeError) +import EulerHS.Framework.Runtime (FlowRuntime, ConfigEntry) +import EulerHS.HttpAPI (HTTPCert, HTTPClientSettings, HTTPRequest, + HTTPResponse, withClientTls, HttpManagerNotFound(..), AwaitingError, MaskReqRespBody) +import EulerHS.KVDB.Language (KVDB) +import EulerHS.KVDB.Types (KVDBAnswer, KVDBConfig, KVDBConn, + KVDBReply) +import qualified EulerHS.KVDB.Types as T +import EulerHS.Logger.Language (Logger, masterLogger) +import EulerHS.Logger.Types (LogLevel (Debug, Error, Info, Warning), + Message (Message), ExceptionEntry(..), ErrorL(..), getErrorLogFromException) +import EulerHS.Options (OptionEntity, mkOptionKey) +import EulerHS.ART.Types (RecordingEntry(..)) +import EulerHS.Prelude hiding (getOption, throwM) +import qualified EulerHS.PubSub.Language as PSL +import EulerHS.SqlDB.Language (SqlDB) +import EulerHS.SqlDB.Types (BeamRunner, BeamRuntime, DBConfig, + DBResult, SqlConn) +import qualified EulerHS.SqlDB.Types as T +import Euler.Events.MetricApi.MetricApi +import qualified Juspay.Extra.Config as Conf +import qualified Data.Pool as DP +import qualified Database.MySQL.Base as MySQL +import qualified EulerHS.Logger.Types as Log + +-- | Flow language. +data FlowMethod (next :: Type) where + LookupHTTPManager + :: HasCallStack + => (Maybe ManagerSelector) + -> (Maybe Manager -> next) + -> FlowMethod next + + GetHTTPManager + :: HasCallStack + => HTTPClientSettings + -> (Manager -> next) + -> FlowMethod next + + CallServantAPI + :: (Show apiTag, HasCallStack) + => Manager + -> BaseUrl + -> apiTag + -> (LBS.ByteString -> Maybe Log.ErrorInfo) + -> EulerClient a + -> (Either ClientError a -> next) + -> FlowMethod next + + CallHTTP + :: (Show apiTag, HasCallStack) + => HTTPRequest + -> apiTag + -> (HTTPResponse -> Maybe Log.ErrorInfo) + -> Manager + -> Maybe MaskReqRespBody + -> (Either Text HTTPResponse -> next) + -> FlowMethod next + + EvalLogger + :: HasCallStack + => Logger a + -> (a -> next) + -> FlowMethod next + + RunIO + :: HasCallStack + => Text + -> IO a + -> (a -> next) + -> FlowMethod next + + WithRunFlow + :: HasCallStack + => ((forall x. Flow x -> IO x) -> IO next) + -> FlowMethod next + + GetOption + :: HasCallStack + => Text + -> (Maybe a -> next) + -> FlowMethod next + + SetOption + :: HasCallStack + => Text + -> a + -> (() -> next) + -> FlowMethod next + + SetLoggerContext + :: HasCallStack + => Text + -> Text + -> (() -> next) + -> FlowMethod next + + GetLoggerContext + :: HasCallStack + => Text + -> ((Maybe Text) -> next) + -> FlowMethod next + + SetLoggerContextMap + :: HasCallStack + => HashMap Text Text + -> (() -> next) + -> FlowMethod next + + ModifyOption + :: HasCallStack + => Text + -> ( a -> a ) + -> ((Maybe a, Maybe a) -> next) + -> FlowMethod next + + DelOption + :: HasCallStack + => Text + -> (() -> next) + -> FlowMethod next + + GetOptionLocal + :: HasCallStack + => Text + -> (Maybe a -> next) + -> FlowMethod next + + SetOptionLocal + :: HasCallStack + => Text + -> a + -> (() -> next) + -> FlowMethod next + + DelOptionLocal + :: HasCallStack + => Text + -> (() -> next) + -> FlowMethod next + + GetRecordingLocal + :: HasCallStack + => ([RecordingEntry] -> next) + -> FlowMethod next + + AppendRecordingLocal + :: HasCallStack + => RecordingEntry + -> (() -> next) + -> FlowMethod next + + DelRecordingLocal + :: HasCallStack + => (() -> next) + -> FlowMethod next + + GetConfig + :: HasCallStack + => Text + -> (Maybe ConfigEntry -> next) + -> FlowMethod next + + SetConfig + :: HasCallStack + => Text + -> ConfigEntry + -> (() -> next) + -> FlowMethod next + + ModifyConfig + :: HasCallStack + => Text + -> (Maybe ConfigEntry -> ConfigEntry) + -> (() -> next) + -> FlowMethod next + + TrySetConfig + :: HasCallStack + => Text + -> ConfigEntry + -> (Maybe () -> next) + -> FlowMethod next + + DelConfig + :: HasCallStack + => Text + -> (() -> next) + -> FlowMethod next + + AcquireConfigLock + :: HasCallStack + => Text + -> (Bool -> next) + -> FlowMethod next + + ReleaseConfigLock + :: HasCallStack + => Text + -> (Bool -> next) + -> FlowMethod next + + GenerateGUID + :: HasCallStack + => (Text -> next) + -> FlowMethod next + + RunSysCmd + :: HasCallStack + => String + -> (String -> next) + -> FlowMethod next + + Fork + :: HasCallStack + => Description + -> ForkGUID + -> Flow a + -> (Awaitable (Either Text a) -> next) + -> FlowMethod next + + Await + :: HasCallStack + => Maybe Microseconds + -> Awaitable (Either Text a) + -> (Either AwaitingError a -> next) + -> FlowMethod next + + ThrowException + :: forall a e next + . (HasCallStack, Exception e) + => e + -> (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 + => SafeFlowGUID + -> Flow a + -> (Either Text a -> next) + -> FlowMethod next + + InitSqlDBConnection + :: HasCallStack + => DBConfig beM + -> (DBResult (SqlConn beM) -> next) + -> FlowMethod next + + DeInitSqlDBConnection + :: HasCallStack + => SqlConn beM + -> (() -> next) + -> FlowMethod next + + GetSqlDBConnection + :: HasCallStack + => DBConfig beM + -> (DBResult (SqlConn beM) -> next) + -> FlowMethod next + + InitKVDBConnection + :: HasCallStack + => KVDBConfig + -> (KVDBAnswer KVDBConn -> next) + -> FlowMethod next + + DeInitKVDBConnection + :: HasCallStack + => KVDBConn + -> (() -> next) + -> FlowMethod next + + GetKVDBConnection + :: HasCallStack + => KVDBConfig + -> (KVDBAnswer KVDBConn -> next) + -> FlowMethod next + + RunDB + :: HasCallStack + => SqlConn beM + -> RunDBInfo beM a + -> (DBResult a -> next) + -> FlowMethod next + + RunKVDB + :: HasCallStack + => Text + -> KVDB a + -> (KVDBAnswer a -> next) + -> FlowMethod next + + RunPubSub + :: HasCallStack + => PubSub a + -> (a -> next) + -> FlowMethod next + + WithModifiedRuntime + :: HasCallStack + => (FlowRuntime -> FlowRuntime) + -> Flow a + -> (a -> next) + -> FlowMethod next + + GetSnowflakeID + :: HasCallStack + => Word8 + -> Word16 + -> String + -> (Either SnowflakeError Snowflake -> next) + -> FlowMethod next + RunDBWithConn + :: HasCallStack + => T.NativeSqlConn + -> SqlDB beM a + -> (DBResult 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 + LookupHTTPManager mSel cont -> LookupHTTPManager mSel (f . cont) + CallServantAPI mgr url apiTag errFunc client cont -> CallServantAPI mgr url apiTag errFunc client (f . cont) + GetHTTPManager settings cont -> GetHTTPManager settings (f . cont) + CallHTTP req mgr apiTag errFunc mskReqRespBody cont -> CallHTTP req mgr apiTag errFunc mskReqRespBody (f . cont) + EvalLogger logger cont -> EvalLogger logger (f . cont) + RunIO t act cont -> RunIO t act (f . cont) + WithRunFlow ioAct -> WithRunFlow (\runFlow -> f <$> ioAct runFlow) + GetOption k cont -> GetOption k (f . cont) + SetOption k v cont -> SetOption k v (f . cont) + SetLoggerContext k v cont -> SetLoggerContext k v (f . cont) + GetLoggerContext k cont -> GetLoggerContext k (f . cont) + SetLoggerContextMap v cont -> SetLoggerContextMap v (f . cont) + ModifyOption k fn cont -> ModifyOption k fn (f . cont) + DelOption k cont -> DelOption k (f . cont) + GetOptionLocal k cont -> GetOptionLocal k (f . cont) + SetOptionLocal k v cont -> SetOptionLocal k v (f . cont) + DelOptionLocal k cont -> DelOptionLocal k (f . cont) + GetRecordingLocal cont -> GetRecordingLocal (f . cont) + AppendRecordingLocal v cont -> AppendRecordingLocal v (f . cont) + DelRecordingLocal cont -> DelRecordingLocal (f . cont) + GetConfig k cont -> GetConfig k (f . cont) + SetConfig k v cont -> SetConfig k v (f . cont) + ModifyConfig k modification cont -> ModifyConfig k modification (f . cont) + TrySetConfig k v cont -> TrySetConfig k v (f . cont) + DelConfig k cont -> DelConfig k (f . cont) + AcquireConfigLock k cont -> AcquireConfigLock k (f . cont) + ReleaseConfigLock k cont -> ReleaseConfigLock k (f . cont) + GenerateGUID cont -> GenerateGUID (f . cont) + RunSysCmd cmd cont -> RunSysCmd cmd (f . cont) + 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) + GetSqlDBConnection conf cont -> GetSqlDBConnection conf (f . cont) + InitKVDBConnection conf cont -> InitKVDBConnection conf (f . cont) + DeInitKVDBConnection conn cont -> DeInitKVDBConnection conn (f . cont) + GetKVDBConnection conf cont -> GetKVDBConnection conf (f . cont) + RunDB conn dbI cont -> RunDB conn dbI (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) + GetSnowflakeID sId pId k cont -> GetSnowflakeID sId pId k (f . cont) + RunDBWithConn conn db cont -> RunDBWithConn conn db (f . cont) + + +newtype Flow (a :: Type) = Flow (F FlowMethod a) + deriving newtype (Functor, Applicative, Monad, MonadFree FlowMethod) + +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 + + +-- | MonadFlow implementation for the `Flow` Monad. This allows implementation of MonadFlow for +-- `ReaderT` and other monad transformers. +-- +-- Omit `forkFlow` as this will break some monads like StateT (you can lift this manually if you +-- know what you're doing) +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, + -- `HttpManagerNotFound` will be returne (as part of `ClientError.ConnectionError`). + -- + -- Thread safe, exception free. + -- + -- Takes remote url, servant client for this endpoint + -- and returns either client error or result. + -- + -- > data User = User { firstName :: String, lastName :: String , userGUID :: String} + -- > deriving (Generic, Show, Eq, ToJSON, FromJSON ) + -- > + -- > data Book = Book { author :: String, name :: String } + -- > deriving (Generic, Show, Eq, ToJSON, FromJSON ) + -- > + -- > type API = "user" :> Get '[JSON] User + -- > :<|> "book" :> Get '[JSON] Book + -- > + -- > api :: HasCallStack => Proxy API + -- > api = Proxy + -- > + -- > getUser :: HasCallStack => EulerClient User + -- > getBook :: HasCallStack => EulerClient Book + -- > (getUser :<|> getBook) = client api + -- > + -- > url = BaseUrl Http "localhost" port "" + -- > + -- > + -- > myFlow = do + -- > book <- callServantAPI url getBook + -- > user <- callServantAPI url getUser + callServantAPI + :: (HasCallStack, Show apiTag) + => Maybe ManagerSelector -- ^ name of the connection manager to be used + -> BaseUrl -- ^ remote url 'BaseUrl' + -> apiTag + -> (LBS.ByteString -> Maybe Log.ErrorInfo) + -> EulerClient a -- ^ servant client 'EulerClient' + -> m (Either ClientError a) -- ^ result + + callAPIUsingManager + :: (HasCallStack, Show apiTag) + => Manager + -> BaseUrl + -> apiTag + -> (LBS.ByteString -> Maybe Log.ErrorInfo) + -> EulerClient a + -> m (Either ClientError a) + + lookupHTTPManager + :: (HasCallStack, MonadFlow m) + => Maybe ManagerSelector + -> m (Maybe Manager) + + getHTTPManager + :: HasCallStack + => HTTPClientSettings + -> m Manager + + -- | Method for calling external HTTP APIs without bothering with types. + -- + -- Thread safe, exception free. + callHTTPUsingManager + :: (HasCallStack, Show apiTag) + => Manager + -> HTTPRequest + -> apiTag + -> (HTTPResponse -> Maybe Log.ErrorInfo) + -> Maybe MaskReqRespBody + -> m (Either Text.Text HTTPResponse) + + -- | Evaluates a logging action. + 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. + -- + -- Warning. This method is dangerous and should be used wisely. + -- + -- > myFlow = do + -- > content <- runIO' "reading from file" $ readFromFile file + -- > logDebugT "content id" $ extractContentId content + -- > pure content + runIO' :: HasCallStack => Text -> IO a -> m a + + -- | Gets stored a typed option by a typed key. + -- + -- Thread safe, exception free. + getOption :: forall k v. (HasCallStack, OptionEntity k v) => k -> m (Maybe v) + + -- Sets a typed option using a typed key (a mutable destructive operation) + -- + -- Be aware that it's possible to overflow the runtime with options + -- created uncontrollably. + -- + -- Also please keep in mind the options are runtime-bound and if you have + -- several API methods working with the same option key, you'll get a race. + -- + -- Thread safe, exception free. + -- + -- > data MerchantIdKey = MerchantIdKey + -- > + -- > instance OptionEntity MerchantIdKey Text + -- > + -- > myFlow = do + -- > _ <- setOption MerchantIdKey "abc1234567" + -- > mKey <- getOption MerchantIdKey + -- > runIO $ putTextLn mKey + -- > delOption MerchantIdKey + setOption :: forall k v. (HasCallStack, OptionEntity k v) => k -> v -> m () + + setLoggerContext :: (HasCallStack) => Text -> Text -> m () + + getLoggerContext :: (HasCallStack) => Text -> m (Maybe Text) + + setLoggerContextMap :: (HasCallStack) => HashMap Text Text -> m () + + -- > Problem Statement : + -- > _ <- getOption k + -- > ---- ------- + -- > ---------------------------------------- + -- > ------------- + -- > ---------------------------------------- + -- > _ <- setOption k + -- > + -- > Since the above block is not thread safe to modify an option + -- > + -- > USE MODIFYOPTION :-) + -- > It takes a key and function and applies the function if it finds a val with key + -- > + -- > + -- > Sample usage: + -- > (oldCount,modifiedCount) <- modifyOption MyCounter (\x -> x + 1) + + modifyOption :: forall k v. (HasCallStack, OptionEntity k v) => k -> (v -> v) -> m (Maybe v,Maybe v) + + -- | Deletes a typed option using a typed key. + delOption :: forall k v. (HasCallStack, OptionEntity k v) => k -> m () + + getOptionLocal :: forall k v. (HasCallStack, OptionEntity k v) => k -> m (Maybe v) + + setOptionLocal :: forall k v. (HasCallStack, OptionEntity k v) => k -> v -> m () + + delOptionLocal :: forall k v. (HasCallStack, OptionEntity k v) => k -> m () + + getRecordingLocal :: (HasCallStack) => m ([RecordingEntry]) + + appendRecordingLocal :: (HasCallStack) => RecordingEntry -> m () + + delRecordingLocal :: (HasCallStack) => m () + + getConfig :: HasCallStack => Text -> m (Maybe ConfigEntry) + + setConfig :: HasCallStack => Text -> ConfigEntry -> m () + + modifyConfig :: HasCallStack => Text -> (Maybe ConfigEntry -> ConfigEntry) -> m () + + trySetConfig :: HasCallStack => Text -> ConfigEntry -> m (Maybe ()) + + delConfig :: HasCallStack => Text -> m () + + acquireConfigLock :: HasCallStack => Text -> m Bool + + releaseConfigLock :: HasCallStack => Text -> m Bool + -- | Generate a version 4 UUIDs as specified in RFC 4122 + -- e.g. 25A8FC2A-98F2-4B86-98F6-84324AF28611. + -- + -- Thread safe, exception free. + generateGUID :: HasCallStack => m Text + + -- | Runs system command and returns its output. + -- + -- Warning. This method is dangerous and should be used wisely. + -- + -- > myFlow = do + -- > currentDir <- runSysCmd "pwd" + -- > logInfoT "currentDir" $ toText currentDir + -- > ... + runSysCmd :: HasCallStack => String -> m String + + -- | Inits an SQL connection using a config. + -- + -- Returns an error (Left $ T.DBError T.ConnectionAlreadyExists msg) + -- if the connection already exists for this config. + -- + -- Thread safe, exception free. + initSqlDBConnection :: HasCallStack => DBConfig beM -> m (DBResult (SqlConn beM)) + + -- | Deinits an SQL connection. + -- Does nothing if the connection is not found (might have been closed earlier). + -- + -- Thread safe, exception free. + deinitSqlDBConnection :: HasCallStack => SqlConn beM -> m () + + -- | Gets the existing connection. + -- + -- Returns an error (Left $ T.DBError T.ConnectionDoesNotExist) + -- if the connection does not exist. + -- + -- Thread safe, exception free. + getSqlDBConnection :: HasCallStack => DBConfig beM -> m (DBResult (SqlConn beM)) + + -- | Inits a KV DB connection using a config. + -- + -- Returns an error (Left $ KVDBError KVDBConnectionAlreadyExists msg) + -- if the connection already exists. + -- + -- Thread safe, exception free. + initKVDBConnection :: HasCallStack => KVDBConfig -> m (KVDBAnswer KVDBConn) + + -- | Deinits the given KV DB connection. + -- Does nothing if the connection is not found (might have been closed earlier). + -- + -- Thread safe, exception free. + deinitKVDBConnection :: HasCallStack => KVDBConn -> m () + + -- | Get the existing connection. + + -- Returns an error (Left $ KVDBError KVDBConnectionDoesNotExist) + -- if the connection does not exits for this config. + -- + -- Thread safe, exception free. + getKVDBConnection :: HasCallStack => KVDBConfig -> m (KVDBAnswer KVDBConn) + + -- | 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. + -- + -- The underlying library is beam which allows to access 3 different SQL backends. + -- See TUTORIAL.md, README.md and QueryExamplesSpec.hs for more info. + -- + -- > myFlow :: HasCallStack => L.Flow (T.DBResult (Maybe User)) + -- > myFlow = do + -- > connection <- L.initSqlDBConnection postgresCfg + -- > + -- > res <- L.runDB connection $ do + -- > let predicate1 User {..} = _userFirstName ==. B.val_ "John" + -- > + -- > L.updateRows $ B.update (_users db) + -- > (\User {..} -> mconcat + -- > [ _userFirstName <-. B.val_ "Leo" + -- > , _userLastName <-. B.val_ "San" + -- > ] + -- > ) + -- > predicate1 + -- > + -- > let predicate2 User {..} = _userFirstName ==. B.val_ "Leo" + -- > L.findRow + -- > $ B.select + -- > $ B.limit_ 1 + -- > $ B.filter_ predicate2 + -- > $ B.all_ (_users db) + -- > + -- > L.deinitSqlDBConnection connection + -- > pure res + runDB + :: + ( HasCallStack + , BeamRunner beM + , BeamRuntime be beM + ) + => SqlConn beM + -> SqlDB beM a + -> m (DBResult a) + + -- | Like `runDB` but runs inside a SQL transaction. + runTransaction + :: + ( HasCallStack + , BeamRunner beM + , BeamRuntime be beM + ) + => SqlConn beM + -> SqlDB beM a + -> m (DBResult a) + + -- | Await for some a result from the flow. + -- If the timeout is Nothing than the operation is blocking. + -- If the timeout is set then the internal mechanism tries to do several (10) checks for the result. + -- Can return earlier if the result became available. + -- Returns either an Awaiting error or a result. + -- + -- Warning. There are no guarantees of a proper thread delaying here. + -- + -- Thread safe, exception free. + -- + -- | mbMcs == Nothing: infinite awaiting. + -- | mbMcs == Just (Microseconds n): await for approximately n seconds. + -- Awaiting may succeed ealier. + -- + -- > myFlow1 = do + -- > logInfoT "myflow1" "logFromMyFlow1" + -- > pure 10 + -- > + -- > myFlow2 = do + -- > awaitable <- forkFlow' "myFlow1 fork" myFlow1 + -- > await Nothing awaitable + await + :: HasCallStack + => Maybe Microseconds + -> Awaitable (Either Text a) + -> m (Either AwaitingError a) + + -- | Throw a given exception. + -- + -- It's possible to catch this exception using runSafeFlow method. + -- + -- Thread safe. Exception throwing. + -- + -- > myFlow = do + -- > res <- authAction + -- > case res of + -- > Failure reason -> throwException err403 {errBody = reason} + -- > Success -> ... + throwException :: forall a e. (HasCallStack, Exception e) => e -> m a + throwException = throwM + + throwExceptionWithoutCallStack :: forall a e. (HasCallStack, Exception e) => e -> m a + throwExceptionWithoutCallStack = throwM + + -- | Run a flow safely with catching all the exceptions from it. + -- Returns either a result or the exception turned into a text message. + -- + -- This includes ususal instances of the Exception type class, + -- `error` exception and custom user exceptions thrown by the `throwException` method. + -- + -- Thread safe, exception free. + -- + -- > myFlow = runSafeFlow $ throwException err403 {errBody = reason} + -- + -- > myFlow = do + -- > eitherContent <- runSafeFlow $ runIO $ readFromFile file + -- > case eitherContent of + -- > Left err -> ... + -- > Right content -> ... + runSafeFlow :: HasCallStack => Flow a -> m (Either Text a) + + -- | Execute kvdb actions. + -- + -- Thread safe, exception free. + -- + -- > myFlow = do + -- > kvres <- L.runKVDB $ do + -- > set "aaa" "bbb" + -- > res <- get "aaa" + -- > del ["aaa"] + -- > pure res + runKVDB + :: HasCallStack + => Text + -> KVDB a -- ^ KVDB action + -> m (KVDBAnswer a) + + ---- Experimental Pub Sub implementation using Redis Pub Sub. + + runPubSub + :: HasCallStack + => PubSub a + -> m a + + -- | Publish payload to channel. + publish + :: HasCallStack + => PSL.Channel -- ^ Channel in which payload will be send + -> PSL.Payload -- ^ Payload + -> m (Either KVDBReply Integer) -- ^ Number of subscribers received payload + + -- | Subscribe to all channels from list. + -- Note: Subscription won't be unsubscribed automatically on thread end. + -- Use canceller explicitly to cancel subscription + subscribe + :: HasCallStack + => [PSL.Channel] -- ^ List of channels to subscribe + -> MessageCallback -- ^ Callback function. + -> m (Flow ()) -- ^ Inner flow is a canceller of current subscription + + -- | Subscribe to all channels from list. Respects redis pattern syntax. + -- Note: Subscription won't be unsubscribed automatically on thread end. + -- Use canceller explicitly to cancel subscription + psubscribe + :: HasCallStack + => [PSL.ChannelPattern] -- ^ List of channels to subscribe (wit respect to patterns supported by redis) + -> 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 + => (FlowRuntime -> FlowRuntime) -- ^ Temporary modification function for runtime + -> Flow a -- ^ Computation to run with modified runtime + -> m a + + fork + :: HasCallStack + => m a -> m () + + getSnowflakeID + :: HasCallStack + => Word8 + -> Word16 + -> String + -> m (Either SnowflakeError Snowflake) + + forkAwaitable + :: HasCallStack + => Description -> m a + -> m (Awaitable (Either Text a)) + + runInDBTransaction :: HasCallStack + => SqlConn beM + -> (T.NativeSqlConn -> Flow a) + -> m (DBResult a) + + runDBWithConn :: + ( HasCallStack + , BeamRunner beM + , BeamRuntime be beM + ) + => T.NativeSqlConn + -> SqlDB beM a + -> m (DBResult a) + +instance MonadFlow Flow where + {-# INLINEABLE callServantAPI #-} + callServantAPI mgrSel url apiTag errFunc cl = do + let _callServantApi mgr = ExceptT $ liftFC $ CallServantAPI mgr url apiTag errFunc cl id + runExceptT $ getMgr mgrSel >>= _callServantApi + {-# INLINEABLE callAPIUsingManager #-} + callAPIUsingManager mgr url apiTag errFunc cl = liftFC $ CallServantAPI mgr url apiTag errFunc cl id + {-# INLINEABLE lookupHTTPManager #-} + lookupHTTPManager mMgrSel = liftFC $ LookupHTTPManager mMgrSel id + {-# INLINEABLE getHTTPManager #-} + getHTTPManager settings = liftFC $ GetHTTPManager settings id + {-# INLINEABLE callHTTPUsingManager #-} + callHTTPUsingManager mgr url apiTag errFunc mskReqRespBody = liftFC $ CallHTTP url apiTag errFunc mgr mskReqRespBody id + {-# INLINEABLE evalLogger' #-} + evalLogger' logAct = liftFC $ EvalLogger logAct id + {-# INLINEABLE runIO' #-} + runIO' descr ioAct = liftFC $ RunIO descr ioAct id + {-# INLINEABLE getOption #-} + getOption :: forall k v. (HasCallStack, OptionEntity k v) => k -> Flow (Maybe v) + getOption k = liftFC $ GetOption (mkOptionKey @k @v k) id + {-# INLINEABLE setOption #-} + setOption :: forall k v. (HasCallStack, OptionEntity k v) => k -> v -> Flow () + setOption k v = liftFC $ SetOption (mkOptionKey @k @v k) v id + {-# INLINEABLE setLoggerContext #-} + setLoggerContext :: (HasCallStack) => Text -> Text -> Flow () + setLoggerContext k v = liftFC $ SetLoggerContext k v id + {-# INLINEABLE getLoggerContext #-} + getLoggerContext :: (HasCallStack) => Text -> Flow (Maybe Text) + getLoggerContext k = liftFC $ GetLoggerContext k id + {-# INLINEABLE setLoggerContextMap #-} + setLoggerContextMap :: (HasCallStack) => HashMap Text Text -> Flow () + setLoggerContextMap v = liftFC $ SetLoggerContextMap v id + {-# INLINEABLE modifyOption #-} + modifyOption :: forall k v. (HasCallStack, OptionEntity k v) => k -> (v -> v) -> Flow (Maybe v,Maybe v) + modifyOption k fn = liftFC $ ModifyOption (mkOptionKey @k @v k) fn id + {-# INLINEABLE delOption #-} + delOption :: forall k v. (HasCallStack, OptionEntity k v) => k -> Flow () + delOption k = liftFC $ DelOption (mkOptionKey @k @v k) id + {-# INLINEABLE getOptionLocal #-} + getOptionLocal :: forall k v. (HasCallStack, OptionEntity k v) => k -> Flow (Maybe v) + getOptionLocal k = liftFC $ GetOptionLocal (mkOptionKey @k @v k) id + {-# INLINEABLE setOptionLocal #-} + setOptionLocal :: forall k v. (HasCallStack, OptionEntity k v) => k -> v -> Flow () + setOptionLocal k v = liftFC $ SetOptionLocal (mkOptionKey @k @v k) v id + {-# INLINEABLE delOptionLocal #-} + delOptionLocal :: forall k v. (HasCallStack, OptionEntity k v) => k -> Flow () + delOptionLocal k = liftFC $ DelOptionLocal (mkOptionKey @k @v k) id + {-# INLINEABLE getRecordingLocal #-} + getRecordingLocal :: (HasCallStack) => Flow ([RecordingEntry]) + getRecordingLocal = liftFC $ GetRecordingLocal id + {-# INLINEABLE appendRecordingLocal #-} + appendRecordingLocal :: (HasCallStack) => RecordingEntry -> Flow () + appendRecordingLocal v = liftFC $ AppendRecordingLocal v id + {-# INLINEABLE delRecordingLocal #-} + delRecordingLocal :: (HasCallStack) => Flow () + delRecordingLocal = liftFC $ DelRecordingLocal id + {-# INLINEABLE getConfig #-} + getConfig :: HasCallStack => Text -> Flow (Maybe ConfigEntry) + getConfig k = liftFC $ GetConfig k id + {-# INLINEABLE setConfig #-} + setConfig :: HasCallStack => Text -> ConfigEntry -> Flow () + setConfig k v = liftFC $ SetConfig k v id + {-# INLINEABLE modifyConfig #-} + modifyConfig :: HasCallStack => Text -> (Maybe ConfigEntry -> ConfigEntry) -> Flow () + modifyConfig k modification = liftFC $ ModifyConfig k modification id + {-# INLINEABLE trySetConfig #-} + trySetConfig :: HasCallStack => Text -> ConfigEntry -> Flow (Maybe ()) + trySetConfig k v = liftFC $ TrySetConfig k v id + {-# INLINEABLE delConfig #-} + delConfig :: HasCallStack => Text -> Flow () + delConfig k = liftFC $ DelConfig k id + {-# INLINEABLE acquireConfigLock #-} + acquireConfigLock :: HasCallStack => Text -> Flow Bool + acquireConfigLock k = liftFC $ AcquireConfigLock k id + {-# INLINEABLE releaseConfigLock #-} + releaseConfigLock :: HasCallStack => Text -> Flow Bool + releaseConfigLock k = liftFC $ ReleaseConfigLock k id + {-# INLINEABLE generateGUID #-} + generateGUID = liftFC $ GenerateGUID id + {-# INLINEABLE runSysCmd #-} + runSysCmd cmd = liftFC $ RunSysCmd cmd id + {-# INLINEABLE initSqlDBConnection #-} + initSqlDBConnection cfg = liftFC $ InitSqlDBConnection cfg id + {-# INLINEABLE deinitSqlDBConnection #-} + deinitSqlDBConnection conn = liftFC $ DeInitSqlDBConnection conn id + {-# INLINEABLE getSqlDBConnection #-} + getSqlDBConnection cfg = liftFC $ GetSqlDBConnection cfg id + {-# INLINEABLE initKVDBConnection #-} + initKVDBConnection cfg = liftFC $ InitKVDBConnection cfg id + {-# INLINEABLE deinitKVDBConnection #-} + deinitKVDBConnection conn = liftFC $ DeInitKVDBConnection conn id + {-# INLINEABLE getKVDBConnection #-} + getKVDBConnection cfg = liftFC $ GetKVDBConnection cfg id + {-# INLINEABLE runDB #-} + runDB conn dbAct = liftFC $ RunDB conn (SqlDBFlow dbAct False) id + {-# INLINEABLE runTransaction #-} + runTransaction conn dbAct = liftFC $ RunDB conn (SqlDBFlow dbAct True) id + {-# INLINEABLE await #-} + await mbMcs awaitable = liftFC $ Await mbMcs awaitable id + {-# INLINEABLE runSafeFlow #-} + runSafeFlow flow = do + safeFlowGUID <- generateGUID + liftFC $ RunSafeFlow safeFlowGUID flow id + {-# INLINEABLE runKVDB #-} + runKVDB cName act = do + res <- liftFC $ RunKVDB cName act id + case res of + Left err -> incrementRedisMetric err cName *> pure res + Right _ -> pure res + {-# INLINEABLE runPubSub #-} + runPubSub act = liftFC $ RunPubSub act id + {-# INLINEABLE publish #-} + publish channel payload = runPubSub $ PubSub $ const $ PSL.publish channel payload + {-# INLINEABLE subscribe #-} + subscribe channels cb = fmap (runIO' "subscribe") $ + runPubSub $ PubSub $ \runFlow -> PSL.subscribe channels (runFlow . cb) + {-# 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 + {-# INLINEABLE fork #-} + fork flow = do + forkFlow "test" flow + {-# INLINEABLE getSnowflakeID #-} + getSnowflakeID sId pId k = liftFC $ GetSnowflakeID sId pId k id + {-# INLINEABLE forkAwaitable #-} + forkAwaitable description flow = do + forkFlow' description flow + {-# INLINEABLE runInDBTransaction #-} + runInDBTransaction conf flow = liftFC $ RunDB conf (TransactionFlow flow) id + {-# INLINEABLE runDBWithConn #-} + runDBWithConn conn dbAction = liftFC $ RunDBWithConn conn dbAction id + +instance MonadFlow m => MonadFlow (ReaderT r m) where + {-# INLINEABLE callServantAPI #-} + callServantAPI mbMgrSel url apiTag errFunc = lift . callServantAPI mbMgrSel url apiTag errFunc + {-# INLINEABLE callAPIUsingManager #-} + callAPIUsingManager mgr url apiTag errFunc = lift . callAPIUsingManager mgr url apiTag errFunc + {-# INLINEABLE lookupHTTPManager #-} + lookupHTTPManager = lift . lookupHTTPManager + {-# INLINEABLE getHTTPManager #-} + getHTTPManager = lift . getHTTPManager + {-# INLINEABLE callHTTPUsingManager #-} + callHTTPUsingManager mgr url apiTag errFunc mskReqRespBody = lift $ callHTTPUsingManager mgr url apiTag errFunc mskReqRespBody + {-# INLINEABLE evalLogger' #-} + evalLogger' = lift . evalLogger' + {-# INLINEABLE runIO' #-} + runIO' descr = lift . runIO' descr + {-# INLINEABLE getOption #-} + getOption = lift . getOption + {-# INLINEABLE setOption #-} + setOption k = lift . setOption k + {-# INLINEABLE setLoggerContext #-} + setLoggerContext k = lift . setLoggerContext k + {-# INLINEABLE getLoggerContext #-} + getLoggerContext = lift . getLoggerContext + {-# INLINEABLE setLoggerContextMap #-} + setLoggerContextMap = lift . setLoggerContextMap + {-# INLINEABLE modifyOption #-} + modifyOption k = lift . modifyOption k + {-# INLINEABLE delOption #-} + delOption = lift . delOption + {-# INLINEABLE getOptionLocal #-} + getOptionLocal = lift . getOptionLocal + {-# INLINEABLE setOptionLocal #-} + setOptionLocal k = lift . setOptionLocal k + {-# INLINEABLE delOptionLocal #-} + delOptionLocal = lift . delOptionLocal + {-# INLINEABLE getRecordingLocal #-} + getRecordingLocal = lift getRecordingLocal + {-# INLINEABLE appendRecordingLocal #-} + appendRecordingLocal = lift . appendRecordingLocal + {-# INLINEABLE delRecordingLocal #-} + delRecordingLocal = lift delRecordingLocal + {-# INLINEABLE getConfig #-} + getConfig = lift . getConfig + {-# INLINEABLE setConfig #-} + setConfig k = lift . setConfig k + {-# INLINEABLE modifyConfig #-} + modifyConfig k = lift . modifyConfig k + {-# INLINEABLE trySetConfig #-} + trySetConfig k = lift . trySetConfig k + {-# INLINEABLE delConfig #-} + delConfig = lift . delConfig + {-# INLINEABLE acquireConfigLock #-} + acquireConfigLock = lift . acquireConfigLock + {-# INLINEABLE releaseConfigLock #-} + releaseConfigLock = lift . releaseConfigLock + {-# INLINEABLE generateGUID #-} + generateGUID = lift generateGUID + {-# INLINEABLE runSysCmd #-} + runSysCmd = lift . runSysCmd + {-# INLINEABLE initSqlDBConnection #-} + initSqlDBConnection = lift . initSqlDBConnection + {-# INLINEABLE deinitSqlDBConnection #-} + deinitSqlDBConnection = lift . deinitSqlDBConnection + {-# INLINEABLE getSqlDBConnection #-} + getSqlDBConnection = lift . getSqlDBConnection + {-# INLINEABLE initKVDBConnection #-} + initKVDBConnection = lift . initKVDBConnection + {-# INLINEABLE deinitKVDBConnection #-} + deinitKVDBConnection = lift . deinitKVDBConnection + {-# INLINEABLE getKVDBConnection #-} + getKVDBConnection = lift . getKVDBConnection + {-# INLINEABLE runDB #-} + runDB conn = lift . runDB conn + {-# INLINEABLE runTransaction #-} + runTransaction conn = lift . runTransaction conn + {-# INLINEABLE await #-} + await mbMcs = lift . await mbMcs + {-# INLINEABLE runSafeFlow #-} + runSafeFlow = lift . runSafeFlow + {-# INLINEABLE runKVDB #-} + runKVDB cName = lift . runKVDB cName + {-# INLINEABLE runPubSub #-} + runPubSub = lift . runPubSub + {-# INLINEABLE publish #-} + publish channel = lift . publish channel + {-# INLINEABLE subscribe #-} + subscribe channels = lift . subscribe channels + {-# INLINEABLE psubscribe #-} + psubscribe channels = lift . psubscribe channels + {-# INLINEABLE withModifiedRuntime #-} + withModifiedRuntime f = lift . withModifiedRuntime f + {-# INLINEABLE fork #-} + fork flow = do + env <- ask + lift . fork $ runReaderT flow env + {-# INLINEABLE getSnowflakeID #-} + getSnowflakeID sId pId = lift . getSnowflakeID sId pId + {-# INLINEABLE forkAwaitable #-} + forkAwaitable description flow = do + env <- ask + lift $ forkAwaitable description $ runReaderT flow env + {-# INLINEABLE runInDBTransaction #-} + runInDBTransaction conn = lift . runInDBTransaction conn + {-# INLINEABLE runDBWithConn #-} + runDBWithConn conn = lift . runDBWithConn conn + +instance MonadFlow m => MonadFlow (StateT s m) where + {-# INLINEABLE callServantAPI #-} + callServantAPI mbMgrSel url apiTag errFunc = lift . callServantAPI mbMgrSel url apiTag errFunc + {-# INLINEABLE callAPIUsingManager #-} + callAPIUsingManager mgr url apiTag errFunc = lift . callAPIUsingManager mgr url apiTag errFunc + {-# INLINEABLE lookupHTTPManager #-} + lookupHTTPManager = lift . lookupHTTPManager + {-# INLINEABLE getHTTPManager #-} + getHTTPManager = lift . getHTTPManager + {-# INLINEABLE callHTTPUsingManager #-} + callHTTPUsingManager mgr url apiTag respFunc mskReqRespBody = lift $ callHTTPUsingManager mgr url apiTag respFunc mskReqRespBody + {-# INLINEABLE evalLogger' #-} + evalLogger' = lift . evalLogger' + {-# INLINEABLE runIO' #-} + runIO' descr = lift . runIO' descr + {-# INLINEABLE getOption #-} + getOption = lift . getOption + {-# INLINEABLE setOption #-} + setOption k = lift . setOption k + {-# INLINEABLE setLoggerContext #-} + setLoggerContext k = lift . setLoggerContext k + {-# INLINEABLE getLoggerContext #-} + getLoggerContext = lift . getLoggerContext + {-# INLINEABLE setLoggerContextMap #-} + setLoggerContextMap = lift . setLoggerContextMap + {-# INLINEABLE modifyOption #-} + modifyOption fn = lift . modifyOption fn + {-# INLINEABLE delOption #-} + delOption = lift . delOption + {-# INLINEABLE getOptionLocal #-} + getOptionLocal = lift . getOptionLocal + {-# INLINEABLE setOptionLocal #-} + setOptionLocal k = lift . setOptionLocal k + {-# INLINEABLE delOptionLocal #-} + delOptionLocal = lift . delOptionLocal + {-# INLINEABLE getRecordingLocal #-} + getRecordingLocal = lift getRecordingLocal + {-# INLINEABLE appendRecordingLocal #-} + appendRecordingLocal = lift . appendRecordingLocal + {-# INLINEABLE delRecordingLocal #-} + delRecordingLocal = lift delRecordingLocal + {-# INLINEABLE getConfig #-} + getConfig = lift . getConfig + {-# INLINEABLE setConfig #-} + setConfig k = lift . setConfig k + {-# INLINEABLE modifyConfig #-} + modifyConfig k = lift . modifyConfig k + {-# INLINEABLE trySetConfig #-} + trySetConfig k = lift . trySetConfig k + {-# INLINEABLE delConfig #-} + delConfig = lift . delConfig + {-# INLINEABLE acquireConfigLock #-} + acquireConfigLock = lift . acquireConfigLock + {-# INLINEABLE releaseConfigLock #-} + releaseConfigLock = lift . releaseConfigLock + {-# INLINEABLE generateGUID #-} + generateGUID = lift generateGUID + {-# INLINEABLE runSysCmd #-} + runSysCmd = lift . runSysCmd + {-# INLINEABLE initSqlDBConnection #-} + initSqlDBConnection = lift . initSqlDBConnection + {-# INLINEABLE deinitSqlDBConnection #-} + deinitSqlDBConnection = lift . deinitSqlDBConnection + {-# INLINEABLE getSqlDBConnection #-} + getSqlDBConnection = lift . getSqlDBConnection + {-# INLINEABLE initKVDBConnection #-} + initKVDBConnection = lift . initKVDBConnection + {-# INLINEABLE deinitKVDBConnection #-} + deinitKVDBConnection = lift . deinitKVDBConnection + {-# INLINEABLE getKVDBConnection #-} + getKVDBConnection = lift . getKVDBConnection + {-# INLINEABLE runDB #-} + runDB conn = lift . runDB conn + {-# INLINEABLE runTransaction #-} + runTransaction conn = lift . runTransaction conn + {-# INLINEABLE await #-} + await mbMcs = lift . await mbMcs + {-# INLINEABLE runSafeFlow #-} + runSafeFlow = lift . runSafeFlow + {-# INLINEABLE runKVDB #-} + runKVDB cName = lift . runKVDB cName + {-# INLINEABLE runPubSub #-} + runPubSub = lift . runPubSub + {-# INLINEABLE publish #-} + publish channel = lift . publish channel + {-# INLINEABLE subscribe #-} + subscribe channels = lift . subscribe channels + {-# INLINEABLE psubscribe #-} + psubscribe channels = lift . psubscribe channels + {-# INLINEABLE withModifiedRuntime #-} + withModifiedRuntime f = lift . withModifiedRuntime f + {-# INLINEABLE fork #-} + fork flow = do + s <- get + lift . fork $ evalStateT flow s + {-# INLINEABLE getSnowflakeID #-} + getSnowflakeID sId pId = lift . getSnowflakeID sId pId + {-# INLINEABLE forkAwaitable #-} + forkAwaitable description flow = do + s <- get + lift $ forkAwaitable description $ evalStateT flow s + {-# INLINEABLE runInDBTransaction #-} + runInDBTransaction conn = lift . runInDBTransaction conn + {-# INLINEABLE runDBWithConn #-} + runDBWithConn conn = lift . runDBWithConn conn + +instance (MonadFlow m, Monoid w) => MonadFlow (WriterT w m) where + {-# INLINEABLE callServantAPI #-} + callServantAPI mbMgrSel url apiTag errFunc = lift . callServantAPI mbMgrSel url apiTag errFunc + {-# INLINEABLE callAPIUsingManager #-} + callAPIUsingManager mgr url apiTag errFunc = lift . callAPIUsingManager mgr url apiTag errFunc + {-# INLINEABLE lookupHTTPManager #-} + lookupHTTPManager = lift . lookupHTTPManager + {-# INLINEABLE getHTTPManager #-} + getHTTPManager = lift . getHTTPManager + {-# INLINEABLE callHTTPUsingManager #-} + callHTTPUsingManager mgr url apiTag errFunc mskReqRespBody = lift $ callHTTPUsingManager mgr url apiTag errFunc mskReqRespBody + {-# INLINEABLE evalLogger' #-} + evalLogger' = lift . evalLogger' + {-# INLINEABLE runIO' #-} + runIO' descr = lift . runIO' descr + {-# INLINEABLE getOption #-} + getOption = lift . getOption + {-# INLINEABLE setOption #-} + setOption k = lift . setOption k + {-# INLINEABLE setLoggerContext #-} + setLoggerContext k = lift . setLoggerContext k + {-# INLINEABLE getLoggerContext #-} + getLoggerContext = lift . getLoggerContext + {-# INLINEABLE setLoggerContextMap #-} + setLoggerContextMap = lift . setLoggerContextMap + {-# INLINEABLE modifyOption #-} + modifyOption fn = lift . modifyOption fn + {-# INLINEABLE delOption #-} + delOption = lift . delOption + {-# INLINEABLE getOptionLocal #-} + getOptionLocal = lift . getOptionLocal + {-# INLINEABLE setOptionLocal #-} + setOptionLocal k = lift . setOptionLocal k + {-# INLINEABLE delOptionLocal #-} + delOptionLocal = lift . delOptionLocal + {-# INLINEABLE getRecordingLocal #-} + getRecordingLocal = lift getRecordingLocal + {-# INLINEABLE appendRecordingLocal #-} + appendRecordingLocal = lift . appendRecordingLocal + {-# INLINEABLE delRecordingLocal #-} + delRecordingLocal = lift delRecordingLocal + {-# INLINEABLE getConfig #-} + getConfig = lift . getConfig + {-# INLINEABLE setConfig #-} + setConfig k = lift . setConfig k + {-# INLINEABLE modifyConfig #-} + modifyConfig k = lift . modifyConfig k + {-# INLINEABLE trySetConfig #-} + trySetConfig k = lift . trySetConfig k + {-# INLINEABLE delConfig #-} + delConfig = lift . delConfig + {-# INLINEABLE acquireConfigLock #-} + acquireConfigLock = lift . acquireConfigLock + {-# INLINEABLE releaseConfigLock #-} + releaseConfigLock = lift . releaseConfigLock + {-# INLINEABLE generateGUID #-} + generateGUID = lift generateGUID + {-# INLINEABLE runSysCmd #-} + runSysCmd = lift . runSysCmd + {-# INLINEABLE initSqlDBConnection #-} + initSqlDBConnection = lift . initSqlDBConnection + {-# INLINEABLE deinitSqlDBConnection #-} + deinitSqlDBConnection = lift . deinitSqlDBConnection + {-# INLINEABLE getSqlDBConnection #-} + getSqlDBConnection = lift . getSqlDBConnection + {-# INLINEABLE initKVDBConnection #-} + initKVDBConnection = lift . initKVDBConnection + {-# INLINEABLE deinitKVDBConnection #-} + deinitKVDBConnection = lift . deinitKVDBConnection + {-# INLINEABLE getKVDBConnection #-} + getKVDBConnection = lift . getKVDBConnection + {-# INLINEABLE runDB #-} + runDB conn = lift . runDB conn + {-# INLINEABLE runTransaction #-} + runTransaction conn = lift . runTransaction conn + {-# INLINEABLE await #-} + await mbMcs = lift . await mbMcs + {-# INLINEABLE runSafeFlow #-} + runSafeFlow = lift . runSafeFlow + {-# INLINEABLE runKVDB #-} + runKVDB cName = lift . runKVDB cName + {-# INLINEABLE runPubSub #-} + runPubSub = lift . runPubSub + {-# INLINEABLE publish #-} + publish channel = lift . publish channel + {-# INLINEABLE subscribe #-} + subscribe channels = lift . subscribe channels + {-# INLINEABLE psubscribe #-} + psubscribe channels = lift . psubscribe channels + {-# INLINEABLE withModifiedRuntime #-} + withModifiedRuntime f = lift . withModifiedRuntime f + {-# INLINEABLE fork #-} + fork = error "Not implemented" + {-# INLINEABLE getSnowflakeID #-} + getSnowflakeID sId pId = lift . getSnowflakeID sId pId + {-# INLINEABLE forkAwaitable #-} + forkAwaitable = error "Not implemented" + {-# INLINEABLE runInDBTransaction #-} + runInDBTransaction conn = lift . runInDBTransaction conn + {-# INLINEABLE runDBWithConn #-} + runDBWithConn conn = lift . runDBWithConn conn + +instance MonadFlow m => MonadFlow (ExceptT e m) where + {-# INLINEABLE callServantAPI #-} + callServantAPI mbMgrSel url apiTag errFunc = lift . callServantAPI mbMgrSel url apiTag errFunc + {-# INLINEABLE callAPIUsingManager #-} + callAPIUsingManager mgr url apiTag errFunc = lift . callAPIUsingManager mgr url apiTag errFunc + {-# INLINEABLE lookupHTTPManager #-} + lookupHTTPManager = lift . lookupHTTPManager + {-# INLINEABLE getHTTPManager #-} + getHTTPManager = lift . getHTTPManager + {-# INLINEABLE callHTTPUsingManager #-} + callHTTPUsingManager mgr url apiTag errFunc mskReqRespBody = lift $ callHTTPUsingManager mgr url apiTag errFunc mskReqRespBody + {-# INLINEABLE evalLogger' #-} + evalLogger' = lift . evalLogger' + {-# INLINEABLE runIO' #-} + runIO' descr = lift . runIO' descr + {-# INLINEABLE getOption #-} + getOption = lift . getOption + {-# INLINEABLE setOption #-} + setOption k = lift . setOption k + {-# INLINEABLE setLoggerContext #-} + setLoggerContext k = lift . setLoggerContext k + {-# INLINEABLE getLoggerContext #-} + getLoggerContext = lift . getLoggerContext + {-# INLINEABLE setLoggerContextMap #-} + setLoggerContextMap = lift . setLoggerContextMap + {-# INLINEABLE modifyOption #-} + modifyOption fn = lift . modifyOption fn + {-# INLINEABLE delOption #-} + delOption = lift . delOption + {-# INLINEABLE getOptionLocal #-} + getOptionLocal = lift . getOptionLocal + {-# INLINEABLE setOptionLocal #-} + setOptionLocal k = lift . setOptionLocal k + {-# INLINEABLE delOptionLocal #-} + delOptionLocal = lift . delOptionLocal + {-# INLINEABLE getRecordingLocal #-} + getRecordingLocal = lift getRecordingLocal + {-# INLINEABLE appendRecordingLocal #-} + appendRecordingLocal = lift . appendRecordingLocal + {-# INLINEABLE delRecordingLocal #-} + delRecordingLocal = lift delRecordingLocal + {-# INLINEABLE getConfig #-} + getConfig = lift . getConfig + {-# INLINEABLE setConfig #-} + setConfig k = lift . setConfig k + {-# INLINEABLE modifyConfig #-} + modifyConfig k = lift . modifyConfig k + {-# INLINEABLE trySetConfig #-} + trySetConfig k = lift . trySetConfig k + {-# INLINEABLE delConfig #-} + delConfig = lift . delConfig + {-# INLINEABLE acquireConfigLock #-} + acquireConfigLock = lift . acquireConfigLock + {-# INLINEABLE releaseConfigLock #-} + releaseConfigLock = lift . releaseConfigLock + {-# INLINEABLE generateGUID #-} + generateGUID = lift generateGUID + {-# INLINEABLE runSysCmd #-} + runSysCmd = lift . runSysCmd + {-# INLINEABLE initSqlDBConnection #-} + initSqlDBConnection = lift . initSqlDBConnection + {-# INLINEABLE deinitSqlDBConnection #-} + deinitSqlDBConnection = lift . deinitSqlDBConnection + {-# INLINEABLE getSqlDBConnection #-} + getSqlDBConnection = lift . getSqlDBConnection + {-# INLINEABLE initKVDBConnection #-} + initKVDBConnection = lift . initKVDBConnection + {-# INLINEABLE deinitKVDBConnection #-} + deinitKVDBConnection = lift . deinitKVDBConnection + {-# INLINEABLE getKVDBConnection #-} + getKVDBConnection = lift . getKVDBConnection + {-# INLINEABLE runDB #-} + runDB conn = lift . runDB conn + {-# INLINEABLE runTransaction #-} + runTransaction conn = lift . runTransaction conn + {-# INLINEABLE await #-} + await mbMcs = lift . await mbMcs + {-# INLINEABLE runSafeFlow #-} + runSafeFlow = lift . runSafeFlow + {-# INLINEABLE runKVDB #-} + runKVDB cName = lift . runKVDB cName + {-# INLINEABLE runPubSub #-} + runPubSub = lift . runPubSub + {-# INLINEABLE publish #-} + publish channel = lift . publish channel + {-# INLINEABLE subscribe #-} + subscribe channels = lift . subscribe channels + {-# INLINEABLE psubscribe #-} + psubscribe channels = lift . psubscribe channels + {-# INLINEABLE withModifiedRuntime #-} + withModifiedRuntime f = lift . withModifiedRuntime f + {-# INLINEABLE fork #-} + fork = error "Not implemented" + {-# INLINEABLE getSnowflakeID #-} + getSnowflakeID sId pId = lift . getSnowflakeID sId pId + {-# INLINEABLE forkAwaitable #-} + forkAwaitable = error "Not implemented" + {-# INLINEABLE runInDBTransaction #-} + runInDBTransaction conn = lift . runInDBTransaction conn + {-# INLINEABLE runDBWithConn #-} + runDBWithConn conn = lift . runDBWithConn conn + +instance (MonadFlow m, Monoid w) => MonadFlow (RWST r w s m) where + {-# INLINEABLE callServantAPI #-} + callServantAPI mbMgrSel url apiTag errFunc = lift . callServantAPI mbMgrSel url apiTag errFunc + {-# INLINEABLE callAPIUsingManager #-} + callAPIUsingManager mgr url apiTag errFunc = lift . callAPIUsingManager mgr url apiTag errFunc + {-# INLINEABLE lookupHTTPManager #-} + lookupHTTPManager = lift . lookupHTTPManager + {-# INLINEABLE getHTTPManager #-} + getHTTPManager = lift . getHTTPManager + {-# INLINEABLE callHTTPUsingManager #-} + callHTTPUsingManager mgr url apiTag errFunc mskReqRespBody = lift $ callHTTPUsingManager mgr url apiTag errFunc mskReqRespBody + {-# INLINEABLE evalLogger' #-} + evalLogger' = lift . evalLogger' + {-# INLINEABLE runIO' #-} + runIO' descr = lift . runIO' descr + {-# INLINEABLE getOption #-} + getOption = lift . getOption + {-# INLINEABLE setOption #-} + setOption k = lift . setOption k + {-# INLINEABLE setLoggerContext #-} + setLoggerContext k = lift . setLoggerContext k + {-# INLINEABLE getLoggerContext #-} + getLoggerContext = lift . getLoggerContext + {-# INLINEABLE setLoggerContextMap #-} + setLoggerContextMap = lift . setLoggerContextMap + {-# INLINEABLE modifyOption #-} + modifyOption fn = lift . modifyOption fn + {-# INLINEABLE delOption #-} + delOption = lift . delOption + {-# INLINEABLE getOptionLocal #-} + getOptionLocal = lift . getOptionLocal + {-# INLINEABLE setOptionLocal #-} + setOptionLocal k = lift . setOptionLocal k + {-# INLINEABLE delOptionLocal #-} + delOptionLocal = lift . delOptionLocal + {-# INLINEABLE getRecordingLocal #-} + getRecordingLocal = lift getRecordingLocal + {-# INLINEABLE appendRecordingLocal #-} + appendRecordingLocal = lift . appendRecordingLocal + {-# INLINEABLE delRecordingLocal #-} + delRecordingLocal = lift delRecordingLocal + {-# INLINEABLE getConfig #-} + getConfig = lift . getConfig + {-# INLINEABLE setConfig #-} + setConfig k = lift . setConfig k + {-# INLINEABLE modifyConfig #-} + modifyConfig k = lift . modifyConfig k + {-# INLINEABLE trySetConfig #-} + trySetConfig k = lift . trySetConfig k + {-# INLINEABLE delConfig #-} + delConfig = lift . delConfig + {-# INLINEABLE acquireConfigLock #-} + acquireConfigLock = lift . acquireConfigLock + {-# INLINEABLE releaseConfigLock #-} + releaseConfigLock = lift . releaseConfigLock + {-# INLINEABLE generateGUID #-} + generateGUID = lift generateGUID + {-# INLINEABLE runSysCmd #-} + runSysCmd = lift . runSysCmd + {-# INLINEABLE initSqlDBConnection #-} + initSqlDBConnection = lift . initSqlDBConnection + {-# INLINEABLE deinitSqlDBConnection #-} + deinitSqlDBConnection = lift . deinitSqlDBConnection + {-# INLINEABLE getSqlDBConnection #-} + getSqlDBConnection = lift . getSqlDBConnection + {-# INLINEABLE initKVDBConnection #-} + initKVDBConnection = lift . initKVDBConnection + {-# INLINEABLE deinitKVDBConnection #-} + deinitKVDBConnection = lift . deinitKVDBConnection + {-# INLINEABLE getKVDBConnection #-} + getKVDBConnection = lift . getKVDBConnection + {-# INLINEABLE runDB #-} + runDB conn = lift . runDB conn + {-# INLINEABLE runTransaction #-} + runTransaction conn = lift . runTransaction conn + {-# INLINEABLE await #-} + await mbMcs = lift . await mbMcs + {-# INLINEABLE runSafeFlow #-} + runSafeFlow = lift . runSafeFlow + {-# INLINEABLE runKVDB #-} + runKVDB cName = lift . runKVDB cName + {-# INLINEABLE runPubSub #-} + runPubSub = lift . runPubSub + {-# INLINEABLE publish #-} + publish channel = lift . publish channel + {-# INLINEABLE subscribe #-} + subscribe channels = lift . subscribe channels + {-# INLINEABLE psubscribe #-} + psubscribe channels = lift . psubscribe channels + {-# INLINEABLE withModifiedRuntime #-} + withModifiedRuntime f = lift . withModifiedRuntime f + {-# INLINEABLE fork #-} + fork = error "Not implemented" + {-# INLINEABLE getSnowflakeID #-} + getSnowflakeID sId pId = lift . getSnowflakeID sId pId + {-# INLINEABLE forkAwaitable #-} + forkAwaitable = error "Not implemented" + {-# INLINEABLE runInDBTransaction #-} + runInDBTransaction conn = lift . runInDBTransaction conn + {-# INLINEABLE runDBWithConn #-} + runDBWithConn conn = lift . runDBWithConn conn + + + +-- +-- +-- Additional actions +-- +-- + + + + +-- +-- HTTP managers +-- + +selectManager :: MonadFlow m => ManagerSelector -> m (Maybe Manager) +selectManager m = lookupHTTPManager $ Just m + +getDefaultManager :: MonadFlow m => m Manager +getDefaultManager = fromJust <$> lookupHTTPManager Nothing + +getMgr :: MonadFlow m => Maybe ManagerSelector -> ExceptT ClientError m Manager +getMgr mgrSel = + ExceptT $ case mgrSel of + Nothing -> Right <$> getDefaultManager + Just sel@(ManagerSelector name) -> do + mmgr <- selectManager sel + case mmgr of + Just mgr -> pure $ Right mgr + Nothing -> pure $ Left $ + ConnectionError $ toException $ HttpManagerNotFound name + +-- +-- Untyped HTTP calls +-- + +-- | Method for calling external HTTP APIs without bothering with types with custom manager. +-- +-- Thread safe, exception free. +-- +-- Takes remote url, optional custom manager selector and returns either client error or result. +-- +-- > myFlow = do +-- > book <- callHTTPWithManager url mSel +callHTTP' + :: (HasCallStack, MonadFlow m, Show apiTag) + => Maybe ManagerSelector -- ^ Selector + -> HTTPRequest -- ^ remote url 'Text' + -> apiTag + -> (HTTPResponse -> Maybe Log.ErrorInfo) + -> Maybe MaskReqRespBody + -> m (Either Text.Text HTTPResponse) -- ^ result +callHTTP' mSel req apiTag errFunc mbMskReqRespBody = do + runExceptT $ withExceptT show (getMgr mSel) >>= (\mngr -> ExceptT $ callHTTPUsingManager mngr req apiTag errFunc mbMskReqRespBody) + +{-# DEPRECATED callHTTPWithManager "Use callHTTP' instead. This method has a confusing name, as it accepts a selector not a manager." #-} +callHTTPWithManager + :: (HasCallStack, MonadFlow m, Show apiTag) + => Maybe ManagerSelector -- ^ Selector + -> HTTPRequest -- ^ remote url 'Text' + -> apiTag + -> (HTTPResponse -> Maybe Log.ErrorInfo) + -> m (Either Text.Text HTTPResponse) -- ^ result +callHTTPWithManager mSel req apiTag errFunc = callHTTP' mSel req apiTag errFunc Nothing + +-- applies custom masking function while logging outgoing request +callHTTPWithManager' + :: (HasCallStack, MonadFlow m, Show apiTag) + => Maybe ManagerSelector -- ^ Selector + -> HTTPRequest -- ^ remote url 'Text' + -> apiTag + -> (HTTPResponse -> Maybe Log.ErrorInfo) + -> Maybe MaskReqRespBody + -> m (Either Text.Text HTTPResponse) -- ^ result +callHTTPWithManager' = callHTTP' + +-- | The same as callHTTP' but uses the default HTTP manager. +-- +-- Thread safe, exception free. +-- +-- Takes remote url and returns either client error or result. +-- +-- > myFlow = do +-- > book <- callHTTP url +callHTTP :: (HasCallStack, MonadFlow m, Show apiTag) => + HTTPRequest -> apiTag -> (HTTPResponse -> Maybe Log.ErrorInfo) -> m (Either Text.Text HTTPResponse) +callHTTP url = callHTTPWithManager Nothing url + +{-# DEPRECATED callHTTPWithCert "Use getHTTPManager/callHTTPUsingManager instead. This method does not allow custom CA store." #-} +callHTTPWithCert :: (MonadFlow m, Show apiTag) => HTTPRequest -> apiTag -> (HTTPResponse -> Maybe Log.ErrorInfo) -> Maybe HTTPCert -> m (Either Text HTTPResponse) +callHTTPWithCert req apiTag errFunc cert = do + mgr <- maybe getDefaultManager (getHTTPManager . withClientTls) cert + callHTTPUsingManager mgr req apiTag errFunc Nothing + +-- applies custom masking function while logging outgoing request +callHTTPWithCert' :: (Show apiTag, MonadFlow m) => HTTPRequest -> Maybe HTTPCert -> apiTag -> (HTTPResponse -> Maybe Log.ErrorInfo) -> Maybe MaskReqRespBody-> m (Either Text HTTPResponse) +callHTTPWithCert' req cert apiTag errFunc mskReqRespBody = do + mgr <- maybe getDefaultManager (getHTTPManager . withClientTls) cert + callHTTPUsingManager mgr req apiTag errFunc mskReqRespBody + +-- To extract the MySQL connection +-- Restricted Function, not for external usecase +getMySQLConnection :: (HasCallStack, MonadIO m, MonadFlow m) => DBConfig beM -> m (Either Text MySQL.MySQLConn) +getMySQLConnection dbConf = do + eConn <- getSqlDBConnection dbConf + case eConn of + Right (T.MySQLPool _ pool) -> do + myConn <- liftIO $ DP.withResource pool pure + pure $ Right myConn + Right _ -> pure $ Left "Could not fetch MySQL DB connection" + Left err -> pure $ Left $ "Error in getting connection: " <> (show err) +-- +-- Well-typed HTTP calls +-- + +-- | 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 returne (as part of `ClientError.ConnectionError`). +-- +-- Thread safe, exception free. +-- +-- Alias for callServantAPI. +-- +-- | Takes remote url, servant client for this endpoint +-- and returns either client error or result. +-- +-- > data User = User { firstName :: String, lastName :: String , userGUID :: String} +-- > deriving (Generic, Show, Eq, ToJSON, FromJSON ) +-- > +-- > data Book = Book { author :: String, name :: String } +-- > deriving (Generic, Show, Eq, ToJSON, FromJSON ) +-- > +-- > type API = "user" :> Get '[JSON] User +-- > :<|> "book" :> Get '[JSON] Book +-- > +-- > api :: HasCallStack => Proxy API +-- > api = Proxy +-- > +-- > getUser :: HasCallStack => EulerClient User +-- > getBook :: HasCallStack => EulerClient Book +-- > (getUser :<|> getBook) = client api +-- > +-- > url = BaseUrl Http "localhost" port "" +-- > +-- > +-- > myFlow = do +-- > book <- callAPI url getBook +-- > user <- callAPI url getUser +callAPI' :: (HasCallStack, MonadFlow m, Show apiTag) => + Maybe ManagerSelector -> BaseUrl -> apiTag -> (LBS.ByteString -> Maybe Log.ErrorInfo) -> EulerClient a -> m (Either ClientError a) +callAPI' = callServantAPI + +-- | The same as `callAPI'` but with default manager to be used. +callAPI :: (HasCallStack, MonadFlow m, Show apiTag) => + BaseUrl -> apiTag -> (LBS.ByteString -> Maybe Log.ErrorInfo) -> EulerClient a -> m (Either ClientError a) +callAPI = callServantAPI Nothing + + +-- +-- Doubts: +-- Is it the right place to put it? +-- Should the type be more generic than IO ()? +logCallStack :: (HasCallStack, MonadFlow m) => m () +logCallStack = logDebug ("CALLSTACK" :: Text) $ Text.pack $ prettyCallStack callStack + + +logExceptionCallStack :: (HasCallStack, Exception e, MonadFlow m) => e -> m () +logExceptionCallStack ex = + let errorReason = Text.pack $ displayException ex + in logErrorWithCategory ("EXCEPTION" :: Text) errorReason $ ErrorL Nothing "EXCEPTION" errorReason + +foldFlow :: (Monad m) => (forall b . FlowMethod b -> m b) -> Flow a -> m a +foldFlow f (Flow comp) = foldF f comp + +type ReaderFlow r = ReaderT r Flow + +newtype PubSub a = PubSub { + unpackLanguagePubSub :: HasCallStack => (forall b . Flow b -> IO b) -> PSL.PubSub a + } + +type MessageCallback + = ByteString -- ^ Message payload + -> Flow () + +type PMessageCallback + = ByteString -- ^ Channel name + -> ByteString -- ^ Message payload + -> Flow () + +-- | MonadBaseControl/UnliftIO-like interface for flow. +-- +-- > withSomeResourceFromIO :: (SomeRes -> IO a) -> IO a +-- > someFlowAction :: SomeRes -> Flow Result +-- > +-- > example :: Flow Result +-- > example = do +-- > withRunFlow \runFlow -> do +-- > withSomeResourceFromIO \res -> do +-- > runFlow (someFlowAction res) +withRunFlow :: ((forall x. Flow x -> IO x) -> IO a) -> Flow a +withRunFlow ioAct = liftFC $ WithRunFlow ioAct + +-- | Fork a unit-returning flow. +-- +-- __Note__: to fork a flow which yields a value use 'forkFlow\'' instead. +-- +-- __Warning__: With forked flows, race coniditions and dead / live blocking become possible. +-- All the rules applied to forked threads in Haskell can be applied to forked flows. +-- +-- Generally, the method is thread safe. Doesn't do anything to bookkeep the threads. +-- There is no possibility to kill a thread at the moment. +-- +-- Thread safe, exception free. +-- +-- > myFlow1 = do +-- > logInfoT "myflow1" "logFromMyFlow1" +-- > someAction +-- > +-- > myFlow2 = do +-- > _ <- runIO someAction +-- > forkFlow "myFlow1 fork" myFlow1 +-- > pure () +-- +forkFlow :: HasCallStack => Description -> Flow a -> Flow () +forkFlow description flow = do + flowGUID <- generateGUID + void $ forkFlow'' description flowGUID $ do + void $ setLoggerContext "flow_guid" flowGUID + eitherResult <- runSafeFlow flow + case eitherResult of + Left msg -> logErrorWithCategory ("forkFlow" :: Text) msg $ ErrorL Nothing "forkFlow" msg + Right _ -> pure () + +-- | Same as 'forkFlow', but takes @Flow a@ and returns an 'T.Awaitable' which can be used +-- to reap results from the flow being forked. +-- +-- > myFlow1 = do +-- > logInfoT "myflow1" "logFromMyFlow1" +-- > pure 10 +-- > +-- > myFlow2 = do +-- > awaitable <- forkFlow' "myFlow1 fork" myFlow1 +-- > await Nothing awaitable +-- +forkFlow'' :: HasCallStack => + Description -> ForkGUID -> Flow a -> Flow (Awaitable (Either Text a)) +forkFlow'' description flowGUID flow = do + logInfo ("ForkFlow" :: Text) $ case Text.uncons description of + Nothing -> + "Flow forked. Description: " +| description |+ " GUID: " +| flowGUID |+ "" + Just _ -> "Flow forked. GUID: " +| flowGUID |+ "" + liftFC $ Fork description flowGUID flow id + +forkFlow' :: HasCallStack => + Description -> Flow a -> Flow (Awaitable (Either Text a)) +forkFlow' description flow = do + flowGUID <- generateGUID + logInfo ("ForkFlow" :: Text) $ case Text.uncons description of + Just _ -> + "Flow forked. Description: " +| description |+ " GUID: " +| flowGUID |+ "" + Nothing -> "Flow forked. GUID: " +| flowGUID |+ "" + liftFC $ Fork description flowGUID flow id + + +logM :: forall (tag :: Type) (m :: Type -> Type) msg val . + (HasCallStack, MonadFlow m, Show tag, Typeable tag, ToJSON msg, ToJSON val) => LogLevel -> tag -> msg -> val -> Maybe ErrorL -> m () +logM logLvl tag m v err + | logLvl == Error = + let jsonVal = toJSON v + e = err <|> (Just $ ErrorL Nothing "DOMAIN_ERROR" $ show jsonVal) + in evalLogger' $ masterLogger logLvl tag "ERROR" Nothing Nothing e Nothing Nothing $ Message (Just $ toJSON m) (Just jsonVal) + | otherwise = evalLogger' $ masterLogger logLvl tag "DOMAIN" Nothing Nothing Nothing Nothing Nothing $ Message (Just $ toJSON m) (Just $ toJSON v) + +log :: forall (tag :: Type) (m :: Type -> Type) . + (HasCallStack, MonadFlow m, Show tag, Typeable tag) => LogLevel -> tag -> Text -> Maybe ErrorL -> m () +log logLvl tag msg err + | logLvl == Error = + let e = err <|> (Just $ ErrorL Nothing "DOMAIN_ERROR" msg) + in evalLogger' $ masterLogger logLvl tag "ERROR" Nothing Nothing e Nothing Nothing $ Message (Just $ A.toJSON msg) Nothing + | otherwise = evalLogger' $ masterLogger logLvl tag "DOMAIN" Nothing Nothing Nothing Nothing Nothing $ Message (Just $ A.toJSON msg) Nothing + +logV :: forall (tag :: Type) (m :: Type -> Type) val . + (HasCallStack, MonadFlow m, Show tag, Typeable tag, ToJSON val) => LogLevel -> tag -> val -> Maybe ErrorL -> m () +logV logLvl tag v err + | logLvl == Error = + let jsonVal = toJSON v + e = err <|> (Just $ ErrorL Nothing "DOMAIN_ERROR" $ show jsonVal) + in evalLogger' $ masterLogger logLvl tag "ERROR" Nothing Nothing e Nothing Nothing $ Message Nothing (Just jsonVal) + | otherwise = evalLogger' $ masterLogger logLvl tag "DOMAIN" Nothing Nothing Nothing Nothing Nothing $ Message Nothing (Just $ toJSON v) + +-- | Log message with Info level. +-- +-- Thread safe. + +logInfoM :: forall (tag :: Type) (m :: Type -> Type) msg val . + (HasCallStack, MonadFlow m, Show tag, Typeable tag, ToJSON msg, ToJSON val) => tag -> msg -> val -> m () +logInfoM t m v = logM Info t m v Nothing + +logInfo :: forall (tag :: Type) (m :: Type -> Type) . + (HasCallStack, MonadFlow m, Show tag, Typeable tag) => tag -> Text -> m () +logInfo t v = log Info t v Nothing + +logInfoV :: forall (tag :: Type) (m :: Type -> Type) val . + (HasCallStack, MonadFlow m, Show tag, Typeable tag, ToJSON val) => tag -> val -> m () +logInfoV t v = logV Info t v Nothing + + +-- | Log message with Error level. +-- +-- Thread safe. +logErrorM :: forall (tag :: Type) (m :: Type -> Type) msg val . + (HasCallStack, MonadFlow m, Show tag, Typeable tag, ToJSON msg, ToJSON val) => tag -> msg -> val -> m () +logErrorM t m v = logM Error t m v Nothing + +logError :: forall (tag :: Type) (m :: Type -> Type) . + (HasCallStack, MonadFlow m, Show tag, Typeable tag) => tag -> Text -> m () +logError t v = log Error t v Nothing + +logErrorV :: forall (tag :: Type) (m :: Type -> Type) val . + (HasCallStack, MonadFlow m, Show tag, Typeable tag, ToJSON val) => tag -> val -> m () +logErrorV t v = logV Error t v Nothing + +logErrorWithCategoryV :: forall (tag :: Type) (m :: Type -> Type) val . + (HasCallStack, MonadFlow m, Show tag, Typeable tag, ToJSON val) => tag -> val -> ErrorL -> m () +logErrorWithCategoryV t v err = logV Error t v $ Just err + +logErrorWithCategory :: forall (tag :: Type) (m :: Type -> Type) . + (HasCallStack, MonadFlow m, Show tag, Typeable tag) => tag -> Text -> ErrorL -> m () +logErrorWithCategory t v err = log Error t v $ Just err +-- | Log message with Debug level. +-- +-- Thread safe. +logDebugM :: forall (tag :: Type) (m :: Type -> Type) msg val . + (HasCallStack, MonadFlow m, Show tag, Typeable tag, ToJSON msg, ToJSON val) => tag -> msg -> val -> m () +logDebugM t m v = logM Debug t m v Nothing + +logDebug :: forall (tag :: Type) (m :: Type -> Type) . + (HasCallStack, MonadFlow m, Show tag, Typeable tag) => tag -> Text -> m () +logDebug t m = log Debug t m Nothing + +logDebugV :: forall (tag :: Type) (m :: Type -> Type) val . + (HasCallStack, MonadFlow m, Show tag, Typeable tag, ToJSON val) => tag -> val -> m () +logDebugV t v = logV Debug t v Nothing + +-- | Log message with Warning level. +-- +-- Thread safe. +logWarningM :: forall (tag :: Type) (m :: Type -> Type) msg val . + (HasCallStack, MonadFlow m, Show tag, Typeable tag, ToJSON msg, ToJSON val) => tag -> msg -> val -> m () +logWarningM t m v = logM Warning t m v Nothing + +logWarning :: forall (tag :: Type) (m :: Type -> Type) . + (HasCallStack, MonadFlow m, Show tag, Typeable tag) => tag -> Text -> m () +logWarning t v = log Warning t v Nothing + +logWarningV :: forall (tag :: Type) (m :: Type -> Type) val . + (HasCallStack, MonadFlow m, Show tag, Typeable tag, ToJSON val) => tag -> val -> m () +logWarningV t v = logV Warning t v Nothing + +logException :: (HasCallStack, MonadFlow m) => SomeException -> m () +logException exception = + let exceptionLogEntry = getErrorLogFromException exception + in logErrorWithCategoryV ("ERROR_TRACKING" :: Text) exceptionLogEntry $ getErrorLog exceptionLogEntry + where + getErrorLog e = ErrorL (Just $ jp_error_code e) (error_code e) (Text.pack $ error_message e) + +-- | Run some IO operation, result should have 'ToJSONEx' instance (extended 'ToJSON'), +-- because we have to collect it in recordings for ART system. +-- +-- Warning. This method is dangerous and should be used wisely. +-- +-- > myFlow = do +-- > content <- runIO $ readFromFile file +-- > logDebugT "content id" $ extractContentId content +-- > pure content +runIO :: (HasCallStack, MonadFlow m) => IO a -> m a +runIO = runIO' "" + + +------------------------------------------------------- +incrementDbAndRedisMetric :: MonadFlow m => DBAndRedisMetricHandler -> DBAndRedisMetric -> Text -> Text -> m () +incrementDbAndRedisMetric handle metric dbName hostName = do + runIO $ ((dBAndRedisCounter handle) (metric, dbName, hostName)) + +data DBAndRedisMetricHandler = DBAndRedisMetricHandler + { dBAndRedisCounter :: (DBAndRedisMetric, Text, Text) -> IO () + } + +data DBAndRedisMetric + = ConnectionLost + | ConnectionFailed + | ConnectionDoesNotExist + | ConnectionAlreadyExists + | TransactionRollbacked +-- | SQLQueryError + | UnrecognizedDBError + | UnexpectedDBResult + | RedisExceptionMessage + +mkDBAndRedisMetricHandler :: IO DBAndRedisMetricHandler +mkDBAndRedisMetricHandler = do + metrics <- register collectionLock + pure $ DBAndRedisMetricHandler $ \case + (ConnectionLost, dbName, hostName) -> + inc (metrics #connection_lost) dbName hostName + (ConnectionFailed, dbName, hostName) -> + inc (metrics #connection_failed) dbName hostName + (ConnectionDoesNotExist, dbName, hostName) -> + inc (metrics #connection_doesnot_exist) dbName hostName + (ConnectionAlreadyExists, dbName, hostName) -> + inc (metrics #connection_already_exists) dbName hostName + (TransactionRollbacked, dbName, hostName) -> + inc (metrics #transaction_rollbacked) dbName hostName + -- (SQLQueryError,dbName, hostName) -> + -- inc (metrics #sql_query_error) dbName hostName + (UnrecognizedDBError, dbName, hostName) -> + inc (metrics #unrecognized_db_error) dbName hostName + (UnexpectedDBResult, dbName, hostName) -> + inc (metrics #unexpected_db_result) dbName hostName + (RedisExceptionMessage, dbName, hostName) -> + inc (metrics #redis_exception_msg) dbName hostName + +connection_lost = counter #connection_lost + .& lbl @"db_name" @Text + .& lbl @"host_name" @Text + .& build + +connection_failed = counter #connection_failed + .& lbl @"db_name" @Text + .& lbl @"host_name" @Text + .& build + +connection_doesnot_exist = counter #connection_doesnot_exist + .& lbl @"db_name" @Text + .& lbl @"host_name" @Text + .& build + +connection_already_exists = counter #connection_already_exists + .& lbl @"db_name" @Text + .& lbl @"host_name" @Text + .& build + +-- sql_query_error = counter #sql_query_error +-- .& lbl @"db_name" @Text +-- .& lbl @"host_name" @Text +-- .& build + +transaction_rollbacked = counter #transaction_rollbacked + .& lbl @"db_name" @Text + .& lbl @"host_name" @Text + .& build + +unrecognized_db_error = counter #unrecognized_db_error + .& lbl @"db_name" @Text + .& lbl @"host_name" @Text + .& build + + +unexpected_db_result = counter #unexpected_db_result + .& lbl @"db_name" @Text + .& lbl @"host_name" @Text + .& build + +redis_exception_msg = counter #redis_exception_msg + .& lbl @"db_name" @Text + .& lbl @"host_name" @Text + .& build + +collectionLock = + connection_lost + .> connection_failed + .> connection_doesnot_exist + .> connection_already_exists +-- .> sql_query_error + .> transaction_rollbacked + .> unrecognized_db_error + .> unexpected_db_result + .> redis_exception_msg + .> MNil + + +--------------------------------------------------------- + +data DBMetricCfg = DBMetricCfg + deriving stock (Generic, Typeable, Show, Eq) + deriving anyclass (ToJSON, FromJSON) + +instance OptionEntity DBMetricCfg DBAndRedisMetricHandler + +--------------------------------------------------------- + +data XTenantHostHeader = XTenantHostHeader + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +instance OptionEntity XTenantHostHeader Text + +--------------------------------------------------------- + +isDBMetricEnabled :: Bool +isDBMetricEnabled = fromMaybe False $ readMaybe =<< Conf.lookupEnvT "DB_METRIC_ENABLED" + +--------------------------------------------------------- + +incrementRedisMetric :: (HasCallStack, MonadFlow m) => T.KVDBReply -> Text -> m () +incrementRedisMetric err cName = when (isDBMetricEnabled) $ + case err of + T.KVDBError T.KVDBConnectionFailed _ -> incrementMetric ConnectionFailed cName + T.KVDBError T.KVDBConnectionAlreadyExists _ -> incrementMetric ConnectionAlreadyExists cName + T.KVDBError T.KVDBConnectionDoesNotExist _ -> incrementMetric ConnectionDoesNotExist cName + T.ExceptionMessage _ -> + if Text.isInfixOf "Network.Socket.connect" $ show err + then incrementMetric ConnectionLost cName + else incrementMetric RedisExceptionMessage cName + _ -> pure () + +incrementDbMetric :: (HasCallStack, MonadFlow m) => T.DBError -> T.DBConfig beM -> m () +incrementDbMetric (T.DBError err msg) dbConf = when isDBMetricEnabled $ + case err of + T.ConnectionFailed -> incrementMetric ConnectionFailed (dbConfigToTag dbConf) + T.ConnectionAlreadyExists -> incrementMetric ConnectionAlreadyExists (dbConfigToTag dbConf) + T.ConnectionDoesNotExist -> incrementMetric ConnectionDoesNotExist (dbConfigToTag dbConf) + T.TransactionRollbacked -> incrementMetric TransactionRollbacked (dbConfigToTag dbConf) + T.UnexpectedResult -> incrementMetric UnexpectedDBResult (dbConfigToTag dbConf) + T.UnrecognizedError -> if Text.isInfixOf "Network.Socket.connect" $ show msg + then incrementMetric ConnectionLost (dbConfigToTag dbConf) + else incrementMetric UnrecognizedDBError (dbConfigToTag dbConf) + _ -> pure () + +incrementMetric :: (HasCallStack, MonadFlow m) => DBAndRedisMetric -> Text -> m () +incrementMetric metric dbName = do + env <- getOption DBMetricCfg + case env of + Just val -> incrementDbAndRedisMetric val metric dbName (fromMaybe "" $ Conf.lookupEnvT "HOSTNAME") + Nothing -> pure () + +dbConfigToTag :: T.DBConfig beM -> Text +dbConfigToTag = \case + T.PostgresPoolConf t _ _ -> t + T.MySQLPoolConf t _ _ -> t + T.SQLitePoolConf t _ _ -> t + +--------------------------------------------------------------------------------TRANSACTION BLOCK------------------------------------------------------------------------------------------------------ + +data RunDBInfo beM a = TransactionFlow (T.NativeSqlConn -> Flow a) | SqlDBFlow (SqlDB beM a) Bool \ No newline at end of file diff --git a/src/EulerHS/Framework/Runtime.hs b/src/EulerHS/Framework/Runtime.hs index bbfa22ed..c8d916b8 100644 --- a/src/EulerHS/Framework/Runtime.hs +++ b/src/EulerHS/Framework/Runtime.hs @@ -5,108 +5,200 @@ 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. -} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE NamedFieldPuns #-} + module EulerHS.Framework.Runtime ( -- * Framework Runtime FlowRuntime(..) + , ConfigEntry(..) + , mkConfigEntry , createFlowRuntime , createFlowRuntime' , withFlowRuntime , kvDisconnect , runPubSubWorker , shouldFlowLogRawSql + , CertificateRegistrationError(..) + , withSelfSignedFlowRuntime + , forkFlowWithNewRecordingLocal ) where -import EulerHS.Prelude - -import Network.HTTP.Client (Manager, newManager) -import Network.HTTP.Client.TLS (tlsManagerSettings) - +import qualified Control.Concurrent.Map as CMap +import Control.Monad.Trans.Except (throwE) +import qualified Data.Cache.LRU as SimpleLRU +import qualified Data.LruCache as LRU import qualified Data.Map as Map (empty) import qualified Data.Pool as DP (destroyAllResources) +import Data.Time.Clock.POSIX +import Data.X509.CertificateStore (readCertificateStore) import qualified Database.Redis as RD -import qualified System.Mem as SYSM (performGC) - +import EulerHS.HttpAPI +import EulerHS.KVDB.Types (NativeKVDBConn (NativeKVDB)) +import qualified EulerHS.Logger.Runtime as R +import EulerHS.Prelude +import EulerHS.SqlDB.Types (ConnTag, + NativeSqlPool (NativeMySQLPool, NativePGPool, NativeSQLitePool)) +import GHC.Conc (labelThread) +import EulerHS.Extra.Snowflakes.Types (SnowflakeGenerator) +import EulerHS.Extra.Snowflakes.Flow (getSnowflakeGenerator) +import Juspay.Extra.Config (lookupEnvT) +import Network.Connection (TLSSettings (TLSSettings)) +import Network.HTTP.Client (Manager, newManager) +import Network.HTTP.Client.TLS (mkManagerSettings) +import Network.TLS (ClientParams (clientShared, clientSupported), + defaultParamsClient, sharedCAStore, + supportedCiphers) +import Network.TLS.Extra.Cipher (ciphersuite_default) import System.IO.Unsafe (unsafePerformIO) +import qualified System.Mem as SYSM (performGC) +import Unsafe.Coerce (unsafeCoerce) +import EulerHS.ART.Types (RecordingEntry(..)) -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 , _defaultHttpClientManager :: Manager -- ^ Http default manager, used for external api calls - , _httpClientManagers :: Map String Manager + , _httpClientManagers :: HashMap Text Manager -- ^ Http managers, used for external api calls + , _dynHttpClientManagers :: MVar (LRU.LruCache HTTPClientSettings Manager) + -- ^ LRU cache of Managers. , _options :: MVar (Map Text Any) -- ^ Typed key-value storage - , _kvdbConnections :: MVar (Map Text T.NativeKVDBConn) + , _optionsLocal :: MVar (Map Text Any) + -- ^ Typed key-value storage - New Ref for every api call + , _kvdbConnections :: MVar (Map Text NativeKVDBConn) -- ^ Connections for key-value databases - , _sqldbConnections :: MVar (Map T.ConnTag T.NativeSqlPool) + , _sqldbConnections :: MVar (Map ConnTag NativeSqlPool) -- ^ Connections for SQL databases , _pubSubController :: RD.PubSubController -- ^ Subscribe controller , _pubSubConnection :: Maybe RD.Connection -- ^ Connection being used for Publish + , _configCache :: IORef (SimpleLRU.LRU Text ConfigEntry) + + , _configCacheLock :: MVar (CMap.Map Text ()) + + , _snowflakeGenerator :: SnowflakeGenerator + , _recordingLocal :: MVar ([RecordingEntry]) + } +data ConfigEntry = ConfigEntry + { + ttl :: POSIXTime + , entry :: Maybe Any + } + +deriving instance Show ConfigEntry + +configCacheSize :: Integer +configCacheSize = + let + mbSize :: Maybe Integer + mbSize = readMaybe =<< lookupEnvT "CONFIG_CACHE_SIZE" + + in fromMaybe 4096 mbSize + +mkConfigEntry :: POSIXTime -> Maybe a -> ConfigEntry +mkConfigEntry valTtl mbVal = ConfigEntry valTtl $ (unsafeCoerce @_ @Any) <$> mbVal +-- | Possible issues that can arise when registering certificates. +-- +-- @since 2.0.4.3 +newtype CertificateRegistrationError = NoCertificatesAtPath FilePath + deriving (Eq) via FilePath + deriving stock (Show) + +instance Exception CertificateRegistrationError + +-- | Works identically to 'withFlowRuntime', but takes an extra parameter. This +-- parameter is a map of textual identifiers to paths where custom CA +-- certificates can be found. +-- +-- You can then use 'callAPI', providing 'Just' the textual identifier to use +-- the self-signed certificate(s) provided. +-- +-- The handler is provided an 'Either' to allow for graceful recovery; if you +-- have nothing you can do with a 'CertificateRegistrationError', you can throw +-- it. +-- +-- @since 2.0.4.3 + +{-# DEPRECATED withSelfSignedFlowRuntime "use manager builders instead, see HttpAPI.hs" #-} +withSelfSignedFlowRuntime :: + HashMap Text FilePath -> + Maybe (IO R.LoggerRuntime) -> + (Either CertificateRegistrationError FlowRuntime -> IO a) -> + IO a +withSelfSignedFlowRuntime certPathMap mRTF handler = do + res <- runExceptT . traverse go $ certPathMap + case res of + Left err -> handler . Left $ err + Right managerMap -> + bracket (fromMaybe R.createVoidLoggerRuntime mRTF) R.clearLoggerRuntime $ + \loggerRT -> bracket (R.createCoreRuntime loggerRT) R.clearCoreRuntime $ + \coreRT -> bracket (mkFlowRT coreRT managerMap) clearFlowRuntime $ + handler . Right + where + go :: + FilePath -> + ExceptT CertificateRegistrationError IO Manager + go certPath = do + mCertStore <- lift . readCertificateStore $ certPath + case mCertStore of + Nothing -> throwE . NoCertificatesAtPath $ certPath + Just store -> do + let defs = defaultParamsClient "localhost" "" + let clientParams = defs { + clientShared = (clientShared defs) { sharedCAStore = store }, + clientSupported = (clientSupported defs) { supportedCiphers = ciphersuite_default }} + lift . newManager . mkManagerSettings (TLSSettings clientParams) $ Nothing + mkFlowRT :: R.CoreRuntime -> HashMap Text Manager -> IO FlowRuntime + mkFlowRT coreRT managers = do + frt <- createFlowRuntime coreRT + pure frt { _httpClientManagers = managers } + -- | Create default FlowRuntime. createFlowRuntime :: R.CoreRuntime -> IO FlowRuntime createFlowRuntime coreRt = do - defaultManagerVar <- newManager tlsManagerSettings - optionsVar <- newMVar mempty - kvdbConnections <- newMVar Map.empty - sqldbConnections <- newMVar Map.empty + defaultManagerVar <- newManager $ buildSettings mempty + optionsVar <- newMVar mempty + optionsLocalVar <- newMVar mempty + configCacheVar <- newIORef $ SimpleLRU.newLRU $ Just configCacheSize + configCacheLockVar <- newMVar =<< CMap.empty + snowFlakeGenerator <- getSnowflakeGenerator + kvdbConnections <- newMVar Map.empty + sqldbConnections <- newMVar Map.empty + dynHttpClientManagers <- newMVar $ LRU.empty 100 + recordingLocal <- newMVar $ [] pubSubController <- RD.newPubSubController [] [] - pure $ FlowRuntime { _coreRuntime = coreRt , _defaultHttpClientManager = defaultManagerVar - , _httpClientManagers = Map.empty + , _httpClientManagers = mempty , _options = optionsVar + , _optionsLocal = optionsLocalVar + , _configCache = configCacheVar + , _configCacheLock = configCacheLockVar , _kvdbConnections = kvdbConnections -- , _runMode = T.RegularMode , _sqldbConnections = sqldbConnections , _pubSubController = pubSubController , _pubSubConnection = Nothing + , _dynHttpClientManagers = dynHttpClientManagers + , _snowflakeGenerator = snowFlakeGenerator + , _recordingLocal = recordingLocal } createFlowRuntime' :: Maybe (IO R.LoggerRuntime) -> IO FlowRuntime @@ -118,6 +210,8 @@ clearFlowRuntime :: FlowRuntime -> IO () clearFlowRuntime FlowRuntime{..} = do _ <- takeMVar _options putMVar _options mempty + _ <- takeMVar _optionsLocal + putMVar _optionsLocal mempty kvConns <- takeMVar _kvdbConnections putMVar _kvdbConnections mempty traverse_ kvDisconnect kvConns @@ -130,17 +224,14 @@ clearFlowRuntime FlowRuntime{..} = do shouldFlowLogRawSql :: FlowRuntime -> Bool shouldFlowLogRawSql = R.shouldLogRawSql . R._loggerRuntime . _coreRuntime -sqlDisconnect :: T.NativeSqlPool -> IO () +sqlDisconnect :: 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 () + NativePGPool connPool -> DP.destroyAllResources connPool + NativeMySQLPool connPool -> DP.destroyAllResources connPool + NativeSQLitePool connPool -> DP.destroyAllResources connPool -kvDisconnect :: T.NativeKVDBConn -> IO () -kvDisconnect = \case - T.NativeKVDBMockedConn -> pure () - T.NativeKVDB conn -> RD.disconnect conn +kvDisconnect :: NativeKVDBConn -> IO () +kvDisconnect (NativeKVDB conn) = RD.disconnect conn -- | Run flow with given logger runtime creation function. withFlowRuntime :: Maybe (IO R.LoggerRuntime) -> (FlowRuntime -> IO a) -> IO a @@ -153,6 +244,25 @@ withFlowRuntime (Just loggerRuntimeCreator) actionF = bracket (R.createCoreRuntime loggerRt) R.clearCoreRuntime $ \coreRt -> bracket (createFlowRuntime coreRt) clearFlowRuntime actionF +forkFlowWithNewRecordingLocal :: FlowRuntime -> MVar ([RecordingEntry]) -> IO FlowRuntime +forkFlowWithNewRecordingLocal FlowRuntime {..} recordingLocal = do + pure $ FlowRuntime + { _coreRuntime + , _defaultHttpClientManager + , _httpClientManagers + , _options + , _optionsLocal + , _configCache + , _configCacheLock + , _kvdbConnections + , _sqldbConnections + , _pubSubController + , _pubSubConnection + , _dynHttpClientManagers + , _snowflakeGenerator + , _recordingLocal = recordingLocal + } + -- 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 #-} @@ -177,23 +287,26 @@ runPubSubWorker rt log = do putMVar pubSubWorkerLock () error "Unable to run Publish/Subscribe worker: No connection to Redis provided" - Just conn -> forkIO $ forever $ do - res <- try @_ @SomeException $ RD.pubSubForever conn (_pubSubController rt) $ do - writeIORef delayRef tsecond - log "Publish/Subscribe worker: Run successfuly" + Just conn -> do + tid <- forkIO $ forever $ do + res <- try @_ @SomeException $ RD.pubSubForever conn (_pubSubController rt) $ do + writeIORef delayRef tsecond + log "Publish/Subscribe worker: Run successfuly" - case res of - Left e -> do - delay <- readIORef delayRef + case res of + Left e -> do + delay <- readIORef delayRef - log $ "Publish/Subscribe worker: Got error: " <> show e - log $ "Publish/Subscribe worker: Restart in " <> show (delay `div` tsecond) <> " sec" + log $ "Publish/Subscribe worker: Got error: " <> show e + log $ "Publish/Subscribe worker: Restart in " <> show (delay `div` tsecond) <> " sec" - modifyIORef' delayRef (\d -> d + d `div` 2) -- (* 1.5) - threadDelay delay - Right _ -> pure () + modifyIORef' delayRef (\d -> d + d `div` 2) -- (* 1.5) + threadDelay delay + Right _ -> pure () + labelThread tid "euler-runPubSubWorker" + return tid pure $ do killThread threadId putMVar pubSubWorkerLock () - log $ "Publish/Subscribe worker: Killed" + log "Publish/Subscribe worker: Killed" diff --git a/src/EulerHS/HttpAPI.hs b/src/EulerHS/HttpAPI.hs new file mode 100644 index 00000000..ed6b5e1f --- /dev/null +++ b/src/EulerHS/HttpAPI.hs @@ -0,0 +1,610 @@ +{- | +Module : EulerHS.HttpAPI +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable + +This module contains types and functions for making HTTP requests and handling responses. +-} + +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DerivingVia #-} + +module EulerHS.HttpAPI + ( + -- * HTTP manager builder stuff + HTTPClientSettings + , buildSettings + , withProxy + , withMbProxy + , withClientTls + , withClientTlsP12 + , withMbClientTls + , withCustomCA + -- * X509 utilities + , makeCertificateStoreFromMemory + -- * Common types and convenience methods + , ClientCert(..) + , HTTPRequest(..) + , HTTPRequestMasked + , HTTPResponse(..) + , HTTPResponseException(..) + , HTTPResponseMasked + , HTTPMethod(..) + , HTTPCert(..) + , HTTPIOException(HTTPIOException) + , P12Cert (..) + , AwaitingError (..) + , HttpManagerNotFound(..) + , MaskReqRespBody + , HttpData(..) + , RequestType(..) + , HTTPResponseWithRequest(..) + , HTTPResponseExceptionWithRequest(..) + , defaultTimeout + , extractBody + , httpGet + , httpPut + , httpPost + , httpDelete + , httpHead + , defaultRequest + , withHeader + , withOptionalHeader + , withBody + , withFormBody + , withJSONBody + , withTimeout + , withRedirects + , withNoCheckLeafV3 + , maskHTTPRequest + , maskHTTPResponse + , mkHttpApiCallLogEntry + , shouldBypassProxy + ) where + +import qualified Crypto.Store.PKCS12 as PKCS12 +import qualified EulerHS.BinaryString as T +import qualified EulerHS.Logger.Types as Log +import EulerHS.Masking (defaultMaskText, getContentTypeForHTTP, + maskHTTPHeaders, parseRequestResponseBody, + shouldMaskKey) +import EulerHS.Prelude hiding (ord) +import Juspay.Extra.Text (formUrlEncode) + +import qualified Data.Aeson as A +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import Data.Default +import qualified Data.Either.Extra as Extra +import qualified Data.Map as Map +import Data.Monoid (All (..)) +import Data.PEM (pemContent, pemParseBS) +import Data.String.Conversions (convertString) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.X509 (Certificate (certSerial), HashALG (..), + decodeSignedCertificate, encodeSignedObject, + getCertificate) +import Data.X509.CertificateStore (CertificateStore, listCertificates, + makeCertificateStore) +import Data.X509.Validation (checkLeafV3, defaultChecks, defaultHooks, + validate) +import Generics.Deriving.Monoid (mappenddefault, memptydefault) +import qualified Network.Connection as Conn +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Client.TLS as TLS +import qualified Network.TLS as TLS +import qualified Network.TLS.Extra.Cipher as TLS +import System.IO.Unsafe (unsafePerformIO) +import System.X509 (getSystemCertificateStore) +import qualified Juspay.Extra.Config as Conf +import qualified Data.List as List + +newtype CertificateStore' + = CertificateStore' + { getCertificateStore :: CertificateStore + } + deriving newtype (Semigroup, Monoid) + +instance Eq CertificateStore' where + (==) a b = a' == b' where + a' = sortedSignedObjects a + b' = sortedSignedObjects b + +sortedSignedObjects :: CertificateStore' -> [ByteString] +sortedSignedObjects = sort . fmap encodeSignedObject . listCertificates . getCertificateStore + +instance Ord CertificateStore' where + compare a b = a' `compare` b' where + a' = sortedSignedObjects a + b' = sortedSignedObjects b + +instance Hashable CertificateStore' where + hashWithSalt salt = hashWithSalt salt . + fmap (certSerial . getCertificate) . listCertificates . getCertificateStore + + +-- | +data HTTPClientSettings = HTTPClientSettings + { httpClientSettingsProxy :: Last ProxySettings + , httpClientSettingsClientCertificate :: Last ClientCert + , httpClientSettingsCustomStore :: CertificateStore' + , httpClientSettingsCheckLeafV3 :: All + } + deriving stock (Eq, Ord, Generic) + -- use DeriveVia? + -- see https://hackage.haskell.org/package/generic-deriving-1.14/docs/Generics-Deriving-Default.html + +instance Hashable HTTPClientSettings where + hashWithSalt salt settings = hashWithSalt salt $ + ( getLast $ httpClientSettingsProxy settings + , getLast $ httpClientSettingsClientCertificate settings + , httpClientSettingsCustomStore settings + ) + + +-- instance Hashable a => Hashable (Last a) where +-- hashWithSalt salt = hashWithSalt salt . getLast + +data ProxySettings + = InsecureProxy + { proxySettingsHost :: Text + , proxySettingsPort :: Int + } + deriving stock (Eq, Ord, Generic) + +instance Hashable ProxySettings + + +instance Semigroup (HTTPClientSettings) where + (<>) = mappenddefault + +instance Monoid (HTTPClientSettings) where + mempty = memptydefault { httpClientSettingsCheckLeafV3 = All True } + +-- | The simplest settings builder +buildSettings :: HTTPClientSettings -> HTTP.ManagerSettings +buildSettings HTTPClientSettings{..} = + applyProxySettings $ baseSettings + where + applyProxySettings = HTTP.managerSetProxy proxyOverride + + proxyOverride = case getLast httpClientSettingsProxy of + Just (InsecureProxy host port) -> HTTP.useProxy $ HTTP.Proxy (Text.encodeUtf8 host) port + Nothing -> HTTP.noProxy + + baseSettings = case getLast httpClientSettingsClientCertificate of + Just cert -> + case cert of + HTTPCertificate HTTPCert{..} -> + case TLS.credentialLoadX509ChainFromMemory getCert getCertChain getCertKey of + Right creds -> + let hooks = def { TLS.onCertificateRequest = + \_ -> return $ Just creds + } + clientParams = mkClientParams hooks + in mkSettings clientParams + Left err -> error $ "cannot load client certificate data: " <> Text.pack err + P12Certificate P12Cert{..} -> + case mkP12Cert getPfx getPassPhrase of + Right creds -> + let hooks = def { TLS.onCertificateRequest = + \_ -> return $ Just creds + } + clientParams = mkClientParams hooks + in mkSettings clientParams + Left err -> error $ "cannot load client certificate data: " <> err + Nothing -> + let clientParams = mkClientParams def + in mkSettings clientParams + + mkClientParams hooks = + let defs = TLS.defaultParamsClient empty "" + in + defs + { TLS.clientShared = (TLS.clientShared defs) + { TLS.sharedCAStore = sysStore <> getCertificateStore httpClientSettingsCustomStore } + , TLS.clientSupported = (TLS.clientSupported defs) + { TLS.supportedCiphers = TLS.ciphersuite_default } + , TLS.clientHooks = hooks + { TLS.onServerCertificate = + validate HashSHA256 defaultHooks $ defaultChecks + { checkLeafV3 = getAll httpClientSettingsCheckLeafV3 } + } + } + + mkSettings clientParams = let + tlsSettings = Conn.TLSSettings clientParams + in + TLS.mkManagerSettings tlsSettings Nothing + + sysStore = memorizedSysStore + + mkP12Cert pfx passPhrase = do + pkcs12Cert <- mapLeftShow $ PKCS12.readP12FileFromMemory pfx + cert <- mapLeftShow $ PKCS12.recover passPhrase pkcs12Cert + let pkcs12Creds = PKCS12.toCredential cert + maybeCreds <- mapLeftShow $ PKCS12.recover passPhrase pkcs12Creds + maybe (Left "Invalid P12 certificate") Right maybeCreds + + mapLeftShow = Extra.mapLeft show + +{-# NOINLINE memorizedSysStore #-} +memorizedSysStore :: CertificateStore +memorizedSysStore = unsafePerformIO getSystemCertificateStore + +type SimpleProxySettings = (Text, Int) + +-- | Add unconditional proxying (for both http/https, regardless +-- HTTP.Client's request proxy settings). +withProxy :: SimpleProxySettings -> HTTPClientSettings +withProxy (host, port) = + mempty {httpClientSettingsProxy = Last $ proxySettings} + where + proxySettings = Just $ InsecureProxy host port + +-- | The same as 'withProxy' but to use with optionally existsting settings. +withMbProxy :: Maybe SimpleProxySettings -> HTTPClientSettings +withMbProxy (Just s) = withProxy s +withMbProxy Nothing = mempty + +-- | Adds a client certificate to do client's TLS authentication +withClientTls :: HTTPCert -> HTTPClientSettings +withClientTls httpCert = + mempty {httpClientSettingsClientCertificate = Last $ Just $ HTTPCertificate httpCert} + +-- | Adds a client p12 certificate to do client's TLS authentication +withClientTlsP12 :: P12Cert -> HTTPClientSettings +withClientTlsP12 p12Cert = + mempty {httpClientSettingsClientCertificate = Last $ Just $ P12Certificate p12Cert} + +withMbClientTls :: Maybe HTTPCert -> HTTPClientSettings +withMbClientTls (Just cert) = withClientTls cert +withMbClientTls Nothing = mempty + +-- | Adds an additional store with trusted CA certificates. There is no Maybe version +-- since 'CertificateStore` is a monoid. +withCustomCA :: CertificateStore -> HTTPClientSettings +withCustomCA store = mempty {httpClientSettingsCustomStore = CertificateStore' store} + +-- | Make a store from in-memory certs +makeCertificateStoreFromMemory :: [ByteString] -> Either String CertificateStore +makeCertificateStoreFromMemory = + fmap makeCertificateStore . mapM decodeSignedCertificate + <=< fmap (fmap pemContent . join) . mapM pemParseBS + +-- | Turns off the check that all certs are X509 v3 ones +{-# WARNING withNoCheckLeafV3 "Don't use in production code, use X509 v3 certs instead." #-} +withNoCheckLeafV3 :: HTTPClientSettings +withNoCheckLeafV3 = mempty { httpClientSettingsCheckLeafV3 = All False } + +data HTTPRequest + = HTTPRequest + { getRequestMethod :: HTTPMethod + , getRequestHeaders :: Map.Map HeaderName HeaderValue + , getRequestBody :: Maybe T.LBinaryString + , getRequestURL :: Text + , getRequestTimeout :: Maybe Int -- ^ timeout, in microseconds + , getRequestRedirects :: Maybe Int + } + deriving stock (Eq, Ord, Generic, Show) + deriving anyclass (ToJSON,FromJSON) + +data HTTPRequestMasked + = HTTPRequestMasked + { getRequestMethod :: HTTPMethod + , getRequestHeaders :: Map.Map HeaderName HeaderValue + , getRequestBody :: Maybe A.Value + , getRequestURL :: Text + , getRequestTimeout :: Maybe Int -- ^ timeout, in microseconds + , getRequestRedirects :: Maybe Int + } + deriving stock (Eq, Generic) + deriving anyclass (ToJSON) + +data HTTPResponse + = HTTPResponse + { getResponseBody :: T.LBinaryString + , getResponseCode :: Int + , getResponseHeaders :: Map.Map HeaderName HeaderValue + , getResponseStatus :: Text + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (ToJSON, FromJSON) + +data HTTPResponseWithRequest + = HTTPResponseWithRequest + { req_body :: A.Value + , req_headers :: A.Value + , req_query_params :: A.Value + , url :: String + , response :: HTTPResponseMasked + } + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON) + +data HTTPResponseMasked + = HTTPResponseMasked + { getResponseBody :: A.Value + , getResponseCode :: Int + , getResponseHeaders :: Map.Map HeaderName HeaderValue + , getResponseStatus :: Text + } + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON) + +data ClientCert + = HTTPCertificate HTTPCert + | P12Certificate P12Cert + deriving stock (Eq, Ord, Generic) + +instance Hashable ClientCert + +data HTTPCert + = HTTPCert + { getCert :: B.ByteString + , getCertChain :: [B.ByteString] + , getCertHost :: String -- ^ Defines the name of the server, along with an extra + -- ^ service identification blob (not supported in Euler ATM). + -- ^ This is important that the hostname part is properly + -- ^ filled for security reason, as it allows to properly + -- ^ as it allow to properly associate the remote side + -- ^ with the given certificate during a handshake. + , getCertKey :: B.ByteString + } + deriving stock (Eq, Ord, Generic) + +instance Hashable HTTPCert + +data P12Cert + = P12Cert + { getPfx :: B.ByteString + , getPassPhrase :: B.ByteString + } + deriving stock (Eq, Ord, Generic) + +instance Hashable P12Cert + +data HTTPMethod + = Get + | Put + | Post + | Delete + | Head + | Trace + | Connect + | Options + | Patch + deriving (Eq, Ord, Show, Generic, ToJSON,FromJSON) + +type HeaderName = Text +type HeaderValue = Text + +data RequestType = INTERNAL | EXTERNAL + deriving stock (Eq,Show,Generic) + deriving anyclass (FromJSON,ToJSON) + +data HttpApiCallLogEntry = HttpApiCallLogEntry + { url :: Maybe Text + , method :: Maybe Text + , req_headers :: Maybe A.Value + , req_body :: Maybe A.Value + , res_code :: Maybe Int + , res_body :: Maybe A.Value + , res_headers :: Maybe A.Value + , latency :: Integer + , api_tag :: Text + , req_type :: RequestType + , error_info :: Maybe Log.ErrorInfo + } + deriving stock (Show,Generic) + +instance ToJSON HttpApiCallLogEntry where + toJSON = A.genericToJSON A.defaultOptions { A.omitNothingFields = True } + +data AwaitingError = AwaitingTimeout | ForkedFlowError Text + deriving stock (Show, Eq, Ord, Generic) + +newtype HttpManagerNotFound = HttpManagerNotFound Text + deriving stock (Show) + deriving (Eq) via Text + +instance Exception HttpManagerNotFound + +mkHttpApiCallLogEntry :: (Show apiTag) => Integer -> Maybe HTTPRequestMasked -> Maybe HTTPResponseMasked -> RequestType -> apiTag -> Maybe Log.ErrorInfo -> HttpApiCallLogEntry +mkHttpApiCallLogEntry lat req res reqType tag errInfo = HttpApiCallLogEntry + { url = (\x -> x.getRequestURL) <$> req + , method = (\x -> show $ x.getRequestMethod) <$> req + , req_headers = (\x -> A.toJSON $ x.getRequestHeaders) <$> req + , req_body = join $ (\x -> x.getRequestBody) <$> req + , res_code = (\x -> x.getResponseCode) <$> res + , res_body = (\x -> x.getResponseBody) <$> res + , res_headers = (\x -> A.toJSON $ x.getResponseHeaders) <$> res + , latency = lat + , api_tag = show tag + , req_type = reqType + , error_info = errInfo + } + + +-- | Used when some IO (or other) exception ocurred during a request +data HTTPIOException + = HTTPIOException + { errorMessage :: Text + , request :: HTTPRequestMasked + , apiTag :: Text + , latency :: Integer + } + deriving (Eq, Generic, ToJSON) + +data HTTPResponseException + = HTTPResponseException + { errorMessage :: Text + , response :: HTTPResponseMasked + , apiTag :: Text + } + deriving (Eq, Generic, ToJSON) + +data HTTPResponseExceptionWithRequest + = HTTPResponseExceptionWithRequest + { errorMessage :: Text + , response :: HTTPResponseWithRequest + , apiTag :: Text + } + deriving (Eq, 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 + +-------------------------------------------------------------------------- +-- Convenience functions +-------------------------------------------------------------------------- + +-- | HTTP GET request. +-- +-- > httpGet "https://google.com" +httpGet :: Text -> HTTPRequest +httpGet = defaultRequest Get + +httpPut :: Text -> HTTPRequest +httpPut = defaultRequest Put + +httpPost :: Text -> HTTPRequest +httpPost = defaultRequest Post + +httpDelete :: Text -> HTTPRequest +httpDelete = defaultRequest Delete + +httpHead :: Text -> HTTPRequest +httpHead = defaultRequest Head + +defaultRequest :: HTTPMethod -> Text -> HTTPRequest +defaultRequest method url + = HTTPRequest + { getRequestMethod = method + , getRequestHeaders = Map.empty + , getRequestBody = Nothing + , getRequestURL = url + , getRequestTimeout = Just defaultTimeout + , getRequestRedirects = Just 10 + } + +defaultTimeout :: Int +defaultTimeout = 9000000 + +-- | Add a header to an HTTPRequest +-- +-- > httpGet "https://google.com" +-- > & withHeader "Content-Type" "application/json" +-- +withHeader :: HeaderName -> HeaderValue -> HTTPRequest -> HTTPRequest +withHeader headerName headerValue request@HTTPRequest {getRequestHeaders} = + let headers = Map.insert headerName headerValue getRequestHeaders + in request { getRequestHeaders = headers } + +withOptionalHeader :: HeaderName -> Maybe HeaderValue -> HTTPRequest -> HTTPRequest +withOptionalHeader headerName (Just headerValue) = withHeader headerName headerValue +withOptionalHeader _ Nothing = id + +-- | Sets timeout, in microseconds +withTimeout :: Int -> HTTPRequest -> HTTPRequest +withTimeout timeout request = + request {getRequestTimeout = Just timeout} + +-- | Sets the maximum number of redirects +withRedirects :: Int -> HTTPRequest -> HTTPRequest +withRedirects redirects request = + request {getRequestRedirects = Just redirects} + +{-# DEPRECATED withBody "use withFormBody and withJSONBody instead" #-} +withBody :: [(Text, Text)] -> HTTPRequest -> HTTPRequest +withBody pairs request = request {getRequestBody = Just body} + where + body = T.LBinaryString $ formUrlEncode pairs + +-- | Sets an http form-based body +withFormBody :: [(Text, Text)] -> HTTPRequest -> HTTPRequest +withFormBody = withBody + +-- | Sets a JSON body +withJSONBody :: ToJSON b => b -> HTTPRequest -> HTTPRequest +withJSONBody body req@HTTPRequest{getRequestHeaders} = + let json = A.encode body + headers = Map.insert "content-type" "application/json" getRequestHeaders + in req + { getRequestBody = Just $ convertString json + , getRequestHeaders = headers + } + +extractBody :: HTTPResponse -> Text +extractBody HTTPResponse{getResponseBody} = decodeUtf8With lenientDecode $ convertString getResponseBody + +data HttpData = HttpRequest HTTPRequest | HttpResponse HTTPResponse + +type MaskReqRespBody = HttpData -> A.Value + +maskHTTPRequest :: Maybe Log.LogMaskingConfig -> HTTPRequest -> Maybe MaskReqRespBody-> HTTPRequestMasked +maskHTTPRequest mbMaskConfig request mbMaskReqBody = HTTPRequestMasked + { getRequestHeaders = maskHTTPHeaders (shouldMaskKey mbMaskConfig) getMaskText requestHeaders + , getRequestBody = maskedRequestBody + , getRequestMethod = request.getRequestMethod + , getRequestURL = request.getRequestURL + , getRequestTimeout = request.getRequestTimeout + , getRequestRedirects = request.getRequestRedirects + } + where + requestHeaders = request.getRequestHeaders + + requestBody = request.getRequestBody + + getMaskText = maybe defaultMaskText (fromMaybe defaultMaskText . Log._maskText) mbMaskConfig + + maskedRequestBody = case mbMaskReqBody of + Just mskReqBody -> Just . mskReqBody $ HttpRequest request + Nothing -> parseRequestResponseBody (shouldMaskKey mbMaskConfig) getMaskText (getContentTypeForHTTP requestHeaders) . LB.toStrict . T.getLBinaryString <$> requestBody + + +maskHTTPResponse :: Maybe Log.LogMaskingConfig -> HTTPResponse -> Maybe MaskReqRespBody-> HTTPResponseMasked +maskHTTPResponse mbMaskConfig response mbMaskResBody = HTTPResponseMasked + { getResponseHeaders = maskHTTPHeaders (shouldMaskKey mbMaskConfig) getMaskText responseHeaders + , getResponseBody = maskedResponseBody + , getResponseCode = response.getResponseCode + , getResponseStatus = response.getResponseStatus + } + where + responseHeaders = response.getResponseHeaders + + responseBody = response.getResponseBody + + getMaskText = maybe defaultMaskText (fromMaybe defaultMaskText . Log._maskText) mbMaskConfig + + maskedResponseBody = case mbMaskResBody of + Just mskResBody -> mskResBody $ HttpResponse response + Nothing -> parseRequestResponseBody (shouldMaskKey mbMaskConfig) getMaskText (getContentTypeForHTTP responseHeaders) . LB.toStrict . T.getLBinaryString $ responseBody + + +httpBypassProxyList :: Maybe Text +httpBypassProxyList = Conf.lookupEnvT "HTTP_PROXY_BYPASS_LIST" + +decodeFromText :: FromJSON a => Text -> Maybe a +decodeFromText = A.decode . LB.fromStrict . Text.encodeUtf8 + +shouldBypassProxy :: Maybe Text -> Bool +shouldBypassProxy mHostname = + case (mHostname, httpBypassProxyList) of + (Just hostname, Just bypassProxyListText) -> + let mUrlList = decodeFromText bypassProxyListText :: Maybe [Text] + urlList = fromMaybe [] mUrlList + in List.any (\x -> Text.isInfixOf x hostname) urlList + (_ , _ ) -> False diff --git a/src/EulerHS/Interpreters.hs b/src/EulerHS/Interpreters.hs index f03fccfb..05ee7a80 100644 --- a/src/EulerHS/Interpreters.hs +++ b/src/EulerHS/Interpreters.hs @@ -5,30 +5,34 @@ 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 + ( runKVDB, + runLogger, + runPubSub, + interpretPubSubF, + runSqlDB, + runFlow, + runFlow' ) where -import EulerHS.Core.Interpreters as X -import EulerHS.Framework.Interpreters as X +import EulerHS.Framework.Interpreter (runFlow, runFlow') +import EulerHS.KVDB.Interpreter (runKVDB) +import EulerHS.Logger.Interpreter (runLogger) +import EulerHS.PubSub.Interpreter (interpretPubSubF, runPubSub) +import EulerHS.SqlDB.Interpreter (runSqlDB) diff --git a/src/EulerHS/KVConnector/DBSync.hs b/src/EulerHS/KVConnector/DBSync.hs new file mode 100644 index 00000000..d0353a88 --- /dev/null +++ b/src/EulerHS/KVConnector/DBSync.hs @@ -0,0 +1,204 @@ +{- | +Module : EulerHS.KVConnector.DBSync +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module EulerHS.KVConnector.DBSync where + +import EulerHS.Prelude +import EulerHS.KVConnector.Types (KVConnector, MeshMeta(..)) +import EulerHS.KVConnector.Utils (getPKeyAndValueList, meshModelTableEntityDescriptor, toPSJSON) +import EulerHS.Types (DBConfig) +import qualified Data.Aeson as A +import Data.Aeson ((.=)) +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import qualified Database.Beam as B +import qualified Database.Beam.Schema.Tables as B +import Sequelize (Model, Where, Clause(..), Term(..), Column, fromColumnar', columnize) +import Text.Casing (pascal) +import EulerHS.PIIEncryption(PIIMetadata(..)) + + +-- For storing DBCommands in stream + +type Tag = Text + +type DBName = Text + +data DBCommandVersion = V1 + deriving (Generic, Show, ToJSON, FromJSON) + +getCreateQuery :: (ToJSON (table Identity)) => Text -> DBCommandVersion -> PIIMetadata -> Double -> DBName -> table Identity -> A.Value +getCreateQuery model cmdVersion piiMeta timestamp dbName dbObject = A.object + [ "contents" .= A.toJSON + [ A.toJSON cmdVersion + , A.toJSON piiMeta + , A.toJSON timestamp + , A.toJSON dbName + , A.object + [ "contents" .= dbObject, + "tag" .= ((T.pack . pascal . T.unpack) model <> "Object") + ] + ] + , "tag" .= ("Create" :: Text) + ] +-- | This will take updateCommand from getDbUpdateCommandJson and returns Aeson value of Update DBCommand +getUpdateQuery :: DBCommandVersion -> PIIMetadata -> Double -> DBName -> A.Value -> A.Value +getUpdateQuery cmdVersion piiMeta timestamp dbName updateCommand = A.object + [ "contents" .= A.toJSON + [ A.toJSON cmdVersion + , A.toJSON piiMeta + , A.toJSON timestamp + , A.toJSON dbName + , updateCommand + ] + , "tag" .= ("Update" :: Text) + ] + +getDbUpdateCommandJson :: forall be table. (Model be table, MeshMeta be table) => Text -> [(Text, A.Value)] -> Where be table -> A.Value +getDbUpdateCommandJson model upd whereClause = A.object + [ "contents" .= A.toJSON + [ updValToJSON . (toPSJSON @be @table) <$> upd + , [whereClauseToJson whereClause] + ] + , "tag" .= ((T.pack . pascal . T.unpack) model <> "Options") + ] + +getDbUpdateCommandJsonWithPrimaryKey :: forall be beM table. (KVConnector (table Identity), Model be table, MeshMeta be table, A.ToJSON (table Identity)) => DBConfig beM -> Text -> [(Text, A.Value)] -> table Identity -> Where be table -> A.Value +getDbUpdateCommandJsonWithPrimaryKey dbConf model upd table whereClause = A.object + [ "contents" .= A.toJSON + [ updValToJSON . (toPSJSON @be @table) <$> upd + , [(whereClauseJsonWithPrimaryKey @be) dbConf table $ whereClauseToJson whereClause] + ] + , "tag" .= ((T.pack . pascal . T.unpack) model <> "Options") + ] + +whereClauseJsonWithPrimaryKey :: forall be beM table. (HasCallStack, KVConnector (table Identity), A.ToJSON (table Identity), MeshMeta be table) => DBConfig beM -> table Identity -> A.Value -> A.Value +whereClauseJsonWithPrimaryKey dbConf table whereClause = + case whereClause of + A.Object o -> + let mbClause = HM.lookup "value1" o + in case mbClause of + Just clause -> + let pKeyValueList = getPKeyAndValueList dbConf table + modifiedKeyValueList = modifyKeyValue <$> pKeyValueList + andOfKeyValueList = A.toJSON $ HM.singleton ("$and" :: Text) $ A.toJSON modifiedKeyValueList + modifiedClause = A.toJSON $ HM.singleton ("$and" :: Text) $ A.toJSON [clause, andOfKeyValueList] + modifiedObject = HM.insert ("value1" :: Text) modifiedClause o + in A.toJSON modifiedObject + Nothing -> error "Invalid whereClause, contains no item value1" + _ -> error "Cannot modify whereClause that is not an Object" + + where + modifyKeyValue :: (Text, A.Value) -> A.Value + modifyKeyValue (key, value) = A.toJSON $ HM.singleton key (snd $ (toPSJSON @be @table) (key, value)) + +getDeleteQuery :: DBCommandVersion -> Tag -> Double -> DBName -> A.Value -> A.Value +getDeleteQuery cmdVersion tag timestamp dbName deleteCommand = A.object + [ "contents" .= A.toJSON + [ A.toJSON cmdVersion + , A.toJSON tag + , A.toJSON timestamp + , A.toJSON dbName + , deleteCommand + ] + , "tag" .= ("Delete" :: Text) + ] + +getDbDeleteCommandJson :: forall be table. (Model be table, MeshMeta be table) => Text -> Where be table -> A.Value +getDbDeleteCommandJson model whereClause = A.object + [ "contents" .= whereClauseToJson whereClause + , "tag" .= ((T.pack . pascal . T.unpack) model <> "Options") + ] + +getDbDeleteCommandJsonWithPrimaryKey :: forall be table beM. (HasCallStack, KVConnector (table Identity), Model be table, MeshMeta be table, A.ToJSON (table Identity)) => DBConfig beM -> Text -> table Identity -> Where be table -> A.Value +getDbDeleteCommandJsonWithPrimaryKey dbConf model table whereClause = A.object + [ "contents" .= ((whereClauseJsonWithPrimaryKey @be) dbConf table $ whereClauseToJson whereClause) + , "tag" .= ((T.pack . pascal . T.unpack) model <> "Options") + ] + +updValToJSON :: (Text, A.Value) -> A.Value +updValToJSON (k, v) = A.object [ "value0" .= k, "value1" .= v ] + +whereClauseToJson :: (Model be table, MeshMeta be table) => Where be table -> A.Value +whereClauseToJson whereClause = A.object + [ ("value0" :: Text) .= ("where" :: Text) + , "value1" .= modelEncodeWhere whereClause + ] + +modelEncodeWhere :: + forall be table. + (Model be table, MeshMeta be table) => + Where be table -> + A.Object +modelEncodeWhere = encodeWhere meshModelTableEntityDescriptor + +encodeWhere :: + forall be table. + (B.Beamable table, MeshMeta be table) => + B.DatabaseEntityDescriptor be (B.TableEntity table) -> + Where be table -> + A.Object +encodeWhere dt = encodeClause dt . And + +encodeClause :: + forall be table. + (B.Beamable table, MeshMeta be table) => + B.DatabaseEntityDescriptor be (B.TableEntity table) -> + Clause be table -> + A.Object +encodeClause dt w = + let foldWhere' = \case + And cs -> foldAnd cs + Or cs -> foldOr cs + Is column val -> foldIs column val + foldAnd = \case + [] -> HM.empty + [x] -> foldWhere' x + xs -> HM.singleton "$and" (A.toJSON $ map foldWhere' xs) + foldOr = \case + [] -> HM.empty + [x] -> foldWhere' x + xs -> HM.singleton "$or" (A.toJSON $ map foldWhere' xs) + foldIs :: A.ToJSON a => Column table value -> Term be a -> A.Object + foldIs column term = + let key = + B._fieldName . fromColumnar' . column . columnize $ + B.dbTableSettings dt + in HM.singleton key $ (encodeTerm @table) key term + in foldWhere' w + +encodeTerm :: forall table be value. (A.ToJSON value, MeshMeta be table) => Text -> Term be value -> A.Value +encodeTerm key = \case + In vals -> array "$in" (modifyToPsFormat <$> vals) + Eq val -> modifyToPsFormat val + Null -> A.Null + GreaterThan val -> single "$gt" (modifyToPsFormat val) + GreaterThanOrEq val -> single "$gte" (modifyToPsFormat val) + LessThan val -> single "$lt" (modifyToPsFormat val) + LessThanOrEq val -> single "$lte" (modifyToPsFormat val) + Not (In vals) -> array "$notIn" (modifyToPsFormat <$> vals) + Not (Eq val) -> single "$ne" (modifyToPsFormat val) + Not Null -> single "$ne" A.Null + Not term -> single "$not" ((encodeTerm @table) key term) + _ -> error "Error while encoding - Term not supported" + + where + modifyToPsFormat val = snd $ (toPSJSON @be @table) (key, A.toJSON val) + +array :: Text -> [A.Value] -> A.Value +array k vs = A.toJSON $ HM.singleton k vs + +single :: Text -> A.Value -> A.Value +single k v = A.toJSON $ HM.singleton k v + diff --git a/src/EulerHS/KVConnector/Encoding.hs b/src/EulerHS/KVConnector/Encoding.hs new file mode 100644 index 00000000..b972e236 --- /dev/null +++ b/src/EulerHS/KVConnector/Encoding.hs @@ -0,0 +1,42 @@ +{- | +Module : EulerHS.KVConnector.Encoding +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE OverloadedStrings #-} +module EulerHS.KVConnector.Encoding + ( + encode_, + encodeDead, + decodeLiveOrDead + ) + where + +import EulerHS.Prelude +import qualified Data.Aeson as Aeson +import qualified Data.Serialize as Cereal +import qualified Data.ByteString.Lazy as BSL +import Data.Cereal.Instances () + +encode_ :: (Aeson.ToJSON a, Cereal.Serialize a) => Bool -> a -> BSL.ByteString +encode_ isEnabled val = + if isEnabled + then BSL.fromStrict $ "CBOR" <> Cereal.encode val + else "JSON" <> Aeson.encode val + + +-- LIVE/DEAD marker for values + +encodeDead :: BSL.ByteString -> BSL.ByteString +encodeDead val = "DEAD" <> val + +decodeLiveOrDead :: BSL.ByteString -> (Bool, BSL.ByteString) +decodeLiveOrDead val = + let (h, v) = BSL.splitAt 4 val + in case h of + "DEAD" -> (False, v) + _ -> (True , val) diff --git a/src/EulerHS/KVConnector/Flow.hs b/src/EulerHS/KVConnector/Flow.hs new file mode 100644 index 00000000..e7aee0ad --- /dev/null +++ b/src/EulerHS/KVConnector/Flow.hs @@ -0,0 +1,1268 @@ +{- | +Module : EulerHS.KVConnector.Flow +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# OPTIONS_GHC -Wno-unused-local-binds #-} + + +module EulerHS.KVConnector.Flow + ( + createWoReturingKVConnector, + createWithKVConnector, + findWithKVConnector, + updateWoReturningWithKVConnector, + updateWithKVConnector, + findAllWithKVConnector, + updateAllWithKVConnector, + getFieldsAndValuesFromClause, + updateAllReturningWithKVConnector, + findAllWithOptionsKVConnector, + deleteWithKVConnector, + deleteReturningWithKVConnector, + deleteAllReturningWithKVConnector + ) + where + +import EulerHS.PIIEncryption +import EulerHS.Extra.Time (getCurrentDateInMillis) +import EulerHS.Prelude hiding (maximum) +import EulerHS.CachedSqlDBQuery + ( findAllSql, + createReturning, + createSqlWoReturing, + updateOneSqlWoReturning, + SqlReturning(..), + findOne, + findAll, + findAllExtended') +import EulerHS.KVConnector.Types (KVConnector(..), MeshConfig, MeshResult, MeshMeta(..), SecondaryKey(..), tableName, keyMap, Source(..), ETLStreamKeys (ETLCreate, ETLUpdate)) +import EulerHS.KVConnector.DBSync (getCreateQuery, getUpdateQuery, getDeleteQuery, getDbDeleteCommandJson, getDbUpdateCommandJson, getDbUpdateCommandJsonWithPrimaryKey, getDbDeleteCommandJsonWithPrimaryKey, DBCommandVersion(..)) +import EulerHS.KVConnector.InMemConfig.Flow (searchInMemoryCache, pushToInMemConfigStream, fetchRowFromDBAndAlterImc) +import EulerHS.KVConnector.InMemConfig.Types (ImcStreamCommand(..)) +import EulerHS.KVConnector.Utils +import EulerHS.KVDB.Types (KVDBReply,MeshError(..)) +import EulerHS.Types (Operation(..)) +import Control.Arrow ((>>>)) +import qualified Data.Aeson as A +import qualified Data.ByteString.Lazy as BSL +import Data.List (span,maximum) +import qualified Data.Text as T +import qualified EulerHS.Language as L +import qualified Data.HashMap.Strict as HM +import Data.Either.Extra (mapLeft, mapRight) +import qualified Data.Serialize as Serialize +import EulerHS.SqlDB.Types (BeamRunner, BeamRuntime, DBConfig, DBError(DBError), DBErrorType (PIIError)) +import qualified EulerHS.SqlDB.Language as DB +import Sequelize (fromColumnar', columnize, sqlSelect, sqlSelect', sqlUpdate, sqlDelete, modelTableName, Model, Where, Clause(..), Set(..), OrderBy(..)) +import qualified Database.Beam as B +import qualified Database.Beam.Postgres as BP +import qualified EulerHS.KVConnector.Encoding as Encoding +import EulerHS.Logger.Types (ErrorL (..)) +import Named (defaults, (!)) +import qualified EulerHS.ART.DBReplay as DBReplay +import qualified EulerHS.ART.EnvVars as Env (isArtReplayEnabled) +import EulerHS.KVConnector.Metrics( incrementRedisCallMetric) +import qualified Juspay.Extra.Config as Conf +import EulerHS.CachedSqlDBQuery (runQuery) + +isArtRecEnabled :: Bool +isArtRecEnabled = fromMaybe False $ readMaybe =<< Conf.lookupEnvT "RUNNING_MODE" + +createWoReturingKVConnector :: forall (table :: (Type -> Type) -> Type) be m beM. + ( HasCallStack, + SqlReturning beM be, + Model be table, + BeamRuntime be beM, + BeamRunner beM, + B.HasQBuilder be, + FromJSON (table Identity), + ToJSON (table Identity), + (PII table), + Serialize.Serialize (table Identity), + Show (table Identity), + KVConnector (table Identity), + L.MonadFlow m) => + DBConfig beM -> + MeshConfig -> + table Identity -> + m (MeshResult ()) +createWoReturingKVConnector dbConf meshCfg value = do + let + isEnabled = meshCfg.meshEnabled && not meshCfg.kvHardKilled + tName = (modelTableName @table) + t1 <- getCurrentDateInMillis + eitherTableRowWithPrimaryId <- getTableRowWithPrimaryId dbConf meshCfg tName value + handleError eitherTableRowWithPrimaryId $ \tableRowWithPrimaryId -> do + res <- create tName isEnabled tableRowWithPrimaryId + t2 <- getCurrentDateInMillis + let + source = if isEnabled then KV else SQL + res' = mapRight (const value) res + logAndIncrementKVMetric True "CREATE" CREATE res' (t2 - t1) (modelTableName @table) source Nothing $> res + where + handleError :: MeshResult a -> (a -> m (MeshResult b)) -> m (MeshResult b) + handleError = flip (either (pure . Left)) + + create :: Text -> Bool -> table Identity -> m (MeshResult ()) + create tName isEnabled tableRowWithPrimaryId = getEncryptionKey tName >>= \case + Right mbKeyConfig -> if isEnabled + then mapRight (const ()) <$> createKV dbConf meshCfg tableRowWithPrimaryId mbKeyConfig + else DBReplay.runWithArtCreatemSQl dbConf tableRowWithPrimaryId "createSqlWoReturing" $ createSqlWoReturing dbConf tableRowWithPrimaryId mbKeyConfig + Left e -> return $ Left $ MDBError e + + +createWithKVConnector :: + forall (table :: (Type -> Type) -> Type) be m beM. + ( HasCallStack, + SqlReturning beM be, + Model be table, + BeamRuntime be beM, + BeamRunner beM, + B.HasQBuilder be, + FromJSON (table Identity), + PII table, + ToJSON (table Identity), + Serialize.Serialize (table Identity), + Show (table Identity), + KVConnector (table Identity), + L.MonadFlow m) => + DBConfig beM -> + MeshConfig -> + table Identity -> + m (MeshResult (table Identity)) +createWithKVConnector dbConf meshCfg value = do + let + isEnabled = meshCfg.meshEnabled && not meshCfg.kvHardKilled + tName = (modelTableName @table) + t1 <- getCurrentDateInMillis + eitherTableRowWithPrimaryId <- getTableRowWithPrimaryId dbConf meshCfg tName value + handleError eitherTableRowWithPrimaryId $ \tableRowWithPrimaryId -> do + res <- imcPush =<< create tName isEnabled tableRowWithPrimaryId + t2 <- getCurrentDateInMillis + let source = if isEnabled then KV else SQL + logAndIncrementKVMetric True "CREATE" CREATE_RETURNING res (t2 - t1) (modelTableName @table) source Nothing $> res + + where + handleError :: MeshResult a -> (a -> m (MeshResult b)) -> m (MeshResult b) + handleError = flip (either (pure . Left)) + + imcPush :: MeshResult (table Identity) -> m (MeshResult (table Identity)) + imcPush res = res <$ (when meshCfg.memcacheEnabled $ do + case res of + Right obj -> pushToInMemConfigStream meshCfg ImcInsert obj + Left _ -> pure ()) + + create :: Text -> Bool -> table Identity -> m (MeshResult (table Identity)) + create tName isKVEnabled tableRowWithPrimaryId = getEncryptionKey tName >>= \case + Right mbKeyConfig -> if isKVEnabled + then createKV dbConf meshCfg tableRowWithPrimaryId mbKeyConfig + else DBReplay.runWithArtCreatemSQl dbConf tableRowWithPrimaryId "createReturning" $ createReturning dbConf tableRowWithPrimaryId Nothing mbKeyConfig + Left e -> pure $ Left $ MDBError e + +createKV :: forall (table :: (Type -> Type) -> Type) m beM. + ( FromJSON (table Identity), + ToJSON (table Identity), + Serialize.Serialize (table Identity), + Show (table Identity), + KVConnector (table Identity), + L.MonadFlow m) => + DBConfig beM -> + MeshConfig -> + table Identity -> + Maybe (PIIEncryptionKeyId, PIIEncryptionKey) -> + m (MeshResult (table Identity)) +createKV dbConf meshCfg val mbKeyConfig = do + let isMySQL = isMySQLConfig dbConf + pKeyText = getLookupKeyByPKey isMySQL val + shard = getShardedHashTag pKeyText + pKey = fromString . T.unpack $ pKeyText <> shard + ntag = makePIIMetadata (mbKeyConfig >>= (\(PIIEncryptionKeyId{encKeyId}, _) -> Just encKeyId)) (pKeyText <> shard) + time <- fromIntegral <$> L.getCurrentDateInMillis + let qCmd = getCreateQuery (tableName @(table Identity)) V1 ntag time meshCfg.meshDBName val + revMappingRes <- mapM (\secIdx -> do + let sKey = fromString . T.unpack $ secIdx + _ <- L.rSadd meshCfg.kvRedis sKey [pKey] + L.rExpireB meshCfg.kvRedis sKey meshCfg.redisTtl + ) $ getSecondaryLookupKeys isMySQL val + case foldEither revMappingRes of + Left err -> pure $ Left $ MRedisError err + Right _ -> do + kvRes <- if meshCfg.shouldPushToETLStream + then addToDBSyncStreamETLStreamAndRedis meshCfg shard qCmd ETLCreate pKey val + else addToDBSyncStreamAndRedis meshCfg shard qCmd pKey val + case kvRes of + Right _ -> pure $ Right val + Left err -> pure $ Left (MRedisError err) + +---------------- Update ----------------- + +updateWoReturningWithKVConnector :: forall be table beM m. + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + SqlReturning beM be, + Model be table, + MeshMeta be table, + B.HasQBuilder be, + KVConnector (table Identity), + PII table, + PIIUpdate be table, + FromJSON (table Identity), + ToJSON (table Identity), + Serialize.Serialize (table Identity), + Show (table Identity), --debugging purpose + L.MonadFlow m + ) => + DBConfig beM -> + MeshConfig -> + [Set be table] -> + Where be table -> + m (MeshResult ()) +updateWoReturningWithKVConnector dbConf meshCfg setClause whereClause = do + let isDisabled = meshCfg.kvHardKilled + t1 <- getCurrentDateInMillis + let tName = (modelTableName @table) + eitherPiiKeys <- getEncryptionKey tName + case eitherPiiKeys of + Left e -> return $ Left $ MDBError e + Right mbval -> do + (source, res) <- if not isDisabled + then do + -- Discarding object + (\updRes -> (fst updRes, mapRight (const ()) (snd updRes))) <$> modifyOneKV dbConf meshCfg whereClause (Just setClause) True True mbval + else do + res <- DBReplay.runWithArtUpdate dbConf setClause whereClause "updateOneSqlWoReturning" $ updateOneSqlWoReturning dbConf setClause whereClause mbval + (SQL,) <$> case res of + Right val -> do + {- + Since beam-mysql doesn't implement updateRowsReturning, we fetch the row from imc (or lower layers) + and then update the json so fetched and finally setting it in the imc. + -} + if meshCfg.memcacheEnabled + then fetchRowFromDBAndAlterImc dbConf meshCfg whereClause ImcInsert + else return $ Right val + + Left e -> return $ Left e + t2 <- getCurrentDateInMillis + + diffRes <- whereClauseDiffCheck dbConf whereClause + logAndIncrementKVMetric True "UPDATE" UPDATE res (t2 - t1) (modelTableName @table) source diffRes + pure res + +updateWithKVConnector :: forall table be beM m. + ( HasCallStack, + SqlReturning beM be, + BeamRuntime be beM, + BeamRunner beM, + Model be table, + MeshMeta be table, + B.HasQBuilder be, + KVConnector (table Identity), + FromJSON (table Identity), + PII table, + PIIUpdate be table, + ToJSON (table Identity), + Serialize.Serialize (table Identity), + Show (table Identity), --debugging purpose + L.MonadFlow m + ) => + DBConfig beM -> + MeshConfig -> + [Set be table] -> + Where be table -> + m (MeshResult (Maybe (table Identity))) +updateWithKVConnector dbConf meshCfg setClause whereClause = do + let isDisabled = meshCfg.kvHardKilled + t1 <- getCurrentDateInMillis + (source, res) <- if not isDisabled + then do + modifyOneKV dbConf meshCfg whereClause (Just setClause) False True Nothing + else do + eitherPiiKeys <- getEncryptionKey (modelTableName @table) + case eitherPiiKeys of + Left e -> return (SQL, Left $ MDBError e) + Right mbval -> do + res <- genericUpdateReturning dbConf meshCfg setClause whereClause mbval + (SQL, ) <$> case res of + Right (Just x) -> do + when meshCfg.memcacheEnabled $ pushToInMemConfigStream meshCfg ImcInsert x + return $ Right (Just x) + Right Nothing -> return $ Right Nothing + Left e -> return $ Left e + t2 <- getCurrentDateInMillis + diffRes <- whereClauseDiffCheck dbConf whereClause + logAndIncrementKVMetric True "UPDATE" UPDATE_RETURNING res (t2 - t1) (modelTableName @table) source diffRes + pure res + +genericUpdateReturning :: forall table be beM m. + ( HasCallStack, + SqlReturning beM be, + BeamRuntime be beM, + BeamRunner beM, + Model be table, + MeshMeta be table, + B.HasQBuilder be, + KVConnector (table Identity), + FromJSON (table Identity), + PII table, + PIIUpdate be table, + ToJSON (table Identity), + Serialize.Serialize (table Identity), + Show (table Identity), + L.MonadFlow m + ) => + DBConfig beM -> + MeshConfig -> + [Set be table] -> + Where be table -> + Maybe (PIIEncryptionKeyId, PIIEncryptionKey) -> + m (MeshResult (Maybe (table Identity))) +genericUpdateReturning dbConf meshCfg setClause whereClause mbval = do + res <- if isMySQLConfig dbConf + then do + findResp <- findOneFromDB dbConf whereClause + result <- DBReplay.runWithArtUpdate dbConf setClause whereClause "updateOneSqlWoReturning" $ updateOneSqlWoReturning dbConf setClause whereClause mbval + case result of + Left err -> pure $ Left err + Right _ -> do + case findResp of + Right (Just respVal) -> case updateModel' setClause respVal of + Right val -> pure $ Right (Just val) + Left errU -> L.logErrorV ("UPDATE_MODEL_LOG_FAILURE" :: Text) (A.object [("model", A.String (modelTableName @table)),("error", A.toJSON errU)]) *> + findOneFromDB dbConf whereClause -- Doesn't seem to occur but just to avoid decode issue in SQL flow because of KV instances + _ -> pure $ findResp + else do + let updateQuery = DB.updateRowsReturningList $ sqlUpdate ! #set setClause ! #where_ whereClause + res <- DBReplay.runWithArtUpdate dbConf setClause whereClause "updateWithKVConnector" $runQuery dbConf updateQuery + case res of + Right [x] -> return $ Right (Just x) + Right [] -> return $ Right Nothing + Right xs -> do + let message = "DB returned \"" <> show (length xs) <> "\" rows after update for table: " <> show (tableName @(table Identity)) + L.logErrorWithCategory @Text "updateWithKVConnector" message $ ErrorL Nothing "KV_ERROR" message + return $ Left $ UnexpectedError message + Left e -> return $ Left e + case res of + Right (Just row) -> addToETLStream meshCfg (isMySQLConfig dbConf) ETLUpdate row $> res + _ -> pure res + + +modifyOneKV :: forall be table beM m. + ( HasCallStack, + SqlReturning beM be, + BeamRuntime be beM, + Model be table, + MeshMeta be table, + B.HasQBuilder be, + KVConnector (table Identity), + PII table, + PIIUpdate be table, + ToJSON (table Identity), + FromJSON (table Identity), + Show (table Identity), + Serialize.Serialize (table Identity), + L.MonadFlow m, B.HasQBuilder be, BeamRunner beM) => + DBConfig beM -> + MeshConfig -> + Where be table -> + Maybe [Set be table] -> + Bool -> + Bool -> + Maybe (PIIEncryptionKeyId , PIIEncryptionKey) -> + m (Source, MeshResult (Maybe (table Identity))) +modifyOneKV dbConf meshCfg whereClause mbSetClause updateWoReturning isLive mbKeyConfig = do + let setClause = fromMaybe [] mbSetClause + updVals = jsonKeyValueUpdates setClause + kvResult <- findOneFromRedis dbConf meshCfg whereClause + case kvResult of + Right ([], []) -> updateInKVOrSQL Nothing updVals setClause + Right ([], _) -> do + L.logDebugT "modifyOneKV" ("Modifying nothing - Row is deleted already for " <> tableName @(table Identity)) + pure (KV, Right Nothing) + Right (kvLiveRows, _) -> do + findFromDBIfMatchingFailsRes <- findFromDBIfMatchingFails dbConf whereClause kvLiveRows + case findFromDBIfMatchingFailsRes of + (_, Right []) -> pure (KV, Right Nothing) + (SQL, Right [dbRow]) -> updateInKVOrSQL (Just dbRow) updVals setClause + (KV, Right [obj]) -> (KV,) . mapRight Just <$> (if isLive + then updateObjectRedis dbConf meshCfg updVals False whereClause mbKeyConfig obj + else deleteObjectRedis dbConf meshCfg False whereClause obj) + (source, Right _) -> do + L.logErrorWithCategory ("modifyOneKV" :: Text) "Found more than one record in redis - Modification failed" $ ErrorL Nothing "KV_ERROR" "" + pure (source, Left $ MUpdateFailed "Found more than one record in redis") + (source, Left err) -> pure (source, Left err) + Left err -> pure (KV, Left err) + + where + alterImc :: Maybe (table Identity) -> m (MeshResult ()) + alterImc mbRow = do + case (isLive, mbRow) of + (True, Nothing) -> fetchRowFromDBAndAlterImc dbConf meshCfg whereClause ImcInsert + (True, Just x) -> Right <$> pushToInMemConfigStream meshCfg ImcInsert x + (False, Nothing) -> + searchInMemoryCache dbConf whereClause >>= (snd >>> \case + Left e -> return $ Left e + Right (Just a) -> Right <$> (pushToInMemConfigStream meshCfg ImcDelete) a + Right (Nothing) -> fetchRowFromDBAndAlterImc dbConf meshCfg whereClause ImcDelete) + (False, Just x) -> Right <$> pushToInMemConfigStream meshCfg ImcDelete x + + runUpdateOrDelete setClause = do + case (isLive, updateWoReturning) of + (True, True) -> do + oldRes <- fromRight Nothing <$> findOneFromDB dbConf whereClause + res <- DBReplay.runWithArtUpdate dbConf setClause whereClause "updateOneSqlWoReturning" $ updateOneSqlWoReturning dbConf setClause whereClause mbKeyConfig + case res of + Right _ -> do + void $ maybe (return ()) (addToETLStream meshCfg (isMySQLConfig dbConf) ETLUpdate) oldRes + pure $ Right Nothing + Left e -> return $ Left e + (True, False) -> do + setCl <- maybe (pure $ Right $ setClause) (\(encKeyId, encKey) -> transformSetClause setClause encKeyId encKey) mbKeyConfig + case setCl of + Left err -> return $ Left $ MDBError $ DBError PIIError err + Right setClause' -> genericUpdateReturning dbConf meshCfg setClause' whereClause mbKeyConfig + (False, True) -> do + let deleteQuery = DB.deleteRows $ sqlDelete ! #where_ whereClause + res <- DBReplay.runWithArtDelete dbConf whereClause "deleteRows" $ runQuery dbConf deleteQuery + case res of + Right _ -> return $ Right Nothing + Left e -> return $ Left e + (False, False) -> do + res <- DBReplay.runWithArtDelete dbConf whereClause "runUpdateOrDelete" $ deleteAllReturning dbConf whereClause + case res of + Right [x] -> return $ Right (Just x) + Right [] -> return $ Right Nothing + Right xs -> do + let message = "DB returned " <> show (length xs) <> " rows after delete for table: " <> show (tableName @(table Identity)) + L.logErrorWithCategory ("deleteReturningWithKVConnector" :: Text) message $ ErrorL Nothing "KV_ERROR" "" + return $ Left $ UnexpectedError message + Left e -> return $ Left e + + updateInKVOrSQL maybeRow updVals setClause = do + if isRecachingEnabled && meshCfg.meshEnabled + then do + dbRes <- case maybeRow of + Nothing -> findOneFromDB dbConf whereClause + Just dbrow -> pure $ Right $ Just dbrow + (KV,) <$> case dbRes of + Right (Just obj) -> do + reCacheDBRowsRes <- reCacheDBRows dbConf meshCfg [obj] + case reCacheDBRowsRes of + Left err -> return $ Left $ MRedisError err + Right _ -> mapRight Just <$> if isLive + then updateObjectRedis dbConf meshCfg updVals False whereClause mbKeyConfig obj + else deleteObjectRedis dbConf meshCfg False whereClause obj + Right Nothing -> pure $ Right Nothing + Left err -> pure $ Left err + else (SQL,) <$> (do + runUpdateOrDelete setClause >>= \case + Left e -> return $ Left e + Right mbRow -> if meshCfg.memcacheEnabled + then + alterImc mbRow <&> ($> mbRow) + else + return . Right $ mbRow + ) + +updateObjectInMemConfig :: forall be table m. + ( HasCallStack, + MeshMeta be table , + KVConnector (table Identity), + FromJSON (table Identity), + ToJSON (table Identity), + L.MonadFlow m + ) => MeshConfig -> Where be table -> [(Text, A.Value)] -> table Identity -> m (MeshResult ()) +updateObjectInMemConfig meshCfg _ updVals obj = do + let shouldUpdateIMC = meshCfg.memcacheEnabled + if not shouldUpdateIMC + then pure . Right $ () + else + case (updateModel @be @table) obj updVals of + Left err -> return $ Left err + Right updatedModelJson -> + case A.fromJSON updatedModelJson of + A.Error decodeErr -> return . Left . MDecodingError . T.pack $ decodeErr + A.Success (updatedModel' :: table Identity) -> do + pushToInMemConfigStream meshCfg ImcInsert updatedModel' + pure . Right $ () + + + +updateObjectRedis :: forall beM be table m. + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + Model be table, + MeshMeta be table, + B.HasQBuilder be, + KVConnector (table Identity), + FromJSON (table Identity), + ToJSON (table Identity), + Serialize.Serialize (table Identity), + -- Show (table Identity), --debugging purpose + L.MonadFlow m + ) => + DBConfig beM -> MeshConfig -> [(Text, A.Value)] -> Bool -> Where be table -> Maybe (PIIEncryptionKeyId, PIIEncryptionKey) -> table Identity -> m (MeshResult (table Identity)) +updateObjectRedis dbConf meshCfg updVals addPrimaryKeyToWhereClause whereClause mbKeyConfig obj = do + configUpdateResult <- updateObjectInMemConfig meshCfg whereClause updVals obj + when (isLeft configUpdateResult) $ L.logErrorWithCategory ("MEMCONFIG_UPDATE_ERROR" :: Text) (show configUpdateResult) $ ErrorL Nothing "MEM_CONFIG_ERROR" (show configUpdateResult) + case (updateModel @be @table) obj updVals of + Left err -> return $ Left err + Right updatedModel -> do + time <- fromIntegral <$> L.getCurrentDateInMillis + let isMySQL = isMySQLConfig dbConf + pKeyText = getLookupKeyByPKey isMySQL obj + shard = getShardedHashTag pKeyText + pKey = fromString . T.unpack $ pKeyText <> shard + ntag = makePIIMetadata (mbKeyConfig >>= (\(PIIEncryptionKeyId{encKeyId}, _) -> Just encKeyId)) (pKeyText <> shard) + updateCmd = if addPrimaryKeyToWhereClause + then getDbUpdateCommandJsonWithPrimaryKey dbConf (tableName @(table Identity)) updVals obj whereClause + else getDbUpdateCommandJson (tableName @(table Identity)) updVals whereClause + qCmd = getUpdateQuery V1 ntag time meshCfg.meshDBName updateCmd + case resultToEither $ A.fromJSON updatedModel of + Right value -> do + let olderSkeys = map (\(SKey s) -> s) (secondaryKeysFiltered isMySQL obj) + skeysUpdationRes <- modifySKeysRedis olderSkeys value + case skeysUpdationRes of + Right _ -> do + kvdbRes <- if meshCfg.shouldPushToETLStream + then addToDBSyncStreamETLStreamAndRedis meshCfg shard qCmd ETLUpdate pKey value + else addToDBSyncStreamAndRedis meshCfg shard qCmd pKey value + case kvdbRes of + Right _ -> pure $ Right value + Left err -> pure $ Left $ MRedisError err + Left err -> pure $ Left err + Left err -> pure $ Left $ MDecodingError err + + where + modifySKeysRedis :: [[(Text, Text)]] -> table Identity -> m (MeshResult (table Identity)) + modifySKeysRedis olderSkeys table = do + let isMySQL = isMySQLConfig dbConf + pKeyText = getLookupKeyByPKey isMySQL table + shard = getShardedHashTag pKeyText + pKey = fromString . T.unpack $ pKeyText <> shard + let tName = tableName @(table Identity) + updValsMap = HM.fromList (map (\p -> (fst p, True)) updVals) + (modifiedSkeysValues, unModifiedSkeysValues) = applyFPair (map getSortedKeyAndValue) $ + span (`isKeyModified` updValsMap) olderSkeys + newSkeysValues = map (\(SKey s) -> getSortedKeyAndValue s) (secondaryKeysFiltered isMySQL table) + let unModifiedSkeys = map (\x -> tName <> "_" <> fst x <> "_" <> snd x) unModifiedSkeysValues + let modifiedSkeysValuesMap = HM.fromList modifiedSkeysValues + mapRight (const table) <$> runExceptT (do + mapM_ ((ExceptT . resetTTL) . (fromString . T.unpack)) unModifiedSkeys + mapM_ (ExceptT . addNewSkey pKey tName) (foldSkeysFunc modifiedSkeysValuesMap newSkeysValues)) + + resetTTL key= do + x <- L.rExpire meshCfg.kvRedis key meshCfg.redisTtl + pure $ mapLeft MRedisError x + + foldSkeysFunc :: HashMap Text Text -> [(Text, Text)] -> [(Text, Text, Text)] + foldSkeysFunc _ [] = [] + foldSkeysFunc hm (x : xs) = do + case HM.lookup (fst x) hm of + Just val -> (fst x, snd x, val) : foldSkeysFunc hm xs + Nothing -> foldSkeysFunc hm xs + + + addNewSkey :: ByteString -> Text -> (Text, Text, Text) -> m (MeshResult ()) + addNewSkey pKey tName (k, v1, v2) = do + let newSKey = fromString . T.unpack $ tName <> "_" <> k <> "_" <> v1 + oldSKey = fromString . T.unpack $ tName <> "_" <> k <> "_" <> v2 + res <- runExceptT $ do + _ <- ExceptT $ L.sRemB meshCfg.kvRedis oldSKey [pKey] + _ <- ExceptT $ L.rSadd meshCfg.kvRedis newSKey [pKey] + ExceptT $ L.rExpireB meshCfg.kvRedis newSKey meshCfg.redisTtl + case res of + Right _ -> pure $ Right () + Left err -> pure $ Left (MRedisError err) + + getSortedKeyAndValue :: [(Text,Text)] -> (Text, Text) + getSortedKeyAndValue kvTup = do + let sortArr = sortBy (compare `on` fst) kvTup + let (appendedKeys, appendedValues) = applyFPair (T.intercalate "_") $ unzip sortArr + (appendedKeys, appendedValues) + + isKeyModified :: [(Text, Text)] -> HM.HashMap Text Bool -> Bool + isKeyModified sKey updValsMap = foldl' (\r k -> HM.member (fst k) updValsMap || r) False sKey + +updateAllReturningWithKVConnector :: forall table m. + ( HasCallStack, + Model BP.Postgres table, + MeshMeta BP.Postgres table, + KVConnector (table Identity), + FromJSON (table Identity), + ToJSON (table Identity), + PIIUpdate BP.Postgres table, + Serialize.Serialize (table Identity), + Show (table Identity), --debugging purpose + L.MonadFlow m + ) => + DBConfig BP.Pg -> + MeshConfig -> + [Set BP.Postgres table] -> + Where BP.Postgres table -> + m (MeshResult [table Identity]) +updateAllReturningWithKVConnector dbConf meshCfg setClause whereClause = do + let isDisabled = meshCfg.kvHardKilled + t1 <- getCurrentDateInMillis + res <- if not isDisabled + then do + let updVals = jsonKeyValueUpdates setClause + kvRows <- redisFindAll dbConf meshCfg whereClause + dbRows <- DBReplay.runWithArtFindALL dbConf whereClause "updateAllReturningWithKVConnector" (findAllSql dbConf whereClause) + updateKVAndDBResults meshCfg whereClause dbRows kvRows (Just updVals) False dbConf (Just setClause) True Nothing + else do + let updateQuery = DB.updateRowsReturningList $ sqlUpdate ! #set setClause ! #where_ whereClause + res <- DBReplay.runWithArtUpdate dbConf setClause whereClause "updateAllReturningWithKVConnector" $ runQuery dbConf updateQuery + case res of + Right x -> do + when meshCfg.memcacheEnabled $ + mapM_ (pushToInMemConfigStream meshCfg ImcInsert ) x + return $ Right x + Left e -> return $ Left e + t2 <- getCurrentDateInMillis + diffRes <- whereClauseDiffCheck dbConf whereClause + let source = if isDisabled then SQL else if (isRecachingEnabled && meshCfg.meshEnabled) then KV else KV_AND_SQL + logAndIncrementKVMetric True "UPDATE" UPDATE_ALL_RETURNING res (t2 - t1) (modelTableName @table) source diffRes + pure res + +updateAllWithKVConnector :: forall be table beM m. + ( HasCallStack, + SqlReturning beM be, + BeamRuntime be beM, + BeamRunner beM, + Model be table, + MeshMeta be table, + B.HasQBuilder be, + KVConnector (table Identity), + PII table, + PIIUpdate be table, + FromJSON (table Identity), + ToJSON (table Identity), + Serialize.Serialize (table Identity), + Show (table Identity), --debugging purpose + L.MonadFlow m + ) => + DBConfig beM -> + MeshConfig -> + [Set be table] -> + Where be table -> + m (MeshResult ()) +updateAllWithKVConnector dbConf meshCfg setClause whereClause = do + let isDisabled = meshCfg.kvHardKilled + t1 <- getCurrentDateInMillis + let tname = (modelTableName @table) + eitherPiiKeys <- getEncryptionKey tname + case eitherPiiKeys of + Left e -> return $ Left $ MDBError e + Right mbval -> do + res <- if not isDisabled + then do + let updVals = jsonKeyValueUpdates setClause + kvRows <- redisFindAll dbConf meshCfg whereClause + dbRows <- DBReplay.runWithArtFindALL dbConf whereClause "updateAllWithKVConnector" $ findAll dbConf Nothing whereClause + mapRight (const ()) <$> updateKVAndDBResults meshCfg whereClause dbRows kvRows (Just updVals) True dbConf (Just setClause) True mbval + else do + setCl <- maybe (pure $ Right $ setClause) (\(x, y) -> transformSetClause setClause x y) mbval + case setCl of + Left err -> return $ Left $ MDBError $ DBError PIIError err + Right setClause' -> do + let updateQuery = DB.updateRows $ sqlUpdate ! #set setClause' ! #where_ whereClause + res <- DBReplay.runWithArtUpdate dbConf setClause whereClause "updateAllWithKVConnector" $ runQuery dbConf updateQuery + case res of + Right _ -> do + let findAllQuery = DB.findRows (sqlSelect ! #where_ whereClause ! defaults) + dbRes <- findAllExtended' dbConf findAllQuery + case dbRes of + Right dbRows -> do + when meshCfg.memcacheEnabled $ + mapM_ (pushToInMemConfigStream meshCfg ImcInsert) dbRows + return . Right $ () + Left e -> return . Left . MDBError $ e + Left e -> return $ Left e + t2 <- getCurrentDateInMillis + + diffRes <- whereClauseDiffCheck dbConf whereClause + let source = if isDisabled then SQL else if (isRecachingEnabled && meshCfg.meshEnabled) then KV else KV_AND_SQL + logAndIncrementKVMetric True "UPDATE" UPDATE_ALL res (t2 - t1) (modelTableName @table) source diffRes + pure res + +updateKVAndDBResults :: forall be table beM m. + ( HasCallStack, + SqlReturning beM be, + BeamRuntime be beM, + BeamRunner beM, + Model be table, + MeshMeta be table, + PIIUpdate be table, + B.HasQBuilder be, + KVConnector (table Identity), + FromJSON (table Identity), + ToJSON (table Identity), + Serialize.Serialize (table Identity), + Show (table Identity), --debugging purpose + L.MonadFlow m + ) => MeshConfig -> Where be table -> Either DBError [table Identity] -> MeshResult ([table Identity], [table Identity]) -> Maybe [(Text, A.Value)] -> Bool -> DBConfig beM -> Maybe [Set be table] -> Bool -> Maybe (PIIEncryptionKeyId, PIIEncryptionKey) -> m (MeshResult [table Identity]) +updateKVAndDBResults meshCfg whereClause eitherDbRows eitherKvRows mbUpdateVals updateWoReturning dbConf mbSetClause isLive mbKeyConfig = do + let setClause = fromMaybe [] mbSetClause --Change this logic + updVals = fromMaybe [] mbUpdateVals + case (eitherDbRows, eitherKvRows) of + (Right allDBRows, Right allKVRows) -> do + let kvLiveRows = fst allKVRows + kvDeadRows = snd allKVRows + kvLiveAndDeadRows = kvLiveRows ++ kvDeadRows + matchedKVLiveRows = findAllMatching whereClause dbConf kvLiveRows + uniqueDbRows = getUniqueDBRes dbConf allDBRows kvLiveAndDeadRows + if isRecachingEnabled && meshCfg.meshEnabled + then do + reCacheDBRowsRes <- reCacheDBRows dbConf meshCfg uniqueDbRows + case reCacheDBRowsRes of + Left err -> return $ Left $ MRedisError err + Right _ -> do + let allRows = matchedKVLiveRows ++ uniqueDbRows + sequence <$> if isLive + then mapM (updateObjectRedis dbConf meshCfg updVals True whereClause mbKeyConfig) allRows + else mapM (deleteObjectRedis dbConf meshCfg True whereClause) allRows + else do + sequence_ $ addToETLStream meshCfg (isMySQLConfig dbConf) ETLUpdate <$> uniqueDbRows + updateOrDelKVRowRes <- if isLive + then mapM (updateObjectRedis dbConf meshCfg updVals True whereClause mbKeyConfig) kvLiveRows + else mapM (deleteObjectRedis dbConf meshCfg True whereClause) kvLiveRows + kvres <- pure $ foldEither updateOrDelKVRowRes + case kvres of + Left err -> return $ Left err + Right kvRes -> runUpdateOrDelete setClause kvRes kvLiveAndDeadRows + + (Left err, _) -> pure $ Left $ MDBError err + (_, Left err) -> pure $ Left err + + + where + runUpdateOrDelete setClause kvres kvLiveAndDeadRows = do + case (isLive, updateWoReturning) of + (True, True) -> do + setCl <- maybe (pure $ Right $ setClause) (\(encKeyId, encKey) -> transformSetClause setClause encKeyId encKey) mbKeyConfig + case setCl of + Left err -> return $ Left $ MDBError $ DBError PIIError err + Right setClause' -> do + let updateQuery = DB.updateRows $ sqlUpdate ! #set setClause' ! #where_ whereClause + res <- DBReplay.runWithArtUpdate dbConf setClause whereClause "updateKVAndDBResults" $ runQuery dbConf updateQuery + case res of + Right _ -> return $ Right [] + Left e -> return $ Left e + (True, False) -> do + setCl <- maybe (pure $ Right setClause) (\(encKeyId, encKey) -> transformSetClause setClause encKeyId encKey) mbKeyConfig + case setCl of + Left err -> return $ Left $ MDBError $ DBError PIIError err + Right setClause' -> do + let updateQuery = DB.updateRowsReturningList $ sqlUpdate ! #set setClause' ! #where_ whereClause + res <- DBReplay.runWithArtUpdate dbConf setClause whereClause "updateKVAndDBResults" $ runQuery dbConf updateQuery + case res of + Right x -> return $ Right $ (getUniqueDBRes dbConf x kvLiveAndDeadRows) ++ kvres + Left e -> return $ Left e + (False, _) -> do + res <- deleteAllReturning dbConf whereClause + case res of + Right x -> return $ Right $ (getUniqueDBRes dbConf x kvLiveAndDeadRows) ++ kvres + Left e -> return $ Left $ MDBError e + + +---------------- Find ----------------------- +findWithKVConnector :: forall be table beM m. + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + B.HasQBuilder be, + Model be table, + MeshMeta be table, + KVConnector (table Identity), + FromJSON (table Identity), + ToJSON (table Identity), + PII table, + Serialize.Serialize (table Identity), + L.MonadFlow m, + Show (table Identity) + ) => + DBConfig beM -> + MeshConfig -> + Where be table -> + m (MeshResult (Maybe (table Identity))) +findWithKVConnector dbConf meshCfg whereClause = do --This function fetches all possible rows and apply where clause on it. + let shouldSearchInMemoryCache = meshCfg.memcacheEnabled + t1 <- getCurrentDateInMillis + (source, res) <- if shouldSearchInMemoryCache + then do + if (Env.isArtReplayEnabled || isArtRecEnabled) + then + DBReplay.searchInMemoryCacheRecRepWrapper "findWithKVConnector" dbConf whereClause + else + searchInMemoryCache dbConf whereClause + else + kvFetch + t2 <- getCurrentDateInMillis + diffRes <- whereClauseDiffCheck dbConf whereClause + logAndIncrementKVMetric False "FIND" FIND res (t2 - t1) (modelTableName @table) source diffRes + pure res + where + + kvFetch :: m ((Source, MeshResult (Maybe (table Identity)))) + kvFetch = do + let isDisabled = meshCfg.kvHardKilled + if not isDisabled + then do + eitherKvRows <- findOneFromRedis dbConf meshCfg whereClause + case eitherKvRows of + Right ([], []) -> do + (SQL,) <$> findOneFromDB dbConf whereClause + Right ([], _) -> do + L.logInfoT "findWithKVConnector" ("Returning nothing - Row is deleted already for " <> tableName @(table Identity)) + pure $ (KV, Right Nothing) + Right (kvLiveRows, _) -> do + second (mapRight listToMaybe) <$> findFromDBIfMatchingFails dbConf whereClause kvLiveRows + Left err -> pure $ (KV, Left err) + else do + (SQL,) <$> findOneFromDB dbConf whereClause + +findFromDBIfMatchingFails :: forall be table beM m. + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + B.HasQBuilder be, + Model be table, + MeshMeta be table, + KVConnector (table Identity), + FromJSON (table Identity), + ToJSON (table Identity), + PII table, + L.MonadFlow m) => + DBConfig beM -> + Where be table -> + [table Identity] -> + m (Source, MeshResult [table Identity]) +findFromDBIfMatchingFails dbConf whereClause kvRows = do + case findAllMatching whereClause dbConf kvRows of -- For solving partial data case - One row in SQL and one in DB + [] -> do + dbRes <- findOneFromDB dbConf whereClause + case dbRes of + Right (Just dbRow) -> do + let isMySQL = isMySQLConfig dbConf + kvPkeys = map (getLookupKeyByPKey isMySQL) kvRows + if (getLookupKeyByPKey isMySQL) dbRow `notElem` kvPkeys + then pure (SQL, Right [dbRow]) + else pure (KV, Right []) + Left err -> pure (SQL, Left err) + _ -> pure (SQL, Right []) + xs -> pure (KV, Right xs) + +findOneFromRedis :: forall be table beM m. + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + B.HasQBuilder be, + Model be table, + MeshMeta be table, + KVConnector (table Identity), + Serialize.Serialize (table Identity), + FromJSON (table Identity), + L.MonadFlow m + ) => + DBConfig beM -> MeshConfig -> Where be table -> m (MeshResult ([table Identity], [table Identity])) +findOneFromRedis dbConf meshCfg whereClause = do + let keyAndValueCombinations = getFieldsAndValuesFromClause dbConf meshModelTableEntityDescriptor (And whereClause) + andCombinations = map (uncurry zip . applyFPair (map (T.intercalate "_") . sortOn (Down . length) . nonEmptySubsequences) . unzip . sort) keyAndValueCombinations + modelName = tableName @(table Identity) + keyHashMap = keyMap @(table Identity) + andCombinationsFiltered = mkUniq $ filterPrimaryAndSecondaryKeys keyHashMap <$> andCombinations + modelWithoutRedisLimit = modelName `elem` tablesWithoutRedisLimit + secondaryKeysLength = if modelWithoutRedisLimit then 0 else sum $ getSecondaryKeyLength keyHashMap <$> andCombinationsFiltered + withRedisLimit "REDIS_FIND_ONE_LIMIT_EXCEEDED" (modelTableName @table) secondaryKeysLength $ do + eitherKeyRes <- mapM (getPrimaryKeyFromFieldsAndValues modelName meshCfg keyHashMap) andCombinationsFiltered + case foldEither eitherKeyRes of + Right keyRes -> do + let lenKeyRes = if modelWithoutRedisLimit then 0 else lengthOfLists keyRes + withRedisLimit "REDIS_FIND_ONE_LIMIT_EXCEEDED" (modelTableName @table) lenKeyRes $ do + allRowsRes <- foldEither <$> mapM (getDataFromPKeysRedis meshCfg) (mkUniq keyRes) + case allRowsRes of + Right allRowsResPairList -> do + let (allRowsResLiveListOfList, allRowsResDeadListOfList) = unzip allRowsResPairList + let total_len = secondaryKeysLength + lenKeyRes + unless modelWithoutRedisLimit $ incrementRedisCallMetric "REDIS_FIND_ONE" (modelTableName @table) total_len (total_len > redisCallsSoftLimit ) (total_len > redisCallsHardLimit ) + return $ Right (concat allRowsResLiveListOfList, concat allRowsResDeadListOfList) + Left err -> return $ Left err + Left err -> pure $ Left err + +findOneFromDB :: forall be table beM m. + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + B.HasQBuilder be, + Model be table, + MeshMeta be table, + KVConnector (table Identity), + FromJSON (table Identity), + ToJSON (table Identity), + PII table, + L.MonadFlow m + ) => + DBConfig beM -> Where be table -> m (MeshResult (Maybe (table Identity))) +findOneFromDB dbConf whereClause = DBReplay.runWithArtFind dbConf whereClause "findOneFromDB" (findOne dbConf Nothing whereClause) + +-- Need to recheck offset implementation +findAllWithOptionsKVConnector :: forall be table beM m. + ( HasCallStack, + BeamRuntime be beM, + Model be table, + MeshMeta be table, + KVConnector (table Identity), + Serialize.Serialize (table Identity), + Show (table Identity), + ToJSON (table Identity), + FromJSON (table Identity), + L.MonadFlow m, B.HasQBuilder be, BeamRunner beM) => + DBConfig beM -> + MeshConfig -> + Where be table -> + OrderBy table -> + Maybe Int -> + Maybe Int -> + m (MeshResult [table Identity]) +findAllWithOptionsKVConnector dbConf meshCfg whereClause orderBy mbLimit mbOffset = do + let isDisabled = meshCfg.kvHardKilled + res <- if not isDisabled + then do + kvRes <- redisFindAll dbConf meshCfg whereClause + case kvRes of + Right kvRows -> do + let matchedKVLiveRows = findAllMatching whereClause dbConf (fst kvRows) + matchedKVDeadRows = snd kvRows + offset = fromMaybe 0 mbOffset + shift = length matchedKVLiveRows + length matchedKVDeadRows + updatedOffset = if offset - shift >= 0 then offset - shift else 0 + findAllQueryUpdated = DB.findRows (sqlSelect' + ! #where_ whereClause + ! #orderBy (Just [orderBy]) + ! #limit ((shift +) <$> mbLimit) + ! #offset (Just updatedOffset) -- Offset is 0 in case mbOffset Nothing + ! defaults) + dbRes <- runQuery dbConf findAllQueryUpdated + case dbRes of + Left err -> pure $ Left $ MDBError err + Right [] -> pure $ Right $ applyOptions offset matchedKVLiveRows + Right dbRows -> do + let mergedRows = matchedKVLiveRows ++ getUniqueDBRes dbConf dbRows (snd kvRows ++ fst kvRows) + if isJust mbOffset + then do + let noOfRowsFelledLeftSide = calculateLeftFelledRedisEntries matchedKVLiveRows dbRows + pure $ Right $ applyOptions ((if updatedOffset == 0 then offset else shift) - noOfRowsFelledLeftSide) mergedRows + else pure $ Right $ applyOptions 0 mergedRows + Left err -> pure $ Left err + else do + let findAllQuery = DB.findRows (sqlSelect' + ! #where_ whereClause + ! #orderBy (Just [orderBy]) + ! #limit mbLimit + ! #offset mbOffset + ! defaults) + mapLeft MDBError <$> runQuery dbConf findAllQuery + let source = if not isDisabled then KV_AND_SQL else SQL + pure res + + where + applyOptions :: Int -> [table Identity] -> [table Identity] + applyOptions shift rows = do + let cmp = case orderBy of + (Asc col) -> compareCols (fromColumnar' . col . columnize) True + (Desc col) -> compareCols (fromColumnar' . col . columnize) False + let resWithoutLimit = (drop shift . sortBy cmp) rows + maybe resWithoutLimit (`take` resWithoutLimit) mbLimit + + compareCols :: (Ord value) => (table Identity -> value) -> Bool -> table Identity -> table Identity -> Ordering + compareCols col isAsc r1 r2 = if isAsc then compare (col r1) (col r2) else compare (col r2) (col r1) + + calculateLeftFelledRedisEntries :: [table Identity] -> [table Identity] -> Int + calculateLeftFelledRedisEntries kvRows dbRows = do + case orderBy of + (Asc col) -> do + let dbMn = maximum $ map (fromColumnar' . col . columnize) dbRows + length $ filter (\r -> dbMn > fromColumnar' (col $ columnize r)) kvRows + (Desc col) -> do + let dbMx = maximum $ map (fromColumnar' . col . columnize) dbRows + length $ filter (\r -> dbMx < fromColumnar' (col $ columnize r)) kvRows + +findAllWithKVConnector :: forall be table beM m. + ( HasCallStack, + BeamRuntime be beM, + Model be table, + MeshMeta be table, + KVConnector (table Identity), + ToJSON (table Identity), + FromJSON (table Identity), + PII table, + Serialize.Serialize (table Identity), + L.MonadFlow m, B.HasQBuilder be, BeamRunner beM) => + DBConfig beM -> + MeshConfig -> + Where be table -> + m (MeshResult [table Identity]) +findAllWithKVConnector dbConf meshCfg whereClause = do + let findAllQuery = DB.findRows (sqlSelect ! #where_ whereClause ! defaults) + let isDisabled = meshCfg.kvHardKilled + t1 <- getCurrentDateInMillis + res <- if not isDisabled + then do + kvRes <- redisFindAll dbConf meshCfg whereClause + case kvRes of + Right kvRows -> do + let matchedKVLiveRows = findAllMatching whereClause dbConf (fst kvRows) + dbRes <- findAllExtended' dbConf findAllQuery + case dbRes of + Right dbRows -> pure $ Right $ matchedKVLiveRows ++ (getUniqueDBRes dbConf dbRows (fst kvRows ++ snd kvRows)) + Left err -> return $ Left $ MDBError err + Left err -> return $ Left err + else mapLeft MDBError <$> (DBReplay.runWithArtFindALL dbConf whereClause "findAllWithKVConnector" $ findAll dbConf Nothing whereClause) + t2 <- getCurrentDateInMillis + diffRes <- whereClauseDiffCheck dbConf whereClause + let source = if not isDisabled then KV_AND_SQL else SQL + logAndIncrementKVMetric False "FIND" FIND_ALL res (t2 - t1) (modelTableName @table) source diffRes + pure res +redisFindAll :: forall be table beM m. + ( HasCallStack, + BeamRuntime be beM, + Model be table, + MeshMeta be table, + KVConnector (table Identity), + FromJSON (table Identity), + Serialize.Serialize (table Identity), + L.MonadFlow m, B.HasQBuilder be, BeamRunner beM) => + DBConfig beM -> + MeshConfig -> + Where be table -> + m (MeshResult ([table Identity], [table Identity])) +redisFindAll dbConf meshCfg whereClause = do + let keyAndValueCombinations = getFieldsAndValuesFromClause dbConf meshModelTableEntityDescriptor (And whereClause) + andCombinations = map (uncurry zip . applyFPair (map (T.intercalate "_") . sortOn (Down . length) . nonEmptySubsequences) . unzip . sort) keyAndValueCombinations + modelName = tableName @(table Identity) + keyHashMap = keyMap @(table Identity) + andCombinationsFiltered = mkUniq $ filterPrimaryAndSecondaryKeys keyHashMap <$> andCombinations + modelWithoutRedisLimit = modelName `elem` tablesWithoutRedisLimit + secondaryKeysLength = if modelWithoutRedisLimit then 0 else sum $ getSecondaryKeyLength keyHashMap <$> andCombinationsFiltered + withRedisLimit "REDIS_FIND_ALL_LIMIT_EXCEEDED" (modelTableName @table) secondaryKeysLength $ do + eitherKeyRes <- mapM (getPrimaryKeyFromFieldsAndValues modelName meshCfg keyHashMap) andCombinationsFiltered + case foldEither eitherKeyRes of + Right keyRes -> do + let lenKeyRes = if modelWithoutRedisLimit then 0 else lengthOfLists keyRes + withRedisLimit "REDIS_FIND_ALL_LIMIT_EXCEEDED" (modelTableName @table) lenKeyRes $ do + allRowsRes <- foldEither <$> mapM (getDataFromPKeysRedis meshCfg) (mkUniq keyRes) + case allRowsRes of + Right allRowsResPairList -> do + let (allRowsResLiveListOfList, allRowsResDeadListOfList) = unzip allRowsResPairList + let total_len = secondaryKeysLength + lenKeyRes + unless modelWithoutRedisLimit $ incrementRedisCallMetric "REDIS_FIND_ALL" modelName total_len (total_len > redisCallsSoftLimit) (total_len>redisCallsHardLimit) + return $ Right (concat allRowsResLiveListOfList, concat allRowsResDeadListOfList) + Left err -> return $ Left err + Left err -> pure $ Left err + +deleteObjectRedis :: forall table be beM m. + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + Model be table, + MeshMeta be table, + B.HasQBuilder be, + KVConnector (table Identity), + FromJSON (table Identity), + ToJSON (table Identity), + Serialize.Serialize (table Identity), + L.MonadFlow m + ) => + DBConfig beM -> MeshConfig -> Bool -> Where be table -> (table Identity) -> m (MeshResult (table Identity)) +deleteObjectRedis dbConf meshCfg addPrimaryKeyToWhereClause whereClause obj = do + time <- fromIntegral <$> L.getCurrentDateInMillis + let pKeyText = getLookupKeyByPKey (isMySQLConfig dbConf) obj + shard = getShardedHashTag pKeyText + pKey = fromString . T.unpack $ pKeyText <> shard + deleteCmd = if addPrimaryKeyToWhereClause + then getDbDeleteCommandJsonWithPrimaryKey dbConf (tableName @(table Identity)) obj whereClause + else getDbDeleteCommandJson (tableName @(table Identity)) whereClause + qCmd = getDeleteQuery V1 (pKeyText <> shard) time meshCfg.meshDBName deleteCmd + kvDbRes <- L.runKVDB meshCfg.kvRedis $ L.multiExecWithHash (encodeUtf8 shard) $ do + _ <- L.xaddTx + (encodeUtf8 (meshCfg.ecRedisDBStream <> shard)) + L.AutoID + [("command", BSL.toStrict $ A.encode qCmd)] + L.setexTx pKey meshCfg.redisTtl (BSL.toStrict $ Encoding.encodeDead $ Encoding.encode_ meshCfg.cerealEnabled obj) + case kvDbRes of + Left err -> return . Left $ MRedisError err + Right _ -> do + pushToInMemConfigStream meshCfg ImcDelete obj + return $ Right obj + +reCacheDBRows :: forall table m beM. + ( HasCallStack, + KVConnector (table Identity), + FromJSON (table Identity), + ToJSON (table Identity), + Serialize.Serialize (table Identity), + -- Show (table Identity), --debugging purpose + L.MonadFlow m + ) => + DBConfig beM -> + MeshConfig -> + [table Identity] -> + m (Either KVDBReply [[Bool]]) +reCacheDBRows dbConf meshCfg dbRows = do + reCacheRes <- mapM (\obj -> do + let isMySQL = isMySQLConfig dbConf + pKeyText = getLookupKeyByPKey isMySQL obj + shard = getShardedHashTag pKeyText + pKey = fromString . T.unpack $ pKeyText <> shard + res <- mapM (\secIdx -> do -- Recaching Skeys in redis + let sKey = fromString . T.unpack $ secIdx + res1 <- L.rSadd meshCfg.kvRedis sKey [pKey] + case res1 of + Left err -> return $ Left err + Right _ -> + L.rExpireB meshCfg.kvRedis sKey meshCfg.redisTtl + ) $ getSecondaryLookupKeys isMySQL obj + return $ sequence res + ) dbRows + return $ sequence reCacheRes + +deleteWithKVConnector :: forall be table beM m. + ( HasCallStack, + SqlReturning beM be, + BeamRuntime be beM, + Model be table, + MeshMeta be table, + B.HasQBuilder be, + KVConnector (table Identity), + PII table, + PIIUpdate be table, + ToJSON (table Identity), + FromJSON (table Identity), + Show (table Identity), + Serialize.Serialize (table Identity), + L.MonadFlow m, B.HasQBuilder be, BeamRunner beM) => + DBConfig beM -> + MeshConfig -> + Where be table -> + m (MeshResult ()) +deleteWithKVConnector dbConf meshCfg whereClause = do + let isDisabled = meshCfg.kvHardKilled + t1 <- getCurrentDateInMillis + (source, res) <- if not isDisabled + then do + (\delRes -> (fst delRes, mapRight (const ()) (snd delRes))) <$> modifyOneKV dbConf meshCfg whereClause Nothing True False Nothing + else do + let deleteQuery = DB.deleteRows $ sqlDelete ! #where_ whereClause + res <- DBReplay.runWithArtDelete dbConf whereClause "deleteWithKVConnector" $ runQuery dbConf deleteQuery + (SQL,) <$> case res of + Left err -> return $ Left err + Right re -> do + if meshCfg.memcacheEnabled + then + searchInMemoryCache dbConf whereClause >>= (snd >>> \case + Left e -> return $ Left e + Right (Just a) -> do + (pushToInMemConfigStream meshCfg ImcDelete) a + return $ Right re + Right (Nothing)-> return $ Right re) + else do + return $ Right re + + t2 <- getCurrentDateInMillis + diffRes <- whereClauseDiffCheck dbConf whereClause + logAndIncrementKVMetric False "DELETE" DELETE_ONE res (t2 - t1) (modelTableName @table) source diffRes + pure res + +deleteReturningWithKVConnector :: forall be table beM m. + ( HasCallStack, + SqlReturning beM be, + BeamRuntime be beM, + Model be table, + MeshMeta be table, + B.HasQBuilder be, + KVConnector (table Identity), + PII table, + PIIUpdate be table, + ToJSON (table Identity), + FromJSON (table Identity), + Show (table Identity), + Serialize.Serialize (table Identity), + L.MonadFlow m, B.HasQBuilder be, BeamRunner beM) => + DBConfig beM -> + MeshConfig -> + Where be table -> + m (MeshResult (Maybe (table Identity))) +deleteReturningWithKVConnector dbConf meshCfg whereClause = do + let isDisabled = meshCfg.kvHardKilled + t1 <- getCurrentDateInMillis + (source, res) <- if not isDisabled + then do + modifyOneKV dbConf meshCfg whereClause Nothing False False Nothing + else do + res <- DBReplay.runWithArtDelete dbConf whereClause "deleteReturningWithKVConnector" $ deleteAllReturning dbConf whereClause + (SQL,) <$> case res of + Left err -> return $ Left err + Right [] -> return $ Right Nothing + Right [r] -> do + when meshCfg.memcacheEnabled $ pushToInMemConfigStream meshCfg ImcDelete r + return $ Right (Just r) + Right rs -> do + when meshCfg.memcacheEnabled $ mapM_ (pushToInMemConfigStream meshCfg ImcDelete) rs + return $ Left $ MUpdateFailed "SQL delete returned more than one record" + t2 <- getCurrentDateInMillis + diffRes <- whereClauseDiffCheck dbConf whereClause + logAndIncrementKVMetric False "DELETE" DELETE_ONE_RETURNING res (t2 - t1) (modelTableName @table) source diffRes + pure res + +deleteAllReturningWithKVConnector :: forall be table beM m. + ( HasCallStack, + SqlReturning beM be, + BeamRuntime be beM, + Model be table, + MeshMeta be table, + B.HasQBuilder be, + KVConnector (table Identity), + ToJSON (table Identity), + PIIUpdate be table, + FromJSON (table Identity), + Show (table Identity), + Serialize.Serialize (table Identity), + L.MonadFlow m, B.HasQBuilder be, BeamRunner beM) => + DBConfig beM -> + MeshConfig -> + Where be table -> + m (MeshResult [table Identity]) +deleteAllReturningWithKVConnector dbConf meshCfg whereClause = do + let isDisabled = meshCfg.kvHardKilled + t1 <- getCurrentDateInMillis + res <- if not isDisabled + then do + kvResult <- redisFindAll dbConf meshCfg whereClause + dbRows <- DBReplay.runWithArtFindALL dbConf whereClause "deleteAllReturningWithKVConnector" $ findAllSql dbConf whereClause + updateKVAndDBResults meshCfg whereClause dbRows kvResult Nothing False dbConf Nothing False Nothing + else do + res <- DBReplay.runWithArtDelete dbConf whereClause "deleteAllReturningWithKVConnector" $ deleteAllReturning dbConf whereClause + case res of + Left err -> return $ Left err + Right re -> do + when meshCfg.memcacheEnabled $ mapM_ (pushToInMemConfigStream meshCfg ImcDelete) re + return $ Right re + t2 <- getCurrentDateInMillis + diffRes <- whereClauseDiffCheck dbConf whereClause + let source = if isDisabled then SQL else if isRecachingEnabled then KV else KV_AND_SQL + logAndIncrementKVMetric False "DELETE" DELETE_ALL_RETURNING res (t2 - t1) (modelTableName @table) source diffRes + pure res \ No newline at end of file diff --git a/src/EulerHS/KVConnector/InMemConfig/Flow.hs b/src/EulerHS/KVConnector/InMemConfig/Flow.hs new file mode 100644 index 00000000..49c70035 --- /dev/null +++ b/src/EulerHS/KVConnector/InMemConfig/Flow.hs @@ -0,0 +1,305 @@ +{- | +Module : EulerHS.KVConnector.InMemConfig.Flow +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module EulerHS.KVConnector.InMemConfig.Flow + + where + +import Control.Monad.Catch (bracket) +import qualified Data.Aeson as A +import qualified Database.Beam as B +import EulerHS.Prelude hiding (bracket) +import qualified EulerHS.SqlDB.Language as DB +import EulerHS.SqlDB.Types (BeamRunner, BeamRuntime, DBConfig) +-- import Control.Monad.Extra (notM) +import qualified Data.HashSet as HS +import qualified Data.Text as T +import EulerHS.CachedSqlDBQuery (findOne) +import qualified EulerHS.Language as L +import EulerHS.KVConnector.InMemConfig.Types +import EulerHS.KVConnector.Types (KVConnector(..), MeshConfig, tableName, MeshResult, MeshMeta(..), Source(..)) +import Unsafe.Coerce (unsafeCoerce) +import Data.Either.Extra (mapLeft) +import EulerHS.CachedSqlDBQuery (findAllExtended') +import EulerHS.Runtime (mkConfigEntry) +import EulerHS.KVConnector.Utils +import Sequelize (Model, Where, Clause(..), sqlSelect) +import Named (defaults, (!)) +import qualified Data.Serialize as Serialize +import EulerHS.KVConnector.DBSync (whereClauseToJson) +import EulerHS.ART.Types +import EulerHS.ART.FlowUtils (addRecToState) +import EulerHS.Logger.Types (ErrorL(..)) +import qualified EulerHS.ART.ReplayFunctions as ER +import qualified EulerHS.ART.EnvVars as Env +import qualified Data.ByteString.Lazy as BS +import qualified Servant as S +import EulerHS.PIIEncryption hiding (PIIEncryptionKey(..)) +import EulerHS.KVDB.Types (MeshError(MDBError, UnexpectedError)) +import Data.Time.Clock.POSIX + +checkAndStartLooper :: forall table m beM. + ( + HasCallStack, + KVConnector (table Identity), + L.MonadFlow m) => DBConfig beM -> MeshConfig -> (ByteString -> Either String (ImcStreamValue (table Identity))) -> m () +checkAndStartLooper dbConf meshCfg decodeTable = do + hasLooperStarted <- L.getOption $ (LooperStarted (tableName @(table Identity))) + case hasLooperStarted of + _hasLooperStarted + | _hasLooperStarted == Just True -> pure () + | otherwise -> do + strmName <- getRandomStream + when shouldLogFindDBCallLogs $ L.logDebug @Text "checkAndStartLooper" $ "Connecting with Stream <" <> strmName <> "> for table " <> tableName @(table Identity) + L.setOption (LooperStarted (tableName @(table Identity))) True + L.fork $ looperForRedisStream dbConf decodeTable meshCfg.kvRedis strmName + +looperForRedisStream :: forall table m beM.( + HasCallStack, + KVConnector (table Identity), + L.MonadFlow m + ) => + DBConfig beM -> + (ByteString -> Either String (ImcStreamValue (table Identity))) -> Text -> Text -> m () +looperForRedisStream dbConf decodeTable redisName' strmName = bracket + (pure ()) + (\ _ -> do + L.logInfoT "looperForRedisStream failed" ("Setting LooperStarted option as False for table " <> tableName @(table Identity)) + L.setOption (LooperStarted (tableName @(table Identity))) False) + (\ _ -> forever $ do + let tName = tableName @(table Identity) + maybeRId <- L.getOption (RecordId tName) + case maybeRId of + Nothing -> do + rId <- T.pack . show <$> L.getCurrentDateInMillis + initRecords <- getRecordsFromStream redisName' strmName rId tName + case initRecords of + Nothing -> do + L.setOption (RecordId tName) rId + return () + Just (latestId, rs) -> do + L.setOption (RecordId tName) latestId + mapM_ (updateInMemCache dbConf tName decodeTable) rs + Just rId -> do + newRecords <- getRecordsFromStream redisName' strmName rId tName + case newRecords of + Nothing -> + return () + Just (latestId, rs) -> do + L.setOption (RecordId tName) latestId + mapM_ (updateInMemCache dbConf tName decodeTable) rs + void $ looperDelayInSec) + + +looperDelayInSec :: (L.MonadFlow m) => m () +looperDelayInSec = L.runIO $ threadDelay $ getConfigStreamLooperDelayInSec * 1000000 + +updateInMemCache :: forall table m beM.( + HasCallStack, + KVConnector(table Identity), + L.MonadFlow m + ) => + DBConfig beM -> + Text -> + (ByteString -> Either String (ImcStreamValue (table Identity))) -> + RecordKeyValues -> m () +updateInMemCache dbConf tName decodeTable (k,val) = do + when (tName == k) $ -- decode only when entry is for the looper's table + case decodeTable val of + Left e-> do + L.logErrorWithCategory ("setInMemCache" :: Text) ("Unable to decode ImcStreamValue for the table <" <> k) $ ErrorL Nothing "MEM_CACHE_ERROR" $ show e + return () + Right strmVal -> do + let + pKeyText = getLookupKeyByPKey (isMySQLConfig dbConf) strmVal.tableRow + invalidateDataCache pKeyText (tableName @(table Identity)) + +extractRecordsFromStreamResponse :: [L.KVDBStreamReadResponseRecord] -> [RecordKeyValues] +extractRecordsFromStreamResponse = foldMap (fmap (bimap decodeUtf8 id) . L.records) + +getRecordsFromStream :: Text -> Text -> LatestRecordId -> Text -> (L.MonadFlow m) => m (Maybe (LatestRecordId, [RecordKeyValues])) +getRecordsFromStream redisName' strmName lastRecordId tName = do + eitherReadResponse <- L.rXreadT redisName' strmName lastRecordId + case eitherReadResponse of + Left err -> do + L.delOption (RecordId tName) + L.logErrorWithCategory ("getRecordsFromStream recorded 1" :: Text) ("Error getting initial records from stream <" <> strmName <> ">" <> show err) $ ErrorL Nothing "STREAM_ERROR" (show err) + return Nothing + Right maybeRs -> case maybeRs of + Nothing -> return Nothing -- Maybe stream doesn't exist or Maybe no new records + Just [] -> return Nothing + Just rs -> case filter (\rec-> (decodeUtf8 rec.streamName) == strmName) rs of + [] -> return Nothing + (rss : _) -> do + case uncons . reverse . L.response $ rss of + Nothing -> return Nothing + Just (latestRecord, _) -> do + L.logDebugT ("getRecordsFromStream for " <> tName) $ (show . length . L.response $ rss) <> " new records in stream <" <> strmName <> ">" + return . Just . bimap (decodeUtf8 . L.recordId) (extractRecordsFromStreamResponse . L.response ) $ (latestRecord, rss) + +{-# INLINE searchInMemoryCache #-} +searchInMemoryCache :: forall be beM table m. + ( + BeamRuntime be beM, + BeamRunner beM, + B.HasQBuilder be, + HasCallStack, + KVConnector (table Identity), + ToJSON (table Identity), + Show (table Identity), + Serialize.Serialize (table Identity), + PII table, + FromJSON (table Identity), + Model be table, + MeshMeta be table, + L.MonadFlow m + ) => DBConfig beM -> + Where be table -> + m (Source, MeshResult (Maybe (table Identity))) +searchInMemoryCache dbConf whereClause = do + mbVal <- L.getConfig inMemCacheKey + case mbVal of + Just val -> do + currentTime <- L.runIO getPOSIXTime + if (val.ttl < currentTime) + then getFromDBAndCache + else + case val.entry of + Nothing -> do + when shouldLogFindDBCallLogs $ L.logDebugT "IMC_EMPTY_RESULT" $ (tableName @(table Identity)) + return (IN_MEM, Right Nothing) + Just item -> do + let parsedVal = (unsafeCoerce @_ @(table Identity) item) + when shouldLogFindDBCallLogs $ L.logDebugV ("IMC_RESULT_FOUND for " <> tableName @(table Identity) ::Text) parsedVal + return . (IN_MEM,) . Right . Just $ parsedVal + Nothing -> getFromDBAndCache + where + inMemCacheKey = getInMemCacheKeyFromWhereClause dbConf (inMemPrefix @(table Identity) <> (tableName @(table Identity)) <>"_key_") meshModelTableEntityDescriptor (And whereClause) + {-# INLINE getFromDBAndCache #-} + getFromDBAndCache = do + eiVal <- mapLeft MDBError <$> findOne dbConf Nothing whereClause + when (isRight eiVal) $ do + let mbVal = fromRight Nothing eiVal + case mbVal of + Just val -> do + newTtl <- getConfigEntryNewTtl + setInMemCache newTtl val + Nothing -> do + when shouldLogFindDBCallLogs $ L.logDebugT ("IMC_KEY_NOT_FOUND_IN_DB - ") ((tableName @(table Identity))) + newTtl <- getConfigNullEntryNewTtl + L.setConfig inMemCacheKey $ mkConfigEntry newTtl Nothing + pure (SQL, eiVal) + + setInMemCache newTtl val = do + L.setConfig inMemCacheKey $ mkConfigEntry newTtl $ Just val + let pKeyText = getLookupKeyByPKey (isMySQLConfig dbConf) val + addToInMemTracker inMemCacheKey pKeyText (tableName @(table Identity)) + +{-# INLINABLE addToInMemTracker #-} +addToInMemTracker :: L.MonadFlow m => Text -> Text -> Text -> m () +addToInMemTracker inMemCacheKey pkVal tName = do + newTtl <- getConfigEntryNewTtl + let f = (\cfgEntry -> do + let newEntry = case cfgEntry of + Just val -> do + case val.entry of + Just item -> HS.insert inMemCacheKey (unsafeCoerce @_ @(HashSet Text) item) + Nothing -> HS.singleton inMemCacheKey + Nothing -> HS.singleton inMemCacheKey + mkConfigEntry newTtl $ Just newEntry) + L.modifyConfig (mkTrackerKey pkVal tName) f + +{-# INLINABLE invalidateDataCache #-} +invalidateDataCache :: L.MonadFlow m => Text -> Text -> m () +invalidateDataCache pkVal tName = do + cfgEntry <- L.getConfig $ mkTrackerKey pkVal tName + case cfgEntry of + Just val -> do + case val.entry of + Just item -> do + let trackerValues = (unsafeCoerce @_ @(HashSet Text) item) + mapM_ L.delConfig trackerValues + Nothing -> pure () + Nothing -> pure () + +pushToConfigStream :: (L.MonadFlow m ) => Text -> Text -> Text -> Text -> m () +pushToConfigStream redisName' k v strmName = + void $ L.rXaddB redisName' (encodeUtf8 strmName) (encodeUtf8 k) (encodeUtf8 v) + +pushToInMemConfigStream :: forall table m. + ( KVConnector (table Identity), + ToJSON (table Identity), + L.MonadFlow m + ) => MeshConfig -> ImcStreamCommand -> table Identity -> m () +pushToInMemConfigStream meshCfg imcCommand alteredModel = do + let + strmValue = ImcStreamValue { + command = imcCommand, + tableRow = Just alteredModel + } + strmValueT = decodeUtf8 . A.encode $ strmValue + mapM_ (pushToConfigStream meshCfg.kvRedis (tableName @(table Identity)) strmValueT) getConfigStreamNames + pure () + +parseDataReplay ::(FromJSON b,L.MonadFlow m) => BS.ByteString -> m (Either MeshError b) +parseDataReplay res = do + let eReply = A.eitherDecode res :: (FromJSON b) => Either String (Either MeshError b) + case eReply of + Left err -> do + let errorMsg = "Failed to decode response: " <> (encodeUtf8 err) + L.throwException $ S.err400 {S.errBody = errorMsg} + Right reply -> pure reply + + +fetchRowFromDBAndAlterImc :: forall be table beM m. + ( HasCallStack, + BeamRuntime be beM, + BeamRunner beM, + Model be table, + B.HasQBuilder be, + KVConnector (table Identity), + MeshMeta be table, + ToJSON (table Identity), + PII table, + L.MonadFlow m + ) => + DBConfig beM -> + MeshConfig -> + Where be table -> + ImcStreamCommand -> + m (MeshResult ()) +fetchRowFromDBAndAlterImc dbConf meshCfg whereClause imcCommand = do + let findQuery = DB.findRows (sqlSelect ! #where_ whereClause ! defaults) + if Env.isArtReplayEnabled + then do + recTimestamp <- L.getCurrentTimeUTC + msessionId <- L.getLoggerContext "x-request-id" + let recDBFind = RunDBEntryT (RunDBEntry "fetchRowFromDBAndAlterImc" A.Null (whereClauseToJson whereClause) (tableName @(table Identity)) A.Null recTimestamp) + resp <- L.runIO $ ER.callBrahmaReplayDB recDBFind msessionId + parseDataReplay resp + else do + dbRes <- findAllExtended' dbConf findQuery + when Env.isArtRecEnabled $ do + recTimestamp <- L.getCurrentTimeUTC + addRecToState $ RunDBEntryT (RunDBEntry "fetchRowFromDBAndAlterImc" A.Null (whereClauseToJson whereClause) (tableName @(table Identity)) (toJSON dbRes) recTimestamp) + case dbRes of + Right [x] -> do + when meshCfg.memcacheEnabled $ pushToInMemConfigStream meshCfg imcCommand x + return $ Right () + Right [] -> return $ Right () + Right xs -> do + let message = "DB returned \"" <> show (length xs) <> "\" rows after update for table: " <> show (tableName @(table Identity)) + L.logErrorWithCategory @Text "updateWoReturningWithKVConnector" message $ ErrorL Nothing "DB_ERROR" message + return $ Left $ UnexpectedError message + Left e -> return $ Left (MDBError e) diff --git a/src/EulerHS/KVConnector/InMemConfig/Types.hs b/src/EulerHS/KVConnector/InMemConfig/Types.hs new file mode 100644 index 00000000..98710f5e --- /dev/null +++ b/src/EulerHS/KVConnector/InMemConfig/Types.hs @@ -0,0 +1,72 @@ +{- | +Module : EulerHS.KVConnector.InMemConfig.Types +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ScopedTypeVariables #-} +module EulerHS.KVConnector.InMemConfig.Types + + where + +import EulerHS.Prelude hiding (maximum) +import Data.Aeson as A +import EulerHS.Options (OptionEntity) +import EulerHS.KVDB.Types (MeshError) +import qualified EulerHS.Types as T + +type KeysRequiringRedisFetch = Text + +data IMCEnabledTables = IMCEnabledTables + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +instance T.OptionEntity IMCEnabledTables [Text] + +data IsIMCEnabled = IsIMCEnabled + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +instance T.OptionEntity IsIMCEnabled Bool + +data InMemCacheResult table where + EntryValid :: (Show table) => table -> InMemCacheResult table + EntryExpired :: (Show table) => table -> Text -> InMemCacheResult table + EntryNotFound :: Text -> InMemCacheResult table + TableIneligible :: InMemCacheResult table + UnknownError :: MeshError -> InMemCacheResult table + + + +type KeyForInMemConfig = Text + +data LooperStarted = LooperStarted Text + deriving (Generic, A.ToJSON, Typeable, Show) + +instance OptionEntity LooperStarted Bool + +data RecordId = RecordId Text + deriving (Generic, Typeable, Show, Eq, ToJSON, FromJSON) + +instance OptionEntity RecordId Text + +type LatestRecordId = Text +type RecordKeyValues = (Text, ByteString) + +data ImcStreamCommand = ImcInsert | ImcDelete + deriving (Generic, Typeable, Show, Eq, ToJSON, FromJSON) + + +data ImcStreamValue table = + ImcStreamValue { + command :: ImcStreamCommand, + tableRow :: table +} + deriving (Generic, Typeable, Show, Eq, ToJSON, FromJSON) \ No newline at end of file diff --git a/src/EulerHS/KVConnector/Metrics.hs b/src/EulerHS/KVConnector/Metrics.hs new file mode 100644 index 00000000..f52c2b9c --- /dev/null +++ b/src/EulerHS/KVConnector/Metrics.hs @@ -0,0 +1,158 @@ +{- | +Module : EulerHS.KVConnector.Metrics +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} + +module EulerHS.KVConnector.Metrics where + +import EulerHS.Prelude +import qualified EulerHS.Language as L +import EulerHS.Options (OptionEntity) +import Euler.Events.MetricApi.MetricApi +import qualified Juspay.Extra.Config as Conf +import EulerHS.KVConnector.Types (DBLogEntry(..), Source(..)) +import EulerHS.Types ( ApiTag(ApiTag) , Operation(..)) + +incrementKVMetric :: L.MonadFlow m => KVMetricHandler -> KVMetric -> DBLogEntry a -> Bool -> m () +incrementKVMetric handle metric dblog isLeftRes = do + let mid = fromMaybe "" $ _merchant_id dblog + let tag = fromMaybe "" $ _apiTag dblog + let source = _source dblog + let model = _model dblog + let action = _operation dblog + latency = _latency dblog + diffFound = isJust $ _whereDiffCheckRes dblog + L.runIO $ kvCounter handle (metric, tag, action, source, model, mid, latency, diffFound, isLeftRes) + +incrementKVRedisCallsMetric :: L.MonadFlow m => KVMetricHandler -> Text -> Text -> Text -> Int ->Bool -> Bool -> m() +incrementKVRedisCallsMetric handler tag action model redisCalls redisSoftLimitExceeded redisHardLimitExceeded = do + L.runIO $ kvCalls handler (tag, action, model, redisCalls, redisSoftLimitExceeded,redisHardLimitExceeded) + +data KVMetricHandler = KVMetricHandler + { kvCounter :: (KVMetric, Text, Operation, Source, Text, Text, Int, Bool, Bool) -> IO (), + kvCalls :: (Text, Text, Text,Int, Bool,Bool) -> IO() + } + +data KVMetric = KVAction + +mkKVMetricHandler :: IO KVMetricHandler +mkKVMetricHandler = do + metrics <- register collectionLock + pure $ KVMetricHandler + (\case + (KVAction, tag, action, source, model , mid, _latency, diffFound, isLeftRes) -> do + inc (metrics #kv_action_counter_mid) action source model mid + inc (metrics #kv_action_counter_tag) tag action source model + when diffFound $ inc (metrics #kv_diff_counter) tag action source model + when isLeftRes $ inc (metrics #kv_sql_error_counter) tag action source model mid) + (\case + (tag,action,model,_redisCalls,redisSoftLimitExceeded, redisHardLimitExceeded) -> do + when redisSoftLimitExceeded (inc (metrics #kvRedis_soft_db_limit_exceeded) tag action model) + when redisHardLimitExceeded (inc (metrics #kvRedis_hard_db_limit_exceeded) tag action model)) + + +kv_action_counter_mid = counter #kv_action_counter_mid + .& lbl @"action" @Operation + .& lbl @"source" @Source + .& lbl @"model" @Text + .& lbl @"mid" @Text + .& build + +kv_action_counter_tag = counter #kv_action_counter_tag + .& lbl @"tag" @Text + .& lbl @"action" @Operation + .& lbl @"source" @Source + .& lbl @"model" @Text + .& build + +kv_diff_counter = counter #kv_diff_counter + .& lbl @"tag" @Text + .& lbl @"action" @Operation + .& lbl @"source" @Source + .& lbl @"model" @Text + .& build + +kv_sql_error_counter = counter #kv_sql_error_counter + .& lbl @"tag" @Text + .& lbl @"action" @Operation + .& lbl @"source" @Source + .& lbl @"model" @Text + .& lbl @"mid" @Text + .& build + +kv_latency_observe = histogram #kv_latency_observe + .& lbl @"tag" @Text + .& lbl @"action" @Operation + .& lbl @"source" @Source + .& lbl @"model" @Text + .& build + +kvRedis_calls_observe = histogram #kvRedis_calls_observe + .& lbl @"tag" @Text + .& lbl @"action" @Text + .& lbl @"model" @Text + .& build + +kvRedis_soft_db_limit_exceeded = counter #kvRedis_soft_db_limit_exceeded + .& lbl @"tag" @Text + .& lbl @"action" @Text + .& lbl @"model" @Text + .& build + +kvRedis_hard_db_limit_exceeded = counter #kvRedis_hard_db_limit_exceeded + .& lbl @"tag" @Text + .& lbl @"action" @Text + .& lbl @"model" @Text + .& build + + +collectionLock = + kv_action_counter_mid + .> kv_action_counter_tag + .> kv_diff_counter + .> kv_sql_error_counter + .> kv_latency_observe + .> kvRedis_calls_observe + .> kvRedis_soft_db_limit_exceeded + .> kvRedis_hard_db_limit_exceeded + .> MNil + + +--------------------------------------------------------- + +data KVMetricCfg = KVMetricCfg + deriving stock (Generic, Typeable, Show, Eq) + deriving anyclass (ToJSON, FromJSON) + +instance OptionEntity KVMetricCfg KVMetricHandler + +--------------------------------------------------------- + +isKVMetricEnabled :: Bool +isKVMetricEnabled = fromMaybe True $ readMaybe =<< Conf.lookupEnvT "KV_METRIC_ENABLED" + +--------------------------------------------------------- + +incrementMetric :: (HasCallStack, L.MonadFlow m) => KVMetric -> DBLogEntry a -> Bool -> m () +incrementMetric metric dblog isLeftRes = when isKVMetricEnabled $ do + env <- L.getOption KVMetricCfg + case env of + Just val -> incrementKVMetric val metric dblog isLeftRes + Nothing -> pure () + +incrementRedisCallMetric :: (HasCallStack , L.MonadFlow m) => Text -> Text -> Int -> Bool -> Bool -> m() +incrementRedisCallMetric action model dbCalls redisSoftLimitExceeded redisHardLimitExceeded = when isKVMetricEnabled $ do + env <- L.getOption KVMetricCfg + case env of + Just val -> do + tag <- fromMaybe "" <$> L.getOptionLocal ApiTag + incrementKVRedisCallsMetric val tag action model dbCalls redisSoftLimitExceeded redisHardLimitExceeded + Nothing -> pure () \ No newline at end of file diff --git a/src/EulerHS/KVConnector/Types.hs b/src/EulerHS/KVConnector/Types.hs new file mode 100644 index 00000000..30fd7263 --- /dev/null +++ b/src/EulerHS/KVConnector/Types.hs @@ -0,0 +1,162 @@ +{- | +Module : EulerHS.KVConnector.Types +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# OPTIONS_GHC -Wno-star-is-type #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module EulerHS.KVConnector.Types + ( + module EulerHS.KVConnector.Types + ) where + + +import EulerHS.Prelude +import qualified Data.Aeson as A +import Data.Aeson.Types (Parser) +import qualified Data.HashMap.Strict as HM +import qualified Data.Map.Strict as Map +import Data.Time (UTCTime) +import Text.Show ( Show(show) ) +import qualified EulerHS.KVDB.Language as L +import qualified Database.Beam as B +import Database.Beam.MySQL (MySQL) +import Database.Beam.Backend (BeamSqlBackend, HasSqlValueSyntax (sqlValueSyntax), autoSqlValueSyntax) +import qualified Database.Beam.Backend.SQL as B +import Database.Beam.Schema (FieldModification, TableField) +import Sequelize (Column, Set) +import qualified EulerHS.Types as T +import EulerHS.KVDB.Types (MeshError(..)) +import Data.Aeson ((.=)) + +------------ TYPES AND CLASSES ------------ + +data PrimaryKey = PKey [(Text,Text)] +data SecondaryKey = SKey [(Text,Text)] + +class KVConnector table where + tableName :: Text + keyMap :: HM.HashMap Text Bool -- True implies it is primary key and False implies secondary + primaryKey :: table -> PrimaryKey + secondaryKeys :: table -> [SecondaryKey] + inMemPrefix :: Text + inMemPrefix = "" + +--------------- EXISTING DB MESH --------------- +class MeshState a where + getShardedHashTag :: a -> Maybe Text + getKVKey :: a -> Maybe Text + getKVDirtyKey :: a -> Maybe Text + isDBMeshEnabled :: a -> Bool + +class MeshMeta be table where + meshModelFieldModification :: table (FieldModification (TableField table)) + valueMapper :: Map.Map Text (A.Value -> A.Value) + parseFieldAndGetClause :: A.Value -> Text -> Parser (TermWrap be table) + parseSetClause :: [(Text, A.Value)] -> Parser [Set be table] + +data TermWrap be (table :: (* -> *) -> *) where + TermWrap :: (B.BeamSqlBackendCanSerialize be a, A.ToJSON a, Ord a, B.HasSqlEqualityCheck be a, Show a) + => Column table a -> a -> TermWrap be table + +type MeshResult a = Either MeshError a + +newtype AutoPrimaryId = AutoPrimaryId { toIntegerId :: Maybe Integer} + + +data QueryPath = KVPath | SQLPath + +data MeshConfig = MeshConfig + { meshEnabled :: Bool + , cerealEnabled :: Bool + , memcacheEnabled :: Bool + , snowFlakeEnabled :: Bool + , meshDBName :: Text + , ecRedisDBStream :: Text + , kvRedis :: Text + , redisTtl :: L.KVDBDuration + , kvHardKilled :: Bool + , shouldPushToETLStream :: Bool + } + deriving (Generic, Eq, Show, A.ToJSON) + + +instance HasSqlValueSyntax MySQL String => HasSqlValueSyntax MySQL UTCTime where + sqlValueSyntax = autoSqlValueSyntax + +instance BeamSqlBackend MySQL => B.HasSqlEqualityCheck MySQL UTCTime + +instance HasSqlValueSyntax MySQL String => HasSqlValueSyntax MySQL A.Value where + sqlValueSyntax = autoSqlValueSyntax + +instance BeamSqlBackend MySQL => B.HasSqlEqualityCheck MySQL A.Value + +instance HasSqlValueSyntax MySQL String => HasSqlValueSyntax MySQL (Vector Int) where + sqlValueSyntax = autoSqlValueSyntax + +instance HasSqlValueSyntax MySQL String => HasSqlValueSyntax MySQL (Vector Text) where + sqlValueSyntax = autoSqlValueSyntax + +instance BeamSqlBackend MySQL => B.HasSqlEqualityCheck MySQL (Vector Int) + +instance BeamSqlBackend MySQL => B.HasSqlEqualityCheck MySQL (Vector Text) + +data MerchantID = MerchantID + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +instance T.OptionEntity MerchantID Text + +data Source = KV | SQL | KV_AND_SQL | IN_MEM + deriving (Generic, Show, Eq, ToJSON) + +data DBLogEntry a = DBLogEntry + { _log_type :: Text + , _action :: Text + , _operation :: T.Operation + , _data :: a + , _latency :: Int + , _model :: Text + , _source :: Source + , _apiTag :: Maybe Text + , _merchant_id :: Maybe Text + , _whereDiffCheckRes :: Maybe [[Text]] + } + deriving stock (Generic) + -- deriving anyclass (ToJSON) +instance (ToJSON a) => ToJSON (DBLogEntry a) where + toJSON val = A.object [ "log_type" .= _log_type val + , "action" .= _action val + , "operation" .= _operation val + , "latency" .= _latency val + , "model" .= _model val + , "data" .= _data val + , "source" .= _source val + , "api_tag" .= _apiTag val + , "merchant_id" .= _merchant_id val + , "whereDiffCheckRes" .= _whereDiffCheckRes val + ] + +data ETLStreamKeys = ETLCreate | ETLUpdate + deriving (Generic, ToJSON) + +instance Show ETLStreamKeys where + show ETLCreate = "create" + show ETLUpdate = "update" + + + diff --git a/src/EulerHS/KVConnector/Utils.hs b/src/EulerHS/KVConnector/Utils.hs new file mode 100644 index 00000000..c50a7279 --- /dev/null +++ b/src/EulerHS/KVConnector/Utils.hs @@ -0,0 +1,756 @@ +{- | +Module : EulerHS.KVConnector.Utils +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + + +module EulerHS.KVConnector.Utils where + +import qualified Data.Aeson as A +-- import Data.Aeson (Value (Object), object) +import Data.Aeson.Encode.Pretty (encodePretty) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.HashMap.Strict as HM +import Data.List (findIndices, intersect) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Database.Beam as B +import qualified Database.Beam.Schema.Tables as B +import qualified EulerHS.KVConnector.Encoding as Encoding +import EulerHS.KVConnector.Metrics (incrementMetric, KVMetric(..),incrementRedisCallMetric) +import EulerHS.KVConnector.Types (AutoPrimaryId(..), MeshMeta(..), MeshResult, MeshConfig, KVConnector(..), PrimaryKey(..), SecondaryKey(..), + DBLogEntry(..), Source(..), MerchantID(..), ETLStreamKeys) +import qualified EulerHS.Language as L +import EulerHS.Prelude +import Text.Casing (quietSnake) +-- import Servant (err500) +import Data.Either.Extra (mapLeft, mapRight) +import Data.Time.Clock.POSIX +import qualified EulerHS.Logger.Types as Log +import EulerHS.Types (Operation(..), ApiTag(..), BeamRuntime, BeamRunner, DBConfig (MySQLPoolConf), KVDBAnswer, TxResult, KVDBStatus) +import EulerHS.Extra.Snowflakes.Types (SnowflakeError(..)) +import Sequelize (fromColumnar', columnize, Model, Where, Clause(..), Term(..), Set(..), modelTableName) +import System.Random (randomRIO) +import Unsafe.Coerce (unsafeCoerce) +import Juspay.Extra.Config (lookupEnvT) +import qualified Data.Fixed as Fixed +import qualified Data.Serialize as Serialize +import qualified Data.Serialize as Cereal +import Safe (atMay) +import EulerHS.KVDB.Types (MeshError(..)) + +jsonKeyValueUpdates :: + forall be table. (HasCallStack, Model be table, MeshMeta be table) + => [Set be table] -> [(Text, A.Value)] +jsonKeyValueUpdates = fmap jsonSet + +jsonSet :: + forall be table. + (HasCallStack, Model be table, MeshMeta be table) => + Set be table -> (Text, A.Value) +jsonSet (Set column value) = (key, modifiedValue) + where + key = B._fieldName . fromColumnar' . column . columnize $ + B.dbTableSettings (meshModelTableEntityDescriptor @table @be) + modifiedValue = A.toJSON value + +jsonSet (SetDefault _) = error "Default values are not supported" + +-- | Update the model by setting it's fields according the given +-- key value mapping. +updateModel :: forall be table. + ( MeshMeta be table, + ToJSON (table Identity) + ) => + table Identity -> [(Text, A.Value)] -> MeshResult A.Value +updateModel model updVals = do + let updVals' = map (\(key,v) -> (key, Map.findWithDefault id key (valueMapper @be @table) v)) updVals + case A.toJSON model of + A.Object o -> Right (A.Object $ foldr (uncurry HM.insert) o updVals') + o -> Left $ MUpdateFailed + ("Failed to update a model. Expected a JSON object but got '" <> + (decodeUtf8 . BSL.toStrict . encodePretty $ o) <> + "'.") + +updateModel' :: forall table be. + ( HasCallStack, + Model be table, + MeshMeta be table, + FromJSON (table Identity), + ToJSON (table Identity) + ) => + [Set be table] -> + table Identity -> + MeshResult (table Identity) +updateModel' setClause model = do + let resp = (updateModel @be @table) model (jsonKeyValueUpdates setClause) + case resp of + Left err -> Left err + Right updatedModel -> + case resultToEither $ A.fromJSON updatedModel of + Right val -> Right val + Left err -> Left $ MDecodingError err + +getDataFromRedisForPKey ::forall table m. ( + KVConnector (table Identity), + FromJSON (table Identity), + Serialize.Serialize (table Identity), + L.MonadFlow m) => MeshConfig -> Text -> m (MeshResult (Maybe (Text, Bool, table Identity))) +getDataFromRedisForPKey meshCfg pKey = do + res <- L.rGetBEither meshCfg.kvRedis (fromString $ T.unpack $ pKey) + case res of + Right (Just r) -> + let + (decodeResult, isLive) = decodeToField $ BSL.fromChunks [r] + in case decodeResult of + Right [decodeRes] -> return . Right . Just $ (pKey, isLive, decodeRes) + Right _ -> return . Right $ Nothing -- Something went wrong + Left e -> return $ Left e + Right Nothing -> do + let traceMsg = "redis_fetch_noexist: Could not find key: " <> show pKey + L.logWarningT "getCacheWithHash" traceMsg + return $ Right Nothing + Left e -> return $ Left $ MRedisError e + +getDataFromPKeysRedis :: forall table m. ( + KVConnector (table Identity), + FromJSON (table Identity), + Serialize.Serialize (table Identity), + L.MonadFlow m) => MeshConfig -> [ByteString] -> m (MeshResult ([table Identity], [table Identity])) +getDataFromPKeysRedis _ [] = pure $ Right ([], []) +getDataFromPKeysRedis meshCfg (pKey : pKeys) = do + res <- L.rGetBEither meshCfg.kvRedis (fromString $ T.unpack $ decodeUtf8 pKey) + case res of + Right (Just r) -> do + let (decodeResult, isLive) = decodeToField $ BSL.fromChunks [r] + case decodeResult of + Right decodeRes -> do + remainingPKeysResult <- getDataFromPKeysRedis meshCfg pKeys + case remainingPKeysResult of + Right remainingResult -> do + if isLive + then return $ Right (decodeRes ++ (fst remainingResult), snd remainingResult) + else return $ Right (fst remainingResult, decodeRes ++ (snd remainingResult)) + Left err -> return $ Left err + Left e -> return $ Left e + Right Nothing -> do + getDataFromPKeysRedis meshCfg pKeys + Left e -> return $ Left $ MRedisError e + +------------- KEY UTILS ------------------ + +keyDelim:: Text +keyDelim = "_" + +getPKeyWithShard :: forall table beM. (KVConnector (table Identity)) => DBConfig beM -> table Identity -> Text +getPKeyWithShard dbConf table = + let pKey = getLookupKeyByPKey (isMySQLConfig dbConf) table + in pKey <> getShardedHashTag pKey + +getLookupKeyByPKey :: forall table. (KVConnector (table Identity)) => Bool -> table Identity -> Text +getLookupKeyByPKey _ table = do + let tName = tableName @(table Identity) + let (PKey k) = primaryKey table + let lookupKey = getSortedKey k + tName <> keyDelim <> lookupKey + +getLookupKeyByPKey' :: forall table. (KVConnector (table Identity)) => table Identity -> Text +getLookupKeyByPKey' table = do + let tName = tableName @(table Identity) + let (PKey k) = primaryKey table + let lookupKey = getSortedKey k + tName <> keyDelim <> lookupKey + +getSecondaryLookupKeys :: forall table. (KVConnector (table Identity)) => Bool -> table Identity -> [Text] +getSecondaryLookupKeys isMySQL table = do + let tName = tableName @(table Identity) + let skeys = secondaryKeysFiltered isMySQL table + let tupList = map (\(SKey s) -> s) skeys + let list = map (\x -> tName <> keyDelim <> getSortedKey x ) tupList + list + +secondaryKeysFiltered :: forall table. (KVConnector (table Identity)) => Bool -> table Identity -> [SecondaryKey] +secondaryKeysFiltered _ table = filter filterEmptyValues (secondaryKeys table) + where + filterEmptyValues :: SecondaryKey -> Bool + filterEmptyValues (SKey sKeyPairs) = not $ any (\p -> snd p == "") sKeyPairs + +applyFPair :: (t -> b) -> (t, t) -> (b, b) +applyFPair f (x, y) = (f x, f y) + +getPKeyAndValueList :: forall table beM. (HasCallStack, KVConnector (table Identity), A.ToJSON (table Identity)) => DBConfig beM -> table Identity -> [(Text, A.Value)] +getPKeyAndValueList _ table = do + let (PKey k) = primaryKey table + keyValueList = sortBy (compare `on` fst) k + rowObject = A.toJSON table + case rowObject of + A.Object hm -> foldl' (\ acc x -> (go hm x) : acc) [] keyValueList + _ -> error "Cannot work on row that isn't an Object" + + where + go hm x = case HM.lookup (fst x) hm of + Just val -> (fst x, val) + Nothing -> error $ "Cannot find " <> (fst x) <> " field in the row" + +getSortedKey :: [(Text,Text)] -> Text +getSortedKey kvTup = do + let sortArr = sortBy (compare `on` fst) kvTup + let (appendedKeys, appendedValues) = applyFPair (T.intercalate "_") $ unzip sortArr + appendedKeys <> "_" <> appendedValues + +getShardedHashTag :: Text -> Text +getShardedHashTag key = do + let slot = unsafeCoerce @_ @Word16 $ L.keyToSlot $ encodeUtf8 key + streamShard = slot `mod` 128 + "{shard-" <> show streamShard <> "}" + +addToETLStream :: forall table m. ((KVConnector (table Identity)), L.MonadFlow m) => MeshConfig -> Bool -> ETLStreamKeys -> table Identity -> m () +addToETLStream meshCfg isMySQLConf key dbRes = when meshCfg.shouldPushToETLStream $ do + let pKeyText = getLookupKeyByPKey isMySQLConf dbRes + shard = getShardedHashTag pKeyText + pKey = fromString . T.unpack $ pKeyText <> shard + void $ L.runKVDB meshCfg.kvRedis $ L.xadd (encodeUtf8 (getETLStreamName <> shard)) L.AutoID [(show key, pKey)] + +addToDBSyncStreamAndRedis :: forall table m. + ( KVConnector (table Identity) + , Serialize (table Identity) + , ToJSON (table Identity) + , L.MonadFlow m + ) + => MeshConfig + -> Text + -> A.Value + -> ByteString + -> table Identity + -> m (KVDBAnswer (TxResult KVDBStatus)) +addToDBSyncStreamAndRedis meshCfg shard qCmd pKey val = L.runKVDB meshCfg.kvRedis $ L.multiExecWithHash (encodeUtf8 shard) $ do + void $ L.xaddTx + (encodeUtf8 (meshCfg.ecRedisDBStream <> shard)) + L.AutoID + [("command", BSL.toStrict $ A.encode qCmd)] + L.setexTx pKey meshCfg.redisTtl (BSL.toStrict $ Encoding.encode_ meshCfg.cerealEnabled val) + +addToDBSyncStreamETLStreamAndRedis :: forall table m. + ( KVConnector (table Identity) + , Serialize (table Identity) + , ToJSON (table Identity) + , L.MonadFlow m + ) + => MeshConfig + -> Text + -> A.Value + -> ETLStreamKeys + -> ByteString + -> table Identity + -> m (KVDBAnswer (TxResult KVDBStatus)) +addToDBSyncStreamETLStreamAndRedis meshCfg shard qCmd key pKey val = L.runKVDB meshCfg.kvRedis $ L.multiExecWithHash (encodeUtf8 shard) $ do + void $ L.xaddTx + (encodeUtf8 (meshCfg.ecRedisDBStream <> shard)) + L.AutoID + [("command", BSL.toStrict $ A.encode qCmd)] + void $ L.xaddTx + (encodeUtf8 (getETLStreamName <> shard)) + L.AutoID + [(show key, pKey)] + L.setexTx pKey meshCfg.redisTtl (BSL.toStrict $ Encoding.encode_ meshCfg.cerealEnabled val) + +------------------------------------------ + +getTableRowWithPrimaryId :: forall (table :: (Type -> Type) -> Type) m beM. + (ToJSON (table Identity), FromJSON (table Identity), KVConnector (table Identity), L.MonadFlow m) + => DBConfig beM -> MeshConfig -> Text -> table Identity -> m (MeshResult (table Identity)) +getTableRowWithPrimaryId dbConf meshCfg tName value = do + eitherPrimaryId <- mapRight toIntegerId <$> + if meshCfg.snowFlakeEnabled + then getSnowflakeValue tName + else + if meshCfg.meshEnabled && not meshCfg.kvHardKilled + then getPrimaryIdFromRedis meshCfg tName + else return . Right . AutoPrimaryId $ Nothing + return $ case eitherPrimaryId of + Left err -> Left $ err + Right (Just primaryId) -> unsafeSetPrimaryIdInTableRow dbConf value primaryId + Right Nothing -> Right $ value + +getPrimaryIdFromRedis :: (L.MonadFlow m) => MeshConfig -> Text -> m (MeshResult AutoPrimaryId) +getPrimaryIdFromRedis meshCfg tName = + let key = (T.pack . quietSnake . T.unpack) tName <> "_auto_increment_id" + in (L.runKVDB meshCfg.kvRedis (L.incr . encodeUtf8 $ key)) <&> either failure (success . Just) + where + success = Right . AutoPrimaryId + failure = Left . MRedisError + +getSnowflakeValue :: forall m .(L.MonadFlow m) => Text -> m (MeshResult AutoPrimaryId) +getSnowflakeValue tName = go snowflakeGenerationRetryLimit + where + snowflakeGenerationRetryLimit :: Int + snowflakeGenerationRetryLimit = fromMaybe 3 $ readMaybe =<< lookupEnvT "SNOWFLAKE_GENERATION_RETRY_LIMIT" + + snowflakeGenerationRetryDelay :: Integer + snowflakeGenerationRetryDelay = fromMaybe 500 $ readMaybe =<< lookupEnvT "SNOWFLAKE_GENERATION_RETRY_DELAY" + + go :: Int -> m (MeshResult AutoPrimaryId) + go 0 = pure . Left . UnexpectedError $ "Could not generate snowflake value" + go retriesLeft = do + eitherSnowflakeId <- L.generateSnowflake $ show tName + case eitherSnowflakeId of + Left (Fatal err) -> pure . Left . UnexpectedError $ err + Left (NonFatal err) -> do + L.logWarningT "getSnowflakeValue" err + void $ L.runIO $ threadDelayMilisec snowflakeGenerationRetryDelay + go $ retriesLeft - 1 + Right snowflake -> + let + autoPrimaryId :: Integer + autoPrimaryId = toInteger snowflake + in pure . Right . AutoPrimaryId $ if autoPrimaryId < 0 + then + Nothing + else + Just autoPrimaryId + +unsafeSetPrimaryIdInTableRow :: forall table beM. (ToJSON (table Identity), FromJSON (table Identity), KVConnector (table Identity)) => + DBConfig beM -> table Identity -> Integer -> MeshResult (table Identity) +unsafeSetPrimaryIdInTableRow _ tableRow primaryId = do + let (PKey p) = primaryKey tableRow + case p of + [(field, _)] -> + case A.toJSON tableRow of + A.Object jsonObject -> + if HM.member field jsonObject + then Right tableRow + else + let + setPrimaryIdInJson = \pId -> A.Object (HM.insert field (A.toJSON pId) jsonObject) + in decodeJsonToTableRow . setPrimaryIdInJson $ primaryId + _ -> Left $ MDecodingError "Can't set AutoIncId value of JSON which isn't a object." + _ -> Right tableRow + where + decodeJsonToTableRow :: A.Value -> MeshResult (table Identity) + decodeJsonToTableRow = either (Left . MDecodingError) Right . resultToEither . A.fromJSON + +foldEither :: [Either a b] -> Either a [b] +foldEither [] = Right [] +foldEither ((Left a) : _) = Left a +foldEither ((Right b) : xs) = mapRight ((:) b) (foldEither xs) + +resultToEither :: A.Result a -> Either Text a +resultToEither (A.Success res) = Right res +resultToEither (A.Error e) = Left $ T.pack e + +getUniqueDBRes :: KVConnector (table Identity) => DBConfig beM -> [table Identity] -> [table Identity] -> [table Identity] +getUniqueDBRes dbConf dbRows kvRows = do + let isMySQL = isMySQLConfig dbConf + kvPkeys = map (getLookupKeyByPKey isMySQL) kvRows + filter (\r -> getLookupKeyByPKey isMySQL r `notElem` kvPkeys) dbRows + +mergeKVAndDBResults :: KVConnector (table Identity) => [table Identity] -> [table Identity] -> [table Identity] +mergeKVAndDBResults dbRows kvRows = do + let kvPkeys = map getLookupKeyByPKey' kvRows + uniqueDbRes = filter (\r -> getLookupKeyByPKey' r `notElem` kvPkeys) dbRows + kvRows ++ uniqueDbRes + +removeDeleteResults :: KVConnector (table Identity) => [table Identity] -> [table Identity] -> [table Identity] +removeDeleteResults delRows rows = do + let delPKeys = map getLookupKeyByPKey' delRows + nonDelRows = filter (\r -> getLookupKeyByPKey' r `notElem` delPKeys) rows + nonDelRows + +getLatencyInMicroSeconds :: Integer -> Integer +getLatencyInMicroSeconds execTime = execTime `div` 1000000 + +isMySQLConfig :: DBConfig beM -> Bool +isMySQLConfig (MySQLPoolConf {}) = True +isMySQLConfig _ = False + +---------------- Match where clauses ------------- +findOneMatching :: (B.Beamable table, BeamRuntime be beM, BeamRunner beM) => Where be table -> DBConfig beM -> [table Identity] -> Maybe (table Identity) +findOneMatching whereClause dbConf = find (matchWhereClause (isMySQLConfig dbConf) whereClause) + +findAllMatching :: (B.Beamable table, BeamRuntime be beM, BeamRunner beM) => Where be table -> DBConfig beM -> [table Identity] -> [table Identity] +findAllMatching whereClause dbConf = filter (matchWhereClause (isMySQLConfig dbConf) whereClause) + +matchWhereClause :: B.Beamable table => Bool -> [Clause be table] -> table Identity -> Bool +matchWhereClause isMySQL whereClause row = all matchClauseQuery whereClause + where + matchClauseQuery = \case + And queries -> all matchClauseQuery queries + Or queries -> any matchClauseQuery queries + Is column' term -> + let column = fromColumnar' . column' . columnize + in termQueryMatch isMySQL (column row) term + +termQueryMatch :: (Ord value, ToJSON value) => Bool -> value -> Term be value -> Bool +termQueryMatch isMySQL columnVal = \case + In literals -> any (matchWithCaseInsensitive columnVal) literals + Null -> isNothing columnVal + Eq literal -> matchWithCaseInsensitive columnVal literal + GreaterThan literal -> columnVal > literal + GreaterThanOrEq literal -> columnVal >= literal + LessThan literal -> columnVal < literal + LessThanOrEq literal -> columnVal <= literal + Not Null -> isJust columnVal + Not (Eq literal) -> not $ matchWithCaseInsensitive columnVal literal + Not term -> not (termQueryMatch isMySQL columnVal term) + _ -> error "Term query not supported" + + where + matchWithCaseInsensitive c1 c2 = + if c1 == c2 + then True + else if isMySQL -- Fallback to case insensitive check (MySQL supports this) + then + case (toJSON c1, toJSON c2) of + (A.String s1, A.String s2) -> T.toLower s1 == T.toLower s2 + _ -> False + else False + +toPico :: Int -> Fixed.Pico +toPico value = Fixed.MkFixed $ ((toInteger value) * 1000000000000) + +getStreamName :: String -> Text +getStreamName shard = getConfigStreamBasename <> "-" <> (T.pack shard) <> "" + +getRandomStream :: (L.MonadFlow m) => m Text +getRandomStream = do + streamShard <- L.runIO' "random shard" $ randomRIO (1, getConfigStreamMaxShards) + return $ getStreamName (show streamShard) + +getConfigStreamNames :: [Text] +getConfigStreamNames = fmap (\shardNo -> getStreamName (show shardNo) ) [1..getConfigStreamMaxShards] + +getConfigStreamBasename :: Text +getConfigStreamBasename = fromMaybe "ConfigStream" $ lookupEnvT "CONFIG_STREAM_BASE_NAME" + +getConfigStreamMaxShards :: Int +getConfigStreamMaxShards = fromMaybe 20 $ readMaybe =<< lookupEnvT "CONFIG_STREAM_MAX_SHARDS" + +getConfigStreamLooperDelayInSec :: Int +getConfigStreamLooperDelayInSec = fromMaybe 5 $ readMaybe =<< lookupEnvT "CONFIG_STREAM_LOOPER_DELAY_IN_SEC" + +getConfigEntryTtlJitterInSeconds :: Int +getConfigEntryTtlJitterInSeconds = fromMaybe 5 $ readMaybe =<< lookupEnvT "CONFIG_STREAM_TTL_JITTER_IN_SEC" + +getConfigEntryBaseTtlInSeconds :: Int +getConfigEntryBaseTtlInSeconds = fromMaybe 10 $ readMaybe =<< lookupEnvT "CONFIG_STREAM_BASE_TTL_IN_SEC" + +getConfigEntryNullBaseTtlInSeconds :: Int +getConfigEntryNullBaseTtlInSeconds = fromMaybe 120 $ readMaybe =<< lookupEnvT "CONFIG_STREAM_NULL_BASE_TTL_IN_SEC" + +getConfigEntryNewTtl :: (L.MonadFlow m) => m POSIXTime +getConfigEntryNewTtl = do + currentTime <- L.runIO getPOSIXTime + let + jitterInSec = getConfigEntryTtlJitterInSeconds + baseTtlInSec = getConfigEntryBaseTtlInSeconds + t = round currentTime :: Int + noise <- L.runIO' "random seconds" $ randomRIO (1, jitterInSec) + return $ fromIntegral (baseTtlInSec + noise + t) + +getConfigNullEntryNewTtl :: (L.MonadFlow m) => m POSIXTime +getConfigNullEntryNewTtl = do + currentTime <- L.runIO getPOSIXTime + let + baseTtlInSec = getConfigEntryNullBaseTtlInSeconds + t = round currentTime :: Int + return $ fromIntegral (baseTtlInSec + t) + +threadDelayMilisec :: Integer -> IO () +threadDelayMilisec ms = threadDelay $ fromIntegral ms * 1000 + +meshModelTableEntityDescriptor :: + forall table be. + (Model be table, MeshMeta be table) => + B.DatabaseEntityDescriptor be (B.TableEntity table) +meshModelTableEntityDescriptor = let B.DatabaseEntity x = (meshModelTableEntity @table) in x + +meshModelTableEntity :: + forall table be db. + (Model be table, MeshMeta be table) => + B.DatabaseEntity be db (B.TableEntity table) +meshModelTableEntity = + let B.EntityModification modification = B.modifyTableFields (meshModelFieldModification @be @table) + in appEndo modification $ B.DatabaseEntity $ B.dbEntityAuto (modelTableName @table) + +toPSJSON :: forall be table. MeshMeta be table => (Text, A.Value) -> (Text, A.Value) +toPSJSON (k, v) = (k, Map.findWithDefault id k (valueMapper @be @table) v) + +decodeToField :: forall a. (FromJSON a, Serialize.Serialize a) => BSL.ByteString -> (MeshResult [a], Bool) +decodeToField val = + let decodeRes = Encoding.decodeLiveOrDead val + in case decodeRes of + (isLive, byteString) -> + let decodedMeshResult = + let (h, v) = BSL.splitAt 4 byteString + in case h of + "CBOR" -> case Cereal.decodeLazy v of + Right r' -> Right [r'] + Left _ -> case Cereal.decodeLazy v of + Right r'' -> Right r'' + Left _ -> case Cereal.decodeLazy v of + Right r''' -> decodeField @a r''' + Left err' -> Left $ MDecodingError $ T.pack err' + "JSON" -> + case A.eitherDecode v of + Right r' -> decodeField @a r' + Left e -> Left $ MDecodingError $ T.pack e + _ -> + case A.eitherDecode val of + Right r' -> decodeField @a r' + Left e -> Left $ MDecodingError $ T.pack e + in (decodedMeshResult, isLive) + +decodeField :: forall a. (FromJSON a, Serialize.Serialize a) => A.Value -> MeshResult [a] +decodeField o@(A.Object _) = + case A.eitherDecode @a $ A.encode o of + Right r -> return [r] + Left e -> Left $ MDecodingError $ T.pack e +decodeField o@(A.Array _) = + mapLeft (MDecodingError . T.pack) + $ A.eitherDecode @[a] $ A.encode o +decodeField o = Left $ MDecodingError + ("Expected list or object but got '" <> T.pack (show o) <> "'.") + +{-# INLINE getInMemCacheKeyFromWhereClause #-} +getInMemCacheKeyFromWhereClause :: forall table be beM. (Model be table, MeshMeta be table) => + DBConfig beM -> Text -> B.DatabaseEntityDescriptor be (B.TableEntity table) -> Clause be table -> Text +getInMemCacheKeyFromWhereClause dbConf acc dt = \case + And cs -> acc <> "_AND_" <> (foldl (\curr ins-> getInMemCacheKeyFromWhereClause dbConf curr dt ins) "" cs) + Or cs -> acc <> "_OR_" <> (foldl (\curr ins-> getInMemCacheKeyFromWhereClause dbConf curr dt ins) "" cs) + Is column (Eq v1) -> do + let key = B._fieldName . fromColumnar' . column . columnize $ B.dbTableSettings dt + acc <> "_IS_" <> key <> "=" <> (showVal isMySQL $ A.toJSON v1) + Is column (In v2) -> do + let key = B._fieldName . fromColumnar' . column . columnize $ B.dbTableSettings dt + acc <> "_IN_" <> key <> "=" <> (showVal isMySQL $ A.toJSON v2) + Is column (GreaterThan v3) -> do + let key = B._fieldName . fromColumnar' . column . columnize $ B.dbTableSettings dt + acc <> "_GT_" <> key <> "=" <> (showVal isMySQL $ A.toJSON v3) + Is column (GreaterThanOrEq v4) -> do + let key = B._fieldName . fromColumnar' . column . columnize $ B.dbTableSettings dt + acc <> "_GTE_" <> key <> "=" <> (showVal isMySQL $ A.toJSON v4) + Is column (LessThan v5) -> do + let key = B._fieldName . fromColumnar' . column . columnize $ B.dbTableSettings dt + acc <> "_LT_" <> key <> "=" <> (showVal isMySQL $ A.toJSON v5) + Is column (LessThanOrEq v6) -> do + let key = B._fieldName . fromColumnar' . column . columnize $ B.dbTableSettings dt + acc <> "_LTE_" <> key <> "=" <> (showVal isMySQL $ A.toJSON v6) + Is column (Null) -> do + let key = B._fieldName . fromColumnar' . column . columnize $ B.dbTableSettings dt + acc <> key <> "_NULL" + Is column (Not Null) -> do + let key = B._fieldName . fromColumnar' . column . columnize $ B.dbTableSettings dt + acc <> key <> "_NOT_NULL" + Is column (Not term) -> getInMemCacheKeyFromWhereClause dbConf (acc <> "_NOT_") dt (Is column term) + _ -> acc + + where + isMySQL = isMySQLConfig dbConf + + showVal :: Bool -> A.Value -> Text + showVal isItMySQL res = case res of + A.String r -> if isItMySQL then T.toLower r else r + A.Number n -> T.pack $ show n + A.Array l -> T.pack $ show l + A.Object o -> T.pack $ show o + A.Bool b -> T.pack $ show b + A.Null -> T.pack "" + +{-# INLINABLE mkTrackerKey #-} +mkTrackerKey :: Text -> Text -> Text +mkTrackerKey pkVal tName = "key_" <> tName <> "_id_" <> pkVal + +getFieldsAndValuesFromClause :: forall table be beM. (Model be table, MeshMeta be table) => + DBConfig beM -> B.DatabaseEntityDescriptor be (B.TableEntity table) -> Clause be table -> [[(Text, Text)]] +getFieldsAndValuesFromClause dbConf dt = \case + And cs -> foldl' processAnd [[]] $ map (getFieldsAndValuesFromClause dbConf dt) cs + Or cs -> processOr cs + Is column (Eq val) -> do + let !key = B._fieldName . fromColumnar' . column . columnize $ B.dbTableSettings dt + [[(key, showVal . snd $ (toPSJSON @be @table) (key, A.toJSON val))]] + Is column (In vals) -> do + let !key = B._fieldName . fromColumnar' . column . columnize $ B.dbTableSettings dt + map (\val -> [(key, showVal . snd $ (toPSJSON @be @table) (key, A.toJSON val))]) vals + _ -> [] + + where + processAnd xs [] = xs + processAnd [] ys = ys + processAnd xs ys = [x ++ y | x <-xs, y <- ys] + processOr xs = concatMap (getFieldsAndValuesFromClause dbConf dt) xs + + showVal res = case res of + A.String r -> if (isMySQLConfig dbConf) then T.toLower r else r + A.Number n -> T.pack $ show n + A.Array l -> T.pack $ show l + A.Object o -> T.pack $ show o + A.Bool b -> T.pack $ show b + A.Null -> T.pack "" + +getPrimaryKeyFromFieldsAndValues :: (L.MonadFlow m,HasCallStack) => Text -> MeshConfig -> HM.HashMap Text Bool -> [(Text, Text)] -> m (MeshResult [ByteString]) +getPrimaryKeyFromFieldsAndValues _ _ _ [] = pure $ Right [] +getPrimaryKeyFromFieldsAndValues modelName meshCfg keyHashMap fieldsAndValues = do + res <- foldEither <$> mapM getPrimaryKeyFromFieldAndValueHelper fieldsAndValues + pure $ mapRight (intersectList . catMaybes) res + where + + getPrimaryKeyFromFieldAndValueHelper (k, v) = do + let constructedKey = modelName <> "_" <> k <> "_" <> v + case HM.lookup k keyHashMap of + Just True -> pure $ Right $ Just [fromString $ T.unpack (constructedKey <> getShardedHashTag constructedKey)] + Just False -> do + res <- L.rSmembersB meshCfg.kvRedis (fromString $ T.unpack constructedKey) + case res of + Right [] -> pure $ Right Nothing + Right r -> pure $ Right $ Just r + Left e -> pure $ Left $ MRedisError e + _ -> pure $ Right Nothing + + intersectList (x : y : xs) = intersectList (intersect x y : xs) + intersectList (x : []) = x + intersectList [] = [] + +filterPrimaryAndSecondaryKeys :: HM.HashMap Text Bool -> [(Text, Text)] -> [(Text, Text)] +filterPrimaryAndSecondaryKeys keyHashMap = filter (\(k, _) -> HM.member k keyHashMap) + +getSecondaryKeyLength :: HM.HashMap Text Bool -> [(Text, Text)] -> Int +getSecondaryKeyLength keyHashMap = length . filter (\(k, _) -> HM.lookup k keyHashMap == Just False) + + +mkUniq :: Ord a => [a] -> [a] -- O(n log n) +mkUniq = Set.toList . Set.fromList + +-- >>> map (T.intercalate "_") (nonEmptySubsequences ["id", "id2", "id3"]) +-- ["id","id2","id_id2","id3","id_id3","id2_id3","id_id2_id3"] +nonEmptySubsequences :: [Text] -> [[Text]] +nonEmptySubsequences [] = [] +nonEmptySubsequences (x:xs) = [x]: foldr f [] (nonEmptySubsequences xs) + where f ys r = ys : (x : ys) : r + +whereClauseDiffCheck :: forall be table m beM. + ( L.MonadFlow m + , Model be table + , MeshMeta be table + , KVConnector (table Identity) + ) => + DBConfig beM -> Where be table -> m (Maybe [[Text]]) +whereClauseDiffCheck dbConf whereClause = + if isWhereClauseDiffCheckEnabled then do + let keyAndValueCombinations = getFieldsAndValuesFromClause dbConf meshModelTableEntityDescriptor (And whereClause) + andCombinations = map (uncurry zip . applyFPair (map (T.intercalate "_") . sortOn (Down . length) . nonEmptySubsequences) . unzip . sort) keyAndValueCombinations + keyHashMap = keyMap @(table Identity) + failedKeys = catMaybes $ map (atMay keyAndValueCombinations) $ findIndices (checkForPrimaryOrSecondary keyHashMap) andCombinations + if (not $ null failedKeys) + then do + let diffRes = map (map fst) failedKeys + if null $ concat diffRes + then pure Nothing + else L.logInfoT "WHERE_DIFF_CHECK" (tableName @(table Identity) <> ": " <> show diffRes) $> Just diffRes + else pure Nothing + else pure Nothing + where + checkForPrimaryOrSecondary _ [] = True + checkForPrimaryOrSecondary keyHashMap ((k, _) : xs) = + case HM.member k keyHashMap of + True -> False + _ -> checkForPrimaryOrSecondary keyHashMap xs + +isWhereClauseDiffCheckEnabled :: Bool +isWhereClauseDiffCheckEnabled = fromMaybe True $ readMaybe =<< lookupEnvT "IS_WHERE_CLAUSE_DIFF_CHECK_ENABLED" + +isRecachingEnabled :: Bool +isRecachingEnabled = fromMaybe False $ readMaybe =<< lookupEnvT "IS_RECACHING_ENABLED" + +shouldLogFindDBCallLogs :: Bool +shouldLogFindDBCallLogs = fromMaybe False $ readMaybe =<< lookupEnvT "IS_FIND_DB_LOGS_ENABLED" + +isLogsEnabledForModel :: Text -> Bool +isLogsEnabledForModel modelName = do + let env :: Text = fromMaybe "development" $ lookupEnvT "NODE_ENV" + if env == "production" then do + let enableModelList = fromMaybe [] $ readMaybe =<< lookupEnvT "IS_LOGS_ENABLED_FOR_MODEL" + modelName `elem` enableModelList + else True + +logAndIncrementKVMetric :: (L.MonadFlow m, ToJSON a) => Bool -> Text -> Operation -> MeshResult a -> Int -> Text -> Source -> Maybe [[Text]] -> m () +logAndIncrementKVMetric shouldLogData action operation res latency model source mbDiffCheckRes = do + apiTag <- L.getOptionLocal ApiTag + mid <- L.getOptionLocal MerchantID + let shouldLogData_ = isLogsEnabledForModel model && shouldLogData + let dblog = DBLogEntry { + _log_type = "DB" + , _action = action -- For logprocessor + , _operation = operation + , _data = case res of + Left err -> A.String (T.pack $ show err) + Right m -> if shouldLogData_ then A.toJSON m else A.Null + , _latency = latency + , _model = model + , _source = source + , _apiTag = apiTag + , _merchant_id = mid + , _whereDiffCheckRes = mbDiffCheckRes + } + case res of + Left err -> + logDb Log.Error ("DB" :: Text) source action model latency dblog (Just err) + Right _ -> + if action == "FIND" then + when shouldLogFindDBCallLogs $ logDb Log.Debug ("DB" :: Text) source action model latency dblog Nothing + else logDb Log.Info ("DB" :: Text) source action model latency dblog Nothing + when (source == KV) $ L.setLoggerContext "PROCESSED_THROUGH_KV" "True" + incrementMetric KVAction dblog (isLeft res) + +logDb :: (L.MonadFlow m, ToJSON val) => Log.LogLevel -> Text -> Source -> Log.Action -> Log.Entity -> Int -> val -> Maybe MeshError -> m () +logDb logLevel tag source action entity latency message maybeMeshError = + L.evalLogger' $ L.masterLogger logLevel tag category (Just action) (Just entity) (getErrorLog <$> maybeMeshError) (Just $ toInteger latency) Nothing $ Log.Message Nothing (Just $ A.toJSON message) + where + getErrorLog (MKeyNotFound k) = Log.ErrorL Nothing "MKeyNotFound" k + getErrorLog (MDBError err) = Log.ErrorL Nothing "DBError" (T.pack $ show err) + getErrorLog (MRedisError err) = Log.ErrorL Nothing "RedisError" (T.pack $ show err) + getErrorLog (MDecodingError v) = Log.ErrorL Nothing "MDecodingError" v + getErrorLog (MUpdateFailed v) = Log.ErrorL Nothing "MUpdateFailed" v + getErrorLog (MMultipleKeysFound v) = Log.ErrorL Nothing "MMultipleKeysFound" v + getErrorLog (UnexpectedError v) = Log.ErrorL Nothing "UnknownMeshError" v + category + | source == KV = "REDIS" + | source == SQL = "DB" + | source == KV_AND_SQL = "REDIS_AND_DB" + | source == IN_MEM = "INMEM" + | otherwise = "" + +lengthOfLists :: [[a]] -> Int +lengthOfLists = foldl' (\acc el -> acc + length el) 0 + +withRedisLimit :: (L.MonadFlow m) => Text -> Text -> Int -> m (MeshResult a) -> m (MeshResult a) +withRedisLimit tag modelName expectedRedisCalls redisFunc = + if expectedRedisCalls > redisCallsHardLimit + then do + incrementRedisCallMetric tag modelName expectedRedisCalls (expectedRedisCalls > redisCallsSoftLimit) (expectedRedisCalls > redisCallsHardLimit) + pure $ Left $ UnexpectedError ("Redis Calls Limit Exceeded with length " <> show expectedRedisCalls) + else + redisFunc + +getETLStreamName :: Text +getETLStreamName = fromMaybe "etl-stream" $ lookupEnvT "ETL_STREAM_NAME" + +redisCallsHardLimit :: Int +redisCallsHardLimit = fromMaybe 5000 $ readMaybe =<< lookupEnvT "REDIS_CALLS_HARD_LIMIT" + +redisCallsSoftLimit :: Int +redisCallsSoftLimit = fromMaybe 100 $ readMaybe =<< lookupEnvT "REDIS_CALLS_SOFT_LIMIT" + +tablesWithoutRedisLimit :: [Text] +tablesWithoutRedisLimit = fromMaybe [] $ readMaybe =<< lookupEnvT "TABLES_WITHOUT_REDIS_LIMIT" diff --git a/src/EulerHS/KVDB/Interpreter.hs b/src/EulerHS/KVDB/Interpreter.hs new file mode 100644 index 00000000..0d97e7f0 --- /dev/null +++ b/src/EulerHS/KVDB/Interpreter.hs @@ -0,0 +1,512 @@ +{- | +Module : EulerHS.KVDB.Interpreter +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module EulerHS.KVDB.Interpreter + ( + -- * KVDB Interpreter + runKVDB + ) where + +import qualified Data.Map as Map +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 Data.Aeson as A +import EulerHS.ART.Types +import EulerHS.ART.EnvVars +import Data.Time (getCurrentTime, utc, utcToZonedTime, + zonedTimeToLocalTime) +import EulerHS.Runtime (FlowRuntime(..)) +import EulerHS.Common (FlowGUID) +import qualified EulerHS.KVDB.Language as L +import EulerHS.KVDB.Types (KVDBError (KVDBConnectionDoesNotExist), + KVDBReply, KVDBReplyF (Bulk, KVDBError), + NativeKVDBConn (NativeKVDB), + exceptionToKVDBReply, fromRdStatus, + fromRdTxResult, hedisReplyToKVDBReply) +import EulerHS.Prelude +import Text.Read (read) + +interpretKeyValueF + :: + (forall b . R.Redis (Either R.Reply b) -> IO (Either KVDBReply b)) + -> L.KeyValueF (Either KVDBReply) a + -> IO a +interpretKeyValueF runRedis (L.Set k v next) = + next . second fromRdStatus <$> runRedis (R.set k v) + +interpretKeyValueF runRedis (L.SetEx k e v next) = + next . second fromRdStatus <$> runRedis (R.setex k e v) + +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 + -- (nil) is ok, app should not fail + Left (Bulk Nothing) -> Right False + Left reply -> Left reply + +interpretKeyValueF runRedis (L.Get k next) = + fmap next $ + runRedis $ R.get k + +interpretKeyValueF runRedis (L.Exists k next) = + fmap next $ + runRedis $ R.exists k + +interpretKeyValueF _ (L.Del [] next) = + pure . next . pure $ 0 + +interpretKeyValueF runRedis (L.Del ks next) = + fmap next $ + runRedis $ R.del ks + +interpretKeyValueF runRedis (L.Expire k sec next) = + fmap next $ + runRedis $ R.expire k sec + +interpretKeyValueF runRedis (L.Incr k next) = + fmap next $ + runRedis $ R.incr k + +interpretKeyValueF runRedis (L.HSet k field value next) = + fmap next $ + runRedis $ R.hset k field value + +interpretKeyValueF runRedis (L.HGet k field next) = + fmap next $ + runRedis $ R.hget k field + +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 sq)) = show ms <> "-" <> show sq + makeStreamEntryId L.AutoID = "*" + + parseStreamEntryId bs = + -- "number-number" is redis entry id invariant + let (ms, sq) = bimap (read . T.unpack) (read . T.unpack) . + T.breakOn "-" . TE.decodeUtf8With TE.lenientDecode $ bs + in L.KVDBStreamEntryID ms sq + +interpretKeyValueF runRedis (L.XRead stream entryId next) = + fmap next $ + runRedis $ do + result <- R.xread [(stream, entryId)] + pure $ (fmap . fmap $ parseXReadResponse) <$> result + where + parseXReadResponseRecord :: R.StreamsRecord -> L.KVDBStreamReadResponseRecord + parseXReadResponseRecord record = + L.KVDBStreamReadResponseRecord (R.recordId record) (R.keyValues record) + + parseXReadResponse :: R.XReadResponse -> L.KVDBStreamReadResponse + parseXReadResponse (R.XReadResponse strm records) = L.KVDBStreamReadResponse strm (parseXReadResponseRecord <$> records) + +interpretKeyValueF runRedis (L.XReadGroup groupName consumerName streamsAndIds opt next) = + fmap next $ + runRedis $ do + result <- R.xreadGroupOpts groupName consumerName streamsAndIds opt + pure $ (fmap . fmap $ parseXReadResponse) <$> result + where + parseXReadResponseRecord :: R.StreamsRecord -> L.KVDBStreamReadResponseRecord + parseXReadResponseRecord record = + L.KVDBStreamReadResponseRecord (R.recordId record) (R.keyValues record) + + parseXReadResponse :: R.XReadResponse -> L.KVDBStreamReadResponse + parseXReadResponse (R.XReadResponse strm records) = L.KVDBStreamReadResponse strm (parseXReadResponseRecord <$> records) + +interpretKeyValueF runRedis (L.XReadOpts strObjs readOpts next) = + fmap next $ + runRedis $ do + result <- R.xreadOpts ((\(a, b) -> (a, makeStreamEntryId b)) <$> strObjs) readOpts + pure result + where + makeStreamEntryId (L.EntryID (L.KVDBStreamEntryID ms sq)) = show ms <> "-" <> show sq + makeStreamEntryId L.AutoID = "*" + + +interpretKeyValueF runRedis (L.XGroupCreate stream groupName startId next) = + fmap next $ runRedis $ R.xgroupCreate stream groupName startId + +interpretKeyValueF runRedis (L.XDel stream entryIds next) = + fmap next $ + runRedis $ R.xdel stream ((\(L.KVDBStreamEntryID ms sq) -> show ms <> "-" <> show sq) <$> entryIds) + +interpretKeyValueF runRedis (L.XRevRange stream send sstart count next) = + fmap next $ + runRedis $ do + result <- R.xrevRange stream send sstart count + pure $ (fmap parseXReadResponseRecord) <$> result + where + parseXReadResponseRecord :: R.StreamsRecord -> L.KVDBStreamReadResponseRecord + parseXReadResponseRecord record = + L.KVDBStreamReadResponseRecord (R.recordId record) (R.keyValues record) + + +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.ZAdd k v next) = + fmap next $ runRedis $ R.zadd k v + +interpretKeyValueF runRedis (L.ZRange k start stop next) = + fmap next $ runRedis $ R.zrange k start stop + +interpretKeyValueF runRedis (L.ZRangeByScore k minScore maxScore next) = + fmap next $ runRedis $ R.zrangebyscore k minScore maxScore + +interpretKeyValueF runRedis (L.ZRangeByScoreWithLimit k minScore maxScore offset count next) = + fmap next $ runRedis $ R.zrangebyscoreLimit k minScore maxScore offset count + +interpretKeyValueF runRedis (L.ZRem k v next) = + fmap next $ runRedis $ R.zrem k v + +interpretKeyValueF runRedis (L.ZRemRangeByScore k minScore maxScore next) = + fmap next $ runRedis $ R.zremrangebyscore k minScore maxScore + +interpretKeyValueF runRedis (L.ZCard k next) = + fmap next $ runRedis $ R.zcard k + +interpretKeyValueF runRedis (L.SRem k v next) = + fmap next $ runRedis $ R.srem k v + +interpretKeyValueF runRedis (L.LPush k v next) = + fmap next $ runRedis $ R.lpush k v + +interpretKeyValueF runRedis (L.LRange k start stop next) = + fmap next $ runRedis $ R.lrange k start stop + +interpretKeyValueF runRedis (L.SMembers k next) = + fmap next $ runRedis $ R.smembers k + +interpretKeyValueF runRedis (L.SMove k1 k2 v next) = + fmap next $ runRedis $ R.smove k1 k2 v + +interpretKeyValueF runRedis (L.SMem k v next) = + fmap next $ runRedis $ R.sismember k v + +interpretKeyValueF runRedis (L.Raw args next) = next <$> runRedis (R.sendRequest args) + +interpretKeyValueF runRedis (L.Ping next) = fmap next $ runRedis $ R.ping + +addToRecordingLocal :: FlowRuntime -> RecordingEntry -> R.RedisTx () +addToRecordingLocal FlowRuntime {..} entry = do + m <- takeMVar _recordingLocal + putMVar _recordingLocal $ m <> [entry] + +interpretKeyValueTxF :: Text -> Maybe FlowGUID -> FlowRuntime -> L.KeyValueF R.Queued a -> R.RedisTx a +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.Set k v next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RSetBT $ RSetB (k) (toJSON v) (Left A.Null) recTimestamp cName + next . fmap fromRdStatus <$> R.set k v + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.SetEx k e v next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RSetexBT $ RSetexB (k) e (toJSON v) (Left A.Null) recTimestamp cName + next . fmap fromRdStatus <$> R.setex k e v + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.SetOpts k v ttl cond next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RSetOptsBT $ RSetOptsB (k) (toJSON v) (toJSON ttl) (toJSON cond) (Left A.Null) recTimestamp cName + next . fmap (R.Ok ==) <$> (R.setOpts k v . makeSetOpts ttl $ cond) + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.Get k next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RGetBT $ RGetB (k) (Nothing) recTimestamp cName + next <$> R.get k + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.Exists k next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RExistsBT $ RExistsB (k) (Left A.Null) recTimestamp cName + next <$> R.exists k + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.Del [] next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RDelBT $ RDelB ([]) (Left A.Null) recTimestamp cName + pure . next . pure $ 0 + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.Del ks next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RDelBT $ RDelB ks (Left A.Null) recTimestamp cName + next <$> R.del ks + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.Expire k sec next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RExpireBT $ RExpireB (k) (sec) (Left A.Null) recTimestamp cName + next <$> R.expire k sec + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.Incr k next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RIncrBT $ RIncrB (k) (Left A.Null) recTimestamp cName + next <$> R.incr k + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.HSet k field value next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RHSetBT $ RHSetB (k) (toJSON field) (toJSON value) (Left A.Null) recTimestamp cName + next <$> R.hset k field value + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.HGet k field next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RHGetT $ RHGet (k) (toJSON field) (Nothing) recTimestamp cName + next <$> R.hget k field + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.XLen stream next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RXLenBT $ RXLenB (stream) (Left A.Null) recTimestamp cName + next <$> R.xlen stream + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.XGroupCreate stream groupName startId next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RXGroupCreateBT $ RXGroupCreateB (stream) (toJSON groupName) (toJSON startId) (Left A.Null) recTimestamp cName + next <$> R.xgroupCreate stream groupName startId + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.XDel stream entryIds next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RXDelBT $ RXDelB (stream) (toJSON entryIds) (Left A.Null) recTimestamp cName + next <$> R.xdel stream ((\(L.KVDBStreamEntryID ms sq) -> show ms <> "-" <> show sq) <$> entryIds) + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.XAdd stream entryId items next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RXaddBT $ RXaddB (stream) (makeStreamEntryId entryId) (toJSON items) (Left A.Null) recTimestamp cName + next . fmap parseStreamEntryId <$> R.xadd stream (makeStreamEntryId entryId) items + where + makeStreamEntryId (L.EntryID (L.KVDBStreamEntryID ms sq)) = show ms <> "-" <> show sq + makeStreamEntryId L.AutoID = "*" + + parseStreamEntryId bs = + -- "number-number" is redis entry id invariant + let (ms, sq) = bimap (read . T.unpack) (read . T.unpack) . + T.breakOn "-" . TE.decodeUtf8With TE.lenientDecode $ bs + in L.KVDBStreamEntryID ms sq + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.XRead stream entryId next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RXreadBT $ RXreadB (stream) (entryId) (Left A.Null) recTimestamp cName + next . fmap (fmap . fmap $ parseXReadResponse) <$> R.xread [(stream, entryId)] + where + parseXReadResponseRecord :: R.StreamsRecord -> L.KVDBStreamReadResponseRecord + parseXReadResponseRecord record = + L.KVDBStreamReadResponseRecord (R.recordId record) (R.keyValues record) + + parseXReadResponse :: R.XReadResponse -> L.KVDBStreamReadResponse + parseXReadResponse (R.XReadResponse strm records) = L.KVDBStreamReadResponse strm (parseXReadResponseRecord <$> records) + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.XReadGroup groupName consumerName streamsAndIds opt next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RXReadGroupBT $ RXReadGroupB (toJSON groupName) (toJSON consumerName) streamsAndIds (toJSON opt) (Left A.Null) recTimestamp cName + next . fmap (fmap . fmap $ parseXReadResponse) <$> R.xreadGroupOpts groupName consumerName streamsAndIds opt + where + parseXReadResponseRecord :: R.StreamsRecord -> L.KVDBStreamReadResponseRecord + parseXReadResponseRecord record = + L.KVDBStreamReadResponseRecord (R.recordId record) (R.keyValues record) + + parseXReadResponse :: R.XReadResponse -> L.KVDBStreamReadResponse + parseXReadResponse (R.XReadResponse strm records) = L.KVDBStreamReadResponse strm (parseXReadResponseRecord <$> records) + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.XReadOpts strObjs readOpts next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RXReadOptsBT $ RXReadOptsB (toJSON strObjs) (toJSON readOpts) (Left A.Null) recTimestamp cName + fmap next $ R.xreadOpts ((\(a, b) -> (a, makeStreamEntryId b)) <$> strObjs) readOpts + where + makeStreamEntryId (L.EntryID (L.KVDBStreamEntryID ms sq)) = show ms <> "-" <> show sq + makeStreamEntryId L.AutoID = "*" + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.XRevRange stream send sstart count next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RXRevRangeBT $ RXRevRangeB (stream) (toJSON send) (toJSON sstart) (count) (Left A.Null) recTimestamp cName + next . fmap (fmap parseXReadResponseRecord) <$> R.xrevRange stream send sstart count + where + parseXReadResponseRecord :: R.StreamsRecord -> L.KVDBStreamReadResponseRecord + parseXReadResponseRecord record = + L.KVDBStreamReadResponseRecord (R.recordId record) (R.keyValues record) + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.SAdd k v next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RSAddBT $ RSAddB (k) (v) (Left A.Null) recTimestamp cName + next <$> R.sadd k v + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.ZAdd k v next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RZAddBT $ RZAddB (k) (v) (Left A.Null) recTimestamp cName + next <$> R.zadd k v + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.ZRange k startRank stopRank next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RZRangeBT $ RZRangeB (k) startRank stopRank (Left A.Null) recTimestamp cName + next <$> R.zrange k startRank stopRank + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.ZRangeByScore k minScore maxScore next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RZRangeByScoreT $ RZRangeByScore k minScore maxScore (Left A.Null) recTimestamp cName + next <$> R.zrangebyscore k minScore maxScore + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.ZRangeByScoreWithLimit k minScore maxScore offset count next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RZRangeByScoreWithLimitT $ RZRangeByScoreWithLimit k minScore maxScore offset count (Left A.Null) recTimestamp cName + next <$> R.zrangebyscoreLimit k minScore maxScore offset count + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.ZRem k v next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RZRemT $ RZRem k v (Left A.Null) recTimestamp cName + next <$> R.zrem k v + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.ZRemRangeByScore k minScore maxScore next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RZRemRangeByScoreT $ RZRemRangeByScore k minScore maxScore (Left A.Null) recTimestamp cName + next <$> R.zremrangebyscore k minScore maxScore + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.ZCard k next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RZCardT $ RZCard k (Left A.Null) recTimestamp cName + next <$> R.zcard k + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.SRem k v next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RSRemBT $ RSRemB k v (Left A.Null) recTimestamp cName + next <$> R.srem k v + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.LRange k start stop next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RLRangeBT $ RLRangeB k start stop (Left A.Null) recTimestamp cName + next <$> R.lrange k start stop + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.LPush k v next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RLPushBT $ RLPushB k v (Left A.Null) recTimestamp cName + next <$> R.lpush k v + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.SMembers k next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RSmembersBT $ RSmembersB k (Left A.Null) recTimestamp cName + next <$> R.smembers k + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.SMove k1 k2 v next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RSMoveBT $ RSMoveB k1 k2 v (Left A.Null) recTimestamp cName + next <$> R.smove k1 k2 v + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.SMem k v next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RSMemBT $ RSMemB k v (Left A.Null) recTimestamp cName + next <$> R.sismember k v + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.Raw args next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RRawBT $ RRawB args (Left A.Null) recTimestamp cName + next <$> R.sendRequest args + +interpretKeyValueTxF cName _mbFlowGuid _flowRt@FlowRuntime {} (L.Ping next) = do + when isArtRecEnabled $ do + recTimestamp <- liftIO $ zonedTimeToLocalTime . utcToZonedTime utc <$> getCurrentTime + addToRecordingLocal _flowRt $ RunKVDBEntryT $ RPingBT $ RPingB (Left A.Null) recTimestamp cName + next <$> R.ping + +interpretTransactionF + :: Text + -> Maybe FlowGUID + -> FlowRuntime + -> (forall b. R.Redis (Either R.Reply b) -> IO (Either KVDBReply b)) + -> L.TransactionF a + -> IO a +interpretTransactionF cName mbFlowGuid flowRt@FlowRuntime{} runRedis (L.MultiExec dsl next) = do + fmap next $ + runRedis $ fmap (Right . fromRdTxResult) $ R.multiExec $ foldF (interpretKeyValueTxF cName mbFlowGuid flowRt) dsl + +interpretTransactionF cName mbFlowGuid flowRt@FlowRuntime{} runRedis (L.MultiExecWithHash _ dsl next) = do + fmap next $ + runRedis $ fmap (Right . fromRdTxResult) $ R.multiExec $ foldF (interpretKeyValueTxF cName mbFlowGuid flowRt) dsl + + +interpretDbF + :: Text -> Maybe FlowGUID + -> FlowRuntime + -> (forall b. R.Redis (Either R.Reply b) -> IO (Either KVDBReply b)) + -> L.KVDBF a + -> IO a +interpretDbF _ _ _ runRedis (L.KV f) = interpretKeyValueF runRedis f +interpretDbF cName mbFlowGuid flowRt runRedis (L.TX f) = interpretTransactionF cName mbFlowGuid flowRt runRedis f + +runKVDB :: Maybe FlowGUID -> FlowRuntime -> Text -> MVar (Map Text NativeKVDBConn) -> L.KVDB a -> IO (Either KVDBReply a) +runKVDB mbFlowGuid flowRt cName kvdbConnMapMVar = + fmap (join . first exceptionToKVDBReply) . try @_ @SomeException . + foldF (interpretDbF cName mbFlowGuid flowRt runRedis) . runExceptT + where + runRedis :: R.Redis (Either R.Reply a) -> IO (Either KVDBReply a) + runRedis redisDsl = do + connections <- readMVar kvdbConnMapMVar + case Map.lookup cName connections of + Nothing -> pure $ Left $ KVDBError KVDBConnectionDoesNotExist + $ "Can't find redis connection: " <> T.unpack cName + Just (NativeKVDB c) -> first hedisReplyToKVDBReply <$> R.runRedis c redisDsl + +makeSetOpts :: L.KVDBSetTTLOption -> L.KVDBSetConditionOption -> R.SetOpts +makeSetOpts ttl cond = + R.SetOpts + { setSeconds = + case ttl of + L.Seconds s -> Just s + _ -> Nothing + , setMilliseconds = + case ttl of + L.Milliseconds ms -> Just ms + _ -> Nothing + , setCondition = + case cond of + L.SetAlways -> Nothing + L.SetIfExist -> Just R.Xx + L.SetIfNotExist -> Just R.Nx + } diff --git a/src/EulerHS/KVDB/Language.hs b/src/EulerHS/KVDB/Language.hs new file mode 100644 index 00000000..3c68b644 --- /dev/null +++ b/src/EulerHS/KVDB/Language.hs @@ -0,0 +1,394 @@ +{- | +Module : EulerHS.KVDB.Language +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} + +module EulerHS.KVDB.Language + ( + -- * KVDB language + -- ** Types + KVDB, KVDBTx, KVDBKey, KVDBValue, KVDBDuration + , KVDBSetTTLOption(..), KVDBSetConditionOption(..) + , KVDBField, KVDBChannel, KVDBMessage + , KVDBStream, KVDBStreamItem, KVDBStreamEntryID (..), KVDBStreamEntryIDInput (..) + , KVDBF(..), KeyValueF(..), TransactionF(..), RecordID, KVDBStreamReadResponse (..), KVDBStreamReadResponseRecord (..), KVDBStreamEnd, KVDBStreamStart + , KVDBGroupName, KVDBConsumerName + -- ** Methods + -- *** Regular + -- **** For simple values + , set, get, incr, setex, setOpts + -- **** For list values + , lpush, lrange + -- **** For hash values + , hset, hget + -- **** For streams + , xadd, xlen, xread, xrevrange, xreadGroup, xdel, xgroupCreate + -- **** For both + , exists, del, expire + -- *** Transactional + -- | Used inside multiExec instead of regular + , multiExec, multiExecWithHash + , setTx, getTx, delTx, setexTx + , lpushTx, lrangeTx + , hsetTx, hgetTx + , xaddTx, xlenTx , xreadTx , xreadOpts + , expireTx + , saddTx + -- *** Set + , sadd, srem + , smembers, smove + , sismember + + --- *** Ordered Set + , zadd + , zrange, zrangebyscore, zrangebyscorewithlimit, zrem, zremrangebyscore, zcard + -- *** Raw + , rawRequest + , pingRequest + ) where + +import qualified Database.Redis as R +import EulerHS.KVDB.Types (KVDBAnswer, KVDBReply, KVDBStatus, + TxResult) +import EulerHS.Prelude hiding (get) + +data KVDBSetTTLOption + = NoTTL + | Seconds Integer + | Milliseconds Integer + deriving stock Generic + deriving anyclass (ToJSON,FromJSON) + +data KVDBSetConditionOption + = SetAlways + | SetIfExist + | SetIfNotExist + deriving stock Generic + deriving anyclass (ToJSON,FromJSON) + +type KVDBKey = ByteString +type KVDBValue = ByteString +type KVDBDuration = Integer +type KVDBField = ByteString +type KVDBChannel = ByteString +type KVDBMessage = ByteString + +type KVDBStream = ByteString +type KVDBStreamEnd = ByteString +type KVDBStreamStart = ByteString +type RecordID = ByteString +type KVDBGroupName = ByteString +type KVDBConsumerName = ByteString + +data KVDBStreamEntryID = KVDBStreamEntryID Integer Integer + deriving stock Generic + deriving anyclass (ToJSON,FromJSON) + +data KVDBStreamEntryIDInput + = EntryID KVDBStreamEntryID + | AutoID + deriving stock Generic + deriving anyclass (ToJSON,FromJSON) + +data KVDBStreamReadResponse = + KVDBStreamReadResponse { + streamName :: ByteString + , response :: [KVDBStreamReadResponseRecord] + } + deriving stock Generic + deriving anyclass (ToJSON,FromJSON) + +data KVDBStreamReadResponseRecord = + KVDBStreamReadResponseRecord { + recordId :: ByteString + , records :: [(ByteString, ByteString)] + } + deriving stock Generic + deriving anyclass (ToJSON,FromJSON) + +type KVDBStreamItem = (ByteString, ByteString) + +---------------------------------------------------------------------- + +data KeyValueF f next where + Set :: KVDBKey -> KVDBValue -> (f KVDBStatus -> next) -> KeyValueF f next + SetEx :: KVDBKey -> KVDBDuration -> KVDBValue -> (f KVDBStatus -> next) -> KeyValueF f next + SetOpts :: KVDBKey -> KVDBValue -> KVDBSetTTLOption -> KVDBSetConditionOption -> (f Bool -> next) -> KeyValueF f next + Get :: KVDBKey -> (f (Maybe ByteString) -> next) -> KeyValueF f next + Exists :: KVDBKey -> (f Bool -> next) -> KeyValueF f next + Del :: [KVDBKey] -> (f Integer -> next) -> KeyValueF f next + Expire :: KVDBKey -> KVDBDuration -> (f Bool -> next) -> KeyValueF f next + Incr :: KVDBKey -> (f Integer -> next) -> KeyValueF f next + HSet :: KVDBKey -> KVDBField -> KVDBValue -> (f Integer -> next) -> KeyValueF f next + HGet :: KVDBKey -> KVDBField -> (f (Maybe ByteString) -> next) -> KeyValueF f next + XAdd :: KVDBStream -> KVDBStreamEntryIDInput -> [KVDBStreamItem] -> (f KVDBStreamEntryID -> next) -> KeyValueF f next + XRead :: KVDBStream -> RecordID -> (f (Maybe [KVDBStreamReadResponse]) -> next) -> KeyValueF f next + XReadGroup :: KVDBGroupName -> KVDBConsumerName -> [(KVDBStream, RecordID)] -> R.XReadOpts -> (f (Maybe [KVDBStreamReadResponse]) -> next) -> KeyValueF f next + XReadOpts :: [(KVDBStream, KVDBStreamEntryIDInput)] -> R.XReadOpts -> (f (Maybe [R.XReadResponse]) -> next) -> KeyValueF f next + XGroupCreate :: KVDBStream -> KVDBGroupName -> RecordID -> (f R.Status -> next) -> KeyValueF f next + XDel :: KVDBStream -> [KVDBStreamEntryID] -> (f Integer -> next) -> KeyValueF f next + XRevRange :: KVDBStream -> KVDBStreamEnd -> KVDBStreamStart -> Maybe Integer -> (f [KVDBStreamReadResponseRecord] -> next) -> KeyValueF f next + XLen :: KVDBStream -> (f Integer -> next) -> KeyValueF f next + SAdd :: KVDBKey -> [KVDBValue] -> (f Integer -> next) -> KeyValueF f next + ZAdd :: KVDBKey -> [(Double, KVDBValue)] -> (f Integer -> next) -> KeyValueF f next + ZRange :: KVDBKey -> Integer -> Integer -> (f [ByteString] -> next) -> KeyValueF f next + ZRangeByScore :: KVDBKey -> Double -> Double -> (f [ByteString] -> next) -> KeyValueF f next + ZRangeByScoreWithLimit :: KVDBKey -> Double -> Double -> Integer -> Integer -> (f [ByteString] -> next) -> KeyValueF f next + ZRem :: KVDBKey -> [KVDBValue] -> (f Integer -> next) -> KeyValueF f next + ZRemRangeByScore :: KVDBKey -> Double -> Double -> (f Integer -> next) -> KeyValueF f next + ZCard :: KVDBKey -> (f Integer -> next) -> KeyValueF f next + SRem :: KVDBKey -> [KVDBValue] -> (f Integer -> next) -> KeyValueF f next + LPush :: KVDBKey -> [KVDBValue] -> (f Integer -> next) -> KeyValueF f next + LRange :: KVDBKey -> Integer -> Integer -> (f [ByteString] -> next) -> KeyValueF f next + SMembers :: KVDBKey -> (f [ByteString] -> next) -> KeyValueF f next + SMove :: KVDBKey -> KVDBKey -> KVDBValue -> (f Bool -> next) -> KeyValueF f next + SMem :: KVDBKey -> KVDBKey -> (f Bool -> next) -> KeyValueF f next + Raw :: (R.RedisResult a) => [ByteString] -> (f a -> next) -> KeyValueF f next + Ping :: (f R.Status -> next) -> KeyValueF f next + +instance Functor (KeyValueF f) where + fmap f (Set k value next) = Set k value (f . next) + fmap f (SetEx k ex value next) = SetEx k ex value (f . next) + fmap f (SetOpts k value ttl cond next) = SetOpts k value ttl cond (f . next) + fmap f (Get k next) = Get k (f . next) + fmap f (Exists k next) = Exists k (f . next) + fmap f (Del ks next) = Del ks (f . next) + fmap f (Expire k sec next) = Expire k sec (f . next) + fmap f (Incr k next) = Incr k (f . next) + fmap f (HSet k field value next) = HSet k field value (f . next) + 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 (XRead s entryId next) = XRead s entryId (f . next) + fmap f (XReadGroup gName cName s opts next) = XReadGroup gName cName s opts (f . next) + fmap f (XGroupCreate s gName startId next) = XGroupCreate s gName startId (f . next) + fmap f (XDel s entryId next) = XDel s entryId (f . next) + fmap f (XRevRange strm send sstart count next) = XRevRange strm send sstart count (f . next) + fmap f (XLen s next) = XLen s (f . next) + fmap f (SAdd k v next) = SAdd k v (f . next) + fmap f (ZAdd k v next) = ZAdd k v (f . next) + fmap f (ZRange k s1 s2 next) = ZRange k s1 s2 (f . next) + fmap f (ZRangeByScore k s1 s2 next) = ZRangeByScore k s1 s2 (f . next) + fmap f (ZRangeByScoreWithLimit k s1 s2 offset count next) = ZRangeByScoreWithLimit k s1 s2 offset count (f . next) + fmap f (ZRem k v next) = ZRem k v (f . next) + fmap f (ZRemRangeByScore k s1 s2 next) = ZRemRangeByScore k s1 s2 (f . next) + fmap f (ZCard k next) = ZCard k (f . next) + fmap f (SRem k v next) = SRem k v (f . next) + fmap f (LPush k v next) = LPush k v (f . next) + fmap f (LRange k start stop next) = LRange k start stop (f . next) + fmap f (SMove k1 k2 v next) = SMove k1 k2 v (f . next) + fmap f (SMembers k next) = SMembers k (f . next) + fmap f (SMem k v next) = SMem k v (f . next) + fmap f (Raw args next) = Raw args (f . next) + fmap f (XReadOpts s readOpts next) = XReadOpts s readOpts (f . next) + fmap f (Ping next) = Ping (f . next) + +type KVDBTx = F (KeyValueF R.Queued) + +---------------------------------------------------------------------- + +data TransactionF next where + MultiExec + :: KVDBTx (R.Queued a) + -> (KVDBAnswer (TxResult a) -> next) + -> TransactionF next + MultiExecWithHash + :: ByteString + -> KVDBTx (R.Queued a) + -> (KVDBAnswer (TxResult a) -> next) + -> TransactionF next + +instance Functor TransactionF where + fmap f (MultiExec dsl next) = MultiExec dsl (f . next) + fmap f (MultiExecWithHash h dsl next) = MultiExecWithHash h dsl (f . next) + +---------------------------------------------------------------------- + +data KVDBF next + = KV (KeyValueF KVDBAnswer next) + | TX (TransactionF next) + deriving Functor + +type KVDB next = ExceptT KVDBReply (F KVDBF) next + +---------------------------------------------------------------------- +-- | Set the value of a key. Transaction version. +setTx :: KVDBKey -> KVDBValue -> KVDBTx (R.Queued KVDBStatus) +setTx key value = liftFC $ Set key value id + +-- | Set the value and ttl of a key. Transaction version. +setexTx :: KVDBKey -> KVDBDuration -> KVDBValue -> KVDBTx (R.Queued KVDBStatus) +setexTx key ex value = liftFC $ SetEx key ex value id + +-- | Set the value of a hash field. Transaction version. +hsetTx :: KVDBKey -> KVDBField -> KVDBValue -> KVDBTx (R.Queued Integer) +hsetTx key field value = liftFC $ HSet key field value id + +-- | Get the value of a key. Transaction version. +getTx :: KVDBKey -> KVDBTx (R.Queued (Maybe ByteString)) +getTx key = liftFC $ Get key id + +-- | Get the value of a hash field. Transaction version. +hgetTx :: KVDBKey -> KVDBField -> KVDBTx (R.Queued (Maybe ByteString)) +hgetTx key field = liftFC $ HGet key field id + +-- | Delete a keys. Transaction version. +delTx :: [KVDBKey] -> KVDBTx (R.Queued Integer) +delTx ks = liftFC $ Del ks id + +-- | Set a key's time to live in seconds. Transaction version. +expireTx :: KVDBKey -> KVDBDuration -> KVDBTx (R.Queued Bool) +expireTx key sec = liftFC $ Expire key sec id + +xaddTx :: KVDBStream -> KVDBStreamEntryIDInput -> [KVDBStreamItem] -> KVDBTx (R.Queued KVDBStreamEntryID) +xaddTx stream entryId items = liftFC $ XAdd stream entryId items id + +xreadTx :: KVDBStream -> RecordID -> KVDBTx (R.Queued (Maybe [KVDBStreamReadResponse])) +xreadTx stream entryId = liftFC $ XRead stream entryId id + +xlenTx :: KVDBStream -> KVDBTx (R.Queued Integer) +xlenTx stream = liftFC $ XLen stream id + +lpushTx :: KVDBKey -> [KVDBValue] -> KVDBTx (R.Queued Integer) +lpushTx key value = liftFC $ LPush key value id + +lrangeTx :: KVDBKey -> Integer -> Integer -> KVDBTx (R.Queued [ByteString]) +lrangeTx key start stop = liftFC $ LRange key start stop id + +saddTx :: KVDBKey -> [KVDBValue] -> KVDBTx (R.Queued Integer) +saddTx setKey setmem = liftFC $ SAdd setKey setmem id + +--- +-- | Set the value of a key +set :: KVDBKey -> KVDBValue -> KVDB KVDBStatus +set key value = ExceptT $ liftFC $ KV $ Set key value id + +-- | Set the value and ttl of a key. +setex :: KVDBKey -> KVDBDuration -> KVDBValue -> KVDB KVDBStatus +setex key ex value = ExceptT $ liftFC $ KV $ SetEx key ex value id + +setOpts :: KVDBKey -> KVDBValue -> KVDBSetTTLOption -> KVDBSetConditionOption -> KVDB Bool +setOpts key value ttl cond = ExceptT $ liftFC $ KV $ SetOpts key value ttl cond id + +-- | Get the value of a key +get :: KVDBKey -> KVDB (Maybe ByteString) +get key = ExceptT $ liftFC $ KV $ Get key id + +-- | Determine if a key exists +exists :: KVDBKey -> KVDB Bool +exists key = ExceptT $ liftFC $ KV $ Exists key id + +-- | Delete a keys +del :: [KVDBKey] -> KVDB Integer +del ks = ExceptT $ liftFC $ KV $ Del ks id + +-- | Set a key's time to live in seconds +expire :: KVDBKey -> KVDBDuration -> KVDB Bool +expire key sec = ExceptT $ liftFC $ KV $ Expire key sec id + +-- | Increment the integer value of a key by one +incr :: KVDBKey -> KVDB Integer +incr key = ExceptT $ liftFC $ KV $ Incr key id + +-- | Set the value of a hash field +hset :: KVDBKey -> KVDBField -> KVDBValue -> KVDB Integer +hset key field value = ExceptT $ liftFC $ KV $ HSet key field value id + +-- | Get the value of a hash field +hget :: KVDBKey -> KVDBField -> KVDB (Maybe ByteString) +hget key field = ExceptT $ liftFC $ KV $ HGet key field id + +xadd :: KVDBStream -> KVDBStreamEntryIDInput -> [KVDBStreamItem] -> KVDB KVDBStreamEntryID +xadd stream entryId items = ExceptT $ liftFC $ KV $ XAdd stream entryId items id + +xread :: KVDBStream -> RecordID -> KVDB (Maybe [KVDBStreamReadResponse]) +xread stream entryId = ExceptT $ liftFC $ KV $ XRead stream entryId id + +xreadGroup :: KVDBGroupName -> KVDBConsumerName -> [(KVDBStream, RecordID)] -> Maybe Integer -> Maybe Integer -> Bool -> KVDB (Maybe [KVDBStreamReadResponse]) +xreadGroup groupName consumerName streamsAndIds mBlock mCount noack = ExceptT $ liftFC $ KV $ XReadGroup groupName consumerName streamsAndIds (R.XReadOpts mBlock mCount noack) id + +xreadOpts :: [(KVDBStream, KVDBStreamEntryIDInput)] -> R.XReadOpts -> KVDB (Maybe [R.XReadResponse]) +xreadOpts stPair readOpts = ExceptT $ liftFC $ KV $ XReadOpts stPair readOpts id + +xgroupCreate :: KVDBStream -> KVDBGroupName -> RecordID -> KVDB R.Status +xgroupCreate stream groupName startId = ExceptT $ liftFC $ KV $ XGroupCreate stream groupName startId id + +xdel :: KVDBStream -> [KVDBStreamEntryID] -> KVDB Integer +xdel stream entryId = ExceptT $ liftFC $ KV $ XDel stream entryId id + +xrevrange :: KVDBStream -> KVDBStreamEnd -> KVDBStreamStart -> Maybe Integer -> KVDB ([KVDBStreamReadResponseRecord]) +xrevrange stream send sstart count = ExceptT $ liftFC $ KV $ XRevRange stream send sstart count id + +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 + +srem :: KVDBKey -> [KVDBValue] -> KVDB Integer +srem setKey setmem = ExceptT $ liftFC $ KV $ SRem setKey setmem id + +zadd :: KVDBKey -> [(Double, KVDBValue)] -> KVDB Integer +zadd key values = ExceptT $ liftFC $ KV $ ZAdd key values id + +zrange :: KVDBKey -> Integer -> Integer -> KVDB [ByteString] +zrange key startRank stopRank = ExceptT $ liftFC $ KV $ ZRange key startRank stopRank id + +zrangebyscore :: KVDBKey -> Double -> Double -> KVDB [ByteString] +zrangebyscore key minScore maxScore = ExceptT $ liftFC $ KV $ ZRangeByScore key minScore maxScore id + +zrem :: KVDBKey -> [KVDBValue] -> KVDB Integer +zrem key values = ExceptT $ liftFC $ KV $ ZRem key values id + +zremrangebyscore :: KVDBKey -> Double -> Double -> KVDB Integer +zremrangebyscore key minScore maxScore = ExceptT $ liftFC $ KV $ ZRemRangeByScore key minScore maxScore id + +zrangebyscorewithlimit :: KVDBKey -> Double -> Double -> Integer -> Integer -> KVDB [ByteString] +zrangebyscorewithlimit key minScore maxScore offset count = ExceptT $ liftFC $ KV $ ZRangeByScoreWithLimit key minScore maxScore offset count id + +zcard :: KVDBKey -> KVDB Integer +zcard key = ExceptT $ liftFC $ KV $ ZCard key id + +lpush :: KVDBKey -> [KVDBValue] -> KVDB Integer +lpush key value = ExceptT $ liftFC $ KV $ LPush key value id + +lrange :: KVDBKey -> Integer -> Integer -> KVDB [ByteString] +lrange key start stop = ExceptT $ liftFC $ KV $ LRange key start stop id + +smembers :: KVDBKey -> KVDB [ByteString] +smembers key = ExceptT $ liftFC $ KV $ SMembers key id + +smove :: KVDBKey -> KVDBKey -> KVDBValue -> KVDB Bool +smove source destination member = ExceptT $ liftFC $ KV $ SMove source destination member 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 :: KVDBTx (R.Queued a) -> KVDB (TxResult a) +multiExec kvtx = ExceptT $ liftFC $ TX $ MultiExec kvtx id + +-- | Run commands inside a transaction(suited only for cluster redis setup). +multiExecWithHash :: ByteString -> KVDBTx (R.Queued a) -> KVDB (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 + +pingRequest :: KVDB R.Status +pingRequest = ExceptT $ liftFC $ KV $ Ping id \ No newline at end of file diff --git a/src/EulerHS/KVDB/Types.hs b/src/EulerHS/KVDB/Types.hs new file mode 100644 index 00000000..a3ae01b7 --- /dev/null +++ b/src/EulerHS/KVDB/Types.hs @@ -0,0 +1,215 @@ +{- | +Module : EulerHS.KVDB.Types +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS -fno-warn-orphans #-} +{-# LANGUAGE DeriveAnyClass #-} + +module EulerHS.KVDB.Types + ( + -- * Core KVDB + -- ** Types + KVDBKey + , KVDBConn(..) + , KVDBAnswer + , KVDBReply + , TxResult(..) + , KVDBStatus + , KVDBStatusF(..) + , KVDBReplyF(..) + , NativeKVDBConn (..) + , KVDBConfig (..) + , RedisConfig (..) + , KVDBError (..) + -- ** Methods + , defaultKVDBConnConfig + , exceptionToKVDBReply + , fromRdStatus + , fromRdTxResult + , hedisReplyToKVDBReply + , mkKVDBConfig + , mkKVDBClusterConfig + , mkRedisConn + , nativeToKVDB + , kvdbToNative + , MeshError(..) + ) where + +import Data.Data (Data) +import Data.Time (NominalDiffTime) +import qualified Data.Aeson as A +import qualified Database.Redis as RD +import EulerHS.Prelude +import qualified GHC.Generics as G +import qualified EulerHS.SqlDB.Types as DBError + + +type KVDBKey = Text + +-- Key-value database connection +data KVDBConn = Redis {-# UNPACK #-} !Text + !RD.Connection + deriving stock (Generic) + +data KVDBError + = KVDBConnectionAlreadyExists + | KVDBConnectionDoesNotExist + | KVDBConnectionFailed + deriving stock (Eq, Show, Generic, Data) + deriving anyclass (ToJSON,FromJSON) + +data KVDBReplyF bs + = SingleLine bs + | Err bs + | Integer Integer + | Bulk (Maybe bs) + | MultiBulk (Maybe [KVDBReplyF bs]) + | ExceptionMessage String + | KVDBError KVDBError String + deriving stock (Eq, Show, Generic, Functor, Data) + deriving anyclass (ToJSON,FromJSON) + +type KVDBReply = KVDBReplyF ByteString + +data KVDBStatusF bs + = Ok + | Pong + | Status bs + deriving stock (Eq, Show, Generic, Functor) + deriving anyclass (ToJSON,FromJSON) + +type KVDBStatus = KVDBStatusF ByteString + +fromRdStatus :: RD.Status -> KVDBStatus +fromRdStatus = \case + RD.Ok -> Ok + RD.Pong -> Pong + RD.Status bs -> Status bs + +data TxResult a + = TxSuccess a + | TxAborted + | TxError String + deriving stock (Eq, Show, Functor, Generic, G.Generic1) + deriving anyclass (ToJSON,FromJSON) + +fromRdTxResult :: RD.TxResult a -> TxResult a +fromRdTxResult = \case + RD.TxSuccess x -> TxSuccess x + RD.TxAborted -> TxAborted + RD.TxError err -> TxError err + +type KVDBAnswer = Either KVDBReply + +hedisReplyToKVDBReply :: RD.Reply -> KVDBReply +hedisReplyToKVDBReply = \case + RD.SingleLine s -> SingleLine s + RD.Error err -> Err err + RD.Integer s -> Integer s + RD.Bulk s -> Bulk s + RD.MultiBulk s -> MultiBulk . fmap (fmap hedisReplyToKVDBReply) $ s + +exceptionToKVDBReply :: Exception e => e -> KVDBReply +exceptionToKVDBReply = ExceptionMessage . displayException + +newtype NativeKVDBConn = NativeKVDB RD.Connection + +-- | Transform 'KVDBConn' to 'NativeKVDBConn' +kvdbToNative :: KVDBConn -> NativeKVDBConn +kvdbToNative (Redis _ conn) = NativeKVDB conn + +-- | Transforms 'NativeKVDBConn' to 'KVDBConn' +nativeToKVDB :: Text -> NativeKVDBConn -> KVDBConn +nativeToKVDB connTag (NativeKVDB conn) = Redis connTag conn + +data KVDBConfig + = KVDBConfig Text RedisConfig + | KVDBClusterConfig Text RedisConfig + deriving stock (Show, Eq, Ord, Generic) + +data RedisConfig = RedisConfig + { connectHost :: String + , connectPort :: Word16 + , connectAuth :: Maybe Text + , connectDatabase :: Integer + , connectReadOnly :: Bool + , connectMaxConnections :: Int + , connectMaxIdleTime :: NominalDiffTime + , connectTimeout :: Maybe NominalDiffTime + } deriving stock (Show, Eq, Ord, Generic) + +defaultKVDBConnConfig :: RedisConfig +defaultKVDBConnConfig = RedisConfig + { connectHost = "localhost" + , connectPort = 6379 + , connectAuth = Nothing + , connectDatabase = 0 + , connectReadOnly = False + , connectMaxConnections = 50 + , connectMaxIdleTime = 30 + , connectTimeout = Nothing + } + +-- | Transform RedisConfig to the Redis ConnectInfo. +toRedisConnectInfo :: RedisConfig -> RD.ConnectInfo +toRedisConnectInfo RedisConfig {..} = RD.ConnInfo + { RD.connectHost = connectHost + , RD.connectPort = RD.PortNumber $ toEnum $ fromEnum connectPort + , RD.connectAuth = encodeUtf8 <$> connectAuth + , RD.connectReadOnly = connectReadOnly + , RD.connectDatabase = connectDatabase + , RD.connectMaxConnections = connectMaxConnections + , RD.connectMaxIdleTime = connectMaxIdleTime + , RD.connectTimeout = connectTimeout + , 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' +mkRedisConn :: KVDBConfig -> IO KVDBConn +mkRedisConn = \case + KVDBConfig connTag cfg -> Redis connTag <$> createRedisConn cfg + KVDBClusterConfig connTag cfg -> Redis connTag <$> createClusterRedisConn cfg + +-- | Connect with the given config to the database. +createRedisConn :: RedisConfig -> IO RD.Connection +createRedisConn = RD.connect . toRedisConnectInfo + +-- | Connect with the given cluster config to the database. +createClusterRedisConn :: RedisConfig -> IO RD.Connection +createClusterRedisConn = RD.connectCluster . toRedisConnectInfo + +data MeshError + = MKeyNotFound Text + | MDBError DBError.DBError + | MRedisError KVDBReply + | MDecodingError Text + | MUpdateFailed Text + | MMultipleKeysFound Text + | UnexpectedError Text + deriving (Show, Generic, Exception, Data) + deriving anyclass (FromJSON) + +instance ToJSON MeshError where + toJSON (MRedisError r) = A.object + [ + "contents" A..= (show r :: Text), + "tag" A..= ("MRedisError" :: Text) + ] + toJSON a = A.toJSON a \ No newline at end of file diff --git a/src/EulerHS/Language.hs b/src/EulerHS/Language.hs index 9b97f64f..75adfb70 100644 --- a/src/EulerHS/Language.hs +++ b/src/EulerHS/Language.hs @@ -5,14 +5,10 @@ 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 @@ -26,40 +22,82 @@ This language provides you with several features out-of-the-box: - 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 + ( module X, + Y.Flow, + Y.FlowMethod (..), + Y.MonadFlow (..), + Y.ReaderFlow, + -- * logging + Y.logCallStack, + Y.logExceptionCallStack, + -- + Y.logInfo, + Y.logError, + Y.logDebug, + Y.logWarning, + -- + Y.logInfoM, + Y.logErrorM, + Y.logDebugM, + Y.logWarningM, + Y.logInfoV, + Y.logErrorV, + Y.logDebugV, + Y.logWarningV, + Y.logException, + Y.logErrorWithCategory, + -- * Calling external services + Y.callAPI, + Y.callAPI', + Y.callHTTP, + Y.callHTTP', + Y.callHTTPWithCert, + Y.callHTTPWithManager, + Y.callHTTPWithCert', + Y.callHTTPWithManager', + -- * other + Y.runIO, + Y.withRunFlow, + Y.forkFlow, + Y.forkFlow'', + Y.forkFlow', + Y.foldFlow, + Y.getMySQLConnection, + -- * dbAndRedisMetric + Y.DBAndRedisMetricHandler, + Y.DBAndRedisMetric (..), + Y.mkDBAndRedisMetricHandler, + Y.DBMetricCfg (..), + Y.XTenantHostHeader (..) ) where -import EulerHS.Core.Language as X import EulerHS.Extra.Language as X -import EulerHS.Framework.Language as X hiding (unpackLanguagePubSub) +import EulerHS.Framework.Language as Y +import EulerHS.KVDB.Language as X +import EulerHS.Logger.Language as X +import EulerHS.PubSub.Language as X hiding (psubscribe, publish, + subscribe) +import EulerHS.SqlDB.Language as X diff --git a/src/EulerHS/Logger/Interpreter.hs b/src/EulerHS/Logger/Interpreter.hs new file mode 100644 index 00000000..571aadca --- /dev/null +++ b/src/EulerHS/Logger/Interpreter.hs @@ -0,0 +1,74 @@ +{- | +Module : EulerHS.Logger.Interpreter +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE BangPatterns #-} + +module EulerHS.Logger.Interpreter + ( + -- * Core Logger Interpreter + runLogger + ) +where + +import qualified Control.Concurrent.MVar as MVar +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.IORef (readIORef) +import EulerHS.Common (FlowGUID) +import EulerHS.Logger.Language (Logger, LoggerMethod (LogMessage)) +import qualified EulerHS.Logger.Runtime as R +import qualified EulerHS.Logger.TinyLogger as Impl +import qualified EulerHS.Logger.Types as T +import EulerHS.Prelude hiding (readIORef) + +interpretLogger :: Maybe FlowGUID -> R.LoggerRuntime -> LoggerMethod a -> IO a + +-- Memory logger +interpretLogger + mbFlowGuid + (R.MemoryLoggerRuntime flowFormatter logContext logLevel logsVar cntVar) + (LogMessage msgLogLvl versionMessage next) = + + fmap next $ + case logLevel <= msgLogLvl of + False -> pure () + _ -> do + formatter <- flowFormatter mbFlowGuid + !msgNum <- R.incLogCounter cntVar + x <- readIORef logContext + let msgBuilder = formatter $ T.convertToPendingMsg mbFlowGuid msgLogLvl msgNum x versionMessage + 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 + (R.LoggerRuntime flowFormatter logContext logLevel _ _ cntVar _ handle severityCounterHandle) + (LogMessage msgLogLevel versionMessage next) = + + fmap next $ + case logLevel <= msgLogLevel of + False -> pure () + _ -> do + msgNum <- R.incLogCounter cntVar + x <- readIORef logContext + Impl.sendPendingMsg flowFormatter handle $ T.convertToPendingMsg mbFlowGuid msgLogLevel msgNum x versionMessage + case severityCounterHandle of + Nothing -> pure () + Just scHandle -> scHandle.incCounter msgLogLevel + +runLogger :: Maybe FlowGUID -> R.LoggerRuntime -> Logger a -> IO a +runLogger mbFlowGuid loggerRt = foldF (interpretLogger mbFlowGuid loggerRt) \ No newline at end of file diff --git a/src/EulerHS/Logger/Language.hs b/src/EulerHS/Logger/Language.hs new file mode 100644 index 00000000..443f3ac0 --- /dev/null +++ b/src/EulerHS/Logger/Language.hs @@ -0,0 +1,78 @@ +{- | +Module : EulerHS.Logger.Language +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module EulerHS.Logger.Language + ( + Logger + , LoggerMethod(..) + , logMessageFormatted + , masterLogger + ) where + +import qualified EulerHS.Logger.Types as T +import EulerHS.Prelude +import Type.Reflection +import Juspay.Extra.Config (lookupEnvT) + +-- | Language for logging. +data LoggerMethod next where + -- | Log message with a predefined level. + LogMessage :: T.LogLevel -> !T.VersionLoggerMessage -> (() -> next) -> LoggerMethod next + +instance Functor LoggerMethod where + fmap f (LogMessage lvl vMsg next) = LogMessage lvl vMsg $ f . next + +type Logger = F LoggerMethod + +logMessage' :: forall tag . (Typeable tag, Show tag) => T.LogLevel -> tag -> T.Message -> Logger () +logMessage' lvl tag msg = liftFC $ LogMessage lvl (T.Ver1 textTag msg) id + where + textTag :: Text + textTag + | Just HRefl <- eqTypeRep (typeRep @tag) (typeRep @Text ) = tag + | Just HRefl <- eqTypeRep (typeRep @tag) (typeRep @String) = toText tag + | otherwise = show tag + +logMessageFormatted :: forall tag. (Typeable tag, Show tag) => T.LogLevel -> T.Category -> Maybe T.Action -> Maybe T.Entity -> Maybe T.ErrorL -> Maybe T.Latency -> Maybe T.RespCode -> T.Message -> tag -> Logger () +logMessageFormatted logLevel category action entity maybeError maybeLatency maybeRespCode message tag = + liftFC $ LogMessage logLevel (T.Ver2 category action' entity maybeError maybeLatency maybeRespCode message) id + where + action' = action <|> (Just textTag) -- keeping tag as action now, if action not found, going ahead we will remove this by verifying all domain action logs + + textTag :: Text + textTag + | Just HRefl <- eqTypeRep (typeRep @tag) (typeRep @Text ) = tag + | Just HRefl <- eqTypeRep (typeRep @tag) (typeRep @String) = toText tag + | otherwise = show tag + + +{- +based on log config: +V1 - older version of logging +V2 - newer version of logging +V1_V2 - both version of logging +-} + +masterLogger :: forall tag. (Typeable tag, Show tag) => T.LogLevel -> tag -> T.Category -> Maybe T.Action -> Maybe T.Entity -> Maybe T.ErrorL -> Maybe T.Latency -> Maybe T.RespCode -> T.Message -> Logger () +masterLogger logLevel tag category action entity maybeError maybeLatency maybeRespCode message + | version == "V1" = logMessage' logLevel tag message + | version == "V2"= logMessageFormatted logLevel category action entity maybeError maybeLatency maybeRespCode message tag + | version == "V1_V2" = do + logMessage' logLevel tag message + logMessageFormatted logLevel category action entity maybeError maybeLatency maybeRespCode message tag + | otherwise = logMessage' logLevel tag message + where + version = getLoggerFormatVersion + +getLoggerFormatVersion :: Text +getLoggerFormatVersion = fromMaybe "V1" $ lookupEnvT "LOGGING_VERSION" \ No newline at end of file diff --git a/src/EulerHS/Logger/Runtime.hs b/src/EulerHS/Logger/Runtime.hs new file mode 100644 index 00000000..d5e510bd --- /dev/null +++ b/src/EulerHS/Logger/Runtime.hs @@ -0,0 +1,163 @@ +{- | +Module : EulerHS.Logger.Runtime +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -- due to RDP - Koz + +module EulerHS.Logger.Runtime + ( + -- * Core Runtime + CoreRuntime(..) + , LoggerRuntime(..) + , SeverityCounterHandle(..) + , shouldLogRawSql + , shouldLogAPI + , incLogCounter + , createCoreRuntime + , createVoidLoggerRuntime + , createMemoryLoggerRuntime + , createLoggerRuntime + , createLoggerRuntime' + , clearCoreRuntime + , clearLoggerRuntime + , getLogMaskingConfig + , module X + ) where + +import Data.IORef (newIORef) +import EulerHS.Prelude hiding (newIORef) +-- Currently, TinyLogger is highly coupled with the Runtime. +-- Fix it if an interchangable implementations are needed. +import qualified EulerHS.Logger.TinyLogger as Impl +import qualified EulerHS.Logger.Types as T +import EulerHS.SqlDB.Types as X (withTransaction) +import qualified System.Logger as Log + +data LoggerRuntime + = LoggerRuntime + { _flowFormatter :: T.FlowFormatter + , _logContext :: IORef T.LogContext + , _logLevel :: T.LogLevel + , _logRawSql :: T.ShouldLogSQL + , _logAPI :: Bool + , _logCounter :: !T.LogCounter + , _logMaskingConfig :: Maybe T.LogMaskingConfig + , _logLoggerHandle :: Impl.LoggerHandle + , _severityCounterHandle :: Maybe SeverityCounterHandle + } + | MemoryLoggerRuntime + !T.FlowFormatter + !(IORef T.LogContext) + !T.LogLevel + !(MVar [Text]) + !T.LogCounter + +newtype CoreRuntime = CoreRuntime + { _loggerRuntime :: LoggerRuntime + } + +-- | Log entry counter by severity handle. +data SeverityCounterHandle = SeverityCounterHandle + { incCounter :: T.LogLevel -> IO () + } + +createMemoryLoggerRuntime :: T.FlowFormatter -> T.LogLevel -> IO LoggerRuntime +createMemoryLoggerRuntime flowFormatter logLevel = do + emptyLoggerCtx <- newIORef mempty + MemoryLoggerRuntime flowFormatter emptyLoggerCtx logLevel <$> newMVar [] <*> initLogCounter + +createLoggerRuntime + :: T.FlowFormatter + -> Maybe SeverityCounterHandle + -> T.LoggerConfig + -> IO LoggerRuntime +createLoggerRuntime flowFormatter severityCounterHandler cfg = do + -- log entries' sequential number + logSequence <- initLogCounter + logHandle <- Impl.createLogger flowFormatter cfg + emptyLoggerCtx <- newIORef mempty + pure $ LoggerRuntime + flowFormatter + emptyLoggerCtx + (T._logLevel cfg) + (T._logRawSql cfg) + (T._logAPI cfg) + logSequence + Nothing + logHandle + severityCounterHandler + +createLoggerRuntime' + :: Maybe Log.DateFormat + -> Maybe Log.Renderer + -> T.BufferSize + -> T.FlowFormatter + -> Maybe SeverityCounterHandle + -> T.LoggerConfig + -> IO LoggerRuntime +createLoggerRuntime' mbDateFormat mbRenderer bufferSize flowFormatter severityCounterHandler cfg = do + -- log entries' sequential number + logSequence <- initLogCounter + loggerHandle <- Impl.createLogger' mbDateFormat mbRenderer bufferSize flowFormatter cfg + emptyLoggerCtx <- newIORef mempty + pure $ LoggerRuntime + flowFormatter + emptyLoggerCtx + (T._logLevel cfg) + (T._logRawSql cfg) + (T._logAPI cfg) + logSequence + (T._logMaskingConfig cfg) + loggerHandle + severityCounterHandler + +createVoidLoggerRuntime :: IO LoggerRuntime +createVoidLoggerRuntime = do + -- log entries' sequential number + logSequence <- initLogCounter + logHandle <- Impl.createVoidLogger + emptyLoggerCtx <- newIORef mempty + pure $ LoggerRuntime + (const $ pure T.showingMessageFormatter) + emptyLoggerCtx + T.Debug + T.SafelyOmitSqlLogs + True + logSequence + Nothing + logHandle + Nothing + +clearLoggerRuntime :: LoggerRuntime -> IO () +clearLoggerRuntime (LoggerRuntime flowFormatter _ _ _ _ _ _ handle _) = Impl.disposeLogger flowFormatter handle +clearLoggerRuntime (MemoryLoggerRuntime _ _ _ msgsVar _) = void $ swapMVar msgsVar [] + +createCoreRuntime :: LoggerRuntime -> IO CoreRuntime +createCoreRuntime = pure . CoreRuntime + +clearCoreRuntime :: CoreRuntime -> IO () +clearCoreRuntime _ = pure () + +shouldLogRawSql :: LoggerRuntime -> Bool +shouldLogRawSql = \case + (LoggerRuntime _ _ _ T.UnsafeLogSQL_DO_NOT_USE_IN_PRODUCTION _ _ _ _ _) -> True + _ -> False +shouldLogAPI :: LoggerRuntime -> Bool +shouldLogAPI (LoggerRuntime _ _ _ _ x _ _ _ _) = x +shouldLogAPI _ = True + +getLogMaskingConfig :: LoggerRuntime -> Maybe T.LogMaskingConfig +getLogMaskingConfig = \case + (LoggerRuntime _ _ _ _ _ _ mbMaskConfig _ _) -> mbMaskConfig + _ -> Nothing + +initLogCounter :: IO T.LogCounter +initLogCounter = newIORef 0 + +incLogCounter :: T.LogCounter -> IO Int +incLogCounter = flip atomicModifyIORef' (\cnt -> (cnt + 1, cnt)) diff --git a/src/EulerHS/Logger/TinyLogger.hs b/src/EulerHS/Logger/TinyLogger.hs new file mode 100644 index 00000000..d676cfef --- /dev/null +++ b/src/EulerHS/Logger/TinyLogger.hs @@ -0,0 +1,195 @@ +{- | +Module : EulerHS.Logger.TinyLogger +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE ScopedTypeVariables #-} + +module EulerHS.Logger.TinyLogger + ( + -- * TinyLogger Implementation + -- ** Types + LoggerHandle + -- ** Methods + , sendPendingMsg + , createLogger + , createLogger' + , createVoidLogger + , disposeLogger + , withLogger + , defaultDateFormat + , defaultRenderer + , defaultBufferSize + ) where + +import Control.Concurrent (forkOn, getNumCapabilities) +import qualified Control.Concurrent.Chan.Unagi.Bounded as Chan +import qualified Data.Aeson as A +import EulerHS.Logger.Types (BufferSize, FlowFormatter, + LogLevel (Debug, Error, Info, Warning), + LoggerConfig (LoggerConfig), + MessageBuilder (MsgBuilder, MsgTransformer, SimpleBS, SimpleLBS, SimpleString, SimpleText), + PendingMsg (..), Message(..), ErrorL(..), ExceptionEntry(..), getFlowGuuid, getLogLevel, getLogContext, getMessageNumber, getErrorLogFromException) +import GHC.Conc (labelThread) +import EulerHS.Prelude +import qualified System.Logger as Log +import qualified Data.Text as Text + +type LogQueue = (Chan.InChan PendingMsg, Chan.OutChan PendingMsg) + +type Loggers = [Log.Logger] + +data LoggerHandle + = AsyncLoggerHandle [ThreadId] LogQueue Loggers + | SyncLoggerHandle Loggers + | VoidLoggerHandle + +dispatchLogLevel :: LogLevel -> Log.Level +dispatchLogLevel Debug = Log.Debug +dispatchLogLevel Info = Log.Info +dispatchLogLevel Warning = Log.Warn +dispatchLogLevel Error = Log.Error + +logPendingMsg :: FlowFormatter -> Loggers -> PendingMsg -> IO () +logPendingMsg flowFormatter loggers pendingMsg = do + formatter <- flowFormatter $ getFlowGuuid pendingMsg + let msgBuilder = formatter pendingMsg + let lvl' = dispatchLogLevel $ getLogLevel pendingMsg + let msg' = case msgBuilder of + SimpleString str -> Log.msg str + SimpleText txt -> Log.msg txt + SimpleBS bs -> Log.msg bs + SimpleLBS lbs -> Log.msg lbs + MsgBuilder bld -> Log.msg bld + MsgTransformer f -> f + mapM_ (\logger -> Log.log logger lvl' msg') loggers + +loggerWorker :: FlowFormatter -> Chan.OutChan PendingMsg -> Loggers -> IO () +loggerWorker flowFormatter outChan loggers = do + pendingMsg <- Chan.readChan outChan + res <- try $ logPendingMsg flowFormatter loggers pendingMsg + case res of + Left (err :: SomeException) -> logPendingMsg flowFormatter loggers $ makeErrorLog err pendingMsg + Right _ -> pure () + where + makeErrorLog e pMsg = + V2 + (getFlowGuuid pMsg) + Error + "ERROR" + Nothing + Nothing + (Just $ errorLog e ) + Nothing + Nothing + (Message (Just $ A.toJSON $ ((show e) :: Text) ) Nothing) + (getMessageNumber pMsg) + (getLogContext pMsg) + errorLog e = + let expEntry = getErrorLogFromException e + in ErrorL (Just $ jp_error_code expEntry) (error_code expEntry) (Text.pack $ error_message expEntry) + +sendPendingMsg :: FlowFormatter -> LoggerHandle -> PendingMsg -> IO () +sendPendingMsg _ VoidLoggerHandle = const (pure ()) +sendPendingMsg flowFormatter (SyncLoggerHandle loggers) = logPendingMsg flowFormatter loggers +sendPendingMsg _ (AsyncLoggerHandle _ (inChan, _) _) = Chan.writeChan inChan + +createVoidLogger :: IO LoggerHandle +createVoidLogger = pure VoidLoggerHandle + +createLogger :: FlowFormatter -> LoggerConfig -> IO LoggerHandle +createLogger = createLogger' defaultDateFormat defaultRenderer defaultBufferSize + +createLogger' + :: Maybe Log.DateFormat + -> Maybe Log.Renderer + -> BufferSize + -> FlowFormatter + -> LoggerConfig + -> IO LoggerHandle +createLogger' + mbDateFormat + mbRenderer + bufferSize + flowFormatter + (LoggerConfig isAsync _ logFileName isConsoleLog isFileLog maxQueueSize _ _ _) = do + + let fileSettings + = Log.setFormat mbDateFormat + $ maybe id Log.setRenderer mbRenderer + $ Log.setBufSize bufferSize + $ Log.setOutput (Log.Path logFileName) + Log.defSettings + + let consoleSettings + = Log.setFormat mbDateFormat + $ maybe id Log.setRenderer mbRenderer + $ Log.setBufSize bufferSize + $ Log.setOutput Log.StdOut + Log.defSettings + + let fileH = [Log.new fileSettings | isFileLog] + let consoleH = [Log.new consoleSettings | isConsoleLog] + let loggersH = fileH ++ consoleH + + unless (null loggersH) $ + if isAsync then putStrLn @String "Creating async loggers..." + else putStrLn @String "Creating sync loggers..." + when isFileLog $ putStrLn @String $ "Creating file logger (" +| logFileName |+ ")..." + when isConsoleLog $ putStrLn @String "Creating console logger..." + + loggers <- sequence loggersH + startLogger isAsync loggers + where + startLogger :: Bool -> Loggers -> IO LoggerHandle + startLogger _ [] = pure VoidLoggerHandle + startLogger False loggers = pure $ SyncLoggerHandle loggers + startLogger True loggers = do + caps <- getNumCapabilities + chan@(_, outChan) <- Chan.newChan (fromIntegral maxQueueSize) + threadIds <- traverse (`forkOn` (forever $ loggerWorker flowFormatter outChan loggers)) [1..caps] + mapM_ (\tid -> labelThread tid "euler-createLogger") threadIds + pure $ AsyncLoggerHandle threadIds chan loggers + +disposeLogger :: FlowFormatter -> LoggerHandle -> IO () +disposeLogger _ VoidLoggerHandle = pure () +disposeLogger _ (SyncLoggerHandle loggers) = do + putStrLn @String "Disposing sync logger..." + mapM_ Log.flush loggers + mapM_ Log.close loggers +disposeLogger flowFormatter (AsyncLoggerHandle threadIds (_, outChan) loggers) = do + putStrLn @String "Disposing async logger..." + traverse_ killThread threadIds + logRemaining outChan + mapM_ Log.flush loggers + mapM_ Log.close loggers + where + logRemaining :: Chan.OutChan 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 + :: FlowFormatter + -> LoggerConfig + -> (LoggerHandle -> IO a) + -> IO a +withLogger flowFormatter cfg = bracket (createLogger flowFormatter cfg) (disposeLogger flowFormatter) + +defaultBufferSize :: BufferSize +defaultBufferSize = 4096 + +defaultDateFormat :: Maybe Log.DateFormat +defaultDateFormat = Nothing + +defaultRenderer :: Maybe Log.Renderer +defaultRenderer = Nothing diff --git a/src/EulerHS/Logger/Types.hs b/src/EulerHS/Logger/Types.hs new file mode 100644 index 00000000..72866be9 --- /dev/null +++ b/src/EulerHS/Logger/Types.hs @@ -0,0 +1,266 @@ +{- | +Module : EulerHS.Logger.Types +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module EulerHS.Logger.Types + ( + -- * Core Logger + -- ** Types + LogLevel(..) + , BufferSize + , MessageBuilder (..) + , MessageFormatter + , FlowFormatter + , LoggerConfig(..) + , Message(..) + , Tag + , PendingMsg(..) + , ShouldLogSQL(..) + , LogEntry (..) + , Log + , LogContext + , LogCounter + , LogMaskingConfig (..) + , MaskKeyType (..) + , ExceptionEntry (..) + , VersionLoggerMessage(..) + , Action + , Category + , Entity + , Latency + , RespCode + , ErrorL(..) + , ErrorInfo(..) + -- ** defaults + , defaultLoggerConfig + , defaultMessageFormatter + , showingMessageFormatter + , defaultFlowFormatter + , builderToByteString + , getFlowGuuid + , getLogLevel + , getLogContext + , getMessageNumber + , convertToPendingMsg + , getErrorLogFromException + ) where + +import qualified EulerHS.Common as T +import EulerHS.Prelude +-- Currently, TinyLogger is highly coupled with the interface. +-- Reason: unclear current practice of logging that affects design and performance. +import qualified Data.Aeson as A +import qualified Data.Text.Lazy.Encoding as TE +import Data.Text.Lazy.Builder +import qualified Data.ByteString.Lazy as LBS +import Formatting.Buildable (Buildable(..)) +import qualified System.Logger.Message as LogMsg +import qualified Control.Exception as Exception +import qualified EulerHS.SqlDB.Types as T +import qualified EulerHS.KVDB.Types as TK +import Data.Typeable (typeOf) +import Data.Data (toConstr, Data) + +-- | Logging level. +data LogLevel = Debug | Info | Warning | Error + deriving (Generic, Eq, Ord, Show, Read, Enum, ToJSON, FromJSON) + +data LogMaskingConfig = + LogMaskingConfig + { _maskKeys :: HashSet Text -- Check : Better to make this case insensitive + , _maskText :: Maybe Text + , _keyType :: MaskKeyType + } deriving (Generic, Show, Read) + +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 + = UnsafeLogSQL_DO_NOT_USE_IN_PRODUCTION + -- | omit SQL logs + | SafelyOmitSqlLogs + deriving (Generic, Show, Read) + +type LogCounter = IORef Int -- No race condition: atomicModifyIORef' is used. + +data Message = Message + { msgMessage :: Maybe A.Value + , msgValue :: Maybe A.Value + } + deriving (Show) + +instance Buildable Message where + build = fromText . decodeUtf8 . showMessage + where + showMessage msg = case (msgMessage msg, msgValue msg) of + (Just message, _) -> A.encode message + (_, Just value) -> A.encode value + (_, _) -> "" + {-# INLINE build #-} + +type Tag = Text +type MessageNumber = Int +type BufferSize = Int +type MessageFormatter = PendingMsg -> MessageBuilder +type FlowFormatter = Maybe T.FlowGUID -> IO MessageFormatter +type LogContext = HashMap Text Text + +data LoggerConfig + = LoggerConfig + { _isAsync :: Bool + , _logLevel :: LogLevel + , _logFilePath :: FilePath + , _logToConsole :: Bool + , _logToFile :: Bool + , _maxQueueSize :: Word + , _logRawSql :: ShouldLogSQL + , _logAPI :: Bool + , _logMaskingConfig :: Maybe LogMaskingConfig + } deriving (Generic, Show, Read) + +data PendingMsg = + V1 !(Maybe T.FlowGUID) !LogLevel !Tag !Message !MessageNumber !LogContext + | V2 !(Maybe T.FlowGUID) !LogLevel !Category !(Maybe Action) !(Maybe Entity) !(Maybe ErrorL) !(Maybe Latency) !(Maybe RespCode) !Message !MessageNumber !LogContext + deriving (Show) + +type Category = Text +type Action = Text +type Entity = Text + +data ErrorInfo = ErrorInfo + { + error_code :: Text, + error_message :: Text, + error_category :: Text, + unified_error_code :: Text, + unified_error_message :: Text + } + + deriving (Show, Generic) + +instance ToJSON ErrorInfo where + toJSON = A.genericToJSON A.defaultOptions + +data ErrorL = ErrorL !(Maybe ErrCode) ErrCategory ErrReason -- kept as maybe till unifiction is done + deriving Show + +type ErrCode = Text +type ErrCategory = Text +type ErrReason = Text +type Latency = Integer +type RespCode = Int + +data LogEntry = LogEntry !LogLevel !Message +type Log = [LogEntry] + +data ExceptionEntry = ExceptionEntry + { error_code :: Text + , error_message :: String + , jp_error_code :: Text + , source :: Text + } deriving (Generic, ToJSON) + +defaultMessageFormatter :: MessageFormatter +defaultMessageFormatter (V1 _ lvl tag msg _ _) = + SimpleString $ "[" +|| lvl ||+ "] <" +| tag |+ "> " +| TE.decodeUtf8 (A.encode (msgMessage msg)) |+ "" +defaultMessageFormatter (V2 _ lvl category action _ _ _ _ msg _ _) = + SimpleString $ "[" +|| lvl ||+ "] <" +| category |+ "> <" +| action |+ "> " +| TE.decodeUtf8 (A.encode (msgMessage msg)) |+ "" + +showingMessageFormatter :: MessageFormatter +showingMessageFormatter = SimpleString . show + +defaultLoggerConfig :: LoggerConfig +defaultLoggerConfig = LoggerConfig + { _isAsync = False + , _logLevel = Debug + , _logFilePath = "" + , _logToConsole = True + , _logToFile = False + , _maxQueueSize = 1000 + , _logRawSql = SafelyOmitSqlLogs + , _logAPI = True + , _logMaskingConfig = Nothing + } + +defaultFlowFormatter :: FlowFormatter +defaultFlowFormatter _ = pure defaultMessageFormatter + +builderToByteString :: LogMsg.Builder -> LBS.ByteString +builderToByteString = LogMsg.eval + + +data VersionLoggerMessage = + Ver1 !Tag !Message + | Ver2 !Category !(Maybe Action) !(Maybe Entity) !(Maybe ErrorL) !(Maybe Latency) !(Maybe RespCode) !Message + +getFlowGuuid :: PendingMsg -> Maybe T.FlowGUID +getFlowGuuid (V1 mbFlowGuid _ _ _ _ _) = mbFlowGuid +getFlowGuuid (V2 mbFlowGuid _ _ _ _ _ _ _ _ _ _) = mbFlowGuid + +getLogLevel :: PendingMsg -> LogLevel +getLogLevel (V1 _ lvl _ _ _ _) = lvl +getLogLevel (V2 _ lvl _ _ _ _ _ _ _ _ _) = lvl + +getLogContext :: PendingMsg -> LogContext +getLogContext (V1 _ _ _ _ _ lContext) = lContext +getLogContext (V2 _ _ _ _ _ _ _ _ _ _ lContext) = lContext + +getMessageNumber :: PendingMsg -> MessageNumber +getMessageNumber (V1 _ _ _ _ msgNumber _) = msgNumber +getMessageNumber (V2 _ _ _ _ _ _ _ _ _ msgNumber _) = msgNumber + +convertToPendingMsg :: Maybe T.FlowGUID -> LogLevel -> MessageNumber -> LogContext -> VersionLoggerMessage -> PendingMsg +convertToPendingMsg mbFlowGuid logLevel msgNum lContext (Ver1 tag msg) = + V1 mbFlowGuid logLevel tag msg msgNum lContext +convertToPendingMsg mbFlowGuid logLevel msgNum lContext (Ver2 category action entity maybeEror maybeLatency maybeRespCode msg) = + V2 mbFlowGuid logLevel category action entity maybeEror maybeLatency maybeRespCode msg msgNum lContext + +deriving instance Data Exception.ArithException +deriving instance Data Exception.ArrayException +deriving instance Data Exception.AsyncException + +getErrorLogFromException :: SomeException -> ExceptionEntry +getErrorLogFromException exception = + fromMaybe (exceptionLogDefault exception) + $ exceptionLogWithConstructor <$> (fromException exception :: Maybe Exception.ArithException) + <|> exceptionLogWithConstructor <$> (fromException exception :: Maybe Exception.ArrayException) + <|> exceptionLogDefault <$> (fromException exception :: Maybe Exception.AssertionFailed) + <|> exceptionLogWithConstructor <$> (fromException exception :: Maybe Exception.AsyncException) + <|> exceptionLogDefault <$> (fromException exception :: Maybe Exception.NonTermination) + <|> exceptionLogDefault <$> (fromException exception :: Maybe Exception.NoMethodError) + <|> exceptionLogDefault <$> (fromException exception :: Maybe Exception.NestedAtomically) + <|> exceptionLogDefault <$> (fromException exception :: Maybe Exception.TypeError) + <|> exceptionLogDefault <$> (fromException exception :: Maybe Exception.BlockedIndefinitelyOnMVar) + <|> exceptionLogDefault <$> (fromException exception :: Maybe Exception.BlockedIndefinitelyOnSTM) + <|> exceptionLogDefault <$> (fromException exception :: Maybe Exception.AllocationLimitExceeded) + <|> exceptionLogDefault <$> (fromException exception :: Maybe Exception.Deadlock) + <|> exceptionLogDefault <$> (fromException exception :: Maybe Exception.PatternMatchFail) + <|> exceptionLogDefault <$> (fromException exception :: Maybe Exception.RecConError) + <|> exceptionLogDefault <$> (fromException exception :: Maybe Exception.RecSelError) + <|> exceptionLogDefault <$> (fromException exception :: Maybe Exception.RecUpdError) + <|> exceptionLogDefault <$> (fromException exception :: Maybe Exception.ErrorCall) + <|> exceptionLogWithConstructor <$> (fromException exception :: Maybe T.DBError) + <|> exceptionLogWithConstructor <$> (fromException exception :: Maybe TK.MeshError) + where + exceptionLogWithConstructor ex = ExceptionEntry (show . toConstr $ ex) (displayException ex) (show $ typeOf ex) "Exception" + exceptionLogDefault ex = ExceptionEntry (show $ typeOf ex) (displayException ex) (show $ typeOf ex) "Exception" \ No newline at end of file diff --git a/src/EulerHS/Masking.hs b/src/EulerHS/Masking.hs new file mode 100644 index 00000000..d0965b66 --- /dev/null +++ b/src/EulerHS/Masking.hs @@ -0,0 +1,142 @@ +{- | +Module : EulerHS.Masking +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable + +-} + +{-# LANGUAGE RecordWildCards #-} + +module EulerHS.Masking where + +import Data.HashSet (member) +import EulerHS.Prelude +import Data.String.Conversions hiding ((<>)) +import qualified Data.Aeson as Aeson +import qualified Data.CaseInsensitive as CI +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashSet as HS +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Text as Text +import qualified EulerHS.Extra.Regex as Regex +import qualified EulerHS.Logger.Types as Log +import qualified Network.HTTP.Types as HTTP + +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 -> Aeson.Value +parseRequestResponseBody shouldMask maskText mbContentType req + | isContentTypeBlockedForLogging mbContentType = notSupportedPlaceHolder mbContentType + | otherwise = + case Aeson.eitherDecodeStrict req of + Right value -> maskJSON shouldMask maskText mbContentType value + Left _ -> maskJSON shouldMask maskText mbContentType $ handleQueryString req + +maskJSON :: (Text -> Bool) -> Text -> Maybe ByteString -> Aeson.Value -> Aeson.Value +maskJSON shouldMask maskText mbContentType (Aeson.Object r) = Aeson.Object $ handleObject shouldMask maskText mbContentType r +maskJSON shouldMask maskText mbContentType (Aeson.Array r) = Aeson.Array $ maskJSON shouldMask maskText mbContentType <$> r +maskJSON shouldMask maskText mbContentType (Aeson.String r) = + bool (Aeson.String r) (decodeToObject) (doesContentTypeHaveNestedStringifiedJSON mbContentType) + where + decodeToObject = + case Aeson.eitherDecodeStrict $ encodeUtf8 $ r of + Right val -> + case val of + (Aeson.Object v) -> Aeson.Object $ handleObject shouldMask maskText Nothing v + (Aeson.Array _) -> maskJSON shouldMask maskText Nothing val + _ -> val + Left _ -> Aeson.String r +maskJSON _ _ _ value = value + +handleObject :: (Text -> Bool) -> Text -> Maybe ByteString -> Aeson.Object -> Aeson.Object +handleObject shouldMask maskText mbContentType = HashMap.mapWithKey maskingFn + where + maskingFn key value = bool (maskJSON shouldMask maskText mbContentType value) (Aeson.String maskText) $ shouldMask key + +handleQueryString :: ByteString -> Aeson.Value +handleQueryString strg = Aeson.Object . fmap (Aeson.String . fromMaybe "") . HashMap.fromList $ HTTP.parseQueryText strg + +notSupportedPlaceHolder :: Maybe ByteString -> Aeson.Value +notSupportedPlaceHolder (Just bs) = Aeson.String $ "Logging Not Support For this content " <> decodeUtf8 bs +notSupportedPlaceHolder Nothing = Aeson.String "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) + + +-- NOTE: This logic is added because we are sending stringified JSON as Value +doesContentTypeHaveNestedStringifiedJSON :: Maybe ByteString -> Bool +doesContentTypeHaveNestedStringifiedJSON Nothing = False +doesContentTypeHaveNestedStringifiedJSON (Just contentType) = (("application/x-www-form-urlencoded" :: ByteString) == 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) + +-- PS Implemention for masking XML [blacklisting] +maskXMLText :: Maybe (HS.HashSet Text) -> Text.Text -> Text.Text +maskXMLText (Just customMaskingKeys) xml = foldl' (\acc x -> maskXMLForTAG x $ maskXMLForAttribute x acc) xml customMaskingKeys +maskXMLText Nothing xml = foldl' (\acc x -> maskXMLForTAG x $ maskXMLForAttribute x acc) xml defaultMaskingKeys + +maskXMLForAttribute :: Text.Text -> Text.Text -> Text.Text +maskXMLForAttribute key xmlToMask = + case (Regex.regex ("(" <> key <> ")=\"[^>]*(\")" :: Text.Text)) of + Left _ -> "[HIDDEN]" -- "ISSUE WITH REGEX" + Right cRegex -> Regex.replace cRegex (((toSBSFromText key) <> "=\"FILTERED\"") :: SBS) xmlToMask + +maskXMLForTAG :: Text.Text -> Text.Text -> Text.Text +maskXMLForTAG key xmlToMask = + case (Regex.regex ("<(" <> key <> ")>[^ key <> ")>" :: Text.Text)) of + Left _ -> "[HIDDEN]" -- "ISSUE WITH REGEX" + Right cRegex -> Regex.replace cRegex (("<" <> (toSBSFromText key) <> ">FILTERED (toSBSFromText key) <> ">") :: SBS) xmlToMask + +toSBSFromText :: Text.Text -> ByteString +toSBSFromText = encodeUtf8 + +-- This is taken from euler-ps +defaultMaskingKeys :: HS.HashSet Text +defaultMaskingKeys = HS.fromList [] \ No newline at end of file diff --git a/src/EulerHS/Options.hs b/src/EulerHS/Options.hs new file mode 100644 index 00000000..2de3cc31 --- /dev/null +++ b/src/EulerHS/Options.hs @@ -0,0 +1,35 @@ +{- | +Module : EulerHS.Options +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable + +This module contains the definition of the `OptionEntity` typeclass. +OptionEntity is a typeclass that is used to define the relationship between +the key and value of an option. +-} + +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module EulerHS.Options + ( + -- * Options + -- | Determine the relationship between key & value + OptionEntity + -- * Make option key + , mkOptionKey + ) where + +import Data.Aeson (encode) +import qualified Data.ByteString.Lazy as BSL +import EulerHS.Prelude +import Type.Reflection (typeRep) + +class (Typeable k, ToJSON k) + => OptionEntity k v | k -> v + +mkOptionKey :: forall k v. OptionEntity k v => k -> Text +mkOptionKey k = show (typeRep @k) <> decodeUtf8 (BSL.toStrict $ encode k) diff --git a/src/EulerHS/PIIEncryption.hs b/src/EulerHS/PIIEncryption.hs new file mode 100644 index 00000000..906af9ec --- /dev/null +++ b/src/EulerHS/PIIEncryption.hs @@ -0,0 +1,112 @@ +{- | +Module : EulerHS.PIIEncryption +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable + +This module contains the PII Encryption/Decryption related types and classes. +PII class is used for encrypting and decrypting rows for DB. Instance will be defined for each table in storage files. + +-} + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# OPTIONS_GHC -Wno-error=unused-top-binds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveAnyClass #-} + +module EulerHS.PIIEncryption + ( PII(..), + PIIUpdate(..), + PIIEncryptionDEK(..), + PIIDecryptionDEKs(..), + PIIMetadata(..), + getEncryptionKey, + makePIIMetadata, + PIIEnabledMerchantAndTables (..), + PIIEncryptionKeyId(..), + PIIEncryptionKey(..), + JuspayPIIKeyConfig(..) + ) +where + +import Data.HashMap.Strict as HM +import EulerHS.Prelude +import EulerHS.SqlDB.Types (DBError(..), DBErrorType(PIIError)) +import Sequelize (Set) +import qualified Data.HashSet as HashSet +import qualified EulerHS.Framework.Language as L +import qualified EulerHS.Options as T + +-- PII class is used for encrypting and decrypting rows for DB. Instance will be defined for each table in storage files. +class PII (table :: (Type -> Type) -> Type) where + encryptRow :: forall m. (L.MonadFlow m) => table Identity -> PIIEncryptionKeyId -> PIIEncryptionKey -> m (Either Text (table Identity)) + decryptRow :: forall m. (L.MonadFlow m) => table Identity -> Maybe (HM.HashMap Text Text) -> m (Either Text (table Identity)) + setPrimaryKey :: table Identity -> table Identity -> table Identity + +-- PIIUpdate class is used for encrypting column values present in setClause. +class PII table => PIIUpdate (be :: Type) table where + transformSetClause :: forall m. (L.MonadFlow m) => [Set be table] -> PIIEncryptionKeyId -> PIIEncryptionKey -> m (Either Text [Set be table]) + +data PIIMetadata = PIIMetadata + { keyID :: Maybe Text + , kvTag :: Text + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +newtype PIIEncryptionKeyId = PIIEncryptionKeyId + { encKeyId :: Text + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +newtype PIIEncryptionKey = PIIEncryptionKey + { encKey :: Text + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +data PIIEncryptionDEK = PIIEncryptionDEK + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +instance T.OptionEntity PIIEncryptionDEK (PIIEncryptionKeyId, PIIEncryptionKey) + +data PIIDecryptionDEKs = PIIDecryptionDEKs + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +instance T.OptionEntity PIIDecryptionDEKs (HM.HashMap Text Text) + +data PIIEnabledMerchantAndTables = PIIEnabledMerchantAndTables + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) +instance T.OptionEntity PIIEnabledMerchantAndTables (Bool, (HashSet.HashSet Text)) + +data JuspayPIIKeyConfig = JuspayPIIKeyConfig + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) +instance T.OptionEntity JuspayPIIKeyConfig [(PIIEncryptionKeyId, PIIEncryptionKey, Bool)] + +makePIIMetadata :: (Maybe Text) -> Text -> PIIMetadata +makePIIMetadata mbKID tg = PIIMetadata + { keyID = mbKID + , kvTag = tg + } + +getEncryptionKey :: (L.MonadFlow m) => Text -> m (Either DBError (Maybe (PIIEncryptionKeyId, PIIEncryptionKey))) -- need here as we have to sent to kv part +getEncryptionKey tName = do + piiEnable <- L.getOptionLocal PIIEnabledMerchantAndTables + case piiEnable of + Just (isMerchantEnabled, enabledPIITables) -> + if isMerchantEnabled && (HashSet.member tName enabledPIITables) + then do + mbKeyConfig <- L.getOptionLocal PIIEncryptionDEK + case mbKeyConfig of + Nothing -> return $ Left $ DBError PIIError "options not set correctly" + val -> return $ Right $ val + else return $ Right Nothing + Nothing -> return $ Right Nothing diff --git a/src/EulerHS/Prelude.hs b/src/EulerHS/Prelude.hs index 6cc862e9..e881fde0 100644 --- a/src/EulerHS/Prelude.hs +++ b/src/EulerHS/Prelude.hs @@ -1,5 +1,3 @@ -{-# OPTIONS -fno-warn-orphans #-} - {- | Module : EulerHS.Prelude Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 @@ -7,25 +5,18 @@ 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. -} +{-# OPTIONS -fno-warn-orphans #-} + module EulerHS.Prelude - -- TODO: This entire export lists needs to be explicit ( module X , liftFC , catchAny - -- JSON - , stripLensPrefixOptions - , stripAllLensPrefixOptions - , jsonSetField - , encodeJSON - , decodeJSON ) where import Control.Concurrent as X (ThreadId, forkIO, killThread, @@ -40,42 +31,24 @@ import Control.Concurrent.STM.TMVar as X (TMVar, newEmptyTMVar, readTMVar, takeTMVar, tryReadTMVar) import Control.Concurrent.STM.TVar as X (modifyTVar) -import Control.Exception as X (SomeException (..)) -import Control.Lens as X (at, (.=)) -import Control.Lens.TH as X (makeFieldsNoPrefix, makeLenses) -import Control.Monad as X (liftM, unless, void, when) import Control.Monad.Free as X (Free (..), foldFree, liftF) import Control.Monad.Free.Church as X (F (..), foldF, fromF, iter, iterM, retract) +import qualified Control.Monad.Free.Church as CF +import qualified Control.Monad.Free.Class as MF import Control.Newtype.Generics as X (Newtype, O, pack, unpack) import Data.Aeson as X (FromJSON, FromJSONKey, ToJSON, ToJSONKey, genericParseJSON, genericToJSON, parseJSON, toJSON) -import Data.Function as X ((&)) import Data.Kind as X (Type) -import Data.Maybe as X (fromJust, fromMaybe) import Data.Serialize as X (Serialize) import Fmt as X ((+|), (+||), (|+), (||+)) import GHC.Base as X (until) -import GHC.Generics as X (Generic) -import Text.Read as X (read, readsPrec) - --- includes Data.IORef -import Universum as X hiding (All, Option, Set, Type, head, init, - last, set, tail, trace, catchAny) import Universum (catchAny) -import Universum.Functor.Fmap as X ((<<$>>)) -import Universum.Unsafe as X (head, init, last, tail, (!!)) - -import EulerHS.Extra.Aeson ( - stripLensPrefixOptions, stripAllLensPrefixOptions, jsonSetField, encodeJSON, decodeJSON) - -import qualified Control.Monad.Free.Church as CF -import qualified Control.Monad.Free.Class as MF - - - +import Universum as X hiding (All, Option, Set, Type, catchAny, head, + init, last, set, tail, trace) +import EulerHS.Extra.Orphans() -- Lift for Church encoded Free liftFC :: (Functor f, MF.MonadFree f m) => f a -> m a -liftFC = CF.liftF \ No newline at end of file +liftFC = CF.liftF diff --git a/src/EulerHS/PubSub/Interpreter.hs b/src/EulerHS/PubSub/Interpreter.hs new file mode 100644 index 00000000..f1810bbc --- /dev/null +++ b/src/EulerHS/PubSub/Interpreter.hs @@ -0,0 +1,46 @@ +{- | +Module : EulerHS.PubSub.Interpreter +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +module EulerHS.PubSub.Interpreter + ( + interpretPubSubF, + runPubSub + ) where + +import Data.Coerce (coerce) +import qualified Database.Redis as R +import EulerHS.Prelude +import EulerHS.PubSub.Language (Channel (Channel), + ChannelPattern (ChannelPattern), + Payload (Payload), PubSub, + PubSubF (PSubscribe, Publish, Subscribe)) +import qualified EulerHS.Types as T + +interpretPubSubF + :: R.PubSubController + -> R.Connection + -> PubSubF a + -> IO a +interpretPubSubF pubSubController conn = \case + Publish ch pl next -> + fmap (next . first T.hedisReplyToKVDBReply) . + R.runRedis conn . + R.publish (coerce ch) . + coerce $ pl + Subscribe chs cb next -> + fmap next . + R.addChannelsAndWait pubSubController (zip (coerce chs) . repeat $ cb) $ [] + PSubscribe patts cb next -> + fmap next . + R.addChannelsAndWait pubSubController [] . + zip (coerce patts) . + repeat $ cb + +runPubSub :: R.PubSubController -> R.Connection -> PubSub a -> IO a +runPubSub pubSubController conn = foldF (interpretPubSubF pubSubController conn) diff --git a/src/EulerHS/PubSub/Language.hs b/src/EulerHS/PubSub/Language.hs new file mode 100644 index 00000000..11bc0e87 --- /dev/null +++ b/src/EulerHS/PubSub/Language.hs @@ -0,0 +1,35 @@ +{- | +Module : EulerHS.PubSub.Language +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +module EulerHS.PubSub.Language where + +import qualified Database.Redis as R +import EulerHS.KVDB.Types (KVDBReply) +import EulerHS.Prelude + +newtype Channel = Channel ByteString +newtype ChannelPattern = ChannelPattern ByteString +newtype Payload = Payload ByteString + +data PubSubF next + = Publish Channel Payload (Either KVDBReply Integer -> next) + | Subscribe [Channel ] R.MessageCallback (IO () -> next) + | PSubscribe [ChannelPattern] R.PMessageCallback (IO () -> next) + deriving Functor + +type PubSub = F PubSubF + +publish :: Channel -> Payload -> PubSub (Either KVDBReply Integer) +publish channel payload = liftFC $ Publish channel payload id + +subscribe :: [Channel] -> R.MessageCallback -> PubSub (IO ()) +subscribe channels cb = liftFC $ Subscribe channels cb id + +psubscribe :: [ChannelPattern] -> R.PMessageCallback -> PubSub (IO ()) +psubscribe channels cb = liftFC $ PSubscribe channels cb id diff --git a/src/EulerHS/Runtime.hs b/src/EulerHS/Runtime.hs index f4484767..9ee05e45 100644 --- a/src/EulerHS/Runtime.hs +++ b/src/EulerHS/Runtime.hs @@ -5,37 +5,29 @@ 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 -import EulerHS.Core.Runtime as X import EulerHS.Framework.Runtime as X +import EulerHS.Logger.Runtime as X diff --git a/src/EulerHS/SqlDB/Interpreter.hs b/src/EulerHS/SqlDB/Interpreter.hs new file mode 100644 index 00000000..f2a97e7b --- /dev/null +++ b/src/EulerHS/SqlDB/Interpreter.hs @@ -0,0 +1,35 @@ +{- | +Module : EulerHS.SqlDB.Interpreter +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +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 `SqlDB` scenarios. +Import this module qualified as `SqlDB`. +-} + +module EulerHS.SqlDB.Interpreter + ( + -- * SQL DB Interpreter + runSqlDB + ) where + +import Control.Exception (throwIO) +import EulerHS.Prelude +import EulerHS.SqlDB.Language (SqlDB, + SqlDBMethodF (SqlDBMethod, SqlThrowException)) +import qualified EulerHS.SqlDB.Types as T + +interpretSqlDBMethod + :: T.NativeSqlConn + -> (Text -> IO ()) + -> SqlDBMethodF beM a + -> IO a +interpretSqlDBMethod conn logger = \case + SqlDBMethod runner next -> next <$> runner conn logger + SqlThrowException ex next -> next <$> throwIO ex + +runSqlDB :: T.NativeSqlConn -> (Text -> IO ()) -> SqlDB beM a -> IO a +runSqlDB sqlConn logger = foldF (interpretSqlDBMethod sqlConn logger) diff --git a/src/EulerHS/SqlDB/Language.hs b/src/EulerHS/SqlDB/Language.hs new file mode 100644 index 00000000..a4c403ac --- /dev/null +++ b/src/EulerHS/SqlDB/Language.hs @@ -0,0 +1,147 @@ +{- | +Module : EulerHS.SqlDB.Language +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable + +-} + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module EulerHS.SqlDB.Language + ( + -- * SQLDB language + -- ** Types + SqlDB + , SqlDBMethodF(..) + -- ** Methods + , findRow + , findRows + , countRows + , insertRows + , insertRowsReturningList + , updateRows + , updateRowsReturningList + , deleteRows + , deleteRowsReturningList + , deleteRowsReturningListPG + , updateRowsReturningListPG + , insertRowReturningMySQL + , sqlThrowException -- for tests + ) where + +import qualified Database.Beam as B +import qualified Database.Beam.MySQL as BM +import qualified Database.Beam.Postgres as BP +import EulerHS.Prelude +import qualified EulerHS.SqlDB.Types as T + +type SqlDB beM = F (SqlDBMethodF beM) + +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) + +sqlDBMethod + :: (HasCallStack, T.BeamRunner beM) + => beM a + -> SqlDB beM a +sqlDBMethod act = liftFC $ SqlDBMethod (`T.getBeamDebugRunner` act) id + +-- For testing purpose +sqlThrowException :: forall a e beM . (HasCallStack, Exception e) => e -> SqlDB beM a +sqlThrowException ex = liftFC $ SqlThrowException ex id + +-- Convenience interface + +-- | 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 +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 + +countRows + :: (HasCallStack, T.BeamRunner beM, T.BeamRuntime be beM, B.FromBackendRow be Int) + => B.SqlSelect be Int + -> SqlDB beM Int +countRows = (fromMaybe 0 <$>) . sqlDBMethod . T.rtSelectReturningOne + +-- | Insert +insertRows + :: (HasCallStack, T.BeamRunner beM, T.BeamRuntime be beM) + => B.SqlInsert be table + -> SqlDB beM () +insertRows = sqlDBMethod . T.rtInsert + +-- | 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 +updateRows + :: (HasCallStack, T.BeamRunner beM, T.BeamRuntime be beM) + => B.SqlUpdate be table + -> SqlDB beM () +updateRows = sqlDBMethod . T.rtUpdate + +-- | Update returning list +updateRowsReturningList + :: (HasCallStack, T.BeamRunner beM, T.BeamRuntime be beM, + B.Beamable table, B.FromBackendRow be (table Identity)) + => B.SqlUpdate be table + -> SqlDB beM [table Identity] +updateRowsReturningList = sqlDBMethod . T.rtUpdateReturningList + +-- | Delete +deleteRows + :: (HasCallStack, T.BeamRunner beM, T.BeamRuntime be beM) + => B.SqlDelete be table + -> SqlDB beM () +deleteRows = sqlDBMethod . T.rtDelete + + +deleteRowsReturningList + :: (HasCallStack, T.BeamRunner beM, T.BeamRuntime be beM, + B.Beamable table, B.FromBackendRow be (table Identity)) + => B.SqlDelete be table + -> SqlDB beM [table Identity] +deleteRowsReturningList = sqlDBMethod . T.rtDeleteReturningList + + +-- Postgres only extra methods + +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 + +updateRowsReturningListPG + :: (HasCallStack, B.Beamable table, B.FromBackendRow BP.Postgres (table Identity)) + => B.SqlUpdate BP.Postgres table + -> SqlDB BP.Pg [table Identity] +updateRowsReturningListPG = sqlDBMethod . T.updateReturningListPG + +insertRowReturningMySQL :: (HasCallStack, B.FromBackendRow BM.MySQL (table Identity)) + => B.SqlInsert BM.MySQL table + -> SqlDB BM.MySQLM (Maybe (table Identity)) +insertRowReturningMySQL = + sqlDBMethod . BM.runInsertRowReturning diff --git a/src/EulerHS/SqlDB/MySQL.hs b/src/EulerHS/SqlDB/MySQL.hs new file mode 100644 index 00000000..3182add8 --- /dev/null +++ b/src/EulerHS/SqlDB/MySQL.hs @@ -0,0 +1,160 @@ +{- | +Module : EulerHS.SqlDB.MySQL +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} + +module EulerHS.SqlDB.MySQL + ( + -- * Core MySQL + -- ** Types + MySQLConfig(..) + , MySqlOption(..) + , MySQLCharset(..) + -- ** Methods + , createMySQLConn + , closeMySQLConn + -- ** Defaults + , defaultMySQLConfig + ) where + +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 + +data MySqlProtocol + = TCP + | Socket + | Pipe + | Memory + deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) + deriving anyclass (ToJSON, FromJSON) + +data MySqlOption + = ConnectTimeout Word + | Compress + | NamedPipe + | ReadDefaultFile FilePath + | CharsetDir FilePath + | CharsetName String + | LocalInFile Bool + | Protocol MySqlProtocol + | ReadTimeout Word + | WriteTimeout Word + | SecureAuth Bool + | ReportDataTruncation Bool + | Reconnect Bool + | FoundRows + | IgnoreSIGPIPE + | IgnoreSpace + | Interactive + | LocalFiles + | MultiResults + | MultiStatements + | NoSchema + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (ToJSON, FromJSON) + +data SSLInfo = SSLInfo + { sslKey :: FilePath + , sslCert :: FilePath + , sslCA :: FilePath + , sslCAPath :: FilePath + , sslCiphers :: String + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (ToJSON, FromJSON) + +-- | 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 + , connectUser :: String + , connectPassword :: String + , connectDatabase :: String + , connectOptions :: [MySqlOption] + , connectPath :: FilePath + , connectSSL :: Maybe SSLInfo + , connectCharset :: !MySQLCharset -- ^ @since 2.0.3.0 + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (ToJSON, FromJSON) + +-- | @since 2.0.3.0 +defaultMySQLConfig :: MySQLConfig +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 = 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/SqlDB/Postgres.hs b/src/EulerHS/SqlDB/Postgres.hs new file mode 100644 index 00000000..37b37389 --- /dev/null +++ b/src/EulerHS/SqlDB/Postgres.hs @@ -0,0 +1,45 @@ +{- | +Module : EulerHS.SqlDB.Postgres +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable +-} + +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE RecordWildCards #-} + +module EulerHS.SqlDB.Postgres + ( + -- * Core Postgres + -- ** Types + PostgresConfig(..) + -- ** Methods + , createPostgresConn + , closePostgresConn + ) where + +import qualified Database.Beam.Postgres as BP +import EulerHS.Prelude + +data PostgresConfig = PostgresConfig + { connectHost :: String + , connectPort :: Word16 + , connectUser :: String + , connectPassword :: String + , connectDatabase :: String + } deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) + +-- | Transform PostgresConfig to the Postgres ConnectInfo. +toBeamPostgresConnectInfo :: PostgresConfig -> BP.ConnectInfo +toBeamPostgresConnectInfo PostgresConfig {..} = BP.ConnectInfo {..} + +-- | Connect with the given config to the database. +createPostgresConn :: PostgresConfig -> IO BP.Connection +createPostgresConn = BP.connect . toBeamPostgresConnectInfo + +-- | Close the given connection. +closePostgresConn :: BP.Connection -> IO () +closePostgresConn = BP.close + diff --git a/src/EulerHS/SqlDB/Types.hs b/src/EulerHS/SqlDB/Types.hs new file mode 100644 index 00000000..8f0d805a --- /dev/null +++ b/src/EulerHS/SqlDB/Types.hs @@ -0,0 +1,455 @@ +{- | +Module : EulerHS.SqlDB.Types +Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 +License : Apache 2.0 (see the file LICENSE) +Maintainer : opensource@juspay.in +Stability : experimental +Portability : non-portable + +This module contains types and functions for working with SQL databases. + +-} + +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module EulerHS.SqlDB.Types + ( + -- * Core DB + -- ** Types + BeamRuntime(..) + , deleteReturningListPG + , updateReturningListPG + , BeamRunner(..) + , NativeSqlPool(..) + , NativeSqlConn(..) + , ConnTag + , SQliteDBname + , SqlConn(..) + , DBConfig(..) -- NOTE: Ensure this is not exported publically. - Koz + , PoolConfig(..) + , DBErrorType(..) + , DBError(..) + , DBResult + -- ** Methods + , bemToNative + , nativeToBem + , mkSqlConn + , mkSQLiteConfig + , mkSQLitePoolConfig + , mkPostgresConfig + , mkPostgresPoolConfig + , mkMySQLConfig + , mkMySQLPoolConfig + , getDBName + -- ** Helpers + , withTransaction + , mysqlErrorToDbError + , sqliteErrorToDbError + , postgresErrorToDbError + , PostgresSqlError(..) + , PostgresExecStatus(..) + , MysqlSqlError(..) + , SqliteSqlError(..) + , SqliteError(..) + , SQLError(..) + ) where + +import Data.Data (Data) +import qualified Data.Pool as DP +import Data.Time.Clock (NominalDiffTime) +import qualified Database.Beam as B +import qualified Database.Beam.Backend.SQL as B +import qualified Database.Beam.Backend.SQL.BeamExtensions 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 Database.Beam.Sqlite.Connection as SQLite +import qualified Database.MySQL.Base as MySQL +import qualified Database.PostgreSQL.Simple as PGS +import qualified Database.SQLite.Simple as SQLite +import EulerHS.Prelude +import EulerHS.SqlDB.MySQL (MySQLConfig (..), createMySQLConn) +import EulerHS.SqlDB.Postgres (PostgresConfig (..), + createPostgresConn) + +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 () + rtDeleteReturningList :: forall table. (B.Beamable table, B.FromBackendRow be (table Identity)) => B.SqlDelete be table -> beM [table Identity] + +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 + rtDeleteReturningList = error "Not implemented" + +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 + rtDeleteReturningList = deleteReturningListPG + +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 + rtDeleteReturningList = error "Not implemented" + +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 = tryAny $ case conn of + 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 a + go hof wrap conn' = 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 + deriving stock (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 = \case + PostgresPool _ pool -> NativePGPool pool + MySQLPool _ pool -> NativeMySQLPool pool + SQLitePool _ pool -> NativeSQLitePool pool + +-- | Create 'SqlConn' from 'DBConfig' +mkSqlConn :: DBConfig beM -> IO (SqlConn beM) +mkSqlConn = \case + PostgresPoolConf connTag cfg PoolConfig {..} -> PostgresPool connTag + <$> DP.createPool (createPostgresConn cfg) BP.close stripes keepAlive resourcesPerStripe + MySQLPoolConf connTag cfg PoolConfig {..} -> MySQLPool connTag + <$> DP.createPool (createMySQLConn cfg) MySQL.close stripes keepAlive resourcesPerStripe + SQLitePoolConf connTag dbname PoolConfig {..} -> SQLitePool connTag + <$> DP.createPool (SQLite.open dbname) SQLite.close stripes keepAlive resourcesPerStripe + +-- | Tag for SQL connections +type ConnTag = Text + +-- | Represents path to the SQLite DB +type SQliteDBname = String + +-- | Represents SQL connection that we use in flow. +-- Parametrised by BEAM monad corresponding to the certain DB (MySQL, Postgres, SQLite) +data SqlConn (beM :: Type -> Type) + = PostgresPool ConnTag (DP.Pool BP.Connection) + -- ^ 'Pool' with Postgres connections + | MySQLPool ConnTag (DP.Pool MySQL.MySQLConn) + -- ^ 'Pool' with MySQL connections + | SQLitePool ConnTag (DP.Pool SQLite.Connection) + -- ^ 'Pool' with SQLite connections + deriving stock (Generic) + +-- | Represents DB configurations +data DBConfig (beM :: Type -> Type) + = PostgresPoolConf ConnTag PostgresConfig PoolConfig + -- ^ config for 'Pool' with Postgres connections + | MySQLPoolConf ConnTag MySQLConfig PoolConfig + -- ^ config for 'Pool' with MySQL connections + | SQLitePoolConf ConnTag SQliteDBname PoolConfig + -- ^ config for 'Pool' with SQlite connections + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (ToJSON, FromJSON) + +-- | Represents 'Pool' parameters +data PoolConfig = PoolConfig + { stripes :: Int + -- ^ a number of sub-pools + , keepAlive :: NominalDiffTime + -- ^ the amount of time the connection will be stored + , resourcesPerStripe :: Int + -- ^ maximum number of connections to be stored in each sub-pool + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (ToJSON, FromJSON) + +defaultPoolConfig :: PoolConfig +defaultPoolConfig = PoolConfig + { stripes = 1 + , keepAlive = 100 + , resourcesPerStripe = 1 + } + +-- | Create SQLite 'DBConfig' +mkSQLiteConfig :: ConnTag -> SQliteDBname -> DBConfig BS.SqliteM +mkSQLiteConfig connTag dbName = SQLitePoolConf connTag dbName defaultPoolConfig + +-- | Create SQLite 'Pool' 'DBConfig' +mkSQLitePoolConfig :: ConnTag -> SQliteDBname -> PoolConfig -> DBConfig BS.SqliteM +mkSQLitePoolConfig = SQLitePoolConf + +-- | Create Postgres 'DBConfig' +mkPostgresConfig :: ConnTag -> PostgresConfig -> DBConfig BP.Pg +mkPostgresConfig connTag dbName = PostgresPoolConf connTag dbName defaultPoolConfig + +-- | Create Postgres 'Pool' 'DBConfig' +mkPostgresPoolConfig :: ConnTag -> PostgresConfig -> PoolConfig -> DBConfig BP.Pg +mkPostgresPoolConfig = PostgresPoolConf + +-- | Create MySQL 'DBConfig' +mkMySQLConfig :: ConnTag -> MySQLConfig -> DBConfig BM.MySQLM +mkMySQLConfig connTag dbName = MySQLPoolConf connTag dbName defaultPoolConfig + +-- | Create MySQL 'Pool' 'DBConfig' +mkMySQLPoolConfig :: ConnTag -> MySQLConfig -> PoolConfig -> DBConfig BM.MySQLM +mkMySQLPoolConfig = MySQLPoolConf + +getDBName :: DBConfig beM -> String +getDBName = \case + PostgresPoolConf _ PostgresConfig{..} _ -> connectDatabase + MySQLPoolConf _ MySQLConfig{..} _ -> connectDatabase + SQLitePoolConf _ dbName _ -> dbName + +data SqliteError + = SqliteErrorOK + | SqliteErrorError + | SqliteErrorInternal + | SqliteErrorPermission + | SqliteErrorAbort + | SqliteErrorBusy + | SqliteErrorLocked + | SqliteErrorNoMemory + | SqliteErrorReadOnly + | SqliteErrorInterrupt + | SqliteErrorIO + | SqliteErrorCorrupt + | SqliteErrorNotFound + | SqliteErrorFull + | SqliteErrorCantOpen + | SqliteErrorProtocol + | SqliteErrorEmpty + | SqliteErrorSchema + | SqliteErrorTooBig + | SqliteErrorConstraint + | SqliteErrorMismatch + | SqliteErrorMisuse + | SqliteErrorNoLargeFileSupport + | SqliteErrorAuthorization + | SqliteErrorFormat + | SqliteErrorRange + | SqliteErrorNotADatabase + | SqliteErrorNotice + | SqliteErrorWarning + | SqliteErrorRow + | SqliteErrorDone + deriving stock (Show, Eq, Ord, Generic, Data) + deriving anyclass (ToJSON, FromJSON) + +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 +toSqliteError _ = SqliteErrorError + +data SqliteSqlError + = SqliteSqlError + { sqlError :: !SqliteError + , sqlErrorDetails :: Text + , sqlErrorContext :: Text + } + deriving stock (Show, Eq, Ord, Generic, Data) + deriving anyclass (ToJSON, FromJSON) + +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 + | MysqlError MysqlSqlError + | SqliteError SqliteSqlError + deriving stock (Show, Eq, Ord, Generic, Data) + deriving anyclass (ToJSON, FromJSON) + +data MysqlSqlError = + MysqlSqlError + { errCode :: {-# UNPACK #-} !Word16, + errMsg :: {-# UNPACK #-} !Text + } + deriving stock (Show, Eq, Ord, Generic, Data) + 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 + +data PostgresExecStatus + = PostgresEmptyQuery + | PostgresCommandOk + | PostgresTuplesOk + | PostgresCopyOut + | PostgresCopyIn + | PostgresCopyBoth + | PostgresBadResponse + | PostgresNonfatalError + | PostgresFatalError + | PostgresSingleTuple + deriving stock (Show, Eq, Ord, Generic, Data) + deriving anyclass (ToJSON, FromJSON) + +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 + , sqlExecStatus :: PostgresExecStatus + , sqlErrorMsg :: Text + , sqlErrorDetail :: Text + , sqlErrorHint :: Text + } + deriving stock (Show, Eq, Ord, Generic, Data) + deriving anyclass (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 failures that may occur while working with the database +data DBErrorType + = ConnectionFailed + | ConnectionAlreadyExists + | ConnectionDoesNotExist + | TransactionRollbacked + | SQLError SQLError + | UnexpectedResult + | UnrecognizedError + | PIIError + deriving stock (Show, Eq, Ord, Generic, Data) + deriving anyclass (ToJSON, FromJSON) + +-- | Represents DB error +data DBError + = DBError DBErrorType Text + deriving stock (Show, Eq, Ord, Generic, Data) + deriving anyclass (ToJSON, FromJSON, Exception) + +-- | Represents resulting type for DB actions +type DBResult a = Either DBError a + +-- | Transforms 'NativeSqlPool' to 'SqlConn' +nativeToBem :: ConnTag -> NativeSqlPool -> SqlConn beM +nativeToBem connTag = \case + NativePGPool conn -> PostgresPool connTag conn + NativeMySQLPool conn -> MySQLPool connTag conn + NativeSQLitePool conn -> SQLitePool connTag conn \ No newline at end of file diff --git a/src/EulerHS/Types.hs b/src/EulerHS/Types.hs index ffe286c3..ef73b7bf 100644 --- a/src/EulerHS/Types.hs +++ b/src/EulerHS/Types.hs @@ -1,3 +1,4 @@ + {- | Module : EulerHS.Types Copyright : (C) Juspay Technologies Pvt Ltd 2019-2022 @@ -5,18 +6,12 @@ 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 @@ -31,9 +26,38 @@ mySQLDevConfig = T.'mkMySQLPoolConfig' "MySQL dev DB" cfg poolCfg @ -} +{-# LANGUAGE DeriveAnyClass #-} + module EulerHS.Types - ( module X + ( module X, + HttpManagerNotFound(..), + AwaitingError(..), + Operation(..) ) where - - -import EulerHS.Core.Types as X +import EulerHS.Prelude +import EulerHS.Api as X +import EulerHS.BinaryString as X +import EulerHS.Common as X +import EulerHS.HttpAPI as X +import EulerHS.KVDB.Types as X +import EulerHS.Logger.Types as X +import EulerHS.Masking as X +import EulerHS.Options as X +import EulerHS.SqlDB.MySQL as X +import EulerHS.SqlDB.Postgres as X +import EulerHS.SqlDB.Types as X hiding (withTransaction) + +data Operation + = CREATE + | CREATE_RETURNING + | UPDATE + | UPDATE_RETURNING + | UPDATE_ALL + | UPDATE_ALL_RETURNING + | FIND + | FIND_ALL + | FIND_ALL_WITH_OPTIONS + | DELETE_ONE + | DELETE_ONE_RETURNING + | DELETE_ALL_RETURNING + deriving (Generic, Show, Eq, ToJSON,FromJSON,Hashable,FromJSONKey,ToJSONKey) \ No newline at end of file diff --git a/test/EulerHS/TestData/test.db.template b/test/EulerHS/TestData/test.db.template deleted file mode 100644 index 17603a5a..00000000 Binary files a/test/EulerHS/TestData/test.db.template and /dev/null differ diff --git a/test/EulerHS/Testing/CommonLog.hs b/test/EulerHS/Testing/CommonLog.hs deleted file mode 100644 index 928baa70..00000000 --- a/test/EulerHS/Testing/CommonLog.hs +++ /dev/null @@ -1,90 +0,0 @@ -module EulerHS.Testing.CommonLog where - -import EulerHS.Prelude -import EulerHS.Testing.HSLog (HSLog (..)) -import qualified EulerHS.Testing.HSLog as HSLog -import EulerHS.Testing.PSLog (PSLog (..)) -import qualified EulerHS.Testing.PSLog as PSLog - -data CommonLog - = CMLog - | CMIO - | CMRunDB - | CMGetDBConn - | CMGetKVDBConn - | CMFork - | CMSysCmd - | CMKVDB - | CMException - | CMSetOpt - | CMGetOpt - | CMGenGuid - | CMCallApi - deriving (Eq, Ord, Show) - -isLog :: CommonLog -> Bool -isLog = \case - CMLog -> True - _ -> False - -fromHSLog :: HSLog.HSLog -> Maybe CommonLog -fromHSLog = \case - SetEntry -> Just CMKVDB - SetExEntry -> Just CMKVDB - GetEntry -> Just CMKVDB - ExistsEntry -> Just CMKVDB - DelEntry -> Just CMKVDB - ExpireEntry -> Just CMKVDB - IncrEntry -> Just CMKVDB - HSetEntry -> Just CMKVDB - HGetEntry -> Just CMKVDB - MultiExecEntry -> Nothing - HSLog.ThrowExceptionEntry -> Just CMException - CallServantApiEntry -> Just CMCallApi - HSLog.SetOptionEntry -> Just CMSetOpt - HSLog.GetOptionEntry -> Just CMGetOpt - HSLog.RunSysCmdEntry -> Just CMSysCmd - ForkEntry -> Just CMFork - GeneratedGUIDEntry -> Just CMGenGuid - RunIOEntry -> Just CMIO - InitSqlDBConnectionEntry -> Nothing - DeInitSqlDBConnectionEntry -> Nothing - GetSqlDBConnectionEntry -> Just CMGetDBConn - HSLog.RunDBEntry -> Just CMRunDB - GetKVDBConnectionEntry -> Just CMGetKVDBConn - AwaitEntry -> Nothing - RunSafeFlowEntry -> Nothing - LogMessageEntry -> Just CMLog - -fromPSLog :: PSLog.PSLog -> Maybe CommonLog -fromPSLog = \case - LogEntry -> Just CMLog - PSLog.RunDBEntry -> Just CMRunDB - RunKVDBEitherEntry -> Just CMKVDB - DoAffEntry -> Just CMIO - PSLog.SetOptionEntry -> Just CMSetOpt - PSLog.GetOptionEntry -> Just CMGetOpt - GenerateGUIDEntry -> Just CMGenGuid - CallAPIEntry -> Just CMCallApi - ForkFlowEntry -> Just CMFork - PSLog.ThrowExceptionEntry -> Just CMException - PSLog.RunSysCmdEntry -> Just CMSysCmd - GetDBConnEntry -> Just CMGetDBConn - GetKVDBConnEntry -> Just CMGetKVDBConn - RunKVDBSimpleEntry -> Just CMKVDB - UnexpectedRecordingEnd -> Nothing - UnknownRRItem -> Nothing - ItemMismatch -> Nothing - ForkedFlowRecordingsMissed -> Nothing - MockDecodingFailed -> Nothing - UnknownPlaybackError -> Nothing - Other -> Nothing - -class HasCommonLog log where - toCommonLog :: log -> Maybe CommonLog - -instance HasCommonLog HSLog.HSLog where - toCommonLog = fromHSLog - -instance HasCommonLog PSLog.PSLog where - toCommonLog = fromPSLog diff --git a/test/EulerHS/Testing/Flow/Runtime.hs b/test/EulerHS/Testing/Flow/Runtime.hs deleted file mode 100644 index 3d3df32d..00000000 --- a/test/EulerHS/Testing/Flow/Runtime.hs +++ /dev/null @@ -1,18 +0,0 @@ -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) - -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 diff --git a/test/EulerHS/Testing/HSLog.hs b/test/EulerHS/Testing/HSLog.hs deleted file mode 100644 index 2ce97404..00000000 --- a/test/EulerHS/Testing/HSLog.hs +++ /dev/null @@ -1,77 +0,0 @@ -module EulerHS.Testing.HSLog where - -import Data.Aeson (FromJSON, Value (..), (.:)) -import qualified Data.Aeson as Aeson -import Data.Aeson.Types (prependFailure, typeMismatch) -import EulerHS.Prelude - -data HSLog - = SetEntry - | SetExEntry - | GetEntry - | ExistsEntry - | DelEntry - | ExpireEntry - | IncrEntry - | HSetEntry - | HGetEntry - | MultiExecEntry - | ThrowExceptionEntry - | CallServantApiEntry - | SetOptionEntry - | GetOptionEntry - | RunSysCmdEntry - | ForkEntry - | GeneratedGUIDEntry - | RunIOEntry - | InitSqlDBConnectionEntry - | DeInitSqlDBConnectionEntry - | GetSqlDBConnectionEntry - | RunDBEntry - | GetKVDBConnectionEntry - | AwaitEntry - | RunSafeFlowEntry - | LogMessageEntry - -hsLogFromText :: Text -> Maybe HSLog -hsLogFromText = \case - "SetEntry" -> Just SetEntry - "SetExEntry" -> Just SetExEntry - "GetEntry" -> Just GetEntry - "ExistsEntry" -> Just ExistsEntry - "DelEntry" -> Just DelEntry - "ExpireEntry" -> Just ExpireEntry - "IncrEntry" -> Just IncrEntry - "HSetEntry" -> Just HSetEntry - "HGetEntry" -> Just HGetEntry - "MultiExecEntry" -> Just MultiExecEntry - "ThrowExceptionEntry" -> Just ThrowExceptionEntry - "CallServantApiEntry" -> Just CallServantApiEntry - "SetOptionEntry" -> Just SetOptionEntry - "GetOptionEntry" -> Just GetOptionEntry - "RunSysCmdEntry" -> Just RunSysCmdEntry - "ForkEntry" -> Just ForkEntry - "GeneratedGUIDEntry" -> Just GeneratedGUIDEntry - "RunIOEntry" -> Just RunIOEntry - "InitSqlDBConnectionEntry" -> Just InitSqlDBConnectionEntry - "DeInitSqlDBConnectionEntry" -> Just DeInitSqlDBConnectionEntry - "GetSqlDBConnectionEntry" -> Just GetSqlDBConnectionEntry - "RunDBEntry" -> Just RunDBEntry - "GetKVDBConnectionEntry" -> Just GetKVDBConnectionEntry - "AwaitEntry" -> Just AwaitEntry - "RunSafeFlowEntry" -> Just RunSafeFlowEntry - "LogMessageEntry" -> Just LogMessageEntry - _ -> Nothing - -instance FromJSON HSLog where - parseJSON j = Aeson.withObject "HSLog" - (\o -> do - logType <- o .: "_entryName" - case hsLogFromText logType of - Nothing -> prependFailure "parsing HSLog failed, " - (typeMismatch "HSLog" j) - Just x -> pure x - ) - j - - diff --git a/test/EulerHS/Testing/PSLog.hs b/test/EulerHS/Testing/PSLog.hs deleted file mode 100644 index 267b36f4..00000000 --- a/test/EulerHS/Testing/PSLog.hs +++ /dev/null @@ -1,67 +0,0 @@ -module EulerHS.Testing.PSLog where - -import Data.Aeson (FromJSON, Value (..), (.:)) -import qualified Data.Aeson as Aeson -import Data.Aeson.Types (Parser, prependFailure, typeMismatch) -import Data.Vector ((!?)) -import EulerHS.Prelude - -data PSLog - = LogEntry - | RunDBEntry - | RunKVDBEitherEntry - | DoAffEntry - | SetOptionEntry - | GetOptionEntry - | GenerateGUIDEntry - | CallAPIEntry - | ForkFlowEntry - | ThrowExceptionEntry - | RunSysCmdEntry - | GetDBConnEntry - | GetKVDBConnEntry - | RunKVDBSimpleEntry - | UnexpectedRecordingEnd - | UnknownRRItem - | ItemMismatch - | ForkedFlowRecordingsMissed - | MockDecodingFailed - | UnknownPlaybackError - | Other - -psLogFromText :: Text -> Maybe PSLog -psLogFromText = \case - "LogEntry" -> Just LogEntry - "RunDBEntry" -> Just RunDBEntry - "RunKVDBEitherEntry" -> Just RunKVDBEitherEntry - "DoAffEntry" -> Just DoAffEntry - "SetOptionEntry" -> Just SetOptionEntry - "GetOptionEntry" -> Just GetOptionEntry - "GenerateGUIDEntry" -> Just GenerateGUIDEntry - "CallAPIEntry" -> Just CallAPIEntry - "ForkFlowEntry" -> Just ForkFlowEntry - "ThrowExceptionEntry" -> Just ThrowExceptionEntry - "RunSysCmdEntry" -> Just RunSysCmdEntry - "GetDBConnEntry" -> Just GetDBConnEntry - "GetKVDBConnEntry" -> Just GetKVDBConnEntry - "RunKVDBSimpleEntry" -> Just RunKVDBSimpleEntry - "UnexpectedRecordingEnd" -> Just UnexpectedRecordingEnd - "UnknownRRItem" -> Just UnknownRRItem - "ItemMismatch" -> Just ItemMismatch - "ForkedFlowRecordingsMissed" -> Just ForkedFlowRecordingsMissed - "MockDecodingFailed" -> Just MockDecodingFailed - "UnknownPlaybackError" -> Just UnknownPlaybackError - "Other" -> Just Other - _ -> Nothing - -instance FromJSON PSLog where - parseJSON j = Aeson.withArray "PSLog" - (\a -> do - logType <- (traverse Aeson.parseJSON $ a !? 2 :: Parser (Maybe Text)) - case psLogFromText =<< logType of - Nothing -> prependFailure "parsing PSLog failed, " - (typeMismatch "PSLog" j) - Just x -> pure x - ) - j - diff --git a/test/EulerHS/Testing/Util.hs b/test/EulerHS/Testing/Util.hs deleted file mode 100644 index 6b3e222a..00000000 --- a/test/EulerHS/Testing/Util.hs +++ /dev/null @@ -1,118 +0,0 @@ -module EulerHS.Testing.Util where - -import Control.Monad.Except (MonadError, runExceptT, throwError) -import Data.Aeson (Result (..), Value (..)) -import qualified Data.Aeson as Aeson -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Vector (Vector (..), (!?)) -import qualified Data.Vector as Vector -import EulerHS.Prelude - -import EulerHS.Testing.CommonLog (CommonLog (..), HasCommonLog) -import qualified EulerHS.Testing.CommonLog as CommonLog -import qualified EulerHS.Testing.HSLog as HSLog -import qualified EulerHS.Testing.PSLog as PSLog - - -readJSONFile :: FilePath -> IO (Maybe Aeson.Value) -readJSONFile fp = Aeson.decodeFileStrict fp - -purescriptEntries :: Value -> Maybe (Vector Value) -purescriptEntries v = do - methodRec <- caseJSONObject (HashMap.lookup "methodRecording") v - entries <- caseJSONObject (HashMap.lookup "entries") methodRec - caseJSONArray Just entries - -haskellEntries :: Value -> Maybe (Vector Value) -haskellEntries v = do - methodRec <- caseJSONObject (HashMap.lookup "methodRecording") v - entries <- caseJSONObject (HashMap.lookup "mrEntries") methodRec - recording <- caseJSONObject (HashMap.lookup "recording") entries - caseJSONArray Just recording - -caseJSONObject :: (HashMap Text Value -> Maybe a) -> Value -> Maybe a -caseJSONObject f v = case v of - Object o -> f o - _ -> Nothing - -caseJSONArray :: (Vector Value -> Maybe a) -> Value -> Maybe a -caseJSONArray f v = case v of - Array a -> f a - _ -> Nothing - -data CheckJSONError - = MissingEventError CommonLog - | LoadJsonError - | ImpossibleError - deriving (Eq, Ord, Show) - -checkJSONFiles :: (MonadIO m) => FilePath -> FilePath -> m (Either CheckJSONError ()) -checkJSONFiles psfile haskellfile = runExceptT $ do - psVal <- liftIO $ readJSONFile psfile - hsVal <- liftIO $ readJSONFile haskellfile - psLogs <- processPSFile psVal - hsLogs <- processHSFile hsVal - compareLogs psLogs hsLogs - pure $ () - -compareLogs :: (MonadError CheckJSONError m) => Vector CommonLog -> Vector CommonLog -> m () -compareLogs psLogs hsLogs = case psLogs !? 0 of - Nothing -> pure () - Just log -> case log `elem` hsLogs of - False -> throwError $ MissingEventError log - True -> compareLogs (Vector.take 1 psLogs) (drop1of log hsLogs) - -drop1of :: forall a. (Eq a) => a -> Vector a -> Vector a -drop1of x xs = fst $ foldr go (Vector.empty, Vector.empty) xs - where - go :: a -> (Vector a, Vector a) -> (Vector a, Vector a) - go new acc@(l, r) = if Vector.null r - then if (new == x) then (l, Vector.cons new r) else (Vector.cons new l, r) - else acc - - -processPSFile :: (MonadError CheckJSONError m) => Maybe Value -> m (Vector CommonLog) -processPSFile maybeValue = do - case maybeValue of - Nothing -> throwError LoadJsonError - Just val -> do - case ( fmap CommonLog.fromPSLog . catMaybeVec . fmap (aesonMaybe . Aeson.fromJSON)) <$> purescriptEntries val of - Nothing -> throwError ImpossibleError - Just vec -> pure . Vector.filter (not . CommonLog.isLog) $ catMaybeVec vec - -processHSFile :: (MonadError CheckJSONError m) => Maybe Value -> m (Vector CommonLog) -processHSFile maybeValue = do - case maybeValue of - Nothing -> throwError LoadJsonError - Just val -> do - case (fmap CommonLog.fromHSLog . catMaybeVec . fmap (aesonMaybe . Aeson.fromJSON)) <$> haskellEntries val of - Nothing -> throwError ImpossibleError - Just vec -> pure $ catMaybeVec vec - -aesonMaybe :: Result a -> Maybe a -aesonMaybe = \case - Error _ -> Nothing - Success a -> Just a - -catMaybeVec :: Vector (Maybe a) -> Vector a -catMaybeVec = foldr go Vector.empty - where - go :: Maybe a -> Vector a -> Vector a - go new acc = case new of - Nothing -> acc - Just n -> acc <> Vector.singleton n - --- psVal :: Maybe Value - - --- the plan --- 1) read in json from file for haskell and PS ( Aeson value ) - done --- 2) parse the value up into a data type (Haskell) --- 3) parse the PS value up into a data type --- 4) parse both values into some comparison type, which unifies discrepancies --- 5) check that the haskell log has effects in the same order as the purescript log - - - - diff --git a/test/EulerHS/Tests/Framework/ArtSpec.hs b/test/EulerHS/Tests/Framework/ArtSpec.hs deleted file mode 100644 index 7ed6e151..00000000 --- a/test/EulerHS/Tests/Framework/ArtSpec.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# OPTIONS_GHC -Werror -Wno-name-shadowing #-} -{-# LANGUAGE DuplicateRecordFields #-} - -module EulerHS.Tests.Framework.ArtSpec ( - -- spec - ) where diff --git a/test/EulerHS/Tests/Framework/Common.hs b/test/EulerHS/Tests/Framework/Common.hs deleted file mode 100644 index 7cac96d5..00000000 --- a/test/EulerHS/Tests/Framework/Common.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# OPTIONS_GHC -Werror #-} - -module EulerHS.Tests.Framework.Common - ( - withServer, - initRTWithManagers - ) where - -import EulerHS.TestData.API.Client (api, port, server) -import Control.Concurrent.Async (withAsync) -import qualified Data.Map as Map -import EulerHS.Prelude -import EulerHS.Runtime (FlowRuntime, _httpClientManagers, - withFlowRuntime) -import Network.HTTP.Client (newManager) -import Network.HTTP.Client.TLS (tlsManagerSettings) -import Network.Wai.Handler.Warp (run) -import Servant.Server (serve) - -withServer :: IO () -> IO () -withServer action = withAsync (run port . serve api $ server) - (const action) - -initRTWithManagers :: IO FlowRuntime -initRTWithManagers = do - flowRt <- withFlowRuntime Nothing pure - m1 <- newManager tlsManagerSettings - m2 <- newManager tlsManagerSettings - let managersMap = Map.fromList - [ ("manager1", m1) - , ("manager2", m2) - ] - pure $ flowRt { _httpClientManagers = managersMap } diff --git a/test/EulerHS/Tests/Framework/KVDBArtSpec.hs b/test/EulerHS/Tests/Framework/KVDBArtSpec.hs deleted file mode 100644 index 491f44dc..00000000 --- a/test/EulerHS/Tests/Framework/KVDBArtSpec.hs +++ /dev/null @@ -1,4 +0,0 @@ -module EulerHS.Tests.Framework.KVDBArtSpec - ( - -- spec - ) where diff --git a/test/EulerHS/Tests/Framework/PubSubSpec.hs b/test/EulerHS/Tests/Framework/PubSubSpec.hs deleted file mode 100644 index 852e50a3..00000000 --- a/test/EulerHS/Tests/Framework/PubSubSpec.hs +++ /dev/null @@ -1,4 +0,0 @@ -module EulerHS.Tests.Framework.PubSubSpec - ( - -- spec - ) where diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 index 2003f377..00000000 --- a/test/Main.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# OPTIONS_GHC -Werror #-} - -module Main (main) where - -import EulerHS.Prelude hiding (bracket) -import qualified EulerHS.Types as T -import qualified EulerHS.Tests.Framework.FlowSpec as Flow -import qualified EulerHS.Tests.Framework.MaskingSpec as MaskSpec -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 - - - - --- Helpers - -logsDisabled :: Maybe T.LoggerConfig -logsDisabled = Nothing diff --git a/test/extra/Main.hs b/test/extra/Main.hs new file mode 100644 index 00000000..21679dec --- /dev/null +++ b/test/extra/Main.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -Werror #-} + +module Main (main) where + + +import EulerHS.Prelude +import qualified Options as Options +import qualified SnowflakesSpec as Snowflakes +import Test.Hspec (hspec) + +main :: IO () +main = hspec $ do + Options.spec + Snowflakes.spec diff --git a/test/extra/Options.hs b/test/extra/Options.hs new file mode 100644 index 00000000..871edf03 --- /dev/null +++ b/test/extra/Options.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Options where + +import EulerHS.Extra.Aeson +import EulerHS.Prelude + +import Data.Aeson +import qualified Data.ByteString.Lazy as BSL +import Test.Hspec + + +spec :: Spec +spec = do + describe "aesonOmitNothingFields" $ do + it "Default option. Null age" $ do + encode personNull `shouldBe` enc_personNull + it "Default option. Just 33 age" $ do + encode person `shouldBe` enc_person + it "With omit option. Null age" $ do + encode personOmitNull `shouldBe` enc_personOmitNull + it "With omit option. Just 33 age" $ do + encode personOmit `shouldBe` enc_personOmit + + describe "unaryRecordOptions" $ do + it "Default option. Complete json" $ do + decode enc_planet `shouldBe` Just lunar + it "Default option. Incomplete json" $ do + eitherDecode @Cosmos enc_planetIncomplete `shouldBe` Left decode_error + it "With unary option. Complete unary json" $ do + decode enc_unarySpace `shouldBe` Just unarySpace + it "With unary option. Incomplete unary json" $ do + decode enc_unarySpaceIncomplete `shouldBe` Just unarySpace + + describe "untaggedOptions" $ do + it "Default option" $ do + encode fruit `shouldBe` enc_plant + it "With untagged option" $ do + encode berry `shouldBe` enc_plantUntag + + describe "stripLensPrefixOptions" $ do + it "Default option" $ do + encode cat `shouldBe` enc_cat + it "With strip option. One char prefix" $ do + encode dog `shouldBe` enc_dog + it "With strip option. Multi char prefix" $ do + encode bull `shouldBe` enc_bull + + describe "stripAllLensPrefixOptions" $ do + it "Default option" $ do + encode cow `shouldBe` enc_cow + it "With strip option. Short prefix" $ do + encode wolf `shouldBe` enc_wolf + it "With strip option. Long equal prefix" $ do + encode wooolf `shouldBe` enc_wooolf + it "With strip option. Long not equal prefix" $ do + encode wulf `shouldBe` enc_wulf + + + +------------------------------------------------------------------------------- +-- aesonOmitNothingFields option +------------------------------------------------------------------------------- + +-- Default option +data Person = Person + { name :: Text + , age :: Maybe Int + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +personNull :: Person +personNull = Person "Omar" Nothing + +enc_personNull :: BSL.ByteString +enc_personNull = "{\"age\":null,\"name\":\"Omar\"}" + +person :: Person +person = Person "Omar" (Just 33) + +enc_person :: BSL.ByteString +enc_person = "{\"age\":33,\"name\":\"Omar\"}" + +-- omit field option +data PersonOmit = PersonOmit + { name :: Text + , age :: Maybe Int + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON) + +instance ToJSON PersonOmit where + toJSON = genericToJSON aesonOmitNothingFields + toEncoding = genericToEncoding aesonOmitNothingFields + +personOmitNull :: PersonOmit +personOmitNull = PersonOmit "Omar" Nothing + +enc_personOmitNull :: BSL.ByteString +enc_personOmitNull = "{\"name\":\"Omar\"}" + +personOmit :: PersonOmit +personOmit = PersonOmit "Omar" (Just 33) + +enc_personOmit :: BSL.ByteString +enc_personOmit = "{\"name\":\"Omar\",\"age\":33}" + + +------------------------------------------------------------------------------- +-- unaryRecordOptions option +------------------------------------------------------------------------------- + +data Space = Space + { name :: Text + , distance :: Maybe Int + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +data Planet = Planet + { name :: Text + , weight :: Maybe Int + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +-- for default decoding +data Cosmos + = Solar Space + | Lunar Planet + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +lunar :: Cosmos +lunar = Lunar $ Planet "Moon" (Just 5923) + +enc_planet :: BSL.ByteString +enc_planet = "{\"tag\":\"Lunar\",\"contents\":{\"weight\":5923,\"name\":\"Moon\"}}" + +enc_planetIncomplete :: BSL.ByteString +enc_planetIncomplete = "{\"weight\":5923,\"name\":\"Moon\"}" + +decode_error :: String +decode_error = "Error in $: parsing Options.Cosmos failed, expected Object with key \"tag\" containing one of [\"Solar\",\"Lunar\"], key \"tag\" not found" + +-- decode with unaryRecordOptions option +data CosmosUnary + = SolarU Space + | LunarU Planet + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON) + +instance FromJSON CosmosUnary where + parseJSON val + = (SolarU <$> parseJSON val) + <|> (LunarU <$> parseJSON val) + <|> genericParseJSON unaryRecordOptions val + +unarySpace :: CosmosUnary +unarySpace = SolarU $ Space "Sirius" (Just 8910) + +enc_unarySpace :: BSL.ByteString +enc_unarySpace = "{\"tag\":\"SolarU\",\"contents\":{\"distance\":8910,\"name\":\"Sirius\"}}" + +enc_unarySpaceIncomplete :: BSL.ByteString +enc_unarySpaceIncomplete = "{\"distance\":8910,\"name\":\"Sirius\"}" + +------------------------------------------------------------------------------- +-- untaggedOptions +------------------------------------------------------------------------------- + +data Apple = Apple + { weight :: Int + , colour :: Maybe Text + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +data Strawberry = Strawberry + { weight :: Int + , colour :: Maybe Text + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +-- for default encoding +data Plant + = Fruit Apple + | Berry Strawberry + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +fruit :: Plant +fruit = Fruit $ Apple 12 (Just "green") + +enc_plant :: BSL.ByteString +enc_plant = "{\"tag\":\"Fruit\",\"contents\":{\"weight\":12,\"colour\":\"green\"}}" + +data PlantUnTag + = FruitU Apple + | BerryU Strawberry + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON) + +instance ToJSON PlantUnTag where + toJSON = genericToJSON untaggedOptions + toEncoding = genericToEncoding untaggedOptions + +berry :: PlantUnTag +berry = BerryU $ Strawberry 2 (Just "red") + +enc_plantUntag :: BSL.ByteString +enc_plantUntag = "{\"weight\":2,\"colour\":\"red\"}" + +------------------------------------------------------------------------------- +-- stripLensPrefixOptions +------------------------------------------------------------------------------- + +data Cat = Cat + { cName :: Text + , cColour :: Maybe Text + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +cat :: Cat +cat = Cat "Kita" (Just "grey") + +enc_cat :: BSL.ByteString +enc_cat = "{\"cName\":\"Kita\",\"cColour\":\"grey\"}" + +data Dog = Dog + { cName :: Text + , cColour :: Maybe Text + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON) + +instance ToJSON Dog where + toJSON = genericToJSON stripLensPrefixOptions + toEncoding = genericToEncoding stripLensPrefixOptions + +dog :: Dog +dog = Dog "Buddy" (Just "white") + +enc_dog :: BSL.ByteString +enc_dog = "{\"Name\":\"Buddy\",\"Colour\":\"white\"}" + +data Bull = Bull + { bbulName :: Text + , bbulColour :: Maybe Text + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON) + +instance ToJSON Bull where + toJSON = genericToJSON stripLensPrefixOptions + toEncoding = genericToEncoding stripLensPrefixOptions + +bull :: Bull +bull = Bull "Bully" (Just "white") + +enc_bull :: BSL.ByteString +enc_bull = "{\"bulName\":\"Bully\",\"bulColour\":\"white\"}" + +------------------------------------------------------------------------------- +-- stripAllLensPrefixOptions +------------------------------------------------------------------------------- + +data Cow = Cow + { cName :: Text + , cColour :: Maybe Text + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +cow :: Cow +cow = Cow "Mu" (Just "white-nd-black") + +enc_cow :: BSL.ByteString +enc_cow = "{\"cName\":\"Mu\",\"cColour\":\"white-nd-black\"}" + +data Wolf = Wolf + { cName :: Text + , cColour :: Maybe Text + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON) + +instance ToJSON Wolf where + toJSON = genericToJSON stripAllLensPrefixOptions + toEncoding = genericToEncoding stripAllLensPrefixOptions + +wolf :: Wolf +wolf = Wolf "Boss" (Just "grey") + +enc_wolf :: BSL.ByteString +enc_wolf = "{\"Name\":\"Boss\",\"Colour\":\"grey\"}" + +data Wooolf = Wooolf + { cccName :: Text + , cccColour :: Maybe Text + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON) + +instance ToJSON Wooolf where + toJSON = genericToJSON stripAllLensPrefixOptions + toEncoding = genericToEncoding stripAllLensPrefixOptions + +wooolf :: Wooolf +wooolf = Wooolf "Boooss" (Just "grey") + +enc_wooolf :: BSL.ByteString +enc_wooolf = "{\"Name\":\"Boooss\",\"Colour\":\"grey\"}" + +data Wulf = Wulf + { cucName :: Text + , cucColour :: Maybe Text + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON) + +instance ToJSON Wulf where + toJSON = genericToJSON stripAllLensPrefixOptions + toEncoding = genericToEncoding stripAllLensPrefixOptions + +wulf :: Wulf +wulf = Wulf "Buss" (Just "black") + +enc_wulf :: BSL.ByteString +enc_wulf = "{\"ucName\":\"Buss\",\"ucColour\":\"black\"}" diff --git a/test/extra/SnowflakesSpec.hs b/test/extra/SnowflakesSpec.hs new file mode 100644 index 00000000..47ba2e8e --- /dev/null +++ b/test/extra/SnowflakesSpec.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE RecordWildCards #-} + +module SnowflakesSpec where + +import EulerHS.Extra.Snowflakes.Types +import EulerHS.KVConnector.Utils (foldEither) +import EulerHS.Prelude +import qualified EulerHS.Interpreters as I +import qualified EulerHS.Language as L +import qualified EulerHS.Runtime as R +import Data.Set as Set (fromList, intersection, size) +import Test.Hspec + +type SnowflakeFlowSpec = SpecWith R.FlowRuntime + +asserting :: Expectation -> L.Flow () +asserting = L.runIO + +snowflakeFlowSpec :: SnowflakeFlowSpec -> Spec +snowflakeFlowSpec = do + aroundAll $ \tests -> do + R.withFlowRuntime Nothing $ \rt -> do + tests rt + +setSnowflakePrerequisites :: L.Flow () +setSnowflakePrerequisites = + void . sequence_ $ [L.setOption StackID 1, L.setOption PodID 1] + +purgeSnowflakePrerequisites :: L.Flow () +purgeSnowflakePrerequisites = + void . sequence_ $ [ L.delOption StackID, L.delOption PodID] + +itSnowflakeFlow :: [Char] -> L.Flow () -> SnowflakeFlowSpec +itSnowflakeFlow description flow = + it description (`I.runFlow` flow) + +spec :: HasCallStack => Spec +spec = snowflakeFlowSpec $ do + itSnowflakeFlow "Snowflake concurrency test: Snowflake generation is thread-safe" + $ do + setSnowflakePrerequisites + a1 <- L.forkFlow' "Snowflake Generation thread 1"$ (replicateM 2000 ( L.generateSnowflake "Sample")) + a2 <- L.forkFlow' "Snowflake Generation thread 2" $ (replicateM 2000 ( L.generateSnowflake "Sample")) + flakes1 <- L.await Nothing a1 + flakes2 <- L.await Nothing a2 + -- res :: Either String Bool + res <- case (flakes1, flakes2) of + (Right ef1, Right ef2) -> case (foldEither ef1, foldEither ef2) of + (Right f1, Right f2) -> return $ Right $ checkCollision f1 f2 + _ -> return $ Left ("Error generating snowflakes" :: String) + _ -> return $ Left ("Error generating snowflakes" :: String) + asserting $ res `shouldBe` (Right True) + + where + checkCollision :: [Snowflake] -> [Snowflake] -> Bool + checkCollision a b = Set.size (Set.intersection (Set.fromList a) (Set.fromList b)) == 0 \ No newline at end of file diff --git a/test/language/ArtSpec.hs b/test/language/ArtSpec.hs new file mode 100644 index 00000000..90e6292c --- /dev/null +++ b/test/language/ArtSpec.hs @@ -0,0 +1,4 @@ +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module ArtSpec ( + ) where diff --git a/test/EulerHS/Tests/Framework/CachedDBSpec.hs b/test/language/CachedDBSpec.hs similarity index 80% rename from test/EulerHS/Tests/Framework/CachedDBSpec.hs rename to test/language/CachedDBSpec.hs index 1ca697d2..a3be5a1b 100644 --- a/test/EulerHS/Tests/Framework/CachedDBSpec.hs +++ b/test/language/CachedDBSpec.hs @@ -1,27 +1,24 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} -module EulerHS.Tests.Framework.CachedDBSpec where +module CachedDBSpec where -import EulerHS.Tests.Framework.DBSetup -import EulerHS.Tests.Framework.DBSetup as DBS +import DBSetup as DBS import qualified Database.Beam as B import EulerHS.CachedSqlDBQuery import EulerHS.Interpreters as I import EulerHS.Language as L import EulerHS.Prelude import EulerHS.Types as T --- import Named import Sequelize import Test.Hspec +import EulerHS.KVConnector.Types (meshConfig) - +redisCfg :: KVDBConfig redisCfg = T.mkKVDBConfig "eulerKVDB" T.defaultKVDBConnConfig spec :: Spec spec = do - around (withEmptyDB) $ + around withEmptyDB $ describe "Cached sequelize layer" $ do @@ -37,7 +34,7 @@ spec = do res <- runFlow rt $ do _ <- L.initKVDBConnection redisCfg conn <- connectOrFail sqliteCfg - L.runDB conn $ L.insertRows $ + _ <- 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")) @@ -60,12 +57,12 @@ spec = do res <- runFlow rt $ do _ <- L.initKVDBConnection redisCfg conn <- connectOrFail sqliteCfg - L.runDB conn $ L.insertRows $ + _ <- 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 $ + _ <- 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")) @@ -73,11 +70,11 @@ spec = do it "findAll finds all values in the database" $ \rt -> do let testKey = "key5" res <- runFlow rt $ do - redisConn <- L.initKVDBConnection redisCfg + _ <- L.initKVDBConnection redisCfg conn <- connectOrFail sqliteCfg - L.runDB conn $ L.insertRows $ + _ <- L.runDB conn $ L.insertRows $ B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates"] - L.runDB conn $ L.insertRows $ + _ <- L.runDB conn $ L.insertRows $ B.insert (users userDB) $ B.insertValues [User 2 "Steve" "Jobs"] _ <- findAll sqliteCfg (Just testKey) [] :: Flow (Either DBError [User]) @@ -104,14 +101,14 @@ spec = do res <- runFlow rt $ do _ <- L.initKVDBConnection redisCfg conn <- connectOrFail sqliteCfg - L.runDB conn $ L.insertRows $ + _ <- L.runDB conn $ L.insertRows $ B.insert (users userDB) $ B.insertValues [User 1 "Bill" "Gates"] - L.runDB conn $ L.insertRows $ + _ <- L.runDB conn $ L.insertRows $ B.insert (users userDB) $ B.insertValues [User 2 "Steve" "Jobs"] - something <- findAll sqliteCfg (Just testKey) [] + _ <- findAll sqliteCfg (Just testKey) [] :: Flow (Either DBError [User]) -- Delete everything to ensure the cache is used - L.runDB conn $ L.deleteRows $ + _ <- L.runDB conn $ L.deleteRows $ B.delete (users userDB) (\u -> _userGUID u B.<. 3) findAll sqliteCfg (Just testKey) [] res `shouldSatisfy` \case @@ -123,7 +120,7 @@ spec = do let user = User 10 "Alonzo" "Church" res <- runFlow rt $ do _ <- initKVDBConnection redisCfg - create sqliteCfg user Nothing + _ <- create sqliteCfg meshConfig user Nothing findOne sqliteCfg Nothing [] res `shouldBe` Right (Just user) @@ -133,34 +130,31 @@ spec = do res <- runFlow rt $ do _ <- initKVDBConnection redisCfg conn <- connectOrFail sqliteCfg - create sqliteCfg user (Just testKey) + _ <- create sqliteCfg meshConfig user (Just testKey) -- Delete from DB to ensure the cache is used - L.runDB conn $ L.deleteRows $ + _ <- 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)] + _ <- create sqliteCfg meshConfig 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 $ + _ <- create sqliteCfg meshConfig user1 (Just testKey) + _ <- updateOne sqliteCfg (Just testKey) [Sequelize.Set DBS._firstName "Kurt"] [Is _userGUID (Eq 10)] + _ <- 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/TestData/API/Client.hs b/test/language/Client.hs similarity index 74% rename from test/EulerHS/TestData/API/Client.hs rename to test/language/Client.hs index b5988805..cb9660d1 100644 --- a/test/EulerHS/TestData/API/Client.hs +++ b/test/language/Client.hs @@ -1,16 +1,17 @@ -{-# OPTIONS_GHC -Werror #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE TypeOperators #-} -module EulerHS.TestData.API.Client +module Client ( Book(..), User(..), - port, api, server, + port, externalServerPort, serverPort, api, server, getUser, getBook ) where import EulerHS.Prelude -import EulerHS.Types (EulerClient, client) +import EulerHS.Types (EulerClient) +import EulerHS.ApiHelpers (client) import Servant.API (Get, JSON, type (:>), (:<|>) ((:<|>))) import Servant.Mock (mock) import Servant.Server (Server) @@ -45,17 +46,21 @@ instance Arbitrary Book where type API = "user" :> Get '[JSON] User :<|> "book" :> Get '[JSON] Book +-- | port number to bind test server's socket +serverPort :: Int +serverPort = 8081 + +-- | external server for some tests (for local use only) +externalServerPort :: Int +externalServerPort = serverPort + +-- | port to connect to when running tests port :: Int -port = 8081 +port = serverPort api :: Proxy API api = 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 diff --git a/test/language/Common.hs b/test/language/Common.hs new file mode 100644 index 00000000..661e8226 --- /dev/null +++ b/test/language/Common.hs @@ -0,0 +1,152 @@ +{-# OPTIONS_GHC -Werror -Wwarn=deprecations #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Common + ( withServer + , withSecureServer + , withClientTlsAuthServer + , withCertV1SecureServer + , initRTWithManagers + , clientHttpCert + + ) where + + +import Data.ByteString (readFile) +import Client (api, serverPort, server) +import Control.Concurrent.Async (withAsync) +import EulerHS.Prelude hiding (readFile, empty) +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 (Settings, runSettings, defaultSettings, setPort, setBeforeMainLoop) +import Network.Wai.Handler.WarpTLS (TLSSettings, runTLS, tlsSettingsChain, tlsWantClientCert, tlsServerHooks) +import Network.TLS (CertificateUsage (..), onClientCertificate) +import Data.Default +import Servant.Server (serve) +-- import Test.Hspec (shouldBe) +import Data.X509.CertificateStore (readCertificateStore) + +readyHandlerSetter :: MVar () -> Settings -> Settings +readyHandlerSetter sem = setBeforeMainLoop $ readyHandler sem + where + readyHandler = flip putMVar () + +portSetter :: Settings -> Settings +portSetter = setPort serverPort + +mkSettings :: MVar () -> Settings -> Settings +mkSettings sem = portSetter . (readyHandlerSetter sem) + +withServer :: IO () -> IO () +withServer action = do + sem <- newEmptyMVar + let settings = mkSettings sem defaultSettings + let runServer = runSettings settings . serve api $ server + let serverIsUpCallback = \_ -> takeMVar sem >> action + withAsync runServer serverIsUpCallback + +tlsSettingsWithCert :: TLSSettings +tlsSettingsWithCert = tlsSettingsChain + "" + [""] + "" + +tlsSettingsWithCertV1 :: TLSSettings +tlsSettingsWithCertV1 = tlsSettingsChain + "" + [""] + "" + +withCertV1SecureServer :: IO () -> IO () +withCertV1SecureServer action = do + sem <- newEmptyMVar + let settings = mkSettings sem defaultSettings + let tlsSettings = tlsSettingsWithCertV1 + { tlsWantClientCert = False + } + let runServer = runTLS tlsSettings settings . serve api $ server + let serverIsUpCallback = \_ -> takeMVar sem >> action + withAsync runServer serverIsUpCallback + +withSecureServer :: IO () -> IO () +withSecureServer action = do + sem <- newEmptyMVar + let settings = mkSettings sem defaultSettings + let tlsSettings = tlsSettingsWithCert + { tlsWantClientCert = False + } + let runServer = runTLS tlsSettings settings . serve api $ server + let serverIsUpCallback = \_ -> takeMVar sem >> action + withAsync runServer serverIsUpCallback + +withClientTlsAuthServer :: IO () -> IO () +withClientTlsAuthServer action = do + sem <- newEmptyMVar + let settings = mkSettings sem defaultSettings + let tlsSettings = tlsSettingsWithCert + { tlsWantClientCert = True + , tlsServerHooks = def + { onClientCertificate = \ _ -> pure $ CertificateUsageAccept + } + } + + let runServer = runTLS tlsSettings settings . serve api $ server + let serverIsUpCallback = \_ -> takeMVar sem >> action + withAsync runServer serverIsUpCallback + + +initRTWithManagers :: IO FlowRuntime +initRTWithManagers = do + flowRt <- withFlowRuntime Nothing pure + -- default managers + m1 <- newManager tlsManagerSettings + m2 <- newManager tlsManagerSettings + + -- custom managers built with euler's builder + + -- sample proxying + m3 <- newManager $ buildSettings $ + withProxy ("localhost", 3306) + + -- custom CA + mbStore <- readCertificateStore "" + let store = fromMaybe (error "") mbStore + + m4 <- newManager $ buildSettings $ + withCustomCA store + + cert <- readFile "" + key <- readFile "" + + -- let managerBuilder = newManager $ extract $ buildSettings + -- with client certificate + m5 <- newManager $ buildSettings $ + withCustomCA store + <> withClientTls (HTTPCert cert [] "localhost" key) + + m6 <- newManager $ buildSettings $ + withCustomCA store + <> withNoCheckLeafV3 + + -- + let managersMap = + [ ("manager1", m1) + , ("manager2", m2) + , ("proxying", m3) + , ("tlsWithCustomCA", m4) + , ("tlsWithClientCertAndCustomCA", m5) + , ("v1CertsSupport", m6) + ] + pure $ flowRt { _httpClientManagers = managersMap } + + + +clientHttpCert:: IO T.HTTPCert +clientHttpCert = do + cert <- readFile "" + key <- readFile "" + return $ HTTPCert cert [] "server01" key diff --git a/test/EulerHS/Tests/Framework/DBSetup.hs b/test/language/DBSetup.hs similarity index 83% rename from test/EulerHS/Tests/Framework/DBSetup.hs rename to test/language/DBSetup.hs index b4630f76..bc85d66a 100644 --- a/test/EulerHS/Tests/Framework/DBSetup.hs +++ b/test/language/DBSetup.hs @@ -1,23 +1,21 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} -module EulerHS.Tests.Framework.DBSetup where +module DBSetup where import Data.Aeson as A import qualified Database.Beam as B -import Database.Beam.Sqlite.Connection (Sqlite, SqliteM) +import Database.Beam.Sqlite.Connection (SqliteM) 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 --- Prepare custom types for tests - data UserT f = User { _userGUID :: B.C f Int , _firstName :: B.C f Text @@ -47,6 +45,7 @@ deriving instance Eq User deriving instance ToJSON User deriving instance FromJSON User +userTMod :: UserT (B.FieldModification (B.TableField UserT)) userTMod = B.tableModification { _userGUID = B.fieldNamed "id" @@ -59,7 +58,8 @@ userEMod = B.modifyTableFields userTMod newtype UserDB f = UserDB { users :: f (B.TableEntity UserT) - } deriving (Generic, B.Database be) + } deriving stock (Generic) + deriving anyclass (B.Database be) userDB :: B.DatabaseSettings be UserDB userDB = B.defaultDbSettings `B.withDbModification` @@ -70,11 +70,12 @@ userDB = B.defaultDbSettings `B.withDbModification` -- Prepare connection to database file testDBName :: String -testDBName = "test/EulerHS/TestData/test.db" +testDBName = "test/language/EulerHS/TestData/test.db" testDBTemplateName :: String -testDBTemplateName = "test/EulerHS/TestData/test.db.template" +testDBTemplateName = "test/language/EulerHS/TestData/test.db.template" +poolConfig :: PoolConfig poolConfig = T.PoolConfig { stripes = 1 , keepAlive = 10 @@ -102,8 +103,10 @@ withEmptyDB act = withFlowRuntime Nothing (\rt -> do Right _ -> act rt `finally` runFlow rt rmTestDB ) --- Prepare record log and test returns + connectOrFail :: T.DBConfig beM -> Flow (T.SqlConn beM) connectOrFail cfg = L.getOrInitSqlConn cfg >>= \case Left e -> error $ show e Right conn -> pure conn + + diff --git a/test/EulerHS/TestData/Types.hs b/test/language/EulerHS/TestData/Types.hs similarity index 83% rename from test/EulerHS/TestData/Types.hs rename to test/language/EulerHS/TestData/Types.hs index d1f8a754..f0aa3960 100644 --- a/test/EulerHS/TestData/Types.hs +++ b/test/language/EulerHS/TestData/Types.hs @@ -1,58 +1,58 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} module EulerHS.TestData.Types where import qualified Data.Aeson as A import EulerHS.Prelude -import EulerHS.Types - +import EulerHS.Types (OptionEntity) data UrlKey = UrlKey deriving (Generic, Typeable, Show, Eq, ToJSON) - data TestStringKey = TestStringKey deriving (Generic, Typeable, Show, Eq, ToJSON) data TestStringKey2 = TestStringKey2 deriving (Generic, Typeable, Show, Eq, ToJSON) - data TestIntKey = TestIntKey deriving (Generic, Typeable, Show, Eq, ToJSON) data TestIntKey2 = TestIntKey2 deriving (Generic, Typeable, Show, Eq, ToJSON) - data TestStringKeyAnotherEnc = TestStringKeyAnotherEnc deriving (Generic, Typeable, Show, Eq) data TestStringKey2AnotherEnc = TestStringKey2AnotherEnc deriving (Generic, Typeable, Show, Eq) +newtype TestKeyWithStringPayload = TestKeyWithStringPayload String + deriving stock (Generic, Typeable, Show) + deriving newtype (Eq) + deriving anyclass (ToJSON) -data TestKeyWithStringPayload = TestKeyWithStringPayload String - deriving (Generic, Typeable, Show, Eq, ToJSON) - -data TestKeyWithIntPayload = TestKeyWithIntPayload Int - deriving (Generic, Typeable, Show, Eq, ToJSON) - +newtype TestKeyWithIntPayload = TestKeyWithIntPayload Int + deriving stock (Generic, Typeable, Show) + deriving newtype (Eq) + deriving anyclass (ToJSON) -data TestKeyWithStringPayloadAnotherEnc = TestKeyWithStringPayloadAnotherEnc String +newtype TestKeyWithStringPayloadAnotherEnc = TestKeyWithStringPayloadAnotherEnc String deriving (Generic, Typeable, Show, Eq) -data TestKeyWithIntPayloadAnotherEnc = TestKeyWithIntPayloadAnotherEnc Int +newtype TestKeyWithIntPayloadAnotherEnc = TestKeyWithIntPayloadAnotherEnc Int deriving (Generic, Typeable, Show, Eq) - - newtype NTTestKeyWithStringPayload = NTTestKeyWithStringPayload String - deriving (Generic, Typeable, Show, Eq, ToJSON) + deriving stock (Generic, Typeable, Show) + deriving newtype (Eq) + deriving anyclass (ToJSON) newtype NTTestKeyWithIntPayload = NTTestKeyWithIntPayload Int - deriving (Generic, Typeable, Show, Eq, ToJSON) - + deriving stock (Generic, Typeable, Show) + deriving newtype (Eq) + deriving anyclass (ToJSON) newtype NTTestKeyWithStringPayloadAnotherEnc = NTTestKeyWithStringPayloadAnotherEnc String deriving (Generic, Typeable, Show, Eq) @@ -60,8 +60,6 @@ newtype NTTestKeyWithStringPayloadAnotherEnc = NTTestKeyWithStringPayloadAnother newtype NTTestKeyWithIntPayloadAnotherEnc = NTTestKeyWithIntPayloadAnotherEnc Int deriving (Generic, Typeable, Show, Eq) - - instance A.ToJSON TestStringKeyAnotherEnc where toJSON = A.genericToJSON $ A.defaultOptions { A.tagSingleConstructors = True } @@ -75,7 +73,6 @@ instance A.ToJSON TestKeyWithStringPayloadAnotherEnc instance A.ToJSON TestKeyWithIntPayloadAnotherEnc where toJSON = A.genericToJSON $ A.defaultOptions { A.tagSingleConstructors = True } - instance A.ToJSON NTTestKeyWithStringPayloadAnotherEnc where toJSON = A.genericToJSON $ A.defaultOptions { A.tagSingleConstructors = True } @@ -87,24 +84,17 @@ instance OptionEntity TestStringKey String instance OptionEntity TestStringKey2 String instance OptionEntity TestIntKey Int instance OptionEntity TestIntKey2 Int - instance OptionEntity TestStringKeyAnotherEnc String instance OptionEntity TestStringKey2AnotherEnc String - instance OptionEntity TestKeyWithStringPayload String instance OptionEntity TestKeyWithIntPayload String - instance OptionEntity TestKeyWithStringPayloadAnotherEnc String instance OptionEntity TestKeyWithIntPayloadAnotherEnc String - instance OptionEntity NTTestKeyWithStringPayload String instance OptionEntity NTTestKeyWithIntPayload Int - instance OptionEntity NTTestKeyWithStringPayloadAnotherEnc String instance OptionEntity NTTestKeyWithIntPayloadAnotherEnc Int - - data TestKVals = TestKVals { mbTestStringKey :: Maybe String , mbTestStringKey2 :: Maybe String @@ -130,8 +120,3 @@ data TestKVals = TestKVals , mbNTTestKeyWithIntPayloadAnotherEncS2 :: Maybe Int } deriving (Show, Eq) - ----------------------------------- - - - diff --git a/test/EulerHS/Testing/Flow/Interpreter.hs b/test/language/EulerHS/Testing/Flow/Interpreter.hs similarity index 90% rename from test/EulerHS/Testing/Flow/Interpreter.hs rename to test/language/EulerHS/Testing/Flow/Interpreter.hs index 4f9cacf0..0c484cb8 100644 --- a/test/EulerHS/Testing/Flow/Interpreter.hs +++ b/test/language/EulerHS/Testing/Flow/Interpreter.hs @@ -1,6 +1,6 @@ -{-# OPTIONS_GHC -Werror #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} module EulerHS.Testing.Flow.Interpreter where @@ -20,9 +20,9 @@ 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 -> + L.CallServantAPI _ _ _ _ _ next -> next . unsafeCoerce <$> takeMockedVal @"mockedCallServantAPI" mmv - L.GetOption _ next -> next <$> (unsafeCoerce $ Just $ takeMockedVal @"mockedGetOption" 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 diff --git a/test/EulerHS/Testing/Types.hs b/test/language/EulerHS/Testing/Types.hs similarity index 100% rename from test/EulerHS/Testing/Types.hs rename to test/language/EulerHS/Testing/Types.hs diff --git a/test/EulerHS/Tests/Framework/FlowSpec.hs b/test/language/FlowSpec.hs similarity index 63% rename from test/EulerHS/Tests/Framework/FlowSpec.hs rename to test/language/FlowSpec.hs index b48e626d..bca8eafd 100644 --- a/test/EulerHS/Tests/Framework/FlowSpec.hs +++ b/test/language/FlowSpec.hs @@ -1,15 +1,28 @@ -{-# OPTIONS_GHC -Werror #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wwarn=deprecations #-} -module EulerHS.Tests.Framework.FlowSpec (spec) where +module FlowSpec (spec) where -import EulerHS.TestData.API.Client (User (User), getBook, getUser, port) -import EulerHS.Tests.Framework.Common (initRTWithManagers, withServer) +import Client (externalServerPort, getBook, getUser, + port) +import Common (clientHttpCert, initRTWithManagers, + withCertV1SecureServer, withClientTlsAuthServer, + withSecureServer, withServer) import qualified Control.Exception as E +import Data.Either.Extra (fromLeft') +import Data.Maybe (fromJust) +import qualified Data.Text as Text import qualified Data.UUID as UUID (fromText) +import Data.X509.CertificateStore (readCertificateStore) +import Servant.Client (BaseUrl (..), ClientError (..), Scheme (..)) +import Servant.Server (err403, errBody) +import Test.Hspec (Spec, around, around_, describe, it, shouldBe, + shouldSatisfy) + import EulerHS.Interpreters (runFlow) import EulerHS.Language as L import EulerHS.Prelude hiding (get, getOption) -import EulerHS.Runtime (withFlowRuntime, createLoggerRuntime) +import EulerHS.Runtime (createLoggerRuntime, withFlowRuntime) import EulerHS.TestData.Types (NTTestKeyWithIntPayload (NTTestKeyWithIntPayload), NTTestKeyWithIntPayloadAnotherEnc (NTTestKeyWithIntPayloadAnotherEnc), NTTestKeyWithStringPayload (NTTestKeyWithStringPayload), @@ -45,83 +58,177 @@ import EulerHS.TestData.Types (NTTestKeyWithIntPayload (NTTestKeyWithI mbTestStringKey, mbTestStringKey2, mbTestStringKey2AnotherEnc, mbTestStringKeyAnotherEnc) -import EulerHS.Testing.Flow.Interpreter (runFlowWithTestInterpreter) -import EulerHS.Testing.Types (FlowMockedValues' (..)) -import EulerHS.Types (HttpManagerNotFound (..), defaultFlowFormatter) +import EulerHS.Types (HttpManagerNotFound (..), defaultFlowFormatter, + getResponseCode) import qualified EulerHS.Types as T -import EulerHS.TestData.Scenarios.Scenario1 (testScenario1) -import Servant.Client (BaseUrl (..), ClientError (..), Scheme (..)) -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 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" + describe "EulerHS flow language tests" $ do + around (withFlowRuntime (map (createLoggerRuntime defaultFlowFormatter Nothing) loggerCfg)) $ do + + around_ withCertV1SecureServer $ do + describe "support for V1 certificates" $ do + it "manager with V1 support connects well" $ \ _ -> do + rt <- initRTWithManagers + let req = T.httpGet $ "https://localhost:" <> show port + resEither <- runFlow rt $ callHTTP' (Just "v1CertsSupport") req ("TESTING" :: Text) (const Nothing) Nothing + resEither `shouldSatisfy` isRight + let code = getResponseCode $ fromRight (error "res is left") resEither + code `shouldBe` 404 + it "by default there is no support for V1 certificates" $ \ rt -> do + let req = T.httpGet $ "https://localhost:" <> show port + resEither <- runFlow rt $ callHTTP req ("TESTING" :: Text) (const Nothing) + resEither `shouldSatisfy` isLeft + around_ withServer $ do - describe "CallServantAPI tests with server" $ 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 + describe "callAPI tests with server" $ do + it "Simple request (book) with default manager" $ \rt -> do + let url = BaseUrl Http "localhost" port "" + bookEither <- runFlow rt $ callAPI url ("TESTING" :: Text) (const Nothing) getBook bookEither `shouldSatisfy` isRight - 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 + it "Simple request (user) with default manager" $ \rt -> do + let url = BaseUrl Http "localhost" port "" + userEither <- runFlow rt $ callAPI url ("TESTING" :: Text) (const Nothing) 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 + let url = BaseUrl Http "localhost" port "" + bookEither <- runFlow rt $ callAPI' (Just "manager1") url ("TESTING" :: Text) (const Nothing) 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 + let url = BaseUrl Http "localhost" port "" + userEither <- runFlow rt $ callAPI' (Just "manager2") url ("TESTING" :: Text) (const Nothing) getUser userEither `shouldSatisfy` isRight it "Simple request with not existing manager" $ \_ -> do rt <- initRTWithManagers - let url = BaseUrl Http "127.0.0.1" port "" + let url = BaseUrl Http "localhost" port "" let err = displayException (ConnectionError (toException $ HttpManagerNotFound "notexist")) - userEither <- runFlow rt $ callServantAPI (Just "notexist") url getUser + userEither <- runFlow rt $ callAPI' (Just "notexist") url ("TESTING" :: Text) (const Nothing) getUser case userEither of Left e -> displayException e `shouldBe` err Right _ -> fail "Success result not expected" - xit "Untyped HTTP API Calls" $ \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 _ -> throwException err403 {errBody = "Expected a response"} - Right response -> pure response - return - ( T.getResponseCode response - , T.getResponseStatus response - , T.getResponseBody response - , T.getResponseHeaders response - ) - -- check status code - statusCode `shouldBe` 200 - status `shouldBe` "OK" - xit "Untyped HTTP API Calls" $ \rt -> do - let url = "https://127.0.0.1:666/fourohhhfour" - _ <- runFlow rt $ do - L.callHTTP $ T.httpGet url :: Flow (Either Text T.HTTPResponse) - pure () - describe "CallServantAPI tests without server" $ do + + describe "callAPI tests without server" $ do it "Simple request (book)" $ \rt -> do let url = BaseUrl Http "localhost" port "" - bookEither <- runFlow rt $ callServantAPI Nothing url getBook + bookEither <- runFlow rt $ callAPI url ("TESTING" :: Text) (const Nothing) getBook bookEither `shouldSatisfy` isLeft it "Simple request (user)" $ \rt -> do let url = BaseUrl Http "localhost" port "" - userEither <- runFlow rt $ callServantAPI Nothing url getUser + userEither <- runFlow rt $ callAPI url ("TESTING" :: Text) (const Nothing) getUser userEither `shouldSatisfy` isLeft + + describe "calling external TLS services with untyped API" $ do + around_ withSecureServer $ do + it "calling secure service using unsecured protocol fails" $ \ rt -> do + let req = T.httpGet $ "http://localhost:" <> show port + resEither <- runFlow rt $ callHTTP req ("TESTING" :: Text) (const Nothing) + resEither `shouldSatisfy` isRight + let code = getResponseCode $ fromRight (error "res is left") resEither + code `shouldBe` 426 + it "server certificates with unknown CA gets rejected" $ \ rt -> do + let req = T.httpGet $ "https://localhost:" <> show port + resEither <- runFlow rt $ callHTTP req ("TESTING" :: Text) (const Nothing) + resEither `shouldSatisfy` isLeft + (fromLeft' resEither) `shouldSatisfy` (\m -> Text.count "certificate has unknown CA" m == 1) + it "validate server certificate with custom CA" $ \ _ -> do + rt <- initRTWithManagers + let req = T.httpGet $ "https://localhost:" <> show port + resEither <- runFlow rt $ callHTTP' (Just "tlsWithCustomCA") req ("TESTING" :: Text) (const Nothing) Nothing + resEither `shouldSatisfy` isRight + let code = getResponseCode $ fromRight (error "res is left") resEither + code `shouldBe` 404 + + describe "TLS client authentication with untyped API" $ do + around_ withClientTlsAuthServer $ do + it "server rejects clients without a certificate" $ \ _ -> do + rt <- initRTWithManagers + let req = T.httpGet $ "https://localhost:" <> show port + resEither <- runFlow rt $ callHTTP' (Just "manager1") req ("TESTING" :: Text) (const Nothing) Nothing + resEither `shouldSatisfy` isLeft + it "authenticate client by a certificate" $ \ _ -> do + rt <- initRTWithManagers + let req = T.httpGet $ "https://localhost:" <> show port + resEither <- runFlow rt $ callHTTP' (Just "tlsWithClientCertAndCustomCA") req ("TESTING" :: Text) (const Nothing) Nothing + resEither `shouldSatisfy` isRight + let code = getResponseCode $ fromRight (error "res is left") resEither + code `shouldBe` 404 + + describe "calling external TLS services with well-typed API" $ do + around_ withSecureServer $ do + it "calling secure service using unsecured protocol fails" $ \ _ -> do + rt <- initRTWithManagers + let url = BaseUrl Http "localhost" port "" + bookEither <- runFlow rt $ callAPI' (Just "manager1") url ("TESTING" :: Text) (const Nothing) getBook + bookEither `shouldSatisfy` isLeft + it "server certificates with unknown CA gets rejected" $ \ _ -> do + rt <- initRTWithManagers + let url = BaseUrl Https "localhost" port "" + bookEither <- runFlow rt $ callAPI' (Just "manager1") url ("TESTING" :: Text) (const Nothing) getBook + bookEither `shouldSatisfy` isLeft + it "validate server certificate with custom CA" $ \ _ -> do + rt <- initRTWithManagers + let url = BaseUrl Https "localhost" port "" + bookEither <- runFlow rt $ callAPI' (Just "tlsWithCustomCA") url ("TESTING" :: Text) (const Nothing) getBook + bookEither `shouldSatisfy` isRight + + describe "TLS client authentication" $ do + around_ withClientTlsAuthServer $ do + it "server rejects clients without a certificate" $ \ _ -> do + rt <- initRTWithManagers + let url = BaseUrl Https "localhost" externalServerPort "" + bookEither <- runFlow rt $ callAPI' (Just "manager1") url ("TESTING" :: Text) (const Nothing) getBook + bookEither `shouldSatisfy` isLeft + it "authenticate client by a certificate" $ \ _ -> do + rt <- initRTWithManagers + let url = BaseUrl Https "localhost" externalServerPort "" + bookEither <- runFlow rt $ callAPI' (Just "tlsWithClientCertAndCustomCA") url ("TESTING" :: Text) (const Nothing) getBook + bookEither `shouldSatisfy` isRight + + it "authenticate client by a ad-hoc certificate using callHTTPWithCert without custom CA store, with cert" $ \ rt -> do + let req = T.httpGet $ "https://localhost:" <> show externalServerPort + cert <- clientHttpCert + resEither <- runFlow rt $ L.callHTTPWithCert req ("TESTING" :: Text) (const Nothing) $ Just cert + resEither `shouldSatisfy` isLeft + (fromLeft' resEither) `shouldSatisfy` (\m -> Text.count "certificate has unknown CA" m == 1) + + it "authenticate client by a ad-hoc certificate using callHTTPWithCert without custom CA store, without cert" $ \ rt -> do + let req = T.httpGet $ "https://localhost:" <> show externalServerPort + resEither <- runFlow rt $ L.callHTTPWithCert req ("TESTING" :: Text) (const Nothing) Nothing + resEither `shouldSatisfy` isLeft + (fromLeft' resEither) `shouldSatisfy` (\m -> Text.count "certificate has unknown CA" m == 1) + + it "authenticate client by an ad-hoc certificate with callHTTP" $ \ rt -> do + let req = T.httpGet $ "https://localhost:" <> show externalServerPort + cert <- clientHttpCert + store <- fromJust <$> readCertificateStore "test/tls/ca-certificates" + resEither <- runFlow rt $ do + -- Here we call getHTTPManager twice as a smoke test for LRU cache, + -- Eq and Ord insatnces for CertificateStore' + let settings = T.withClientTls cert <> T.withCustomCA store + mgr <- L.getHTTPManager settings + _ <- L.getHTTPManager settings + L.callHTTPUsingManager mgr req ("TESTING" :: Text) (const Nothing) Nothing + resEither `shouldSatisfy` isRight + + it "authenticate client by an ad-hoc certificate with callAPI" $ \ rt -> do + cert <- clientHttpCert + store <- fromJust <$> readCertificateStore "test/tls/ca-certificates" + resEither <- runFlow rt $ do + -- Here we call getHTTPManager twice as a smoke test for LRU cache, + -- Eq and Ord insatnces for CertificateStore' + let settings = T.withClientTls cert <> T.withCustomCA store + mgr <- L.getHTTPManager settings + _ <- L.getHTTPManager settings + let url = BaseUrl Https "localhost" externalServerPort "" + L.callAPIUsingManager mgr url ("TESTING" :: Text) (const Nothing) getBook + resEither `shouldSatisfy` isRight + describe "runIO tests" $ do it "RunIO" $ \rt -> do result <- runFlow rt $ runIO (pure ("hi" :: String)) @@ -145,6 +252,22 @@ spec loggerCfg = do it "RunUntracedIO" $ \rt -> do result <- runFlow rt $ runIO (pure ("hi" :: String)) result `shouldBe` "hi" + describe "withRunFlow" $ do + it "works" $ \rt -> do + let withResource :: (Int -> IO a) -> IO a + withResource act = do + threadDelay 10 + act 42 + + action :: Int -> Flow Int + action res = runIO $ do + threadDelay 10 + pure res + result <- runFlow rt $ do + L.withRunFlow $ \run -> do + withResource $ \res -> do + run (action res) + result `shouldBe` 42 describe "STM tests" $ do it "STM Test" $ \rt -> do result <- runFlow rt $ do @@ -165,6 +288,7 @@ spec loggerCfg = do _ <- await Nothing awaitable1 >> await Nothing awaitable2 runIO $ readTVarIO countVar result `shouldBe` 100 + describe "Options" $ do it "One key" $ \rt -> do result <- runFlow rt $ do @@ -268,6 +392,7 @@ spec loggerCfg = do result <- runFlow rt $ runSysCmd "echo test" result `shouldBe` "test\n" it "RunSysCmd with bad command" $ \rt -> do + putStrLn ("" :: Text) result <- E.catch (runFlow rt $ runSysCmd "badEcho test") (\e -> do let err = show (e :: E.SomeException) @@ -285,6 +410,7 @@ spec loggerCfg = do (\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 @@ -353,29 +479,8 @@ spec loggerCfg = do 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/language/HttpAPISpec.hs b/test/language/HttpAPISpec.hs new file mode 100644 index 00000000..c0b02707 --- /dev/null +++ b/test/language/HttpAPISpec.hs @@ -0,0 +1,41 @@ +{-# OPTIONS_GHC -Wwarn=deprecations #-} + +module HttpAPISpec (spec) where + +import EulerHS.Prelude hiding (get, getOption) +import Test.Hspec (Spec, describe, it, shouldBe) +import qualified EulerHS.Types as T +import qualified Data.Map as Map + +spec :: Spec +spec = do + describe "Building HTTP requests" $ do + it "building a JSON request" $ do + let req = T.httpGet "http://localhost:8080/" & + T.withJSONBody @String "foo" + let req' = defRequest + { T.getRequestHeaders = Map.singleton "content-type" "application/json" + , T.getRequestBody = Just $ T.LBinaryString "\"foo\"" + } + req `shouldBe` req' + + it "building a Form-based request" $ do + let req = T.httpGet "http://localhost:8080/" & + T.withFormBody + [ ("foo", "bar") + , ("baz", "qux") + ] + let req' = defRequest + { T.getRequestBody = Just $ T.LBinaryString "foo=bar&baz=qux" + } + req `shouldBe` req' + + where + defRequest = T.HTTPRequest + { getRequestMethod = T.Get + , getRequestHeaders = Map.empty + , getRequestBody = Nothing + , getRequestURL = "http://localhost:8080/" + , getRequestTimeout = Just T.defaultTimeout + , getRequestRedirects = Just 10 + } \ No newline at end of file diff --git a/test/language/KVDBArtSpec.hs b/test/language/KVDBArtSpec.hs new file mode 100644 index 00000000..db5e4b7a --- /dev/null +++ b/test/language/KVDBArtSpec.hs @@ -0,0 +1,3 @@ +module KVDBArtSpec + ( + ) where diff --git a/test/language/Main.hs b/test/language/Main.hs new file mode 100644 index 00000000..44b2d3db --- /dev/null +++ b/test/language/Main.hs @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -Werror #-} + +module Main (main) where + + +import EulerHS.Prelude hiding (bracket) +import qualified EulerHS.Types as T +import qualified MaskingSpec as MaskSpec +import qualified FlowSpec as Flow +import qualified HttpAPISpec as HttpAPISpec +import Test.Hspec.Core.Runner + +main :: IO () +main = do + + hspecWith defaultConfig{ configPrintCpuTime = True, configColorMode = ColorAlways} $ do + HttpAPISpec.spec + MaskSpec.spec + Flow.spec logsDisabled + + where + logsDisabled :: Maybe T.LoggerConfig + logsDisabled = Nothing + + diff --git a/test/EulerHS/Tests/Framework/MaskingSpec.hs b/test/language/MaskingSpec.hs similarity index 55% rename from test/EulerHS/Tests/Framework/MaskingSpec.hs rename to test/language/MaskingSpec.hs index 5ed29a0a..6eaf0852 100644 --- a/test/EulerHS/Tests/Framework/MaskingSpec.hs +++ b/test/language/MaskingSpec.hs @@ -1,6 +1,8 @@ -module EulerHS.Tests.Framework.MaskingSpec (spec) where +module MaskingSpec (spec) where import EulerHS.Prelude hiding (readFile) +import qualified Data.Aeson as A +import Data.Aeson ((.=)) import qualified Data.ByteString.Lazy as LBS import qualified EulerHS.Types as CType import qualified Data.HashSet as HashSet @@ -33,21 +35,25 @@ spec = 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 :: A.Value +expectedOutput = A.object + [ ] -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' :: A.Value +expectedOutput' = A.object + [ ] + +expectedOutput'' :: A.Value +expectedOutput'' = A.object + [ ] + +expectedOutput''' :: A.Value +expectedOutput''' = A.String "Logging Not Support For this content application/html" -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}}" +inputJSON = "" makeLogMaskingConfig :: CType.MaskKeyType -> [Text] -> Text -> CType.LogMaskingConfig makeLogMaskingConfig keyType keyList maskText = @@ -55,4 +61,4 @@ makeLogMaskingConfig keyType keyList maskText = { _maskKeys = HashSet.fromList keyList , _maskText = Just maskText , _keyType = keyType - } \ No newline at end of file + } diff --git a/test/language/PubSubSpec.hs b/test/language/PubSubSpec.hs new file mode 100644 index 00000000..88201572 --- /dev/null +++ b/test/language/PubSubSpec.hs @@ -0,0 +1,4 @@ +module PubSubSpec + ( + ) where + diff --git a/test/EulerHS/Tests/Framework/SQLArtSpec.hs b/test/language/SQLArtSpec.hs similarity index 61% rename from test/EulerHS/Tests/Framework/SQLArtSpec.hs rename to test/language/SQLArtSpec.hs index fe87d3f1..59da278e 100644 --- a/test/EulerHS/Tests/Framework/SQLArtSpec.hs +++ b/test/language/SQLArtSpec.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE StandaloneDeriving #-} -module EulerHS.Tests.Framework.SQLArtSpec +module SQLArtSpec ( - -- spec ) where diff --git a/test/EulerHS/TestData/Scenarios/Scenario1.hs b/test/language/Scenario1.hs similarity index 82% rename from test/EulerHS/TestData/Scenarios/Scenario1.hs rename to test/language/Scenario1.hs index c0bafb79..3b46ae4a 100644 --- a/test/EulerHS/TestData/Scenarios/Scenario1.hs +++ b/test/language/Scenario1.hs @@ -1,11 +1,11 @@ {-# OPTIONS_GHC -fno-warn-deprecations -Werror #-} -module EulerHS.TestData.Scenarios.Scenario1 +module Scenario1 ( mkUrl, testScenario1 ) where -import EulerHS.TestData.API.Client (User (User), getUser, port, userGUID) +import Client (User (User), getUser, port, userGUID) import Data.Text (pack) import EulerHS.Language import EulerHS.Prelude hiding (getOption, pack) @@ -21,7 +21,7 @@ testScenario1 = do localGUID <- runIO (undefined :: IO Text) guid <- generateGUID url <- maybe (mkUrl "localhost") mkUrl <$> getOption UrlKey - res <- callServantAPI Nothing url getUser + res <- callServantAPI Nothing url ("TESTING" :: Text) (const Nothing) getUser case res of Right u -> if localGUID /= userGUID u then pure u else pure $ User localUserName "" guid diff --git a/testDB/KVDB/KVDBSpec.hs b/testDB/KVDB/KVDBSpec.hs index dd32512c..bd0ed749 100644 --- a/testDB/KVDB/KVDBSpec.hs +++ b/testDB/KVDB/KVDBSpec.hs @@ -1,15 +1,17 @@ module KVDB.KVDBSpec where -import Test.Hspec hiding (runIO) - import EulerHS.Interpreters import qualified EulerHS.Language as L import EulerHS.Prelude import EulerHS.Runtime import qualified EulerHS.Types as T +import Test.Hspec hiding (runIO) +import Prelude (head) -redisName = "eulerKVDB" +redisName :: Text +redisName = "db" +redisCfg :: T.KVDBConfig redisCfg = T.mkKVDBConfig redisName T.defaultKVDBConnConfig spec :: Spec @@ -23,17 +25,18 @@ spec = eConn1 <- L.initKVDBConnection redisCfg eConn2 <- L.initKVDBConnection redisCfg 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 $ "Failed to connect 1st time: " <> show @Text err + (_, Left (T.KVDBError T.KVDBConnectionAlreadyExists _)) -> pure $ Right () (_, Left err) -> pure $ Left $ "Unexpected error type on 2nd connect: " <> show err + _ -> pure . Left $ "Double connection somehow worked" eRes `shouldBe` Right () it "Get uninialized connection should fail" $ \rt -> do eRes <- runFlow rt $ do eConn <- L.getKVDBConnection redisCfg case eConn of - Left (T.KVDBError T.KVDBConnectionDoesNotExist msg) -> pure $ Right () - Left err -> pure $ Left $ "Unexpected error: " <> show err + Left (T.KVDBError T.KVDBConnectionDoesNotExist _) -> pure $ Right () + Left err -> pure $ Left $ "Unexpected error: " <> show @Text err Right _ -> pure $ Left "Unexpected connection success" eRes `shouldBe` Right () @@ -42,7 +45,7 @@ spec = eConn1 <- L.initKVDBConnection redisCfg eConn2 <- L.getKVDBConnection redisCfg case (eConn1, eConn2) of - (Left err, _) -> pure $ Left $ "Failed to connect: " <> show err + (Left err, _) -> pure $ Left $ "Failed to connect: " <> show @Text err (_, Left err) -> pure $ Left $ "Unexpected error on get connection: " <> show err _ -> pure $ Right () eRes `shouldBe` Right () @@ -53,7 +56,7 @@ spec = eConn2 <- L.getKVDBConnection redisCfg eConn3 <- L.getKVDBConnection redisCfg case (eConn1, eConn2, eConn3) of - (Left err, _, _) -> pure $ Left $ "Failed to connect: " <> show err + (Left err, _, _) -> pure $ Left $ "Failed to connect: " <> show @Text err (_, Left err, _) -> pure $ Left $ "Unexpected error on 1st get connection: " <> show err (_, _, Left err) -> pure $ Left $ "Unexpected error on 2nd get connection: " <> show err _ -> pure $ Right () @@ -63,7 +66,7 @@ spec = eRes <- runFlow rt $ do eConn <- L.getOrInitKVDBConn redisCfg case eConn of - Left err -> pure $ Left $ "Failed to connect: " <> show err + Left err -> pure $ Left $ "Failed to connect: " <> show @Text err _ -> pure $ Right () eRes `shouldBe` Right () @@ -83,12 +86,12 @@ spec = case eConn of Left err -> error $ "Failed to get prepared connection: " <> show err - Right conn -> do + Right _ -> do let hour = 60 * 60 L.runKVDB redisName $ do - L.setex key hour value + _ <- L.setex key hour value res <- L.get key - L.del [key] + _ <- L.del [key] pure res result `shouldBe` Right (Just value) @@ -100,8 +103,8 @@ spec = case eConn of Left err -> error $ "Failed to get prepared connection: " <> show err - Right conn -> do - L.rSetB redisName key value + Right _ -> do + _ <- L.rSetB redisName key value L.rGetB redisName key result `shouldBe` Just value @@ -113,8 +116,8 @@ spec = case eConn of Left err -> error $ "Failed to get prepared connection: " <> show err - Right conn -> do - L.rSetT redisName key value + Right _ -> do + _ <- L.rSetT redisName key value L.rGetT redisName key result `shouldBe` Just value @@ -126,8 +129,8 @@ spec = case eConn of Left err -> error $ "Failed to get prepared connection: " <> show err - Right conn -> do - L.rSet redisName key value + Right _ -> do + _ <- L.rSet redisName key value L.rGet redisName key result `shouldBe` Just value it "Redis set functions" $ \rt -> do @@ -138,7 +141,7 @@ spec = case eConn of Left err -> error $ "Failed to get prepared connection: " <> show err - Right conn -> do + Right _ -> do void $ L.rSadd redisName key value L.rSismember redisName key (head value) - result `shouldBe` (Right True) + result `shouldBe` Right True diff --git a/testDB/Main.hs b/testDB/Main.hs index f398b1cf..8ef74718 100644 --- a/testDB/Main.hs +++ b/testDB/Main.hs @@ -1,11 +1,12 @@ module Main where import EulerHS.Prelude -import Test.Hspec - -import qualified SQLDB.Tests.SQLiteDBSpec as SQLiteDB import qualified SQLDB.Tests.QueryExamplesSpec as Ex +import qualified SQLDB.Tests.SQLiteDBSpec as SQLiteDB +import Test.Hspec (hspec) +main :: IO () main = hspec $ do SQLiteDB.spec Ex.spec + diff --git a/testDB/SQLDB/TestData/Connections.hs b/testDB/SQLDB/TestData/Connections.hs index 0fa0b390..4b449895 100644 --- a/testDB/SQLDB/TestData/Connections.hs +++ b/testDB/SQLDB/TestData/Connections.hs @@ -1,24 +1,24 @@ -module SQLDB.TestData.Connections where +{-# LANGUAGE ScopedTypeVariables #-} -import EulerHS.Prelude +module SQLDB.TestData.Connections where import EulerHS.Interpreters import qualified EulerHS.Language as L +import EulerHS.Prelude import EulerHS.Runtime (withFlowRuntime) import qualified EulerHS.Runtime as R import qualified EulerHS.Types as T - connectOrFail :: T.DBConfig beM -> L.Flow (T.SqlConn beM) connectOrFail cfg = L.initSqlDBConnection cfg >>= \case Left e -> error $ show e -- L.throwException $ toException $ show e Right conn -> pure conn testDBName :: String -testDBName = "./test/EulerHS/TestData/test.db" +testDBName = "" testDBTemplateName :: String -testDBTemplateName = "./test/EulerHS/TestData/test.db.template" +testDBTemplateName = "" rmTestDB :: L.Flow () rmTestDB = void $ L.runSysCmd $ "rm -f " <> testDBName diff --git a/testDB/SQLDB/TestData/Scenarios/MySQL.hs b/testDB/SQLDB/TestData/Scenarios/MySQL.hs index 05cefb7a..a22ec778 100644 --- a/testDB/SQLDB/TestData/Scenarios/MySQL.hs +++ b/testDB/SQLDB/TestData/Scenarios/MySQL.hs @@ -1,24 +1,21 @@ -module SQLDB.TestData.Scenarios.MySQL where - -import EulerHS.Prelude - -import qualified EulerHS.Language as L -import qualified EulerHS.Types as T +{-# LANGUAGE RecordWildCards #-} -import SQLDB.TestData.Connections (connectOrFail) -import SQLDB.TestData.Types +module SQLDB.TestData.Scenarios.MySQL where import Database.Beam ((<-.), (==.)) import qualified Database.Beam as B import qualified Database.Beam.MySQL as BM - +import qualified EulerHS.Language as L +import EulerHS.Prelude +import qualified EulerHS.Types as T +import SQLDB.TestData.Types uniqueConstraintViolationDbScript :: T.DBConfig BM.MySQLM -> L.Flow (T.DBResult ()) uniqueConstraintViolationDbScript dbcfg = do econn <- L.getSqlDBConnection dbcfg flip (either $ error "Unable to get connection") econn $ \conn -> do - L.runDB conn $ + _ <- L.runDB conn $ L.insertRows $ B.insert (_users eulerDb) $ B.insertValues [User 2 "Rosa" "Rosa"] @@ -48,7 +45,7 @@ uniqueConstraintViolationMickeyDbScript dbcfg = do econn <- L.getSqlDBConnection dbcfg flip (either $ error "Unable to get connection") econn $ \conn -> do - L.runDB conn $ + _ <- L.runDB conn $ L.insertRows $ B.insert (_users eulerDb) $ B.insertValues [User 4 "Mickey" "Mouse"] @@ -74,7 +71,7 @@ throwExceptionFlowScript dbcfg = do $ B.insert (_users eulerDb) $ B.insertValues [User 6 "Billy" "Evil"] - L.sqlThrowException ThisException + _ <- L.sqlThrowException ThisException L.insertRows $ B.insert (_users eulerDb) @@ -118,7 +115,7 @@ selectRowDbScript userId dbcfg = do flip (either $ error "Unable to get connection") econn $ \conn -> L.runDB conn $ do - let predicate User {..} = _userId ==. (B.val_ userId) + let predicate User {..} = _userId ==. B.val_ userId L.findRow $ B.select $ B.limit_ 1 @@ -131,7 +128,7 @@ selectOneDbScript dbcfg = do econn <- L.getSqlDBConnection dbcfg flip (either $ error "Unable to get connection") econn $ \conn -> do - L.runDB conn + _ <- L.runDB conn $ L.insertRows $ B.insert (_users eulerDb) $ B.insertExpressions (mkUser <$> susers) diff --git a/testDB/SQLDB/TestData/Scenarios/Postgres.hs b/testDB/SQLDB/TestData/Scenarios/Postgres.hs index a86b8b54..51e90dc1 100644 --- a/testDB/SQLDB/TestData/Scenarios/Postgres.hs +++ b/testDB/SQLDB/TestData/Scenarios/Postgres.hs @@ -1,17 +1,14 @@ -module SQLDB.TestData.Scenarios.Postgres where - -import EulerHS.Prelude - -import qualified EulerHS.Language as L -import qualified EulerHS.Types as T +{-# LANGUAGE RecordWildCards #-} -import SQLDB.TestData.Connections (connectOrFail) -import SQLDB.TestData.Types +module SQLDB.TestData.Scenarios.Postgres where import Database.Beam ((<-.), (==.)) import qualified Database.Beam as B import qualified Database.Beam.Postgres as BP - +import qualified EulerHS.Language as L +import EulerHS.Prelude +import qualified EulerHS.Types as T +import SQLDB.TestData.Types -- Scenarios @@ -20,7 +17,7 @@ uniqueConstraintViolationDbScript dbcfg = do econn <- L.getSqlDBConnection dbcfg flip (either $ error "Unable to get connection") econn $ \conn -> do - L.runDB conn + _ <- L.runDB conn $ L.insertRows $ B.insert (_users eulerDb) $ B.insertValues [User 2 "Eve" "Beon"] @@ -50,7 +47,7 @@ selectOneDbScript dbcfg = do econn <- L.getSqlDBConnection dbcfg flip (either $ error "Unable to get connection") econn $ \conn -> do - L.runDB conn + _ <- L.runDB conn $ L.insertRows $ B.insert (_users eulerDb) $ B.insertExpressions (mkUser <$> susers) diff --git a/testDB/SQLDB/TestData/Scenarios/SQLite.hs b/testDB/SQLDB/TestData/Scenarios/SQLite.hs index f52cb341..b58477be 100644 --- a/testDB/SQLDB/TestData/Scenarios/SQLite.hs +++ b/testDB/SQLDB/TestData/Scenarios/SQLite.hs @@ -1,31 +1,29 @@ -module SQLDB.TestData.Scenarios.SQLite where +{-# LANGUAGE RecordWildCards #-} -import EulerHS.Prelude +module SQLDB.TestData.Scenarios.SQLite where +import Database.Beam ((/=.), (<-.), (==.)) +import qualified Database.Beam as B +import qualified Database.Beam.Sqlite as BS import qualified EulerHS.Language as L +import EulerHS.Prelude import qualified EulerHS.Types as T - import SQLDB.TestData.Connections import SQLDB.TestData.Types -import Database.Beam ((/=.), (<-.), (==.)) -import qualified Database.Beam as B -import qualified Database.Beam.Sqlite as BS - - -- Scenarios deleteTestValues :: T.DBConfig BS.SqliteM -> L.Flow () deleteTestValues cfg = do - conn <- connectOrFail cfg -- $ T.mkSQLiteConfig testDBName + conn <- connectOrFail cfg void $ L.runDB conn $ L.deleteRows $ B.delete (_users eulerDb) (\u -> _userId u /=. B.val_ 0) void $ L.runDB conn $ L.updateRows $ B.update (_sqlite_sequence sqliteSequenceDb) - (\(SqliteSequence {..}) -> mconcat [_seq <-. B.val_ 0]) - (\(SqliteSequence {..}) -> _name ==. B.val_ "users") + (\SqliteSequence {..} -> mconcat [_seq <-. B.val_ 0]) + (\SqliteSequence {..} -> _name ==. B.val_ "users") insertTestValues :: T.DBConfig BS.SqliteM -> L.Flow () insertTestValues cfg = do @@ -47,7 +45,7 @@ uniqueConstraintViolationDbScript :: T.DBConfig BS.SqliteM -> L.Flow (T.DBResult uniqueConstraintViolationDbScript cfg = do connection <- connectOrFail cfg - L.runDB connection + _ <- L.runDB connection $ L.insertRows $ B.insert (_users eulerDb) $ B.insertValues [User 1 "Eve" "Beon"] diff --git a/testDB/SQLDB/TestData/Types.hs b/testDB/SQLDB/TestData/Types.hs index 2740b697..ad4a2cd9 100644 --- a/testDB/SQLDB/TestData/Types.hs +++ b/testDB/SQLDB/TestData/Types.hs @@ -1,16 +1,16 @@ +{-# OPTIONS_GHC -fclear-plugins #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE StandaloneDeriving #-} module SQLDB.TestData.Types where +import qualified Database.Beam as B +import Database.Beam.Backend.SQL (BeamSqlBackend) import EulerHS.Prelude import qualified EulerHS.Types as T -import qualified Database.Beam as B - --- sqlite3 db --- CREATE TABLE users (id INTEGER PRIMARY KEY AUTOINCREMENT, first_name VARCHAR NOT NULL, last_name VARCHAR NOT NULL); data UserT f = User { _userId :: B.C f Int , _userFirstName :: B.C f Text @@ -24,7 +24,6 @@ instance B.Table UserT where type User = UserT Identity - type UserId = B.PrimaryKey UserT Identity deriving instance Show User @@ -32,9 +31,10 @@ deriving instance Eq User deriving instance ToJSON User deriving instance FromJSON User -data EulerDb f = EulerDb +newtype EulerDb f = EulerDb { _users :: f (B.TableEntity UserT) - } deriving (Generic, B.Database be) + } deriving stock (Generic) + deriving anyclass (B.Database be) eulerDb :: B.DatabaseSettings be EulerDb eulerDb = B.defaultDbSettings @@ -53,14 +53,14 @@ instance B.Table SqliteSequenceT where type SqliteSequence = SqliteSequenceT Identity type SqliteSequenceId = B.PrimaryKey SqliteSequenceT Identity -data SqliteSequenceDb f = SqliteSequenceDb +newtype SqliteSequenceDb f = SqliteSequenceDb { _sqlite_sequence :: f (B.TableEntity SqliteSequenceT) - } deriving (Generic, B.Database be) + } deriving stock (Generic) + deriving anyclass (B.Database be) sqliteSequenceDb :: B.DatabaseSettings be SqliteSequenceDb sqliteSequenceDb = B.defaultDbSettings - data SimpleUser = SimpleUser {first :: Text, last :: Text} susers :: [SimpleUser] @@ -69,8 +69,14 @@ susers = , SimpleUser "Doe" "John" ] -mkUser SimpleUser {..} = User B.default_ (B.val_ first) (B.val_ last) - +mkUser :: + (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 first' last') = 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 diff --git a/testDB/SQLDB/TestData/query_examples.db.template b/testDB/SQLDB/TestData/query_examples.db.template deleted file mode 100644 index e22c2028..00000000 Binary files a/testDB/SQLDB/TestData/query_examples.db.template and /dev/null differ diff --git a/testDB/SQLDB/Tests/MySQLDBSpec.hs b/testDB/SQLDB/Tests/MySQLDBSpec.hs index 1deace99..c09608fe 100644 --- a/testDB/SQLDB/Tests/MySQLDBSpec.hs +++ b/testDB/SQLDB/Tests/MySQLDBSpec.hs @@ -1,24 +1,30 @@ +{-# LANGUAGE RecordWildCards #-} + module SQLDB.Tests.MySQLDBSpec where +import Database.Beam.MySQL (MySQLM) +import Database.MySQL.Base () +import EulerHS.Extra.Test (withMysqlDb) +import EulerHS.Interpreters (runFlow) +import EulerHS.Language (initSqlDBConnection) import EulerHS.Prelude - -import EulerHS.Interpreters -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 Test.Hspec hiding (runIO) - -import qualified Database.Beam.MySQL as BM -import Database.MySQL.Base -import EulerHS.Language +import EulerHS.Runtime (withFlowRuntime) import qualified EulerHS.Types as T -import System.Process - -import EulerHS.Extra.Test +import Prelude (head, (!!)) +import SQLDB.TestData.Scenarios.MySQL (insertAndSelectWithinOneConnectionScript, + insertReturningScript, + selectOneDbScript, + selectRowDbScript, + selectUnknownDbScript, + throwExceptionFlowScript, + uniqueConstraintViolationDbScript, + uniqueConstraintViolationEveDbScript, + uniqueConstraintViolationMickeyDbScript, + updateAndSelectDbScript) +import SQLDB.TestData.Types (UserT (User), someUser, _userFirstName, + _userId, _userLastName) +import System.Process () +import Test.Hspec hiding (runIO) testDBName :: String @@ -34,7 +40,7 @@ mySQLCfg = T.MySQLConfig , connectOptions = [T.CharsetName "utf8"] , connectPath = "" , connectSSL = Nothing - , connectCharset = Latin1 + , connectCharset = T.Latin1 } mySQLRootCfg :: T.MySQLConfig @@ -48,15 +54,18 @@ mySQLRootCfg = where T.MySQLConfig {..} = mySQLCfg +mkMysqlConfig :: T.MySQLConfig -> T.DBConfig MySQLM mkMysqlConfig = T.mkMySQLConfig "eulerMysqlDB" +poolConfig :: T.PoolConfig poolConfig = T.PoolConfig { stripes = 1 , keepAlive = 10 , resourcesPerStripe = 50 } -mkMysqlPoolConfig mySQLCfg = mkMySQLPoolConfig "eulerMysqlDB" mySQLCfg poolConfig +mkMysqlPoolConfig :: T.MySQLConfig -> T.DBConfig MySQLM +mkMysqlPoolConfig mySQLCfg' = T.mkMySQLPoolConfig "eulerMysqlDB" mySQLCfg' poolConfig spec :: Spec spec = do @@ -64,9 +73,9 @@ spec = do it "Unique Constraint Violation" $ \rt -> do eRes <- runFlow rt $ uniqueConstraintViolationDbScript dbCfg eRes `shouldBe` - ( Left $ DBError - ( SQLError $ MysqlError $ - MysqlSqlError + Left (T.DBError + ( T.SQLError $ T.MysqlError $ + T.MysqlSqlError { errCode = 1062 , errMsg = "Duplicate entry '2' for key 'PRIMARY'" } @@ -86,7 +95,7 @@ spec = do it "First insert success, last insert resolved on DB side (Mickey)" $ \rt -> do _ <- runFlow rt $ uniqueConstraintViolationMickeyDbScript dbCfg eRes <- runFlow rt $ selectRowDbScript 4 dbCfg - eRes `shouldSatisfy` (someUser "Mickey" "Mouse") + eRes `shouldSatisfy` someUser "Mickey" "Mouse" it "Txn should be completely rollbacked on exception (Billy)" $ \rt -> do _ <- runFlow rt $ throwExceptionFlowScript dbCfg @@ -96,19 +105,19 @@ spec = do it "Insert and Select in one db connection (Milky way)" $ \rt -> do eRes <- runFlow rt $ insertAndSelectWithinOneConnectionScript dbCfg - eRes `shouldSatisfy` (someUser "Milky" "Way") + eRes `shouldSatisfy` someUser "Milky" "Way" it "Select one, row not found" $ \rt -> do eRes <- runFlow rt $ selectUnknownDbScript dbCfg - eRes `shouldBe` (Right Nothing) + eRes `shouldBe` Right Nothing it "Select one, row found" $ \rt -> do eRes <- runFlow rt $ selectOneDbScript dbCfg - eRes `shouldSatisfy` (someUser "John" "Doe") + eRes `shouldSatisfy` someUser "John" "Doe" it "Update / Select, row found & changed" $ \rt -> do eRes <- runFlow rt $ updateAndSelectDbScript dbCfg - eRes `shouldSatisfy` (someUser "Leo" "San") + eRes `shouldSatisfy` someUser "Leo" "San" it "Insert returning should return list of rows" $ \rt -> do eRes <- runFlow rt $ insertReturningScript dbCfg @@ -117,7 +126,7 @@ spec = do Left _ -> expectationFailure "Left DBResult" Right us -> do length us `shouldBe` 2 - let u1 = us !! 0 + let u1 = head us let u2 = us !! 1 _userFirstName u1 `shouldBe` "John" diff --git a/testDB/SQLDB/Tests/PostgresDBSpec.hs b/testDB/SQLDB/Tests/PostgresDBSpec.hs index ce1c44fc..90c37c0d 100644 --- a/testDB/SQLDB/Tests/PostgresDBSpec.hs +++ b/testDB/SQLDB/Tests/PostgresDBSpec.hs @@ -1,22 +1,20 @@ +{-# LANGUAGE RecordWildCards #-} + module SQLDB.Tests.PostgresDBSpec where +import Database.Beam.Postgres (Pg) +import EulerHS.Extra.Test (preparePostgresDB) +import EulerHS.Interpreters (runFlow) +import EulerHS.Language () import EulerHS.Prelude - -import EulerHS.Interpreters import EulerHS.Runtime (withFlowRuntime) -import EulerHS.Types hiding (error) import qualified EulerHS.Types as T - -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 SQLDB.TestData.Scenarios.Postgres (selectOneDbScript, + selectUnknownDbScript, + uniqueConstraintViolationDbScript, + updateAndSelectDbScript) +import SQLDB.TestData.Types (someUser) +import System.Process () import Test.Hspec hiding (runIO) -- Configurations @@ -30,7 +28,6 @@ pgCfg = T.PostgresConfig , connectDatabase = "euler_test_db" -- String } - pgRootCfg :: T.PostgresConfig pgRootCfg = T.PostgresConfig @@ -42,31 +39,34 @@ pgRootCfg = where T.PostgresConfig {..} = pgCfg -mkPgCfg = mkPostgresConfig "eulerPGDB" +mkPgCfg :: T.PostgresConfig -> T.DBConfig Pg +mkPgCfg = T.mkPostgresConfig "eulerPGDB" +poolConfig :: T.PoolConfig poolConfig = T.PoolConfig { stripes = 1 , keepAlive = 10 , resourcesPerStripe = 50 } -mkPgPoolCfg cfg = mkPostgresPoolConfig "eulerPGDB" cfg poolConfig +mkPgPoolCfg :: T.PostgresConfig -> T.DBConfig Pg +mkPgPoolCfg cfg = T.mkPostgresPoolConfig "eulerPGDB" cfg poolConfig -- Tests spec :: Spec spec = do let - test pgCfg = do + test pgCfg' = do it "Unique Constraint Violation" $ \rt -> do - eRes <- runFlow rt $ uniqueConstraintViolationDbScript pgCfg + eRes <- runFlow rt $ uniqueConstraintViolationDbScript pgCfg' eRes `shouldBe` - ( Left $ DBError - ( SQLError $ PostgresError $ - PostgresSqlError + Left (T.DBError + ( T.SQLError $ T.PostgresError $ + T.PostgresSqlError { sqlState = "23505" - , sqlExecStatus = PostgresFatalError + , sqlExecStatus = T.PostgresFatalError , sqlErrorMsg = "duplicate key value violates unique constraint \"users_pkey\"" , sqlErrorDetail = "Key (id)=(2) already exists." , sqlErrorHint = "" @@ -76,16 +76,16 @@ spec = do ) it "Select one, row not found" $ \rt -> do - eRes <- runFlow rt $ selectUnknownDbScript pgCfg - eRes `shouldBe` (Right Nothing) + eRes <- runFlow rt $ selectUnknownDbScript pgCfg' + eRes `shouldBe` Right Nothing it "Select one, row found" $ \rt -> do - eRes <- runFlow rt $ selectOneDbScript pgCfg - eRes `shouldSatisfy` (someUser "John" "Doe") + eRes <- runFlow rt $ selectOneDbScript pgCfg' + eRes `shouldSatisfy` someUser "John" "Doe" it "Update / Select, row found & changed" $ \rt -> do - eRes <- runFlow rt $ updateAndSelectDbScript pgCfg - eRes `shouldSatisfy` (someUser "Leo" "San") + eRes <- runFlow rt $ updateAndSelectDbScript pgCfg' + eRes `shouldSatisfy` someUser "Leo" "San" let prepare pgCfgToDbCfg = preparePostgresDB diff --git a/testDB/SQLDB/Tests/QueryExamplesSpec.hs b/testDB/SQLDB/Tests/QueryExamplesSpec.hs index 807f0ea9..08d6533e 100644 --- a/testDB/SQLDB/Tests/QueryExamplesSpec.hs +++ b/testDB/SQLDB/Tests/QueryExamplesSpec.hs @@ -1,31 +1,23 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} module SQLDB.Tests.QueryExamplesSpec where - -import Data.Aeson (encode) -import qualified Data.ByteString.Lazy as BSL import Data.Time -import EulerHS.Prelude hiding (getOption) -import Test.Hspec hiding (runIO) -import Unsafe.Coerce - +import Database.Beam ((&&.), (<.), (==.), (>=.)) +import qualified Database.Beam as B +import Database.Beam.Sqlite (SqliteM) import EulerHS.Interpreters import EulerHS.Language -import EulerHS.Runtime (withFlowRuntime) -import EulerHS.Types hiding (error) - import qualified EulerHS.Language as L +import EulerHS.Prelude hiding (getOption) +import EulerHS.Runtime (withFlowRuntime) import qualified EulerHS.Runtime as R +import EulerHS.Types (_isAsync, _logFilePath, _logToFile, + defaultLoggerConfig) import qualified EulerHS.Types as T - -import Database.Beam ((&&.), (/=.), (<-.), (<.), (==.), (>.), (>=.)) -import qualified Database.Beam as B -import qualified Database.Beam.Backend.SQL as B -import qualified Database.Beam.Sqlite as BS - +import Test.Hspec hiding (runIO) date1 :: LocalTime date1 = LocalTime @@ -213,12 +205,14 @@ testDBName = "./testDB/SQLDB/TestData/test.db" testDBTemplateName :: String testDBTemplateName = "./testDB/SQLDB/TestData/query_examples.db.template" +poolConfig :: T.PoolConfig poolConfig = T.PoolConfig { stripes = 1 , keepAlive = 10 , resourcesPerStripe = 50 } +sqliteCfg :: T.DBConfig SqliteM sqliteCfg = T.mkSQLitePoolConfig "clubSQliteDB" testDBName poolConfig connectOrFail :: T.DBConfig beM -> Flow (T.SqlConn beM) @@ -233,7 +227,6 @@ prepareTestDB :: L.Flow () prepareTestDB = do rmTestDB void $ L.runSysCmd $ "cp " <> testDBTemplateName <> " " <> testDBName - pure () --Basic string searches @@ -285,10 +278,10 @@ selectWithUnion = do conn <- connectOrFail sqliteCfg L.runDB conn $ let - sn = fmap surName - $ B.all_ (members clubDB) - n = fmap name - $ B.all_ (facilities clubDB) + sn = surName + <$> B.all_ (members clubDB) + n = name + <$> B.all_ (facilities clubDB) in L.findRows $ B.select $ B.limit_ 3 $ B.union_ sn n @@ -297,16 +290,16 @@ aggregate1 = do conn <- connectOrFail sqliteCfg res <- L.runDB conn $ L.findRow $ B.select - $ B.aggregate_ (\m -> B.max_ (joinDate m )) + $ B.aggregate_ (B.max_ . joinDate) $ B.all_ (members clubDB) pure $ join <$> res -aggregate2 :: L.Flow (T.DBResult (Maybe (Text, Text,(LocalTime)))) +aggregate2 :: L.Flow (T.DBResult (Maybe (Text, Text, LocalTime))) aggregate2 = do conn <- connectOrFail sqliteCfg L.runDB conn $ L.findRow $ B.select $ do - mdate <- B.aggregate_ (\ms -> ( B.max_ (joinDate ms))) + mdate <- B.aggregate_ (B.max_ . joinDate) $ B.all_ (members clubDB) lm <- B.filter_ (\m -> joinDate m ==. B.fromMaybe_ (B.val_ date2) mdate) $ B.all_ (members clubDB) pure (firstName lm, surName lm, joinDate lm) @@ -333,12 +326,12 @@ join2 = do $ do fs <- B.all_ (facilities clubDB) bs <- B.join_ (bookings clubDB) (\book -> facId book ==. B.primaryKey fs) - B.guard_ ( starttime bs >=. (B.val_ date3) - &&. starttime bs <. (B.val_ date4) + B.guard_ ( starttime bs >=. B.val_ date3 + &&. starttime bs <. B.val_ date4 &&. name fs `B.like_` "%Tennis Court%") pure (fs, bs) - +loggerCfg :: T.LoggerConfig loggerCfg = defaultLoggerConfig { _logToFile = True , _logFilePath = "/tmp/euler-backend.log" diff --git a/testDB/SQLDB/Tests/SQLiteDBSpec.hs b/testDB/SQLDB/Tests/SQLiteDBSpec.hs index 627de9aa..9f02e890 100644 --- a/testDB/SQLDB/Tests/SQLiteDBSpec.hs +++ b/testDB/SQLDB/Tests/SQLiteDBSpec.hs @@ -1,27 +1,27 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} module SQLDB.Tests.SQLiteDBSpec where -import EulerHS.Prelude - -import EulerHS.Interpreters +import qualified Database.Beam.Sqlite as BS +import EulerHS.Interpreters (runFlow) import qualified EulerHS.Language as L -import EulerHS.Types hiding (error) +import EulerHS.Prelude +import EulerHS.Types (DBConfig, DBError (DBError), + DBErrorType (SQLError), SQLError (SqliteError), + SqliteError (SqliteErrorConstraint)) import qualified EulerHS.Types as T - -import SQLDB.TestData.Connections -import SQLDB.TestData.Scenarios.SQLite -import SQLDB.TestData.Types - -import qualified Database.Beam.Sqlite as BS +import Prelude (head, (!!)) +import SQLDB.TestData.Connections (testDBName, withEmptyDB) +import SQLDB.TestData.Scenarios.SQLite (insertReturningScript, + insertTestValues, + selectOneDbScript, + selectUnknownDbScript, + uniqueConstraintViolationDbScript, + updateAndSelectDbScript) +import SQLDB.TestData.Types (someUser, _userFirstName, _userLastName) import Test.Hspec hiding (runIO) - -- Configurations sqliteCfg :: DBConfig BS.SqliteM @@ -34,7 +34,6 @@ poolConfig = T.PoolConfig , resourcesPerStripe = 50 } - sqlitePoolCfg :: T.DBConfig BS.SqliteM sqlitePoolCfg = T.mkSQLitePoolConfig "eulerSQliteDB" testDBName poolConfig @@ -43,45 +42,46 @@ sqlitePoolCfg = T.mkSQLitePoolConfig "eulerSQliteDB" testDBName poolConfig spec :: Spec spec = do let - test sqliteCfg = do + test sqliteCfg' = do it "Double connection initialization should fail" $ \rt -> do eRes <- runFlow rt $ do - eConn1 <- L.initSqlDBConnection sqliteCfg - eConn2 <- L.initSqlDBConnection sqliteCfg + eConn1 <- L.initSqlDBConnection sqliteCfg' + eConn2 <- L.initSqlDBConnection sqliteCfg' case (eConn1, eConn2) of - (Left err, _) -> pure $ Left $ "Failed to connect 1st time: " <> show err + (Left err, _) -> pure $ Left $ "Failed to connect 1st time: " <> show @Text err (_, Left (T.DBError T.ConnectionAlreadyExists msg)) | msg == "Connection for eulerSQliteDB already created." -> pure $ Right () (_, Left err) -> pure $ Left $ "Unexpected error type on 2nd connect: " <> show err + _ -> pure . Left $ "Double initialization worked for some reason" eRes `shouldBe` Right () it "Get uninialized connection should fail" $ \rt -> do eRes <- runFlow rt $ do - eConn <- L.getSqlDBConnection sqliteCfg + eConn <- L.getSqlDBConnection sqliteCfg' case eConn of Left (T.DBError T.ConnectionDoesNotExist msg) | msg == "Connection for eulerSQliteDB does not exists." -> pure $ Right () - Left err -> pure $ Left $ "Unexpected error: " <> show err + Left err -> pure $ Left $ "Unexpected error: " <> show @Text err Right _ -> pure $ Left "Unexpected connection success" eRes `shouldBe` Right () it "Init and get connection should succeed" $ \rt -> do eRes <- runFlow rt $ do - eConn1 <- L.initSqlDBConnection sqliteCfg - eConn2 <- L.getSqlDBConnection sqliteCfg + eConn1 <- L.initSqlDBConnection sqliteCfg' + eConn2 <- L.getSqlDBConnection sqliteCfg' case (eConn1, eConn2) of - (Left err, _) -> pure $ Left $ "Failed to connect: " <> show err + (Left err, _) -> pure $ Left $ "Failed to connect: " <> show @Text err (_, Left err) -> pure $ Left $ "Unexpected error on get connection: " <> show err _ -> pure $ Right () eRes `shouldBe` Right () it "Init and double get connection should succeed" $ \rt -> do eRes <- runFlow rt $ do - eConn1 <- L.initSqlDBConnection sqliteCfg - eConn2 <- L.getSqlDBConnection sqliteCfg - eConn3 <- L.getSqlDBConnection sqliteCfg + eConn1 <- L.initSqlDBConnection sqliteCfg' + eConn2 <- L.getSqlDBConnection sqliteCfg' + eConn3 <- L.getSqlDBConnection sqliteCfg' case (eConn1, eConn2, eConn3) of - (Left err, _, _) -> pure $ Left $ "Failed to connect: " <> show err + (Left err, _, _) -> pure $ Left $ "Failed to connect: " <> show @Text err (_, Left err, _) -> pure $ Left $ "Unexpected error on 1st get connection: " <> show err (_, _, Left err) -> pure $ Left $ "Unexpected error on 2nd get connection: " <> show err _ -> pure $ Right () @@ -89,26 +89,26 @@ spec = do it "getOrInitSqlConn should succeed" $ \rt -> do eRes <- runFlow rt $ do - eConn <- L.getOrInitSqlConn sqliteCfg + eConn <- L.getOrInitSqlConn sqliteCfg' case eConn of - Left err -> pure $ Left $ "Failed to connect: " <> show err + Left err -> pure $ Left $ "Failed to connect: " <> show @Text err _ -> pure $ Right () eRes `shouldBe` Right () it "Prepared connection should be available" $ \rt -> do void $ runFlow rt $ do - eConn <- L.initSqlDBConnection sqliteCfg + eConn <- L.initSqlDBConnection sqliteCfg' when (isLeft eConn) $ error "Failed to prepare connection." void $ runFlow rt $ do - eConn <- L.getSqlDBConnection sqliteCfg + eConn <- L.getSqlDBConnection sqliteCfg' when (isLeft eConn) $ error "Failed to get prepared connection." it "Unique Constraint Violation" $ \rt -> do - eRes <- runFlow rt (uniqueConstraintViolationDbScript sqliteCfg) + eRes <- runFlow rt (uniqueConstraintViolationDbScript sqliteCfg') eRes `shouldBe` - ( Left $ DBError + Left (DBError ( SQLError $ SqliteError $ - SqliteSqlError + T.SqliteSqlError { sqlError = SqliteErrorConstraint , sqlErrorDetails = "UNIQUE constraint failed: users.id" , sqlErrorContext = "step" @@ -118,25 +118,25 @@ spec = do ) it "Select one, row not found" $ \rt -> do - eRes <- runFlow rt (selectUnknownDbScript sqliteCfg) - eRes `shouldBe` (Right Nothing) + eRes <- runFlow rt (selectUnknownDbScript sqliteCfg') + eRes `shouldBe` Right Nothing it "Select one, row found" $ \rt -> do - eRes <- runFlow rt (selectOneDbScript sqliteCfg) - eRes `shouldSatisfy` (someUser "John" "Doe") + eRes <- runFlow rt (selectOneDbScript sqliteCfg') + eRes `shouldSatisfy` someUser "John" "Doe" it "Update / Select, row found & changed" $ \rt -> do - eRes <- runFlow rt (updateAndSelectDbScript sqliteCfg) - eRes `shouldSatisfy` (someUser "Leo" "San") + eRes <- runFlow rt (updateAndSelectDbScript sqliteCfg') + eRes `shouldSatisfy` someUser "Leo" "San" it "Insert returning should return list of rows" $ \rt -> do - eRes <- runFlow rt (insertReturningScript sqliteCfg) + eRes <- runFlow rt (insertReturningScript sqliteCfg') case eRes of Left _ -> expectationFailure "Left DBResult" Right us -> do length us `shouldBe` 2 - let u1 = us !! 0 + let u1 = head us let u2 = us !! 1 _userFirstName u1 `shouldBe` "John"