SqliteSpec: Fix shrinking in state machine tests

lib/core/cardano-wallet-core.cabal

@@ -308,6 +308,7 @@ test-suite unit
     , transformers
     , tree-diff
     , unliftio
+    , unliftio-core
     , unordered-containers
     , x509
     , x509-store

lib/core/src/Cardano/Wallet/DB/Sqlite.hs

@@ -34,9 +34,12 @@ module Cardano.Wallet.DB.Sqlite
     , withDBLayer
     , withDBLayerInMemory
     , WalletDBLog (..)
-    , newDBLayerWith
     , CacheBehavior (..)
 
+    -- * Unbracketed internal implementation
+    , newDBLayerWith
+    , newDBLayerInMemory
+
     -- * Interfaces
     , PersistState (..)
 
@@ -1198,6 +1201,9 @@ withDBLayerInMemory
 withDBLayerInMemory tr ti action = bracket (newDBLayerInMemory tr ti) fst (action . snd)
 
 -- | Creates a 'DBLayer' backed by a sqlite in-memory database.
+--
+-- Returns a cleanup function which you should always use exactly once when
+-- finished with the 'DBLayer'.
 newDBLayerInMemory
     :: forall s k.
         ( PersistState s

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

@@ -58,19 +58,20 @@ import Cardano.Wallet.DB
     , cleanDB
     )
 import Cardano.Wallet.DB.Arbitrary
-    ( KeyValPairs (..) )
+    ( GenState, KeyValPairs (..) )
 import Cardano.Wallet.DB.Properties
     ( properties )
 import Cardano.Wallet.DB.Sqlite
     ( DefaultFieldValues (..)
     , PersistState
     , WalletDBLog (..)
     , newDBFactory
+    , newDBLayerInMemory
     , withDBLayer
     , withDBLayerInMemory
     )
 import Cardano.Wallet.DB.StateMachine
-    ( prop_parallel, prop_sequential, validateGenerators )
+    ( TestConstraints, prop_parallel, prop_sequential, validateGenerators )
 import Cardano.Wallet.DummyTarget.Primitive.Types
     ( block0, dummyGenesisParameters, dummyTimeInterpreter, mockHash )
 import Cardano.Wallet.Gen
@@ -183,6 +184,8 @@ import Data.Time.Clock
     ( getCurrentTime )
 import Data.Time.Clock.POSIX
     ( posixSecondsToUTCTime )
+import Data.Typeable
+    ( Typeable, typeOf )
 import Data.Word
     ( Word64 )
 import Database.Persist.Sql
