Make sure we close DBs in Wallet Sqlite Specs

Instead of consuming 10s of GB, we the unit tests only consumes 50 MB at
most. Hopefully this will fix the CI unit test timeouts.

lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs

@@ -14,51 +14,42 @@ module Cardano.Pool.DB.SqliteSpec
 import Prelude
 
 import Cardano.BM.Trace
-    ( traceInTVarIO )
+    ( nullTracer )
 import Cardano.DB.Sqlite
-    ( DBLog (..), SqliteContext )
+    ( DBLog (..) )
 import Cardano.Pool.DB
     ( DBLayer (..) )
 import Cardano.Pool.DB.Log
     ( PoolDbLog (..) )
 import Cardano.Pool.DB.Properties
     ( properties )
 import Cardano.Pool.DB.Sqlite
-    ( newDBLayer, withDBLayer )
+    ( withDBLayer )
 import Cardano.Wallet.DummyTarget.Primitive.Types
     ( dummyTimeInterpreter )
 import System.Directory
     ( copyFile )
 import System.FilePath
     ( (</>) )
 import Test.Hspec
-    ( Spec, before, describe, it, shouldBe )
+    ( Spec, around, describe, it, shouldBe )
 import Test.Hspec.Extra
     ( parallel )
 import Test.Utils.Paths
     ( getTestData )
 import Test.Utils.Trace
     ( captureLogging )
-import UnliftIO.STM
-    ( TVar, newTVarIO )
 import UnliftIO.Temporary
     ( withSystemTempDirectory )
 
--- | Set up a DBLayer for testing, with the command context, and the logging
--- variable.
-newMemoryDBLayer :: IO (DBLayer IO)
-newMemoryDBLayer = snd . snd <$> newMemoryDBLayer'
-
-newMemoryDBLayer' :: IO (TVar [PoolDbLog], (SqliteContext, DBLayer IO))
-newMemoryDBLayer' = do
-    logVar <- newTVarIO []
-    (logVar, ) <$> newDBLayer (traceInTVarIO logVar) Nothing ti
-  where
-    ti = dummyTimeInterpreter
+withMemoryDBLayer
+    :: (DBLayer IO -> IO a)
+    -> IO a
+withMemoryDBLayer = withDBLayer nullTracer Nothing dummyTimeInterpreter
 
 spec :: Spec
 spec = parallel $ do
-    before newMemoryDBLayer $ do
+    around withMemoryDBLayer $ do
         parallel $ describe "Sqlite" properties
 
     describe "Migration Regressions" $ do

lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs

@@ -29,6 +29,7 @@
 -- >>> db <- newMemoryDBLayer :: IO TestDBSeq
 -- >>> quickCheck $ prop_sequential db
 
