Merge pull request #259 from input-output-hk/rvl/154/db-layer-qsm

Generate DBLayer tests with quickcheck-state-machine

.weeder.yaml

@@ -39,4 +39,12 @@
     - message:
       - name: Module not compiled
       - module: Cardano.Launcher.Windows
-
+- package:
+  - name: cardano-wallet-core
+  - section:
+    - name: test:unit
+    - message:
+      - name: Weeds exported
+      - module:
+        - name: Cardano.Wallet.DB.StateMachine
+        - identifier: showLabelledExamples

lib/core/cardano-wallet-core.cabal

@@ -120,6 +120,7 @@ test-suite unit
     , deepseq
     , file-embed
     , fmt
+    , foldl
     , generic-arbitrary
     , hspec
     , hspec-golden-aeson
@@ -128,13 +129,16 @@ test-suite unit
     , memory
     , QuickCheck
     , quickcheck-instances
+    , quickcheck-state-machine >= 0.6.0
+    , random
     , servant-server
     , servant-swagger
     , swagger2
     , text
     , text-class
     , time
     , transformers
+    , tree-diff
     , yaml
   type:
      exitcode-stdio-1.0
@@ -146,6 +150,7 @@ test-suite unit
       Cardano.Wallet.Api.TypesSpec
       Cardano.Wallet.ApiSpec
       Cardano.Wallet.DB.MVarSpec
+      Cardano.Wallet.DB.StateMachine
       Cardano.Wallet.DB.SqliteSpec
       Cardano.Wallet.DBSpec
       Cardano.Wallet.EnvironmentSpec

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

