From 2b557cf2ba02646b26aadcc5e58b0f3946f5e417 Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Sat, 3 Aug 2024 16:28:01 +0200 Subject: [PATCH 1/3] Add `hoistStore` to `Data.Store` --- lib/delta-store/src/Data/Store.hs | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/lib/delta-store/src/Data/Store.hs b/lib/delta-store/src/Data/Store.hs index 597bbf68267..bc0364fbe52 100644 --- a/lib/delta-store/src/Data/Store.hs +++ b/lib/delta-store/src/Data/Store.hs @@ -58,6 +58,7 @@ module Data.Store ( , mkQueryStore -- ** Combinators + , hoistStore , embedStore , pairStores , newCachedStore @@ -331,6 +332,9 @@ other "expected" rules such as and use @atomically@ in a scope where you want to use the 'Store' rather than implement it. + Use 'hoistStore'@ atomically@ to map a 'Store'@ MyMonad@ + to a 'Store'@ IO@ where the monad has less atomicity. + * __Non-determinism__ or other effects: Here be dragons. -} @@ -576,6 +580,19 @@ embedStore' Embedding'{load,write,update} Store{loadS,writeS,updateS} = Right a -> updateL (Just a) da in mkUpdateStore loadL (writeS . write) updateL +-- | Lift +hoistStore + :: Monad m + => (forall a. m a -> n a) + -> Store m qa da + -> Store n qa da +hoistStore f Store{loadS,writeS,updateS,queryS} = Store + { loadS = f loadS + , writeS = f . writeS + , updateS = \ma -> f . updateS ma + , queryS = f . queryS + } + -- | Combine two 'Stores' into a 'Store' for pairs. -- -- TODO: Handle the case where 'writeS' or 'updateS' throw an exception From 6bb0184815575b550beffbeab973cf3cfd9a6ae0 Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Sat, 3 Aug 2024 16:28:24 +0200 Subject: [PATCH 2/3] Use `Store IO` in `WalletEnv`, remove `atomically` We have to increase the delay in `postTx` of the mock environment. --- .../src/Cardano/Wallet/Deposit/IO.hs | 21 +++++++--------- .../Cardano/Wallet/Deposit/IO/Network/Mock.hs | 2 +- .../test/scenario/Test/Scenario/Blockchain.hs | 25 +++++++------------ 3 files changed, 19 insertions(+), 29 deletions(-) diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs index f05e51f1a58..eadc4d30351 100644 --- a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs @@ -55,7 +55,6 @@ import Data.List.NonEmpty ( NonEmpty ) -import qualified Cardano.Wallet.Deposit.IO.DB as DB import qualified Cardano.Wallet.Deposit.IO.Network.Type as Network import qualified Cardano.Wallet.Deposit.Pure as Wallet import qualified Cardano.Wallet.Deposit.Read as Read @@ -77,13 +76,12 @@ data WalletEnv m = { logger :: Tracer m WalletLog , genesisData :: Read.GenesisData , networkEnv :: Network.NetworkEnv m Read.Block - , database :: Store.UpdateStore DB.SqlM Wallet.DeltaWalletState - , atomically :: forall a. DB.SqlM a -> m a + , database :: Store.UpdateStore IO Wallet.DeltaWalletState } data WalletInstance = WalletInstance { env :: WalletEnv IO - , walletState :: DBVar.DBVar DB.SqlM Wallet.DeltaWalletState + , walletState :: DBVar.DBVar IO Wallet.DeltaWalletState } {----------------------------------------------------------------------------- @@ -94,16 +92,16 @@ onWalletState :: WalletInstance -> Delta.Update Wallet.DeltaWalletState r -> IO r -onWalletState WalletInstance{env,walletState} update' = - atomically env $ Delta.onDBVar walletState update' +onWalletState WalletInstance{walletState} = + Delta.onDBVar walletState -- FIXME: Propagation of exceptions from Pure to IO. -- | Convenience to read the 'WalletState'. -- -- Use 'onWalletState' if you want to use the result in an atomic update. readWalletState :: WalletInstance -> IO WalletState -readWalletState WalletInstance{env,walletState} = - atomically env $ DBVar.readDBVar walletState +readWalletState WalletInstance{walletState} = + DBVar.readDBVar walletState {----------------------------------------------------------------------------- Operations @@ -117,8 +115,7 @@ withWalletInit -> (WalletInstance -> IO a) -> IO a withWalletInit env@WalletEnv{..} xpub knownCustomerCount action = do - walletState <- atomically - $ DBVar.initDBVar database + walletState <- DBVar.initDBVar database $ Wallet.fromXPubAndGenesis xpub knownCustomerCount genesisData withWalletDBVar env walletState action @@ -128,12 +125,12 @@ withWalletLoad -> (WalletInstance -> IO a) -> IO a withWalletLoad env@WalletEnv{..} action = do - walletState <- atomically $ DBVar.loadDBVar database + walletState <- DBVar.loadDBVar database withWalletDBVar env walletState action withWalletDBVar :: WalletEnv IO - -> DBVar.DBVar DB.SqlM Wallet.DeltaWalletState + -> DBVar.DBVar IO Wallet.DeltaWalletState -> (WalletInstance -> IO a) -> IO a withWalletDBVar env@WalletEnv{..} walletState action = do diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Mock.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Mock.hs index 11779cbff30..898ed143f84 100644 --- a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Mock.hs +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Mock.hs @@ -84,7 +84,7 @@ newNetworkEnvMock = do (block, tip) <- forgeBlock tx broadcast block tip -- brief delay to account for asynchronous chain followers - threadDelay 10 + threadDelay 100 pure $ Right () } diff --git a/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Blockchain.hs b/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Blockchain.hs index e9fcc2c388d..9b9cc75834b 100644 --- a/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Blockchain.hs +++ b/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Blockchain.hs @@ -30,10 +30,6 @@ import Prelude import Cardano.Crypto.Wallet ( XPrv ) -import Cardano.Wallet.Deposit.IO.DB - ( SqlContext (..) - , withSqlContextInMemory - ) import Cardano.Wallet.Deposit.IO.Network.Mock ( newNetworkEnvMock ) @@ -92,18 +88,15 @@ withWalletEnvMock :: ScenarioEnv -> (Wallet.WalletEnv IO -> IO a) -> IO a -withWalletEnvMock ScenarioEnv{..} action = - withSqlContextInMemory nullTracer - $ \SqlContext{runSqlM} -> do - database <- runSqlM newStore - let walletEnv = Wallet.WalletEnv - { Wallet.logger = nullTracer - , Wallet.genesisData = genesisData - , Wallet.networkEnv = networkEnv - , Wallet.database = database - , Wallet.atomically = runSqlM - } - action walletEnv +withWalletEnvMock ScenarioEnv{..} action = do + database <- newStore + let walletEnv = Wallet.WalletEnv + { Wallet.logger = nullTracer + , Wallet.genesisData = genesisData + , Wallet.networkEnv = networkEnv + , Wallet.database = database + } + action walletEnv {----------------------------------------------------------------------------- Faucet From 8c0211bdd275035616fe221e3d41120ed62f262d Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Sat, 3 Aug 2024 16:48:22 +0200 Subject: [PATCH 3/3] Use `Database.Table.SQLite.Simple` in Deposit Wallet --- .../customer-deposit-wallet.cabal | 2 +- .../src/Cardano/Wallet/Deposit/IO/DB.hs | 77 ++++++++----------- 2 files changed, 32 insertions(+), 47 deletions(-) diff --git a/lib/customer-deposit-wallet/customer-deposit-wallet.cabal b/lib/customer-deposit-wallet/customer-deposit-wallet.cabal index 7b2bd1fcb28..3bf107ee8a2 100644 --- a/lib/customer-deposit-wallet/customer-deposit-wallet.cabal +++ b/lib/customer-deposit-wallet/customer-deposit-wallet.cabal @@ -58,11 +58,11 @@ library , contra-tracer , customer-deposit-wallet-pure , delta-store + , delta-table , delta-types , io-classes , iohk-monitoring-extra , OddWord - , persistent , sqlite-simple , text , transformers diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB.hs index 0c2ca7fe16a..ea11be61815 100644 --- a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB.hs +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB.hs @@ -1,76 +1,61 @@ -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE Rank2Types #-} module Cardano.Wallet.Deposit.IO.DB - ( SqlM - , SqlContext (..) + ( Connection , withSqliteFile - , withSqlContextInMemory + , withSqliteInMemory + + , SqlM + , runSqlM , DBLog (..) ) where import Prelude -import Cardano.BM.Extra - ( bracketTracer - ) -import Cardano.DB.Sqlite - ( DBLog (..) - ) -import Control.Concurrent.MVar - ( newMVar - , withMVar - ) -import Control.Monad.Trans.Reader - ( ReaderT (..) - ) import Control.Tracer ( Tracer - , contramap , traceWith ) - -import qualified Database.SQLite.Simple as Sqlite +import Database.Table.SQLite.Simple + ( Connection + , SqlM + , runSqlM + , withConnection + ) {----------------------------------------------------------------------------- SqlContext ------------------------------------------------------------------------------} --- | Monad to run SQL queries in. -type SqlM = ReaderT Sqlite.Connection IO - --- | A facility to run 'SqlM' computations. --- Importantly, computations are not run in parallel, but sequenced. -newtype SqlContext = SqlContext - { runSqlM :: forall a. SqlM a -> IO a - } - --- | Acquire and release an 'SqlContext' in memory. -withSqlContextInMemory +-- | Acquire and release an SQLite 'Connection' in memory. +withSqliteInMemory :: Tracer IO DBLog -- ^ Logging - -> (SqlContext -> IO a) + -> (Connection -> IO a) -- ^ Action to run -> IO a -withSqlContextInMemory tr = withSqliteFile tr ":memory:" +withSqliteInMemory tr = withSqliteFile tr ":memory:" --- | Use sqlite to open a database file --- and provide an 'SqlContext' for running 'SqlM' actions. +-- | Acquire and release an SQLite 'Connection' from a file. withSqliteFile :: Tracer IO DBLog -- ^ Logging -> FilePath -- ^ Database file - -> (SqlContext -> IO a) + -> (Connection -> IO a) -- ^ Action to run -> IO a withSqliteFile tr filepath action = - Sqlite.withConnection filepath $ \connection0 -> do - traceWith tr $ MsgOpenSingleConnection filepath - -- The lock ensures that database operations are sequenced. - lock <- newMVar connection0 - let runSqlM :: SqlM a -> IO a - runSqlM cmd = withMVar lock (observe . runReaderT cmd) - action SqlContext{runSqlM} - where - observe :: IO a -> IO a - observe = bracketTracer (contramap MsgRun tr) + withConnection filepath $ \conn -> do + traceWith tr $ MsgStartConnection filepath + result <- action conn + traceWith tr $ MsgDoneConnection filepath + pure result + +{------------------------------------------------------------------------------- + Logging +-------------------------------------------------------------------------------} + +data DBLog + = MsgStartConnection FilePath + | MsgDoneConnection FilePath + deriving (Show, Eq)