diff --git a/freer-extras/freer-extras.cabal b/freer-extras/freer-extras.cabal index c2f9a10b80..f15635772d 100644 --- a/freer-extras/freer-extras.cabal +++ b/freer-extras/freer-extras.cabal @@ -49,6 +49,7 @@ library mtl -any, openapi3 -any, prettyprinter -any, + resource-pool -any, sqlite-simple -any, streaming -any, text -any, @@ -75,5 +76,6 @@ test-suite freer-extras-test freer-extras -any, freer-simple -any, lens -any, + resource-pool -any, semigroups -any, sqlite-simple -any, diff --git a/freer-extras/src/Control/Monad/Freer/Extras/Beam.hs b/freer-extras/src/Control/Monad/Freer/Extras/Beam.hs index 0c6109981d..c856e6d449 100644 --- a/freer-extras/src/Control/Monad/Freer/Extras/Beam.hs +++ b/freer-extras/src/Control/Monad/Freer/Extras/Beam.hs @@ -1,31 +1,32 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} module Control.Monad.Freer.Extras.Beam where import Cardano.BM.Data.Tracer (ToObject (..)) import Cardano.BM.Trace (Trace, logDebug) import Control.Concurrent (threadDelay) -import Control.Exception (try) +import Control.Exception (Exception, throw, try) import Control.Monad (guard) import Control.Monad.Freer (Eff, LastMember, Member, type (~>)) -import Control.Monad.Freer.Error (Error, throwError) import Control.Monad.Freer.Extras.Pagination (Page (..), PageQuery (..), PageSize (..)) import Control.Monad.Freer.Reader (Reader, ask) import Control.Monad.Freer.TH (makeEffect) @@ -33,6 +34,8 @@ import Data.Aeson (FromJSON, ToJSON) import Data.Foldable (traverse_) import Data.List.NonEmpty qualified as L import Data.Maybe (isJust, listToMaybe) +import Data.Pool (Pool) +import Data.Pool qualified as Pool import Data.Text (Text) import Data.Text qualified as Text import Database.Beam (Beamable, DatabaseEntity, FromBackendRow, Identity, MonadIO (liftIO), Q, QBaseScope, QExpr, @@ -58,6 +61,8 @@ newtype BeamError = deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON, ToObject) +instance Exception BeamError + instance Pretty BeamError where pretty = \case SqlError s -> "SqlError (via Beam)" <> colon <+> pretty s @@ -126,8 +131,7 @@ instance Semigroup (BeamEffect ()) where handleBeam :: forall effs. ( LastMember IO effs - , Member (Error BeamError) effs - , Member (Reader Sqlite.Connection) effs + , Member (Reader (Pool Sqlite.Connection)) effs ) => Trace IO BeamLog -> BeamEffect @@ -176,30 +180,28 @@ handleBeam trace eff = runBeam trace $ execute eff runBeam :: forall effs. ( LastMember IO effs - , Member (Error BeamError) effs - , Member (Reader Sqlite.Connection) effs + , Member (Reader (Pool Sqlite.Connection)) effs ) => Trace IO BeamLog -> SqliteM ~> Eff effs runBeam trace action = do - conn <- ask @Sqlite.Connection - loop conn ( 5 :: Int ) + pool <- ask @(Pool Sqlite.Connection) + liftIO $ Pool.withResource pool $ \conn -> loop conn ( 5 :: Int ) where loop conn retries = do let traceSql = logDebug trace . SqlLog - resultEither <- liftIO $ try $ Sqlite.withTransaction conn $ runBeamSqliteDebug traceSql conn action + resultEither <- try $ Sqlite.withTransaction conn $ runBeamSqliteDebug traceSql conn action case resultEither of -- 'Database.SQLite.Simple.ErrorError' corresponds to an SQL error or -- missing database. When this exception is raised, we suppose it's -- because the another transaction was already running. Left (Sqlite.SQLError Sqlite.ErrorError _ _) | retries > 0 -> do - liftIO $ threadDelay 100_000 + threadDelay 100_000 loop conn (retries - 1) -- We handle and rethrow errors other than -- 'Database.SQLite.Simple.ErrorError'. - Left e -> do - throwError $ SqlError $ Text.pack $ show e + Left e -> throw $ SqlError $ Text.pack $ show e Right v -> return v makeEffect ''BeamEffect diff --git a/freer-extras/test/Control/Monad/Freer/Extras/BeamSpec.hs b/freer-extras/test/Control/Monad/Freer/Extras/BeamSpec.hs index 7aaeddb722..688a1e645d 100644 --- a/freer-extras/test/Control/Monad/Freer/Extras/BeamSpec.hs +++ b/freer-extras/test/Control/Monad/Freer/Extras/BeamSpec.hs @@ -6,6 +6,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -24,6 +25,8 @@ import Control.Tracer (nullTracer) import Data.Int (Int16) import Data.Kind (Constraint) import Data.List (sort) +import Data.Pool (Pool) +import Data.Pool qualified as Pool import Data.Semigroup.Generic (GenericSemigroupMonoid (..)) import Data.Set qualified as Set import Database.Beam (Beamable, Columnar, Database, DatabaseSettings, FromBackendRow, Generic, MonadIO (liftIO), Q, @@ -182,27 +185,28 @@ selectAllPages pq q = do runBeamEffectInGenTestDb :: Set Int - -> Eff '[BeamEffect, Error BeamError, Reader Sqlite.Connection, IO] a + -> Eff '[BeamEffect, Error BeamError, Reader (Pool Sqlite.Connection), IO] a -> (a -> PropertyT IO ()) -> PropertyT IO () runBeamEffectInGenTestDb items effect runTest = do - result <- liftIO $ Sqlite.withConnection ":memory:" $ \conn -> do - Sqlite.runBeamSqlite conn $ do + pool <- liftIO $ Pool.createPool (Sqlite.open ":memory:") Sqlite.close 1 1_000_000 1 + result <- liftIO $ do + Pool.withResource pool $ \conn -> Sqlite.runBeamSqlite conn $ do autoMigrate Sqlite.migrationBackend checkedSqliteDb runInsert $ insertOnConflict (testRows db) (insertValues $ IntegerRow . fromIntegral <$> Set.toList items) anyConflict onConflictDoNothing - liftIO $ runBeamEffect conn effect + runBeamEffect pool effect case result of Left _ -> Hedgehog.assert False Right r -> runTest r runBeamEffect - :: Sqlite.Connection - -> Eff '[BeamEffect, Error BeamError, Reader Sqlite.Connection, IO] a + :: Pool Sqlite.Connection + -> Eff '[BeamEffect, Error BeamError, Reader (Pool Sqlite.Connection), IO] a -> IO (Either BeamError a) -runBeamEffect conn effect = do +runBeamEffect pool effect = do effect & interpret (handleBeam nullTracer) & runError - & runReader conn + & runReader pool & runM diff --git a/nix/pkgs/haskell/materialized-darwin/.plan.nix/freer-extras.nix b/nix/pkgs/haskell/materialized-darwin/.plan.nix/freer-extras.nix index 663fec1f27..22aeec89c2 100644 --- a/nix/pkgs/haskell/materialized-darwin/.plan.nix/freer-extras.nix +++ b/nix/pkgs/haskell/materialized-darwin/.plan.nix/freer-extras.nix @@ -45,6 +45,7 @@ (hsPkgs."mtl" or (errorHandler.buildDepError "mtl")) (hsPkgs."openapi3" or (errorHandler.buildDepError "openapi3")) (hsPkgs."prettyprinter" or (errorHandler.buildDepError "prettyprinter")) + (hsPkgs."resource-pool" or (errorHandler.buildDepError "resource-pool")) (hsPkgs."sqlite-simple" or (errorHandler.buildDepError "sqlite-simple")) (hsPkgs."streaming" or (errorHandler.buildDepError "streaming")) (hsPkgs."text" or (errorHandler.buildDepError "text")) @@ -76,6 +77,7 @@ (hsPkgs."freer-extras" or (errorHandler.buildDepError "freer-extras")) (hsPkgs."freer-simple" or (errorHandler.buildDepError "freer-simple")) (hsPkgs."lens" or (errorHandler.buildDepError "lens")) + (hsPkgs."resource-pool" or (errorHandler.buildDepError "resource-pool")) (hsPkgs."semigroups" or (errorHandler.buildDepError "semigroups")) (hsPkgs."sqlite-simple" or (errorHandler.buildDepError "sqlite-simple")) ]; diff --git a/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-chain-index-core.nix b/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-chain-index-core.nix index b1a8ee8831..3c8f548da8 100644 --- a/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-chain-index-core.nix +++ b/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-chain-index-core.nix @@ -72,6 +72,7 @@ (hsPkgs."unordered-containers" or (errorHandler.buildDepError "unordered-containers")) (hsPkgs."bytestring" or (errorHandler.buildDepError "bytestring")) (hsPkgs."text" or (errorHandler.buildDepError "text")) + (hsPkgs."resource-pool" or (errorHandler.buildDepError "resource-pool")) (hsPkgs."servant" or (errorHandler.buildDepError "servant")) (hsPkgs."servant-openapi3" or (errorHandler.buildDepError "servant-openapi3")) (hsPkgs."servant-server" or (errorHandler.buildDepError "servant-server")) @@ -132,7 +133,9 @@ (hsPkgs."freer-simple" or (errorHandler.buildDepError "freer-simple")) (hsPkgs."hedgehog" or (errorHandler.buildDepError "hedgehog")) (hsPkgs."lens" or (errorHandler.buildDepError "lens")) + (hsPkgs."resource-pool" or (errorHandler.buildDepError "resource-pool")) (hsPkgs."serialise" or (errorHandler.buildDepError "serialise")) + (hsPkgs."stm" or (errorHandler.buildDepError "stm")) (hsPkgs."sqlite-simple" or (errorHandler.buildDepError "sqlite-simple")) (hsPkgs."tasty" or (errorHandler.buildDepError "tasty")) (hsPkgs."tasty-hedgehog" or (errorHandler.buildDepError "tasty-hedgehog")) diff --git a/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-chain-index.nix b/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-chain-index.nix index 99d0877dbe..f5eea831ea 100644 --- a/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-chain-index.nix +++ b/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-chain-index.nix @@ -52,6 +52,7 @@ (hsPkgs."optparse-applicative" or (errorHandler.buildDepError "optparse-applicative")) (hsPkgs."ouroboros-network" or (errorHandler.buildDepError "ouroboros-network")) (hsPkgs."prettyprinter" or (errorHandler.buildDepError "prettyprinter")) + (hsPkgs."resource-pool" or (errorHandler.buildDepError "resource-pool")) (hsPkgs."sqlite-simple" or (errorHandler.buildDepError "sqlite-simple")) (hsPkgs."stm" or (errorHandler.buildDepError "stm")) (hsPkgs."time-units" or (errorHandler.buildDepError "time-units")) diff --git a/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-example.nix b/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-example.nix index ad9134e3f9..d43807d858 100644 --- a/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-example.nix +++ b/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-example.nix @@ -125,6 +125,10 @@ (hsPkgs."text" or (errorHandler.buildDepError "text")) (hsPkgs."unordered-containers" or (errorHandler.buildDepError "unordered-containers")) ]; + build-tools = [ + (hsPkgs.buildPackages.cardano-node.components.exes.cardano-node or (pkgs.buildPackages.cardano-node or (errorHandler.buildToolDepError "cardano-node:cardano-node"))) + (hsPkgs.buildPackages.cardano-cli.components.exes.cardano-cli or (pkgs.buildPackages.cardano-cli or (errorHandler.buildToolDepError "cardano-cli:cardano-cli"))) + ]; buildable = true; modules = [ "Test/PlutusExample/Direct/ScriptContextEquality" diff --git a/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-pab-executables.nix b/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-pab-executables.nix index f77903ea8b..a19553f42b 100644 --- a/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-pab-executables.nix +++ b/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-pab-executables.nix @@ -337,6 +337,7 @@ (hsPkgs."playground-common" or (errorHandler.buildDepError "playground-common")) (hsPkgs."yaml" or (errorHandler.buildDepError "yaml")) (hsPkgs."iohk-monitoring" or (errorHandler.buildDepError "iohk-monitoring")) + (hsPkgs."sqlite-simple" or (errorHandler.buildDepError "sqlite-simple")) (hsPkgs."servant-server" or (errorHandler.buildDepError "servant-server")) (hsPkgs."purescript-bridge" or (errorHandler.buildDepError "purescript-bridge")) (hsPkgs."async" or (errorHandler.buildDepError "async")) @@ -379,6 +380,7 @@ (hsPkgs."plutus-ledger" or (errorHandler.buildDepError "plutus-ledger")) (hsPkgs."plutus-ledger-constraints" or (errorHandler.buildDepError "plutus-ledger-constraints")) (hsPkgs."servant-client" or (errorHandler.buildDepError "servant-client")) + (hsPkgs."sqlite-simple" or (errorHandler.buildDepError "sqlite-simple")) (hsPkgs."tasty" or (errorHandler.buildDepError "tasty")) (hsPkgs."tasty-hunit" or (errorHandler.buildDepError "tasty-hunit")) (hsPkgs."text" or (errorHandler.buildDepError "text")) diff --git a/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-pab.nix b/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-pab.nix index 5dd0fe502d..c1001d19c7 100644 --- a/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-pab.nix +++ b/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-pab.nix @@ -86,6 +86,7 @@ (hsPkgs."prettyprinter" or (errorHandler.buildDepError "prettyprinter")) (hsPkgs."quickcheck-instances" or (errorHandler.buildDepError "quickcheck-instances")) (hsPkgs."random" or (errorHandler.buildDepError "random")) + (hsPkgs."resource-pool" or (errorHandler.buildDepError "resource-pool")) (hsPkgs."row-types" or (errorHandler.buildDepError "row-types")) (hsPkgs."servant" or (errorHandler.buildDepError "servant")) (hsPkgs."servant-client" or (errorHandler.buildDepError "servant-client")) diff --git a/nix/pkgs/haskell/materialized-linux/.plan.nix/freer-extras.nix b/nix/pkgs/haskell/materialized-linux/.plan.nix/freer-extras.nix index 663fec1f27..22aeec89c2 100644 --- a/nix/pkgs/haskell/materialized-linux/.plan.nix/freer-extras.nix +++ b/nix/pkgs/haskell/materialized-linux/.plan.nix/freer-extras.nix @@ -45,6 +45,7 @@ (hsPkgs."mtl" or (errorHandler.buildDepError "mtl")) (hsPkgs."openapi3" or (errorHandler.buildDepError "openapi3")) (hsPkgs."prettyprinter" or (errorHandler.buildDepError "prettyprinter")) + (hsPkgs."resource-pool" or (errorHandler.buildDepError "resource-pool")) (hsPkgs."sqlite-simple" or (errorHandler.buildDepError "sqlite-simple")) (hsPkgs."streaming" or (errorHandler.buildDepError "streaming")) (hsPkgs."text" or (errorHandler.buildDepError "text")) @@ -76,6 +77,7 @@ (hsPkgs."freer-extras" or (errorHandler.buildDepError "freer-extras")) (hsPkgs."freer-simple" or (errorHandler.buildDepError "freer-simple")) (hsPkgs."lens" or (errorHandler.buildDepError "lens")) + (hsPkgs."resource-pool" or (errorHandler.buildDepError "resource-pool")) (hsPkgs."semigroups" or (errorHandler.buildDepError "semigroups")) (hsPkgs."sqlite-simple" or (errorHandler.buildDepError "sqlite-simple")) ]; diff --git a/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-chain-index-core.nix b/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-chain-index-core.nix index b1a8ee8831..3c8f548da8 100644 --- a/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-chain-index-core.nix +++ b/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-chain-index-core.nix @@ -72,6 +72,7 @@ (hsPkgs."unordered-containers" or (errorHandler.buildDepError "unordered-containers")) (hsPkgs."bytestring" or (errorHandler.buildDepError "bytestring")) (hsPkgs."text" or (errorHandler.buildDepError "text")) + (hsPkgs."resource-pool" or (errorHandler.buildDepError "resource-pool")) (hsPkgs."servant" or (errorHandler.buildDepError "servant")) (hsPkgs."servant-openapi3" or (errorHandler.buildDepError "servant-openapi3")) (hsPkgs."servant-server" or (errorHandler.buildDepError "servant-server")) @@ -132,7 +133,9 @@ (hsPkgs."freer-simple" or (errorHandler.buildDepError "freer-simple")) (hsPkgs."hedgehog" or (errorHandler.buildDepError "hedgehog")) (hsPkgs."lens" or (errorHandler.buildDepError "lens")) + (hsPkgs."resource-pool" or (errorHandler.buildDepError "resource-pool")) (hsPkgs."serialise" or (errorHandler.buildDepError "serialise")) + (hsPkgs."stm" or (errorHandler.buildDepError "stm")) (hsPkgs."sqlite-simple" or (errorHandler.buildDepError "sqlite-simple")) (hsPkgs."tasty" or (errorHandler.buildDepError "tasty")) (hsPkgs."tasty-hedgehog" or (errorHandler.buildDepError "tasty-hedgehog")) diff --git a/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-chain-index.nix b/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-chain-index.nix index 99d0877dbe..f5eea831ea 100644 --- a/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-chain-index.nix +++ b/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-chain-index.nix @@ -52,6 +52,7 @@ (hsPkgs."optparse-applicative" or (errorHandler.buildDepError "optparse-applicative")) (hsPkgs."ouroboros-network" or (errorHandler.buildDepError "ouroboros-network")) (hsPkgs."prettyprinter" or (errorHandler.buildDepError "prettyprinter")) + (hsPkgs."resource-pool" or (errorHandler.buildDepError "resource-pool")) (hsPkgs."sqlite-simple" or (errorHandler.buildDepError "sqlite-simple")) (hsPkgs."stm" or (errorHandler.buildDepError "stm")) (hsPkgs."time-units" or (errorHandler.buildDepError "time-units")) diff --git a/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-pab-executables.nix b/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-pab-executables.nix index f77903ea8b..a19553f42b 100644 --- a/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-pab-executables.nix +++ b/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-pab-executables.nix @@ -337,6 +337,7 @@ (hsPkgs."playground-common" or (errorHandler.buildDepError "playground-common")) (hsPkgs."yaml" or (errorHandler.buildDepError "yaml")) (hsPkgs."iohk-monitoring" or (errorHandler.buildDepError "iohk-monitoring")) + (hsPkgs."sqlite-simple" or (errorHandler.buildDepError "sqlite-simple")) (hsPkgs."servant-server" or (errorHandler.buildDepError "servant-server")) (hsPkgs."purescript-bridge" or (errorHandler.buildDepError "purescript-bridge")) (hsPkgs."async" or (errorHandler.buildDepError "async")) @@ -379,6 +380,7 @@ (hsPkgs."plutus-ledger" or (errorHandler.buildDepError "plutus-ledger")) (hsPkgs."plutus-ledger-constraints" or (errorHandler.buildDepError "plutus-ledger-constraints")) (hsPkgs."servant-client" or (errorHandler.buildDepError "servant-client")) + (hsPkgs."sqlite-simple" or (errorHandler.buildDepError "sqlite-simple")) (hsPkgs."tasty" or (errorHandler.buildDepError "tasty")) (hsPkgs."tasty-hunit" or (errorHandler.buildDepError "tasty-hunit")) (hsPkgs."text" or (errorHandler.buildDepError "text")) diff --git a/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-pab.nix b/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-pab.nix index 5dd0fe502d..c1001d19c7 100644 --- a/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-pab.nix +++ b/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-pab.nix @@ -86,6 +86,7 @@ (hsPkgs."prettyprinter" or (errorHandler.buildDepError "prettyprinter")) (hsPkgs."quickcheck-instances" or (errorHandler.buildDepError "quickcheck-instances")) (hsPkgs."random" or (errorHandler.buildDepError "random")) + (hsPkgs."resource-pool" or (errorHandler.buildDepError "resource-pool")) (hsPkgs."row-types" or (errorHandler.buildDepError "row-types")) (hsPkgs."servant" or (errorHandler.buildDepError "servant")) (hsPkgs."servant-client" or (errorHandler.buildDepError "servant-client")) diff --git a/nix/pkgs/haskell/materialized-windows/.plan.nix/freer-extras.nix b/nix/pkgs/haskell/materialized-windows/.plan.nix/freer-extras.nix index 663fec1f27..22aeec89c2 100644 --- a/nix/pkgs/haskell/materialized-windows/.plan.nix/freer-extras.nix +++ b/nix/pkgs/haskell/materialized-windows/.plan.nix/freer-extras.nix @@ -45,6 +45,7 @@ (hsPkgs."mtl" or (errorHandler.buildDepError "mtl")) (hsPkgs."openapi3" or (errorHandler.buildDepError "openapi3")) (hsPkgs."prettyprinter" or (errorHandler.buildDepError "prettyprinter")) + (hsPkgs."resource-pool" or (errorHandler.buildDepError "resource-pool")) (hsPkgs."sqlite-simple" or (errorHandler.buildDepError "sqlite-simple")) (hsPkgs."streaming" or (errorHandler.buildDepError "streaming")) (hsPkgs."text" or (errorHandler.buildDepError "text")) @@ -76,6 +77,7 @@ (hsPkgs."freer-extras" or (errorHandler.buildDepError "freer-extras")) (hsPkgs."freer-simple" or (errorHandler.buildDepError "freer-simple")) (hsPkgs."lens" or (errorHandler.buildDepError "lens")) + (hsPkgs."resource-pool" or (errorHandler.buildDepError "resource-pool")) (hsPkgs."semigroups" or (errorHandler.buildDepError "semigroups")) (hsPkgs."sqlite-simple" or (errorHandler.buildDepError "sqlite-simple")) ]; diff --git a/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-chain-index-core.nix b/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-chain-index-core.nix index b1a8ee8831..3c8f548da8 100644 --- a/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-chain-index-core.nix +++ b/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-chain-index-core.nix @@ -72,6 +72,7 @@ (hsPkgs."unordered-containers" or (errorHandler.buildDepError "unordered-containers")) (hsPkgs."bytestring" or (errorHandler.buildDepError "bytestring")) (hsPkgs."text" or (errorHandler.buildDepError "text")) + (hsPkgs."resource-pool" or (errorHandler.buildDepError "resource-pool")) (hsPkgs."servant" or (errorHandler.buildDepError "servant")) (hsPkgs."servant-openapi3" or (errorHandler.buildDepError "servant-openapi3")) (hsPkgs."servant-server" or (errorHandler.buildDepError "servant-server")) @@ -132,7 +133,9 @@ (hsPkgs."freer-simple" or (errorHandler.buildDepError "freer-simple")) (hsPkgs."hedgehog" or (errorHandler.buildDepError "hedgehog")) (hsPkgs."lens" or (errorHandler.buildDepError "lens")) + (hsPkgs."resource-pool" or (errorHandler.buildDepError "resource-pool")) (hsPkgs."serialise" or (errorHandler.buildDepError "serialise")) + (hsPkgs."stm" or (errorHandler.buildDepError "stm")) (hsPkgs."sqlite-simple" or (errorHandler.buildDepError "sqlite-simple")) (hsPkgs."tasty" or (errorHandler.buildDepError "tasty")) (hsPkgs."tasty-hedgehog" or (errorHandler.buildDepError "tasty-hedgehog")) diff --git a/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-chain-index.nix b/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-chain-index.nix index 99d0877dbe..f5eea831ea 100644 --- a/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-chain-index.nix +++ b/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-chain-index.nix @@ -52,6 +52,7 @@ (hsPkgs."optparse-applicative" or (errorHandler.buildDepError "optparse-applicative")) (hsPkgs."ouroboros-network" or (errorHandler.buildDepError "ouroboros-network")) (hsPkgs."prettyprinter" or (errorHandler.buildDepError "prettyprinter")) + (hsPkgs."resource-pool" or (errorHandler.buildDepError "resource-pool")) (hsPkgs."sqlite-simple" or (errorHandler.buildDepError "sqlite-simple")) (hsPkgs."stm" or (errorHandler.buildDepError "stm")) (hsPkgs."time-units" or (errorHandler.buildDepError "time-units")) diff --git a/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-pab-executables.nix b/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-pab-executables.nix index f77903ea8b..a19553f42b 100644 --- a/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-pab-executables.nix +++ b/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-pab-executables.nix @@ -337,6 +337,7 @@ (hsPkgs."playground-common" or (errorHandler.buildDepError "playground-common")) (hsPkgs."yaml" or (errorHandler.buildDepError "yaml")) (hsPkgs."iohk-monitoring" or (errorHandler.buildDepError "iohk-monitoring")) + (hsPkgs."sqlite-simple" or (errorHandler.buildDepError "sqlite-simple")) (hsPkgs."servant-server" or (errorHandler.buildDepError "servant-server")) (hsPkgs."purescript-bridge" or (errorHandler.buildDepError "purescript-bridge")) (hsPkgs."async" or (errorHandler.buildDepError "async")) @@ -379,6 +380,7 @@ (hsPkgs."plutus-ledger" or (errorHandler.buildDepError "plutus-ledger")) (hsPkgs."plutus-ledger-constraints" or (errorHandler.buildDepError "plutus-ledger-constraints")) (hsPkgs."servant-client" or (errorHandler.buildDepError "servant-client")) + (hsPkgs."sqlite-simple" or (errorHandler.buildDepError "sqlite-simple")) (hsPkgs."tasty" or (errorHandler.buildDepError "tasty")) (hsPkgs."tasty-hunit" or (errorHandler.buildDepError "tasty-hunit")) (hsPkgs."text" or (errorHandler.buildDepError "text")) diff --git a/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-pab.nix b/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-pab.nix index 5dd0fe502d..c1001d19c7 100644 --- a/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-pab.nix +++ b/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-pab.nix @@ -86,6 +86,7 @@ (hsPkgs."prettyprinter" or (errorHandler.buildDepError "prettyprinter")) (hsPkgs."quickcheck-instances" or (errorHandler.buildDepError "quickcheck-instances")) (hsPkgs."random" or (errorHandler.buildDepError "random")) + (hsPkgs."resource-pool" or (errorHandler.buildDepError "resource-pool")) (hsPkgs."row-types" or (errorHandler.buildDepError "row-types")) (hsPkgs."servant" or (errorHandler.buildDepError "servant")) (hsPkgs."servant-client" or (errorHandler.buildDepError "servant-client")) diff --git a/plutus-chain-index-core/plutus-chain-index-core.cabal b/plutus-chain-index-core/plutus-chain-index-core.cabal index 2940726ed5..0339cef7d9 100644 --- a/plutus-chain-index-core/plutus-chain-index-core.cabal +++ b/plutus-chain-index-core/plutus-chain-index-core.cabal @@ -96,6 +96,7 @@ library unordered-containers -any, bytestring -any, text -any, + resource-pool -any, servant -any, servant-openapi3 -any, servant-server -any, @@ -137,7 +138,9 @@ test-suite plutus-chain-index-test freer-simple -any, hedgehog -any, lens -any, + resource-pool -any, serialise -any, + stm -any, sqlite-simple -any, tasty -any, tasty-hedgehog -any, diff --git a/plutus-chain-index-core/src/Plutus/ChainIndex.hs b/plutus-chain-index-core/src/Plutus/ChainIndex.hs index 06b6279e9a..6c52429c4d 100644 --- a/plutus-chain-index-core/src/Plutus/ChainIndex.hs +++ b/plutus-chain-index-core/src/Plutus/ChainIndex.hs @@ -23,7 +23,7 @@ import Plutus.ChainIndex.Types as Export import Plutus.ChainIndex.UtxoState as Export import Cardano.BM.Trace (Trace) -import Control.Concurrent.MVar (MVar, putMVar, takeMVar) +import Control.Concurrent.STM (TVar, atomically, readTVarIO, writeTVar) import Control.Monad.Freer (Eff, LastMember, Member, interpret) import Control.Monad.Freer.Error (handleError, runError, throwError) import Control.Monad.Freer.Extras.Beam (BeamEffect, handleBeam) @@ -32,14 +32,15 @@ import Control.Monad.Freer.Extras.Modify (raiseEnd, raiseMUnderN) import Control.Monad.Freer.Reader (runReader) import Control.Monad.Freer.State (runState) import Control.Monad.IO.Class (liftIO) +import Data.Pool (Pool) import Database.SQLite.Simple qualified as Sqlite import Plutus.Monitoring.Util (PrettyObject (PrettyObject), convertLog, runLogEffects) -- | The required arguments to run the chain index effects. data RunRequirements = RunRequirements { trace :: Trace IO (PrettyObject ChainIndexLog) - , stateMVar :: MVar ChainIndexState - , conn :: Sqlite.Connection + , stateTVar :: TVar ChainIndexState + , pool :: Pool Sqlite.Connection , securityParam :: Int } @@ -59,11 +60,11 @@ handleChainIndexEffects => RunRequirements -> Eff (ChainIndexQueryEffect ': ChainIndexControlEffect ': BeamEffect ': effs) a -> Eff effs (Either ChainIndexError a) -handleChainIndexEffects RunRequirements{trace, stateMVar, conn, securityParam} action = do - state <- liftIO $ takeMVar stateMVar +handleChainIndexEffects RunRequirements{trace, stateTVar, pool, securityParam} action = do + state <- liftIO $ readTVarIO stateTVar (result, newState) <- runState state - $ runReader conn + $ runReader pool $ runReader (Depth securityParam) $ runError @ChainIndexError $ flip handleError (throwError . BeamEffectError) @@ -72,5 +73,5 @@ handleChainIndexEffects RunRequirements{trace, stateMVar, conn, securityParam} a $ interpret handleQuery -- Insert the 5 effects needed by the handlers of the 3 chain index effects between those 3 effects and 'effs'. $ raiseMUnderN @[_,_,_,_,_] @[_,_,_] action - liftIO $ putMVar stateMVar newState + liftIO $ atomically $ writeTVar stateTVar newState pure result diff --git a/plutus-chain-index-core/test/Plutus/ChainIndex/HandlersSpec.hs b/plutus-chain-index-core/test/Plutus/ChainIndex/HandlersSpec.hs index 22ee8bee06..0039b84b55 100644 --- a/plutus-chain-index-core/test/Plutus/ChainIndex/HandlersSpec.hs +++ b/plutus-chain-index-core/test/Plutus/ChainIndex/HandlersSpec.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} module Plutus.ChainIndex.HandlersSpec (tests) where -import Control.Concurrent.MVar (newMVar) +import Control.Concurrent.STM (newTVarIO) import Control.Lens (view) import Control.Monad (forM) import Control.Monad.Freer (Eff) @@ -17,6 +18,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Tracer (nullTracer) import Data.Default (def) import Data.Maybe (isJust) +import Data.Pool qualified as Pool import Data.Set qualified as S import Database.Beam.Migrate.Simple (autoMigrate) import Database.Beam.Sqlite qualified as Sqlite @@ -133,10 +135,12 @@ runChainIndexTest ] a -> m a runChainIndexTest action = do - result <- liftIO $ Sqlite.withConnection ":memory:" $ \conn -> do - Sqlite.runBeamSqlite conn $ autoMigrate Sqlite.migrationBackend checkedSqliteDb - stateMVar <- newMVar mempty - runChainIndexEffects (RunRequirements nullTracer stateMVar conn 10) action + result <- liftIO $ do + pool <- Pool.createPool (Sqlite.open ":memory:") Sqlite.close 1 1_000_000 1 + Pool.withResource pool $ \conn -> + Sqlite.runBeamSqlite conn $ autoMigrate Sqlite.migrationBackend checkedSqliteDb + stateTVar <- newTVarIO mempty + runChainIndexEffects (RunRequirements nullTracer stateTVar pool 10) action case result of Left _ -> Hedgehog.failure diff --git a/plutus-chain-index/plutus-chain-index.cabal b/plutus-chain-index/plutus-chain-index.cabal index 6bf3bfe5a2..fd1b28df0c 100644 --- a/plutus-chain-index/plutus-chain-index.cabal +++ b/plutus-chain-index/plutus-chain-index.cabal @@ -60,6 +60,7 @@ library optparse-applicative -any, ouroboros-network -any, prettyprinter >=1.1.0.1, + resource-pool -any, sqlite-simple -any, stm -any, time-units -any, diff --git a/plutus-chain-index/src/Plutus/ChainIndex/Lib.hs b/plutus-chain-index/src/Plutus/ChainIndex/Lib.hs index ccca349c5f..2e2a417f85 100644 --- a/plutus-chain-index/src/Plutus/ChainIndex/Lib.hs +++ b/plutus-chain-index/src/Plutus/ChainIndex/Lib.hs @@ -44,12 +44,12 @@ module Plutus.ChainIndex.Lib ( , getTipSlot ) where -import Control.Concurrent.MVar (newMVar) import Control.Monad.Freer (Eff) import Control.Monad.Freer.Extras.Beam (BeamEffect, BeamLog (SqlLog)) import Control.Monad.Freer.Extras.Log qualified as Log import Data.Default (def) import Data.Functor (void) +import Data.Pool qualified as Pool import Database.Beam.Migrate.Simple (autoMigrate) import Database.Beam.Sqlite qualified as Sqlite import Database.Beam.Sqlite.Migrate qualified as Sqlite @@ -62,7 +62,7 @@ import Cardano.BM.Trace (Trace, logDebug, logError, nullTracer) import Cardano.Protocol.Socket.Client qualified as C import Cardano.Protocol.Socket.Type (epochSlots) -import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM (atomically, newTVarIO) import Control.Concurrent.STM.TBMQueue (TBMQueue, writeTBMQueue) import Plutus.ChainIndex (ChainIndexLog (BeamLogItem), RunRequirements (RunRequirements), getResumePoints, runChainIndexEffects, tipBlockNo) @@ -77,13 +77,9 @@ import Plutus.Monitoring.Util (PrettyObject (PrettyObject), convertLog, runLogEf -- | Generate the requirements to run the chain index effects given logging configuration and chain index configuration. withRunRequirements :: CM.Configuration -> Config.ChainIndexConfig -> (RunRequirements -> IO ()) -> IO () withRunRequirements logConfig config cont = do - Sqlite.withConnection (Config.cicDbPath config) $ \conn -> do - - (trace :: Trace IO (PrettyObject ChainIndexLog), _) <- setupTrace_ logConfig "chain-index" - - -- Optimize Sqlite for write performance, halves the sync time. - -- https://sqlite.org/wal.html - Sqlite.execute_ conn "PRAGMA journal_mode=WAL" + pool <- Pool.createPool (Sqlite.open (Config.cicDbPath config) >>= setupConn) Sqlite.close 5 1_000_000 5 + (trace :: Trace IO (PrettyObject ChainIndexLog), _) <- setupTrace_ logConfig "chain-index" + Pool.withResource pool $ \conn -> do Sqlite.runBeamSqliteDebug (logDebug (convertLog PrettyObject trace) . (BeamLogItem . SqlLog)) conn $ do autoMigrate Sqlite.migrationBackend checkedSqliteDb @@ -97,8 +93,15 @@ withRunRequirements logConfig config cont = do \ AND input_row_out_ref = old.output_row_out_ref; \ \END" - stateMVar <- newMVar mempty - cont $ RunRequirements trace stateMVar conn (Config.cicSecurityParam config) + stateTVar <- newTVarIO mempty + cont $ RunRequirements trace stateTVar pool (Config.cicSecurityParam config) + + where + setupConn conn = do + -- Optimize Sqlite for write performance, halves the sync time. + -- https://sqlite.org/wal.html + Sqlite.execute_ conn "PRAGMA journal_mode=WAL;" + return conn -- | Generate the requirements to run the chain index effects given default configurations. withDefaultRunRequirements :: (RunRequirements -> IO ()) -> IO () diff --git a/plutus-pab-executables/plutus-pab-executables.cabal b/plutus-pab-executables/plutus-pab-executables.cabal index 4ea55a2d49..483f0f9165 100644 --- a/plutus-pab-executables/plutus-pab-executables.cabal +++ b/plutus-pab-executables/plutus-pab-executables.cabal @@ -300,6 +300,7 @@ test-suite plutus-pab-test-full playground-common -any, yaml -any, iohk-monitoring -any, + sqlite-simple -any, servant-server -any, purescript-bridge -any, async -any, @@ -347,6 +348,7 @@ test-suite plutus-pab-test-full-long-running plutus-ledger -any, plutus-ledger-constraints -any, servant-client -any, + sqlite-simple -any, tasty -any, tasty-hunit -any, text -any, diff --git a/plutus-pab-executables/test/full/Plutus/PAB/CliSpec.hs b/plutus-pab-executables/test/full/Plutus/PAB/CliSpec.hs index 92110d8bbe..75da7a636f 100644 --- a/plutus-pab-executables/test/full/Plutus/PAB/CliSpec.hs +++ b/plutus-pab-executables/test/full/Plutus/PAB/CliSpec.hs @@ -38,6 +38,7 @@ import Data.List (delete) import Data.OpenApi.Schema qualified as OpenApi import Data.Text qualified as Text import Data.Yaml (decodeFileThrow) +import Database.SQLite.Simple qualified as Sqlite import GHC.Generics (Generic) import Ledger.Ada (lovelaceValueOf) import Network.HTTP.Client (ManagerSettings (managerResponseTimeout), defaultManagerSettings, newManager, @@ -57,7 +58,8 @@ import Plutus.PAB.Run.Cli (ConfigCommandArgs, runConfigCommand) import Plutus.PAB.Run.Command (ConfigCommand (ChainIndex, ForkCommands, Migrate), allServices) import Plutus.PAB.Run.CommandParser (AppOpts (AppOpts, cmd, configPath, logConfigPath, minLogLevel, passphrase, resumeFrom, rollbackHistory, runEkgServer, storageBackend)) import Plutus.PAB.Run.PSGenerator (HasPSTypes (psTypes)) -import Plutus.PAB.Types (Config (Config, chainIndexConfig, dbConfig, nodeServerConfig, pabWebserverConfig, walletServerConfig)) +import Plutus.PAB.Types (Config (Config, chainIndexConfig, dbConfig, nodeServerConfig, pabWebserverConfig, walletServerConfig), + DbConfig (..)) import Plutus.PAB.Types qualified as PAB.Types import Plutus.PAB.Webserver.API (API) import Plutus.PAB.Webserver.Client (InstanceClient (callInstanceEndpoint), @@ -234,48 +236,56 @@ time. restoreContractStateTests :: TestTree restoreContractStateTests = + let dbPath = Text.unpack . dbConfigFile . dbConfig in testGroup "restoreContractState scenarios" [ testCase "Can init,pong,ping in one PAB instance" $ do -- This isn't testing anything related to restoring state; but simply -- provides evidence that if the subsequent tests _fail_, then that is -- an genuine error. let pabConfig = defaultPabConfig - startPrimaryPab pabConfig - ci <- startPingPongContract pabConfig - runPabInstanceEndpoints pabConfig ci (map Succeed ["initialise", "pong", "ping"]) + -- We use 'withConnection' here and in the tests below + -- to keep the in-memory sqlite db, otherwise the pool + -- closes the connection and the db gets destroyed + Sqlite.withConnection (dbPath pabConfig) $ \_ -> do + startPrimaryPab pabConfig + ci <- startPingPongContract pabConfig + + runPabInstanceEndpoints pabConfig ci (map Succeed ["initialise", "pong", "ping"]) , testCase "PingPong contract state is maintained across PAB instances" $ do -- We'll check the following: Init, Pong, , , Ping works. let pabConfig = bumpConfig 50 "db1" defaultPabConfig - startPrimaryPab pabConfig - ci <- startPingPongContract pabConfig + Sqlite.withConnection (dbPath pabConfig) $ \_ -> do + startPrimaryPab pabConfig + ci <- startPingPongContract pabConfig - -- Run init, pong on one pab - runPabInstanceEndpoints pabConfig ci (map Succeed ["initialise", "pong"]) + -- Run init, pong on one pab + runPabInstanceEndpoints pabConfig ci (map Succeed ["initialise", "pong"]) - -- Then, check 'ping' works on a different PAB instance (that will - -- have restored from the same DB.) - let newConfig = bumpConfig 50 "db1" pabConfig - startSecondaryPab (secondaryConfig pabConfig newConfig) + -- Then, check 'ping' works on a different PAB instance (that will + -- have restored from the same DB.) + let newConfig = bumpConfig 50 "db1" pabConfig + startSecondaryPab (secondaryConfig pabConfig newConfig) - runPabInstanceEndpoints newConfig ci [Succeed "ping"] + runPabInstanceEndpoints newConfig ci [Succeed "ping"] , testCase "PingPong contract state is NOT maintained across PAB instances with different dbs" $ do -- Note: We bump the ports by 100 here because the two calls above. -- This should mean that no matter the order of these tests, there -- will be no clashes. let pabConfig = bumpConfig 100 "db2" defaultPabConfig - startPrimaryPab pabConfig - ci <- startPingPongContract pabConfig + Sqlite.withConnection (dbPath pabConfig) $ \_ -> do + startPrimaryPab pabConfig + ci <- startPingPongContract pabConfig - -- Run init, pong on one pab - runPabInstanceEndpoints pabConfig ci (map Succeed ["initialise", "pong"]) + -- Run init, pong on one pab + runPabInstanceEndpoints pabConfig ci (map Succeed ["initialise", "pong"]) - -- This time, "ping" should fail because we're using a different - -- in-memory db. - let newConfig = bumpConfig 10 "db3" pabConfig - startSecondaryPab (secondaryConfig pabConfig newConfig) + -- This time, "ping" should fail because we're using a different + -- in-memory db. + let newConfig = bumpConfig 10 "db3" pabConfig + startSecondaryPab (secondaryConfig pabConfig newConfig) - runPabInstanceEndpoints newConfig ci [Fail "ping"] + runPabInstanceEndpoints newConfig ci [Fail "ping"] ] diff --git a/plutus-pab/plutus-pab.cabal b/plutus-pab/plutus-pab.cabal index 80d392b0ad..298d8de69f 100644 --- a/plutus-pab/plutus-pab.cabal +++ b/plutus-pab/plutus-pab.cabal @@ -172,6 +172,7 @@ library prettyprinter >=1.1.0.1, quickcheck-instances -any, random -any, + resource-pool -any, row-types -any, servant -any, servant-client -any, diff --git a/plutus-pab/src/Plutus/PAB/App.hs b/plutus-pab/src/Plutus/PAB/App.hs index 9d27e174c5..62f8beaaca 100644 --- a/plutus-pab/src/Plutus/PAB/App.hs +++ b/plutus-pab/src/Plutus/PAB/App.hs @@ -6,6 +6,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RankNTypes #-} @@ -53,12 +54,13 @@ import Data.Aeson (FromJSON, ToJSON, eitherDecode) import Data.ByteString.Lazy qualified as BSL import Data.Coerce (coerce) import Data.Default (def) +import Data.Pool (Pool) +import Data.Pool qualified as Pool import Data.Text (Text, pack, unpack) import Data.Typeable (Typeable) import Database.Beam.Migrate.Simple (autoMigrate) import Database.Beam.Sqlite qualified as Sqlite import Database.Beam.Sqlite.Migrate qualified as Sqlite -import Database.SQLite.Simple (open) import Database.SQLite.Simple qualified as Sqlite import Network.HTTP.Client (managerModifyRequest, newManager, setRequestIgnoreStatus) import Network.HTTP.Client.TLS (tlsManagerSettings) @@ -78,7 +80,7 @@ import Plutus.PAB.Monitoring.Monitoring (convertLog, handleLogMsgTrace) import Plutus.PAB.Monitoring.PABLogMsg (PABLogMsg (SMultiAgent), PABMultiAgentMsg (BeamLogItem, UserLog, WalletClient), WalletClientMsg) import Plutus.PAB.Timeout (Timeout (Timeout)) -import Plutus.PAB.Types (Config (Config), DbConfig (DbConfig, dbConfigFile), +import Plutus.PAB.Types (Config (Config), DbConfig (..), DevelopmentOptions (DevelopmentOptions, pabResumeFrom, pabRollbackHistory), PABError (BeamEffectError, ChainIndexError, NodeClientError, RemoteWalletWithMockNodeError, WalletClientError, WalletError), WebserverConfig (WebserverConfig), chainIndexConfig, dbConfig, developmentOptions, @@ -95,7 +97,7 @@ import Wallet.Types (ContractInstanceId) -- | Application environment with a contract type `a`. data AppEnv a = AppEnv - { dbConnection :: Sqlite.Connection + { dbPool :: Pool Sqlite.Connection , walletClientEnv :: Maybe ClientEnv -- ^ No 'ClientEnv' when in the remote client setting. , nodeClientEnv :: ClientEnv , chainIndexEnv :: ClientEnv @@ -148,7 +150,7 @@ appEffectHandlers storageBackend config trace BuiltinHandler{contractHandler} = interpret (handleLogMsgTrace trace) . reinterpret (mapLog @_ @(PABLogMsg (Builtin a)) SMultiAgent) . interpret (Core.handleUserEnvReader @(Builtin a) @(AppEnv a)) - . interpret (Core.handleMappedReader @(AppEnv a) dbConnection) + . interpret (Core.handleMappedReader @(AppEnv a) dbPool) . flip handleError (throwError . BeamEffectError) . interpret (handleBeam (convertLog (SMultiAgent . BeamLogItem) trace)) . reinterpretN @'[_, _, _, _, _] BeamEff.handleContractStore @@ -157,7 +159,7 @@ appEffectHandlers storageBackend config trace BuiltinHandler{contractHandler} = interpret (handleLogMsgTrace trace) . reinterpret (mapLog @_ @(PABLogMsg (Builtin a)) SMultiAgent) . interpret (Core.handleUserEnvReader @(Builtin a) @(AppEnv a)) - . interpret (Core.handleMappedReader @(AppEnv a) dbConnection) + . interpret (Core.handleMappedReader @(AppEnv a) dbPool) . flip handleError (throwError . BeamEffectError) . interpret (handleBeam (convertLog (SMultiAgent . BeamLogItem) trace)) . reinterpretN @'[_, _, _, _, _] handleContractDefinition @@ -259,7 +261,7 @@ mkEnv appTrace appConfig@Config { dbConfig walletClientEnv <- maybe (pure Nothing) (fmap Just . clientEnv) $ preview Wallet._LocalWalletConfig walletServerConfig nodeClientEnv <- clientEnv pscBaseUrl chainIndexEnv <- clientEnv (ChainIndex.ciBaseUrl chainIndexConfig) - dbConnection <- dbConnect appTrace dbConfig + dbPool <- dbConnect appTrace dbConfig txSendHandle <- case pscNodeMode of AlonzoNode -> pure Nothing @@ -291,9 +293,9 @@ logDebugString trace = logDebug trace . SMultiAgent . UserLog -- | Initialize/update the database to hold our effects. migrate :: Trace IO (PABLogMsg (Builtin a)) -> DbConfig -> IO () migrate trace config = do - connection <- dbConnect trace config + pool <- dbConnect trace config logDebugString trace "Running beam migration" - runBeamMigration trace connection + Pool.withResource pool (runBeamMigration trace) runBeamMigration :: Trace IO (PABLogMsg (Builtin a)) @@ -303,10 +305,11 @@ runBeamMigration trace conn = Sqlite.runBeamSqliteDebug (logDebugString trace . autoMigrate Sqlite.migrationBackend checkedSqliteDb -- | Connect to the database. -dbConnect :: Trace IO (PABLogMsg (Builtin a)) -> DbConfig -> IO Sqlite.Connection -dbConnect trace DbConfig {dbConfigFile} = do +dbConnect :: Trace IO (PABLogMsg (Builtin a)) -> DbConfig -> IO (Pool Sqlite.Connection) +dbConnect trace DbConfig {dbConfigFile, dbConfigPoolSize} = do + pool <- Pool.createPool (Sqlite.open $ unpack dbConfigFile) Sqlite.close dbConfigPoolSize 5_000_000 5 logDebugString trace $ "Connecting to DB: " <> dbConfigFile - open (unpack dbConfigFile) + return pool handleContractDefinition :: forall a effs. HasDefinitions a diff --git a/plutus-pab/src/Plutus/PAB/Db/Beam.hs b/plutus-pab/src/Plutus/PAB/Db/Beam.hs index 80a4468d39..18b544478f 100644 --- a/plutus-pab/src/Plutus/PAB/Db/Beam.hs +++ b/plutus-pab/src/Plutus/PAB/Db/Beam.hs @@ -18,6 +18,7 @@ import Control.Monad.Freer.Extras.Beam (handleBeam) import Control.Monad.Freer.Extras.Modify qualified as Modify import Control.Monad.Freer.Reader (runReader) import Data.Aeson (FromJSON, ToJSON) +import Data.Pool (Pool) import Data.Typeable (Typeable) import Database.SQLite.Simple (Connection) import Plutus.PAB.Db.Beam.ContractStore (handleContractStore) @@ -37,14 +38,14 @@ runBeamStoreAction :: , HasDefinitions a , Typeable a ) - => Connection + => Pool Connection -> Trace IO (PABLogMsg (Builtin a)) -> Eff '[ContractStore (Builtin a), LogMsg (PABMultiAgentMsg (Builtin a)), DelayEffect, IO] b -> IO (Either PABError b) -runBeamStoreAction connection trace = +runBeamStoreAction pool trace = runM . runError - . runReader connection + . runReader pool . flip handleError (throwError . BeamEffectError) . interpret (handleBeam (convertLog (SMultiAgent . BeamLogItem) trace)) . subsume @IO