@@ -12,6 +12,7 @@ module Cardano.Wallet.DB
     ( -- * Interface
       DBLayer(..)
     , PrimaryKey(..)
+    , cleanDB
 
       -- * Errors
     , ErrNoSuchWallet(..)
@@ -27,7 +28,7 @@ import Cardano.Wallet.Primitive.Model
 import Cardano.Wallet.Primitive.Types
     ( Hash, Tx, TxMeta, WalletId, WalletMetadata )
 import Control.Monad.Trans.Except
-    ( ExceptT )
+    ( ExceptT, runExceptT )
 import Data.Map.Strict
     ( Map )
 
@@ -146,3 +147,7 @@ newtype ErrWalletAlreadyExists
 -- (like for instance, the last known network tip).
 newtype PrimaryKey key = PrimaryKey key
     deriving (Eq, Ord)
+
+-- | Clean a database by removing all wallets.
+cleanDB :: Monad m => DBLayer m s t -> m ()
+cleanDB db = listWallets db >>= mapM_ (runExceptT . removeWallet db)

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

@@ -1,5 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedLabels #-}
@@ -14,6 +15,7 @@
 
 module Cardano.Wallet.DB.Sqlite
     ( newDBLayer
+    , DummyState(..)
     ) where
 
 import Prelude
@@ -71,8 +73,6 @@ import Control.Monad.Trans.Maybe
     ( MaybeT (..) )
 import Control.Monad.Trans.Resource
     ( runResourceT )
-import Data.Bifunctor
-    ( bimap )
 import Data.Coerce
     ( coerce )
 import Data.Either
@@ -97,7 +97,7 @@ import Database.Persist.Sql
     , insert_
     , putMany
     , rawExecute
-    , runMigration
+    , runMigrationSilent
     , runSqlConn
     , selectFirst
     , selectKeysList
@@ -112,6 +112,8 @@ import Database.Persist.Sqlite
     ( SqlBackend, SqlPersistM, SqlPersistT, wrapConnection )
 import Database.Sqlite
     ( Error (ErrorConstraint), SqliteException (SqliteException) )
+import GHC.Generics
+    ( Generic )
 import System.IO
     ( stderr )
 import System.Log.FastLogger
@@ -184,7 +186,7 @@ newDBLayer fp = do
     conn <- createSqliteBackend fp (dbLogs [LevelError])
     let runQuery' = withMVar bigLock . const . runQuery conn
 
-    runQuery' $ void $ runMigration migrateAll
+    runQuery' $ void $ runMigrationSilent migrateAll
     runQuery' addIndexes
 
     return $ DBLayer
@@ -213,7 +215,8 @@ newDBLayer fp = do
                   Nothing -> pure $ Left $ ErrNoSuchWallet wid
 
         , listWallets = runQuery' $
-              map (PrimaryKey . unWalletKey) <$> selectKeysList [] []
+              map (PrimaryKey . unWalletKey) <$>
+              selectKeysList [] [Asc WalTableId]
 
         {-----------------------------------------------------------------------
                                     Checkpoints
@@ -267,9 +270,7 @@ newDBLayer fp = do
                   Just _ -> do
                       let (metas, txins, txouts) = mkTxHistory wid txs
                       putTxMetas wid metas
-                      putMany txins
-                      putMany txouts
-                      deleteLooseTransactions
+                      putTxs (TxId <$> Map.keys txs) txins txouts
                       pure $ Right ()
                   Nothing -> pure $ Left $ ErrNoSuchWallet wid
 
@@ -381,11 +382,10 @@ mkCheckpointEntity
     -> W.Wallet s t
     -> (Checkpoint, [UTxO], [PendingTx], [TxIn], [TxOut])
 mkCheckpointEntity wid wal =
-    ( cp, utxo, map (pendingTx . fst) pending
-    , concatMap (dist pendingTxIn . fmap W.inputs) pending
-    , concatMap (dist pendingTxOut . fmap (zip [0..] . W.outputs)) pending )
+    (cp, utxo, map (pendingTx . TxId . fst) pending, ins, outs)
   where
-    pending = [(TxId (W.txId @t tx), tx) | tx <- Set.toList (W.getPending wal)]
+    pending = [(W.txId @t tx, tx) | tx <- Set.toList (W.getPending wal)]
+    (ins, outs) = mkTxInputsOutputs pending
     sl = W.currentTip wal
     cp = Checkpoint
         { checkpointTableWalletId = wid
@@ -396,22 +396,12 @@ mkCheckpointEntity wid wal =
         , pendingTxTableCheckpointSlot = sl
         , pendingTxTableId2 = tid
         }
-    pendingTxIn tid txIn = TxIn
-        { txInputTableTxId = tid
-        , txInputTableSourceTxId = TxId (W.inputId txIn)
-        , txInputTableSourceIndex = W.inputIx txIn
-        }
-    pendingTxOut tid (ix, txOut) = TxOut
-        { txOutputTableTxId = tid
-        , txOutputTableIndex = ix
-        , txOutputTableAddress = W.address txOut
-        , txOutputTableAmount = W.coin txOut
-        }
     utxo = [ UTxO wid sl (TxId input) ix addr coin
            | (W.TxIn input ix, W.TxOut addr coin) <- utxoMap ]
     utxoMap = Map.assocs (W.getUTxO (W.totalUTxO wal))
 
--- inputs and outputs must be sorted by txid, then ix
+-- note: TxIn records must already be sorted by order
+-- and TxOut records must already by sorted by index.
 checkpointFromEntity
     :: forall s t. (W.IsOurs s, NFData s, Show s, W.TxId t)
     => Checkpoint
@@ -426,7 +416,7 @@ checkpointFromEntity (Checkpoint _ tip) utxo ins outs =
     utxo' = W.UTxO . Map.fromList $
         [ (W.TxIn input ix, W.TxOut addr coin)
         | UTxO _ _ (TxId input) ix addr coin <- utxo ]
-    ins' = [(txid, W.TxIn src ix) | TxIn txid (TxId src) ix <- ins]
+    ins' = [(txid, W.TxIn src ix) | TxIn txid _ (TxId src) ix <- ins]
     outs' = [ (txid, W.TxOut addr amt)
             | TxOut txid _ix addr amt <- outs ]
     txids = Set.fromList $ map fst ins' ++ map fst outs'
@@ -440,25 +430,36 @@ mkTxHistory
     :: W.WalletId
     -> Map.Map (W.Hash "Tx") (W.Tx, W.TxMeta)
     -> ([TxMeta], [TxIn], [TxOut])
-mkTxHistory wid txs =
-    ( map (uncurry (mkTxMetaEntity wid)) metas
-    , concatMap (dist mkTxIn . fmap W.inputs) hist
-    , concatMap (dist mkTxOut . fmap (zip [0..] . W.outputs)) hist )
+mkTxHistory wid txs = (map (uncurry (mkTxMetaEntity wid)) metas, ins, outs)
   where
     pairs = Map.toList txs
     metas = fmap snd <$> pairs
-    hist = bimap TxId fst <$> pairs
-    mkTxIn tid txIn = TxIn
-        { txInputTableTxId = tid
+    hist = fmap fst <$> pairs
+    (ins, outs) = mkTxInputsOutputs hist
+
+mkTxInputsOutputs :: [(W.Hash "Tx", W.Tx)] -> ([TxIn], [TxOut])
+mkTxInputsOutputs txs =
+    ( concatMap (dist mkTxIn . ordered W.inputs) txs
+    , concatMap (dist mkTxOut . ordered W.outputs) txs )
+  where
+    mkTxIn tid (ix, txIn) = TxIn
+        { txInputTableTxId = TxId tid
+        , txInputTableOrder = ix
         , txInputTableSourceTxId = TxId (W.inputId txIn)
         , txInputTableSourceIndex = W.inputIx txIn
         }
     mkTxOut tid (ix, txOut) = TxOut
-        { txOutputTableTxId = tid
+        { txOutputTableTxId = TxId tid
         , txOutputTableIndex = ix
         , txOutputTableAddress = W.address txOut
         , txOutputTableAmount = W.coin txOut
         }
+    ordered f = fmap (zip [0..] . f)
+    -- | Distribute `a` accross many `b`s using the given function.
+    -- >>> dist TxOut (addr, [Coin 1, Coin 42, Coin 14])
+    -- [TxOut addr (Coin 1), TxOut addr (Coin 42), TxOut addr (Coin 14)]
+    dist :: (a -> b -> c) -> (a, [b]) -> [c]
+    dist f (a, bs) = [f a b | b <- bs]
 
 mkTxMetaEntity :: W.WalletId -> W.Hash "Tx" -> W.TxMeta -> TxMeta
 mkTxMetaEntity wid txid meta = TxMeta
@@ -471,7 +472,8 @@ mkTxMetaEntity wid txid meta = TxMeta
     }
     where getAmount (Quantity n) = n
 
--- note: TxOut records must already be sorted by index
+-- note: TxIn records must already be sorted by order
+-- and TxOut records must already be sorted by index
 txHistoryFromEntity
     :: [TxMeta]
     -> [TxIn]
@@ -548,6 +550,14 @@ putTxMetas wid metas = do
         , TxMetaTableTxId <-. map txMetaTableTxId metas ]
     insertMany_ metas
 
+-- | Insert multiple transactions, removing old instances first.
+putTxs :: [TxId] -> [TxIn] -> [TxOut] -> SqlPersistM ()
+putTxs txIds txins txouts = do
+    deleteWhere [TxInputTableTxId <-. txIds]
+    putMany txins
+    deleteWhere [TxOutputTableTxId <-. txIds]
+    putMany txouts
+
 -- | Delete transactions that aren't referred to by either Pending or TxMeta of
 -- any wallet.
 deleteLooseTransactions :: SqlPersistM ()
@@ -584,7 +594,7 @@ selectTxs
     -> SqlPersistM ([TxIn], [TxOut])
 selectTxs txids = do
     ins <- fmap entityVal <$> selectList [TxInputTableTxId <-. txids]
-        [Asc TxInputTableTxId, Asc TxInputTableSourceIndex]
+        [Asc TxInputTableTxId, Asc TxInputTableOrder]
     outs <- fmap entityVal <$> selectList [TxOutputTableTxId <-. txids]
         [Asc TxOutputTableTxId, Asc TxOutputTableIndex]
     pure (ins, outs)
@@ -595,10 +605,7 @@ selectTxHistory
 selectTxHistory wid = do
     metas <- fmap entityVal <$> selectList [TxMetaTableWalletId ==. wid] []
     let txids = map txMetaTableTxId metas
-    ins <- fmap entityVal <$> selectList [TxInputTableTxId <-. txids]
-        [Asc TxInputTableTxId, Asc TxInputTableSourceIndex]
-    outs <- fmap entityVal <$> selectList [TxOutputTableTxId <-. txids]
-        [Asc TxOutputTableTxId, Asc TxOutputTableIndex]
+    (ins, outs) <- selectTxs txids
     pure $ txHistoryFromEntity metas ins outs
 
 ---------------------------------------------------------------------------
@@ -692,11 +699,11 @@ selectSeqStatePendingIxs ssid =
   where
     fromRes = fmap (W.Index . seqStatePendingIxIndex . entityVal)
 
-----------------------------------------------------------------------------
--- Utilities
+data DummyState = DummyState
+    deriving (Show, Eq, Generic)
 
--- | Distribute `a` accross many `b`s using the given function.
--- >>> dist TxOut (addr, [Coin 1, Coin 42, Coin 14])
--- [TxOut addr (Coin 1), TxOut addr (Coin 42), TxOut addr (Coin 14)]
-dist :: (a -> b -> c) -> (a, [b]) -> [c]
-dist f (a, bs) = [f a b | b <- bs]
+instance PersistState DummyState where
+    insertState (wid, sl) _ = insert_ (SeqState wid sl)
+    selectState (wid, sl) = fmap (const DummyState) <$>
+        selectFirst [SeqStateTableWalletId ==. wid, SeqStateTableCheckpointSlot ==. sl] []
+    deleteState wid = deleteWhere [SeqStateTableWalletId ==. wid]

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

@@ -97,6 +97,7 @@ TxMeta
 -- not the wallet. txInputTableTxId is referred to by TxMeta and PendingTx
 TxIn
     txInputTableTxId         TxId        sql=tx_id
+    txInputTableOrder        Int         sql=order
     txInputTableSourceTxId   TxId        sql=source_id
     txInputTableSourceIndex  Word32      sql=source_index
 

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

@@ -3,6 +3,7 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -12,10 +13,6 @@ module Cardano.Wallet.DB.MVarSpec
 
 import Prelude
 
-import Cardano.Wallet.DB
-    ( DBLayer (..) )
-import Cardano.Wallet.DB.MVar
-    ( newDBLayer )
 import Cardano.Wallet.DBSpec
     ( DummyTarget, dbPropertyTests, withDB )
 import Cardano.Wallet.Primitive.AddressDiscovery
@@ -29,9 +26,11 @@ import Test.Hspec
 import Test.QuickCheck
     ( Arbitrary (..) )
 
+import qualified Cardano.Wallet.DB.MVar as MVar
+
 spec :: Spec
-spec = withDB (newDBLayer :: IO (DBLayer IO (SeqState DummyTarget) DummyTarget)) $
-       describe "MVar" dbPropertyTests
+spec = withDB @(SeqState DummyTarget) MVar.newDBLayer $
+    describe "MVar" dbPropertyTests
 
 newtype DummyStateMVar = DummyStateMVar Int
     deriving (Show, Eq)

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

@@ -17,6 +17,8 @@ import Cardano.Wallet.DB
     ( DBLayer (..), ErrWalletAlreadyExists (..), PrimaryKey (..) )
 import Cardano.Wallet.DB.Sqlite
     ( newDBLayer )
+import Cardano.Wallet.DB.StateMachine
+    ( prop_parallel, prop_sequential )
 import Cardano.Wallet.DBSpec
     ( DummyTarget, dbPropertyTests, withDB )
 import Cardano.Wallet.Primitive.AddressDerivation
@@ -66,17 +68,20 @@ import Data.Time.Clock
 import System.IO.Unsafe
     ( unsafePerformIO )
 import Test.Hspec
-    ( Spec, describe, it, shouldReturn )
+    ( Spec, SpecWith, describe, it, shouldReturn, xit )
 
 import qualified Data.Map as Map
 
 spec :: Spec
-spec = do
-    describe "Simple tests" simpleSpec
-    describe "Sqlite Property tests" $ withDB newMemoryDBLayer dbPropertyTests
-
-simpleSpec :: Spec
-simpleSpec = withDB newMemoryDBLayer $ do
+spec = withDB newMemoryDBLayer $ do
+    describe "Sqlite Simple tests" simpleSpec
+    describe "Sqlite" dbPropertyTests
+    describe "Sqlite State machine tests" $ do
+        it "Sequential" prop_sequential
+        xit "Parallel" prop_parallel
+
+simpleSpec :: SpecWith (DBLayer IO (SeqState DummyTarget) DummyTarget)
+simpleSpec = do
     describe "Wallet table" $ do
         it "create and list works" $ \db -> do
             unsafeRunExceptT $ createWallet db testPk testCp testMetadata