@@ -207,6 +210,7 @@ import Test.Hspec
     ( Expectation
     , Spec
     , SpecWith
+    , anyIOException
     , around
     , before
     , beforeWith
@@ -223,9 +227,16 @@ import Test.Hspec
 import Test.Hspec.Extra
     ( parallel )
 import Test.QuickCheck
-    ( Property, generate, noShrinking, property, (==>) )
+    ( Arbitrary (..)
+    , Property
+    , choose
+    , generate
+    , noShrinking
+    , property
+    , (==>)
+    )
 import Test.QuickCheck.Monadic
-    ( monadicIO )
+    ( assert, monadicIO, run )
 import Test.Utils.Paths
     ( getTestData )
 import Test.Utils.Trace
@@ -256,31 +267,40 @@ import qualified UnliftIO.STM as STM
 
 spec :: Spec
 spec = parallel $ do
-    sqliteSpecSeq
-    sqliteSpecRnd
+    stateMachineSpecSeq
+    stateMachineSpecRnd
     propertiesSpecSeq
     loggingSpec
     fileModeSpec
     manualMigrationsSpec
 
-sqliteSpecSeq :: Spec
-sqliteSpecSeq = do
-    validateGenerators @(SeqState 'Mainnet ShelleyKey)
-    around withShelleyDBLayer $
-        describe "Sqlite State machine tests" $ do
-        it "Sequential" (prop_sequential :: TestDBSeq -> Property)
-        xit "Parallel" prop_parallel
-
-sqliteSpecRnd :: Spec
-sqliteSpecRnd = do
-    validateGenerators @(RndState 'Mainnet)
-    around withByronDBLayer $ do
-        describe "Sqlite State machine (RndState)" $ do
-            it "Sequential state machine tests"
-                (prop_sequential :: TestDBRnd -> Property)
+stateMachineSpec
+    :: forall k s.
+        ( WalletKey k
+        , PersistPrivateKey (k 'RootK)
+        , PaymentAddress 'Mainnet k
+        , PersistState s
+        , Arbitrary (Wallet s)
+        , GenState s
+        , TestConstraints s k
+        , Typeable s
+        )
+    => Spec
+stateMachineSpec = describe ("State machine test (" ++ showState @s ++ ")") $ do
+    validateGenerators @s
+    let newDB = newDBLayerInMemory @s @k nullTracer dummyTimeInterpreter
+    it "Sequential" $ prop_sequential newDB
+    xit "Parallel" $ prop_parallel newDB
+
+showState :: forall s. Typeable s => String
+showState = show (typeOf @s undefined)
+
+stateMachineSpecSeq, stateMachineSpecRnd :: Spec
+stateMachineSpecSeq = stateMachineSpec @ShelleyKey @(SeqState 'Mainnet ShelleyKey)
+stateMachineSpecRnd = stateMachineSpec @ByronKey @(RndState 'Mainnet)
 
 propertiesSpecSeq :: Spec
-propertiesSpecSeq = around withShelleyDBLayer $ describe "Sqlite"
+propertiesSpecSeq = around withShelleyDBLayer $ describe "Properties"
     (properties :: SpecWith TestDBSeq)
 
 testMigrationTxMetaFee
@@ -573,7 +593,6 @@ findObserveDiffs = filter isObserveDiff
 -------------------------------------------------------------------------------}
 
 type TestDBSeq = DBLayer IO (SeqState 'Mainnet ShelleyKey) ShelleyKey
-type TestDBRnd = DBLayer IO (RndState 'Mainnet) ByronKey
 
 fileModeSpec :: Spec
 fileModeSpec =  do
@@ -891,11 +910,8 @@ defaultFieldValues = DefaultFieldValues
     , defaultKeyDeposit = Coin 2_000_000
     }
 
--- Note: Having two separate helpers with concrete key types reduces the need
+-- Note: Having helper with concrete key types reduces the need
 -- for type-application everywhere.
-withByronDBLayer :: PersistState s => ((DBLayer IO s ByronKey) -> IO a) -> IO a
-withByronDBLayer = withDBLayerInMemory nullTracer dummyTimeInterpreter
-
 withShelleyDBLayer :: PersistState s => (DBLayer IO s ShelleyKey -> IO a) -> IO a
 withShelleyDBLayer = withDBLayerInMemory nullTracer dummyTimeInterpreter
 

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

@@ -13,6 +13,7 @@
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -48,6 +49,7 @@ module Cardano.Wallet.DB.StateMachine
     , prop_parallel
     , validateGenerators
     , showLabelledExamples
+    , TestConstraints
     ) where
 
 import Prelude
@@ -162,8 +164,8 @@ import Control.Foldl
     ( Fold (..) )
 import Control.Monad
     ( forM_, replicateM, void, when )
-import Control.Monad.IO.Class
-    ( liftIO )
+import Control.Monad.IO.Unlift
+    ( MonadIO )
 import Control.Monad.Trans.Except
     ( mapExceptT, runExceptT )
 import Crypto.Hash
@@ -215,7 +217,7 @@ import Test.QuickCheck
     , (===)
     )
 import Test.QuickCheck.Monadic
-    ( monadicIO )
+    ( monadicIO, run )
 import Test.QuickCheck.Random
     ( mkQCGen )
 import Test.StateMachine
@@ -453,20 +455,16 @@ runMock = \case
   Interpreter: real I/O
 -------------------------------------------------------------------------------}
 
--- | Type alias for the 'DBLayer', just to reduce noise in type signatures. This
--- 'DBLayer' is specialized to a dummy node backend.
-type DBLayerTest s k = DBLayer IO s k
-
 runIO
-    :: forall s k. (MockPrivKey (k 'RootK))
-    => DBLayerTest s k
+    :: forall m s k. (MonadIO m, MockPrivKey (k 'RootK))
+    => DBLayer m s k
     -> Cmd s WalletId
-    -> IO (Resp s WalletId)
+    -> m (Resp s WalletId)
 runIO db@DBLayer{..} = fmap Resp . go
   where
     go
         :: Cmd s WalletId
-        -> IO (Either (Err WalletId) (Success s WalletId))
+        -> m (Either (Err WalletId) (Success s WalletId))
     go = \case
         CleanDB -> do
             Right . Unit <$> cleanDB db
@@ -789,10 +787,10 @@ postcondition m c r =
     e = lockstep m c r
 
 semantics
-    :: MockPrivKey (k 'RootK)
-    => DBLayerTest s k
+    :: (MonadIO m, MockPrivKey (k 'RootK))
+    => DBLayer m s k
     -> Cmd s :@ Concrete
-    -> IO (Resp s :@ Concrete)
+    -> m (Resp s :@ Concrete)
 semantics db (At c) =
     (At . fmap QSM.reference) <$>
         runIO db (fmap QSM.concrete c)
@@ -808,12 +806,13 @@ type TestConstraints s k =
     , Eq s
     , GenState s
     , Arbitrary (Wallet s)
+    , ToExpr s
     )
 
 sm
-    :: TestConstraints s k
-    => DBLayerTest s k
-    -> StateMachine (Model s) (At (Cmd s)) IO (At (Resp s))
+    :: (MonadIO m, TestConstraints s k)
+    => DBLayer m s k
+    -> StateMachine (Model s) (At (Cmd s)) m (At (Resp s))
 sm db = QSM.StateMachine
     { initModel = initModel
     , transition = transition
@@ -1277,7 +1276,7 @@ showLabelledExamples mReplay = do
             , replay = Just (mkQCGen replaySeed, 0)
             }
     labelledExamplesWith args $
-        forAllCommands (sm @s @k dbLayerUnused) Nothing $ \cmds ->
+        forAllCommands (sm @IO @s @k dbLayerUnused) Nothing $ \cmds ->
             repeatedly collect (tag . execCmds $ cmds) (property True)
 
 repeatedly :: (a -> b -> b) -> ([a] -> b -> b)
@@ -1287,17 +1286,21 @@ repeatedly = flip . L.foldl' . flip
   Top-level tests
 -------------------------------------------------------------------------------}
 
-prop_sequential :: forall s k. (TestConstraints s k, ToExpr s) => DBLayerTest s k -> Property
-prop_sequential db =
+prop_sequential
+    :: forall s k. (TestConstraints s k)
+    => (IO (IO (), DBLayer IO s k))
+    -> Property
+prop_sequential newDB =
     QC.checkCoverage $
-    forAllCommands (sm @s @k dbLayerUnused) Nothing $ \cmds ->
-    monadicIO $ do
-        liftIO $ cleanDB db
-        let sm' = sm db
-        (hist, _model, res) <- runCommands sm' cmds
-        prettyCommands sm' hist
-            $ measureTagCoverage cmds
-            $ res === Ok
+    forAllCommands (sm @IO @s @k dbLayerUnused) Nothing $ \cmds ->
+        monadicIO $ do
+            (destroyDB, db) <- run newDB
+            let sm' = sm db
+            (hist, _model, res) <- runCommands sm' cmds
+            prettyCommands sm' hist
+                $ measureTagCoverage cmds
+                $ res === Ok
+            run destroyDB -- fixme: bracket difficult
   where
     measureTagCoverage :: Commands (At (Cmd s)) (At (Resp s)) -> Property -> Property
     measureTagCoverage cmds prop = foldl' measureTag prop allTags
@@ -1308,13 +1311,19 @@ prop_sequential db =
         matchedTags :: Set Tag
         matchedTags = Set.fromList $ tag $ execCmds cmds
 
-prop_parallel :: forall s k. TestConstraints s k => DBLayerTest s k -> Property
-prop_parallel db =
-    forAllParallelCommands (sm @s @k dbLayerUnused) nThreads $ \cmds ->
+prop_parallel
+    :: forall s k. TestConstraints s k
+    => (IO (IO (), DBLayer IO s k))
+    -> Property
+prop_parallel newDB =
+    forAllParallelCommands (sm @IO @s @k dbLayerUnused) nThreads $ \cmds ->
     monadicIO $ do
+        (destroyDB, db) <- run newDB
         let sm' = sm db
             cmds' = addCleanDB cmds
-        prettyParallelCommands cmds =<< runParallelCommands sm' cmds'
+        res <- runParallelCommands sm' cmds'
+        prettyParallelCommands cmds res
+        run destroyDB
   where
     nThreads = Just 4
 
@@ -1386,5 +1395,5 @@ addCleanDB (ParallelCommands p s) = ParallelCommands (clean <> p) s
     cmd = Command (At CleanDB)
     resp = At (Resp (Right (Unit ())))
 
-dbLayerUnused :: DBLayerTest s k
+dbLayerUnused :: DBLayer m s k
 dbLayerUnused = error "DBLayer not used during command generation"