+{-# OPTIONS_GHC -Wno-unused-imports #-}
 module Cardano.Wallet.DB.SqliteSpec
     ( spec
     ) where
@@ -46,7 +47,7 @@ import Cardano.BM.Trace
 import Cardano.Crypto.Wallet
     ( XPrv )
 import Cardano.DB.Sqlite
-    ( DBLog (..), SqliteContext, destroyDBLayer, fieldName )
+    ( DBLog (..), SqliteContext, fieldName )
 import Cardano.Mnemonic
     ( SomeMnemonic (..) )
 import Cardano.Wallet.DB
@@ -61,12 +62,7 @@ import Cardano.Wallet.DB.Arbitrary
 import Cardano.Wallet.DB.Properties
     ( properties )
 import Cardano.Wallet.DB.Sqlite
-    ( DefaultFieldValues (..)
-    , PersistState
-    , newDBFactory
-    , newDBLayer
-    , withDBLayer
-    )
+    ( DefaultFieldValues (..), PersistState, newDBFactory, withDBLayer )
 import Cardano.Wallet.DB.StateMachine
     ( prop_parallel, prop_sequential, validateGenerators )
 import Cardano.Wallet.DummyTarget.Primitive.Types
@@ -208,8 +204,8 @@ import Test.Hspec
     ( Expectation
     , Spec
     , SpecWith
+    , around
     , before
-    , beforeAll
     , beforeWith
     , describe
     , it
@@ -410,7 +406,8 @@ spec = parallel $ do
 sqliteSpecSeq :: Spec
 sqliteSpecSeq = do
     validateGenerators @(SeqState 'Mainnet ShelleyKey)
-    before newMemoryDBLayer $ do
+    let f = (withDBLayer nullTracer defaultFieldValues Nothing dummyTimeInterpreter) . (. snd)
+    around f $ do
         parallel $ describe "Sqlite" properties
         parallel $ describe "Sqlite State machine tests" $ do
             it "Sequential" (prop_sequential :: TestDBSeq -> Property)
@@ -419,7 +416,8 @@ sqliteSpecSeq = do
 sqliteSpecRnd :: Spec
 sqliteSpecRnd = do
     validateGenerators @(RndState 'Mainnet)
-    before newMemoryDBLayer $ do
+    let f = (withDBLayer nullTracer defaultFieldValues Nothing dummyTimeInterpreter) . (. snd)
+    around f $ do
         parallel $ describe "Sqlite State machine (RndState)" $ do
             it "Sequential state machine tests"
                 (prop_sequential :: TestDBRnd -> Property)
@@ -663,7 +661,7 @@ testMigrationPassphraseScheme = do
 -------------------------------------------------------------------------------}
 
 loggingSpec :: Spec
-loggingSpec = withLoggingDB @(SeqState 'Mainnet ShelleyKey) @ShelleyKey $ do
+loggingSpec = withLoggingDB @(SeqState 'Mainnet ShelleyKey) $ do
     describe "Sqlite query logging" $ do
         it "should log queries at DEBUG level" $ \(getLogs, DBLayer{..}) -> do
             atomically $ unsafeRunExceptT $
@@ -685,39 +683,22 @@ loggingSpec = withLoggingDB @(SeqState 'Mainnet ShelleyKey) @ShelleyKey $ do
             msgs <- findObserveDiffs <$> getLogs
             length msgs `shouldBe` count * 2
 
--- | Set up a DBLayer for testing, with the command context, and the logging
--- variable.
-newMemoryDBLayer
-    ::  ( PersistState s
-        , PersistPrivateKey (k 'RootK)
-        , WalletKey k
-        )
-    => IO (DBLayer IO s k)
-newMemoryDBLayer = snd . snd <$> newMemoryDBLayer'
-
-newMemoryDBLayer'
-    ::  ( PersistState s
-        , PersistPrivateKey (k 'RootK)
-        , WalletKey k
-        )
-    => IO (TVar [DBLog], (SqliteContext, DBLayer IO s k))
-newMemoryDBLayer' = do
-    logVar <- newTVarIO []
-    (logVar, ) <$>
-        newDBLayer (traceInTVarIO logVar) defaultFieldValues Nothing ti
-  where
-   ti = dummyTimeInterpreter
 
 withLoggingDB
-    ::  ( PersistState s
-        , PersistPrivateKey (k 'RootK)
-        , WalletKey k
-        )
-    => SpecWith (IO [DBLog], DBLayer IO s k)
+    :: PersistState s
+    => SpecWith (IO [DBLog], DBLayer IO s ShelleyKey)
     -> Spec
-withLoggingDB = beforeAll newMemoryDBLayer' . beforeWith clean
+withLoggingDB = around f . beforeWith clean
   where
-    clean (logs, (_, db)) = do
+    f act = do
+        logVar <- newTVarIO []
+        withDBLayer
+            (traceInTVarIO logVar)
+            defaultFieldValues
+            Nothing
+            dummyTimeInterpreter
+            (\(_, db) -> act (logVar, db))
+    clean (logs, db) = do
         cleanDB db
         STM.atomically $ writeTVar logs []
         pure (readTVarIO logs, db)
@@ -752,8 +733,8 @@ fileModeSpec =  do
         it "Opening and closing of db works" $ do
             replicateM_ 25 $ do
                 db <- Just <$> temporaryDBFile
-                (ctx, _) <- newDBLayer' @(SeqState 'Mainnet ShelleyKey) db
-                destroyDBLayer ctx
+                withDBLayer' @(SeqState 'Mainnet ShelleyKey) db
+                    (\_ -> pure ())
 
     describe "DBFactory" $ do
         let ti = dummyTimeInterpreter
@@ -830,73 +811,67 @@ fileModeSpec =  do
         describe "Check db reading/writing from/to file and cleaning" $ do
 
         it "create and list wallet works" $ \f -> do
-            (ctx, DBLayer{..}) <- newDBLayer' (Just f)
-            atomically $ unsafeRunExceptT $
-                initializeWallet testPk testCp testMetadata mempty gp
-            destroyDBLayer ctx
+            withDBLayer' (Just f) $ \(_, DBLayer{..}) -> do
+                atomically $ unsafeRunExceptT $
+                    initializeWallet testPk testCp testMetadata mempty gp
             testOpeningCleaning f listWallets' [testPk] []
 
         it "create and get meta works" $ \f -> do
-            (ctx, DBLayer{..}) <- newDBLayer' (Just f)
-            now <- getCurrentTime
-            let meta = testMetadata
-                   { passphraseInfo = Just $ WalletPassphraseInfo now EncryptWithPBKDF2 }
-            atomically $ unsafeRunExceptT $
-                initializeWallet testPk testCp meta mempty gp
-            destroyDBLayer ctx
+            meta <- withDBLayer' (Just f) $ \(_, DBLayer{..}) -> do
+                now <- getCurrentTime
+                let meta = testMetadata
+                       { passphraseInfo = Just $ WalletPassphraseInfo now EncryptWithPBKDF2 }
+                atomically $ unsafeRunExceptT $
+                    initializeWallet testPk testCp meta mempty gp
+                return meta
             testOpeningCleaning f (`readWalletMeta'` testPk) (Just meta) Nothing
 
         it "create and get private key" $ \f-> do
-            (ctx, db@DBLayer{..}) <- newDBLayer' (Just f)
-            atomically $ unsafeRunExceptT $
-                initializeWallet testPk testCp testMetadata mempty gp
-            (k, h) <- unsafeRunExceptT $ attachPrivateKey db testPk
-            destroyDBLayer ctx
+            (k, h) <- withDBLayer' (Just f) $ \(_, db@DBLayer{..}) -> do
+                atomically $ unsafeRunExceptT $
+                    initializeWallet testPk testCp testMetadata mempty gp
+                unsafeRunExceptT $ attachPrivateKey db testPk
             testOpeningCleaning f (`readPrivateKey'` testPk) (Just (k, h)) Nothing
 
         it "put and read tx history (Ascending)" $ \f -> do
-            (ctx, DBLayer{..}) <- newDBLayer' (Just f)
-            atomically $ do
-                unsafeRunExceptT $
-                    initializeWallet testPk testCp testMetadata mempty gp
-                unsafeRunExceptT $ putTxHistory testPk testTxs
-            destroyDBLayer ctx
+            withDBLayer' (Just f) $ \(_, DBLayer{..}) -> do
+                atomically $ do
+                    unsafeRunExceptT $
+                        initializeWallet testPk testCp testMetadata mempty gp
+                    unsafeRunExceptT $ putTxHistory testPk testTxs
             testOpeningCleaning
                 f
                 (\db' -> readTxHistory' db' testPk Ascending wholeRange Nothing)
                 testTxs
                 mempty
 
         it "put and read tx history (Decending)" $ \f -> do
-            (ctx, DBLayer{..}) <- newDBLayer' (Just f)
-            atomically $ do
-                unsafeRunExceptT $
-                    initializeWallet testPk testCp testMetadata mempty gp
-                unsafeRunExceptT $ putTxHistory testPk testTxs
-            destroyDBLayer ctx
+            withDBLayer' (Just f) $ \(_, DBLayer{..}) -> do
+                atomically $ do
+                    unsafeRunExceptT $
+                        initializeWallet testPk testCp testMetadata mempty gp
+                    unsafeRunExceptT $ putTxHistory testPk testTxs
             testOpeningCleaning
                 f
                 (\db' -> readTxHistory' db' testPk Descending wholeRange Nothing)
                 testTxs
                 mempty
 
         it "put and read checkpoint" $ \f -> do
-            (ctx, DBLayer{..}) <- newDBLayer' (Just f)
-            atomically $ do
-                unsafeRunExceptT $
-                    initializeWallet testPk testCp testMetadata mempty gp
-                unsafeRunExceptT $ putCheckpoint testPk testCp
-            destroyDBLayer ctx
+            withDBLayer' (Just f) $ \(_, DBLayer{..}) -> do
+                atomically $ do
+                    unsafeRunExceptT $
+                        initializeWallet testPk testCp testMetadata mempty gp
+                    unsafeRunExceptT $ putCheckpoint testPk testCp
             testOpeningCleaning f (`readCheckpoint'` testPk) (Just testCp) Nothing
 
         describe "Golden rollback scenarios" $ do
             let dummyHash x = Hash $ x <> BS.pack (replicate (32 - (BS.length x)) 0)
             let dummyAddr x = Address $ x <> BS.pack (replicate (32 - (BS.length x)) 0)
 
             it "(Regression test #1575) - TxMetas and checkpoints should \
-               \rollback to the same place" $ \f -> do
-                (_ctx, db@DBLayer{..}) <- newDBLayer' (Just f)
-
+               \rollback to the same place"
+               $ \f -> withDBLayer' (Just f) $ \(_, db@DBLayer{..}) -> do
                 let ourAddrs = knownAddresses (getState testCp)
 
                 atomically $ unsafeRunExceptT $ initializeWallet
@@ -977,15 +952,15 @@ prop_randomOpChunks (KeyValPairs pairs) =
   where
     prop = do
         filepath <- temporaryDBFile
-        (ctxF, dbF) <- newDBLayer' (Just filepath) >>= cleanDB'
-        (ctxM, dbM) <- inMemoryDBLayer >>= cleanDB'
-        forM_ pairs (insertPair dbM)
-        cutRandomly pairs >>= mapM_ (\chunk -> do
-            (ctx, db) <- newDBLayer' (Just filepath)
-            forM_ chunk (insertPair db)
-            destroyDBLayer ctx)
-        dbF `shouldBeConsistentWith` dbM
-        destroyDBLayer ctxF *> destroyDBLayer ctxM
+        withDBLayer' (Just filepath) $ \x -> do
+            (_ctxF, dbF) <- cleanDB' x
+            withMemoryDBLayer $ \x' -> do
+                (_ctxM, dbM) <- cleanDB' x'
+                forM_ pairs (insertPair dbM)
+                cutRandomly pairs >>= mapM_ (\chunk -> do
+                    withDBLayer' (Just filepath) (\(_ctx, db) ->
+                        forM_ chunk (insertPair db)))
+                dbF `shouldBeConsistentWith` dbM
 
     insertPair
         :: DBLayer IO s k
@@ -1027,14 +1002,12 @@ testOpeningCleaning
     -> s
     -> Expectation
 testOpeningCleaning filepath call expectedAfterOpen expectedAfterClean = do
-    (ctx1, db1) <- newDBLayer' (Just filepath)
-    call db1 `shouldReturn` expectedAfterOpen
-    _ <- cleanDB db1
-    call db1 `shouldReturn` expectedAfterClean
-    destroyDBLayer ctx1
-    (ctx2,db2) <- newDBLayer' (Just filepath)
-    call db2 `shouldReturn` expectedAfterClean
-    destroyDBLayer ctx2
+    withDBLayer' (Just filepath) $ \(_, db1) -> do
+        call db1 `shouldReturn` expectedAfterOpen
+        _ <- cleanDB db1
+        call db1 `shouldReturn` expectedAfterClean
+    withDBLayer' (Just filepath) $ \(_, db2) -> do
+        call db2 `shouldReturn` expectedAfterClean
 
 
 -- | Run a test action inside withDBLayer, then check assertions.
@@ -1058,10 +1031,12 @@ withTestDBFile action expectations = do
   where
     ti = dummyTimeInterpreter
 
-inMemoryDBLayer
+
+
+withMemoryDBLayer
     :: PersistState s
-    => IO (SqliteContext, DBLayer IO s ShelleyKey)
-inMemoryDBLayer = newDBLayer' Nothing
+    => (((SqliteContext, DBLayer IO s ShelleyKey) -> IO a) -> IO a)
+withMemoryDBLayer = withDBLayer' Nothing
 
 temporaryDBFile :: IO FilePath
 temporaryDBFile = emptySystemTempFile "cardano-wallet-SqliteFileMode"
@@ -1075,11 +1050,11 @@ defaultFieldValues = DefaultFieldValues
     , defaultKeyDeposit = Coin 2_000_000
     }
 
-newDBLayer'
+withDBLayer'
     :: PersistState s
     => Maybe FilePath
-    -> IO (SqliteContext, DBLayer IO s ShelleyKey)
-newDBLayer' fp = newDBLayer nullTracer defaultFieldValues fp ti
+    -> (((SqliteContext, DBLayer IO s ShelleyKey) -> IO a) -> IO a)
+withDBLayer' fp = withDBLayer nullTracer defaultFieldValues fp ti
   where
     ti = dummyTimeInterpreter