[ADP-2565] Use Database.Table.SQLite.Simple in Deposit Wallet (#4715)

This pull request changes the Deposit Wallet to use the database
functionality from `Database.Table.SQLite.Simple`.

At the moment, this actually means removing all database usage from the
Deposit Wallet — the mock environment does not need it, and also cannot
use it, as the `SqlM` monad is not an instance of `MonadSTM`. (For good
reason: The `SqlM` monad meant to represent atomic database operations
and is **not** an instance of `MonadIO`).

However, I want to keep the module `Cardano.Wallet.Deposit.IO.DB` around
as a small indirection over `Database.Table.SQLite.Simple`.

### Issue Number

ADP-2565

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

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

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)

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 ()
         }
 

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

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