diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs index 6d89efccc8c..8d758bbd632 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs @@ -26,6 +26,27 @@ import Cardano.Wallet.DB , ErrWalletAlreadyExists (..) , PrimaryKey (..) ) +import Cardano.Wallet.DB.Sqlite.TH + ( AddressPool (..) + , AddressPoolId + , AddressPoolIndex (..) + , Checkpoint (..) + , EntityField (..) + , PendingTx (..) + , PrivateKey (..) + , SeqState (..) + , SeqStateExternalPool (..) + , SeqStateId + , SeqStateInternalPool (..) + , SeqStatePendingIx (..) + , TxIn (..) + , TxMeta (..) + , TxOut (..) + , UTxO (..) + , Wallet (..) + , migrateAll + , unWalletKey + ) import Cardano.Wallet.DB.Sqlite.Types ( AddressPoolXPub (..), TxId (..) ) import Cardano.Wallet.Primitive.AddressDerivation @@ -35,7 +56,7 @@ import Control.Concurrent.MVar import Control.DeepSeq ( NFData ) import Control.Monad - ( mapM_, void ) + ( mapM_, void, when ) import Control.Monad.Catch ( MonadCatch (..), handleJust ) import Control.Monad.IO.Class @@ -54,6 +75,8 @@ import Data.Bifunctor ( bimap ) import Data.Coerce ( coerce ) +import Data.Either + ( isRight ) import Data.Generics.Internal.VL.Lens ( (^.) ) import Data.Quantity @@ -94,8 +117,6 @@ import System.IO import System.Log.FastLogger ( fromLogStr ) -import Cardano.Wallet.DB.Sqlite.TH - import qualified Cardano.Wallet.Primitive.AddressDerivation as W import qualified Cardano.Wallet.Primitive.AddressDiscovery as W import qualified Cardano.Wallet.Primitive.Model as W @@ -115,9 +136,9 @@ enableForeignKeys conn = stmt >>= void . Sqlite.step createSqliteBackend :: Maybe FilePath -> LogFunc -> IO SqlBackend createSqliteBackend fp logFunc = do - conn <- Sqlite.open (sqliteConnStr fp) - enableForeignKeys conn - wrapConnection conn logFunc + conn <- Sqlite.open (sqliteConnStr fp) + enableForeignKeys conn + wrapConnection conn logFunc sqliteConnStr :: Maybe FilePath -> Text sqliteConnStr = maybe ":memory:" T.pack @@ -139,9 +160,9 @@ runQuery conn = runResourceT . runNoLoggingT . flip runSqlConn conn handleConstraint :: MonadCatch m => e -> m a -> m (Either e a) handleConstraint e = handleJust select handler . fmap Right where - select (SqliteException ErrorConstraint _ _) = Just () - select _ = Nothing - handler = const . pure . Left $ e + select (SqliteException ErrorConstraint _ _) = Just () + select _ = Nothing + handler = const . pure . Left $ e ---------------------------------------------------------------------------- -- Database layer methods @@ -159,116 +180,123 @@ newDBLayer -> IO (DBLayer IO s t) newDBLayer fp = do lock <- newMVar () + writeLock <- newMVar () + let withWriteLock = ExceptT . withMVar writeLock . const . runExceptT + conn <- createSqliteBackend fp (dbLogs [LevelError]) runQuery conn $ runMigration migrateAll runQuery conn addIndexes + return $ DBLayer {----------------------------------------------------------------------- Wallets -----------------------------------------------------------------------} - { createWallet = \(PrimaryKey wid) cp meta -> - ExceptT $ runQuery conn $ - handleConstraint (ErrWalletAlreadyExists wid) $ do - insert_ (mkWalletEntity wid meta) - insertCheckpoint wid cp - - , removeWallet = \(PrimaryKey wid) -> - ExceptT $ runQuery conn $ - selectWallet wid >>= \case - Just _ -> Right <$> do - -- fixme: deleteCascade is not working with persistent-sqlite. - -- Therefore we need to delete related entities as well. - deleteCheckpoints @s wid - deleteLooseTransactions wid - deleteCascadeWhere [WalTableId ==. wid] - Nothing -> pure $ Left $ ErrNoSuchWallet wid + { createWallet = \(PrimaryKey wid) cp meta -> withWriteLock $ + ExceptT $ runQuery conn $ do + res <- handleConstraint (ErrWalletAlreadyExists wid) $ + insert_ (mkWalletEntity wid meta) + when (isRight res) $ + insertCheckpoint wid cp + pure res + + , removeWallet = \(PrimaryKey wid) -> withWriteLock $ + ExceptT $ runQuery conn $ + selectWallet wid >>= \case + Just _ -> Right <$> do + deleteCheckpoints @s wid + deleteTxMetas wid + deleteLooseTransactions + deleteWhere [PrivateKeyTableWalletId ==. wid] + deleteCascadeWhere [WalTableId ==. wid] + Nothing -> pure $ Left $ ErrNoSuchWallet wid , listWallets = runQuery conn $ - map (PrimaryKey . unWalletKey) <$> selectKeysList [] [] + map (PrimaryKey . unWalletKey) <$> selectKeysList [] [] {----------------------------------------------------------------------- Checkpoints -----------------------------------------------------------------------} - , putCheckpoint = \(PrimaryKey wid) cp -> - ExceptT $ runQuery conn $ Right <$> do - deleteCheckpoints @s wid -- clear out all checkpoints - deleteLooseTransactions wid -- clear transactions - insertCheckpoint wid cp -- add this checkpoint - - , readCheckpoint = \(PrimaryKey wid) -> - runQuery conn $ - selectLatestCheckpoint wid >>= \case - Just cp -> do - utxo <- selectUTxO cp - pendings <- selectPending cp - (ins, outs) <- selectTxs pendings - s <- selectState (checkpointId cp) - pure (checkpointFromEntity cp utxo ins outs <$> s) - Nothing -> pure Nothing + , putCheckpoint = \(PrimaryKey wid) cp -> withWriteLock $ + ExceptT $ runQuery conn $ + selectWallet wid >>= \case + Just _ -> Right <$> do + deleteCheckpoints @s wid -- clear out all checkpoints + deleteLooseTransactions -- clear unused transaction data + insertCheckpoint wid cp -- add this checkpoint + Nothing -> pure $ Left $ ErrNoSuchWallet wid + + , readCheckpoint = \(PrimaryKey wid) -> runQuery conn $ + selectLatestCheckpoint wid >>= \case + Just cp -> do + utxo <- selectUTxO cp + pendings <- selectPending cp + (ins, outs) <- selectTxs pendings + s <- selectState (checkpointId cp) + pure (checkpointFromEntity cp utxo ins outs <$> s) + Nothing -> pure Nothing {----------------------------------------------------------------------- Wallet Metadata -----------------------------------------------------------------------} - , putWalletMeta = \(PrimaryKey wid) meta -> - ExceptT $ runQuery conn $ - selectWallet wid >>= \case - Just _ -> do - updateWhere [WalTableId ==. wid] - (mkWalletMetadataUpdate meta) - pure $ Right () - Nothing -> pure $ Left $ ErrNoSuchWallet wid + , putWalletMeta = \(PrimaryKey wid) meta -> withWriteLock $ + ExceptT $ runQuery conn $ + selectWallet wid >>= \case + Just _ -> do + updateWhere [WalTableId ==. wid] + (mkWalletMetadataUpdate meta) + pure $ Right () + Nothing -> pure $ Left $ ErrNoSuchWallet wid - , readWalletMeta = \(PrimaryKey wid) -> - runQuery conn $ - fmap (metadataFromEntity . entityVal) <$> - selectFirst [WalTableId ==. wid] [] + , readWalletMeta = \(PrimaryKey wid) -> runQuery conn $ + fmap (metadataFromEntity . entityVal) <$> + selectFirst [WalTableId ==. wid] [] {----------------------------------------------------------------------- Tx History -----------------------------------------------------------------------} - , putTxHistory = \(PrimaryKey wid) txs -> - ExceptT $ runQuery conn $ - selectWallet wid >>= \case - Just _ -> do - let (metas, txins, txouts) = mkTxHistory wid txs - putMany metas - putMany txins - putMany txouts - pure $ Right () - Nothing -> pure $ Left $ ErrNoSuchWallet wid + , putTxHistory = \(PrimaryKey wid) txs -> withWriteLock $ + ExceptT $ runQuery conn $ + selectWallet wid >>= \case + Just _ -> do + let (metas, txins, txouts) = mkTxHistory wid txs + putTxMetas wid metas + putMany txins + putMany txouts + deleteLooseTransactions + pure $ Right () + Nothing -> pure $ Left $ ErrNoSuchWallet wid , readTxHistory = \(PrimaryKey wid) -> runQuery conn $ - selectTxHistory wid + selectTxHistory wid {----------------------------------------------------------------------- Keystore -----------------------------------------------------------------------} - , putPrivateKey = \(PrimaryKey wid) key -> - ExceptT $ runQuery conn $ - selectWallet wid >>= \case - Just _ -> Right <$> do - deleteWhere [PrivateKeyTableWalletId ==. wid] - insert_ (mkPrivateKeyEntity wid key) - Nothing -> pure $ Left $ ErrNoSuchWallet wid + , putPrivateKey = \(PrimaryKey wid) key -> withWriteLock $ + ExceptT $ runQuery conn $ + selectWallet wid >>= \case + Just _ -> Right <$> do + deleteWhere [PrivateKeyTableWalletId ==. wid] + insert_ (mkPrivateKeyEntity wid key) + Nothing -> pure $ Left $ ErrNoSuchWallet wid - , readPrivateKey = \(PrimaryKey wid) -> - runQuery conn $ let - keys = selectFirst [PrivateKeyTableWalletId ==. wid] [] - toMaybe = either (const Nothing) Just - in (>>= toMaybe . privateKeyFromEntity . entityVal) <$> keys + , readPrivateKey = \(PrimaryKey wid) -> runQuery conn $ + let keys = selectFirst [PrivateKeyTableWalletId ==. wid] [] + toMaybe = either (const Nothing) Just + in (>>= toMaybe . privateKeyFromEntity . entityVal) <$> keys {----------------------------------------------------------------------- Lock -----------------------------------------------------------------------} , withLock = \action -> - ExceptT $ withMVar lock $ \() -> runExceptT action + ExceptT $ withMVar lock $ \() -> runExceptT action } ---------------------------------------------------------------------------- @@ -496,16 +524,29 @@ deleteCheckpoints wid = do deleteWhere [CheckpointTableWalletId ==. wid] deleteState @s wid -- clear state --- | Delete transactions that belong to a wallet and aren't referred to by --- either Pending or TxMeta. -deleteLooseTransactions +-- | Delete TxMeta values for a wallet. +deleteTxMetas + :: W.WalletId + -> SqlPersistM () +deleteTxMetas wid = deleteWhere [ TxMetaTableWalletId ==. wid ] + +-- | Add new TxMeta rows, overwriting existing ones. +putTxMetas :: W.WalletId + -> [TxMeta] -> SqlPersistM () -deleteLooseTransactions wid = do - pendingTxId <- fmap (pendingTxTableId2 . entityVal) <$> - selectList [PendingTxTableWalletId ==. wid] [] - metaTxId <- fmap (txMetaTableTxId . entityVal) <$> - selectList [TxMetaTableWalletId ==. wid] [] +putTxMetas wid metas = do + deleteWhere + [ TxMetaTableWalletId ==. wid + , TxMetaTableTxId <-. map txMetaTableTxId metas ] + insertMany_ metas + +-- | Delete transactions that aren't referred to by either Pending or TxMeta of +-- any wallet. +deleteLooseTransactions :: SqlPersistM () +deleteLooseTransactions = do + pendingTxId <- fmap (pendingTxTableId2 . entityVal) <$> selectList [] [] + metaTxId <- fmap (txMetaTableTxId . entityVal) <$> selectList [] [] deleteWhere [ TxInputTableTxId /<-. pendingTxId , TxInputTableTxId /<-. metaTxId ] deleteWhere [ TxOutputTableTxId /<-. pendingTxId @@ -596,7 +637,13 @@ instance W.KeyToAddress t => PersistState (W.SeqState t) where pure $ W.SeqState internalPool externalPool pendingChangeIxs deleteState wid = do - -- fixme: cascading delete not working with persistent-sqlite + ssid <- fmap entityKey <$> selectList [ SeqStateTableWalletId ==. wid ] [] + intApId <- fmap (seqStateInternalPoolAddressPool . entityVal) <$> + selectList [ SeqStateInternalPoolSeqStateId <-. ssid ] [] + extApId <- fmap (seqStateExternalPoolAddressPool . entityVal) <$> + selectList [ SeqStateExternalPoolSeqStateId <-. ssid ] [] + deleteCascadeWhere [AddressPoolId <-. intApId] + deleteCascadeWhere [AddressPoolId <-. extApId] deleteCascadeWhere [SeqStateTableWalletId ==. wid] insertAddressPool diff --git a/lib/core/src/Cardano/Wallet/Primitive/AddressDiscovery.hs b/lib/core/src/Cardano/Wallet/Primitive/AddressDiscovery.hs index b50fffe3d0d..497544eeaed 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/AddressDiscovery.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/AddressDiscovery.hs @@ -399,7 +399,7 @@ nextAddresses _ !key (AddressPoolGap !g) !cc !fromIx = -- | An ordered set of pending indexes. This keep track of indexes used newtype PendingIxs = PendingIxs { pendingIxsToList :: [Index 'Soft 'AddressK] } - deriving stock (Generic, Show) + deriving stock (Generic, Show, Eq) instance NFData PendingIxs -- | An empty pending set of change indexes. diff --git a/lib/core/test/unit/Cardano/Wallet/DB/MVarSpec.hs b/lib/core/test/unit/Cardano/Wallet/DB/MVarSpec.hs index e31987501ca..40409df062e 100644 --- a/lib/core/test/unit/Cardano/Wallet/DB/MVarSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/DB/MVarSpec.hs @@ -17,20 +17,21 @@ import Cardano.Wallet.DB import Cardano.Wallet.DB.MVar ( newDBLayer ) import Cardano.Wallet.DBSpec - ( DummyTarget, dbPropertyTests ) + ( DummyTarget, dbPropertyTests, withDB ) import Cardano.Wallet.Primitive.AddressDiscovery - ( IsOurs (..) ) + ( IsOurs (..), SeqState (..) ) import Cardano.Wallet.Primitive.Model ( Wallet, initWallet ) import Control.DeepSeq ( NFData ) import Test.Hspec - ( Spec ) + ( Spec, describe ) import Test.QuickCheck ( Arbitrary (..) ) spec :: Spec -spec = dbPropertyTests (newDBLayer :: IO (DBLayer IO DummyStateMVar DummyTarget)) +spec = withDB (newDBLayer :: IO (DBLayer IO (SeqState DummyTarget) DummyTarget)) $ + describe "MVar" dbPropertyTests newtype DummyStateMVar = DummyStateMVar Int deriving (Show, Eq) diff --git a/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs b/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs index a5528147037..2a1d0553df5 100644 --- a/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs @@ -18,7 +18,7 @@ import Cardano.Wallet.DB import Cardano.Wallet.DB.Sqlite ( newDBLayer ) import Cardano.Wallet.DBSpec - ( DummyTarget, cleanDB ) + ( DummyTarget, dbPropertyTests, withDB ) import Cardano.Wallet.Primitive.AddressDerivation ( Passphrase (..) , encryptPassphrase @@ -26,7 +26,7 @@ import Cardano.Wallet.Primitive.AddressDerivation , unsafeGenerateKeyFromSeed ) import Cardano.Wallet.Primitive.AddressDiscovery - ( SeqState, defaultAddressPoolGap, mkSeqState ) + ( SeqState (..), defaultAddressPoolGap, mkSeqState ) import Cardano.Wallet.Primitive.Mnemonic ( EntropySize, entropyToBytes, genEntropy ) import Cardano.Wallet.Primitive.Model @@ -66,12 +66,17 @@ import Data.Time.Clock import System.IO.Unsafe ( unsafePerformIO ) import Test.Hspec - ( Spec, beforeAll, beforeWith, describe, it, shouldReturn ) + ( Spec, describe, it, shouldReturn ) import qualified Data.Map as Map spec :: Spec -spec = beforeAll newMemoryDBLayer $ beforeWith cleanDB $ do +spec = do + describe "Simple tests" simpleSpec + describe "Sqlite Property tests" $ withDB newMemoryDBLayer dbPropertyTests + +simpleSpec :: Spec +simpleSpec = withDB newMemoryDBLayer $ do describe "Wallet table" $ do it "create and list works" $ \db -> do unsafeRunExceptT $ createWallet db testPk testCp testMetadata @@ -102,6 +107,18 @@ spec = beforeAll newMemoryDBLayer $ beforeWith cleanDB $ do runExceptT (putTxHistory db testPk testTxs) `shouldReturn` Right () readTxHistory db testPk `shouldReturn` testTxs + it "put and read tx history - regression case" $ \db -> do + unsafeRunExceptT $ createWallet db testPk testCp testMetadata + unsafeRunExceptT $ createWallet db testPk1 testCp testMetadata + runExceptT (putTxHistory db testPk1 testTxs) `shouldReturn` Right () + runExceptT (removeWallet db testPk) `shouldReturn` Right () + readTxHistory db testPk1 `shouldReturn` testTxs + + it "put and read checkpoint" $ \db -> do + unsafeRunExceptT $ createWallet db testPk testCp testMetadata + runExceptT (putCheckpoint db testPk testCp) `shouldReturn` Right () + readCheckpoint db testPk `shouldReturn` Just testCp + newMemoryDBLayer :: IO (DBLayer IO (SeqState DummyTarget) DummyTarget) newMemoryDBLayer = newDBLayer Nothing @@ -125,9 +142,15 @@ testMetadata = WalletMetadata testWid :: WalletId testWid = WalletId (hash ("test" :: ByteString)) +testWid1 :: WalletId +testWid1 = WalletId (hash ("test1" :: ByteString)) + testPk :: PrimaryKey WalletId testPk = PrimaryKey testWid +testPk1 :: PrimaryKey WalletId +testPk1 = PrimaryKey testWid1 + testTxs :: Map.Map (Hash "Tx") (Tx, TxMeta) testTxs = Map.fromList [ (Hash "tx2" diff --git a/lib/core/test/unit/Cardano/Wallet/DBSpec.hs b/lib/core/test/unit/Cardano/Wallet/DBSpec.hs index 6a2d0da1efc..26a215506eb 100644 --- a/lib/core/test/unit/Cardano/Wallet/DBSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/DBSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -5,6 +6,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} @@ -12,15 +14,15 @@ module Cardano.Wallet.DBSpec ( spec - , DummyTarget , dbPropertyTests - , cleanDB + , withDB + , DummyTarget ) where import Prelude import Cardano.Crypto.Wallet - ( unXPrv ) + ( unXPrv, unXPub ) import Cardano.Wallet ( unsafeRunExceptT ) import Cardano.Wallet.DB @@ -30,17 +32,34 @@ import Cardano.Wallet.DB , PrimaryKey (..) ) import Cardano.Wallet.Primitive.AddressDerivation - ( Depth (..) + ( ChangeChain (..) + , Depth (..) , Key , KeyToAddress (..) , Passphrase (..) , XPrv + , XPub + , deriveAddressPublicKey , generateKeyFromSeed + , getKey + , publicKey + , unsafeGenerateKeyFromSeed ) import Cardano.Wallet.Primitive.AddressDiscovery - ( IsOurs (..) ) + ( AddressPool + , AddressPoolGap (..) + , IsOurs (..) + , SeqState (..) + , accountPubKey + , addresses + , changeChain + , emptyPendingIxs + , gap + , mkAddressPool + , mkAddressPoolGap + ) import Cardano.Wallet.Primitive.Model - ( Wallet ) + ( Wallet, initWallet ) import Cardano.Wallet.Primitive.Types ( Address (..) , Coin (..) @@ -79,6 +98,8 @@ import Data.Map.Strict ( Map ) import Data.Quantity ( Percentage, Quantity (..), mkPercentage ) +import Data.Typeable + ( Typeable ) import Data.Word ( Word32 ) import GHC.Generics @@ -86,7 +107,15 @@ import GHC.Generics import System.IO.Unsafe ( unsafePerformIO ) import Test.Hspec - ( Spec, beforeAll, beforeWith, describe, it, shouldBe, shouldReturn ) + ( Spec + , SpecWith + , beforeAll + , beforeWith + , describe + , it + , shouldBe + , shouldReturn + ) import Test.QuickCheck ( Arbitrary (..) , Gen @@ -153,12 +182,18 @@ instance (Arbitrary k, Arbitrary v) => Arbitrary (KeyValPairs k v) where data DummyTarget +instance KeyToAddress DummyTarget where + keyToAddress = Address . unXPub . getKey + +deriving instance Eq (SeqState DummyTarget) + +instance Arbitrary (Wallet (SeqState DummyTarget) DummyTarget) where + shrink _ = [] + arbitrary = initWallet <$> arbitrary + instance TxId DummyTarget where txId = Hash . B8.pack . show -instance KeyToAddress DummyTarget where - keyToAddress _ = Address "" - instance Arbitrary (PrimaryKey WalletId) where shrink _ = [] arbitrary = do @@ -167,6 +202,70 @@ instance Arbitrary (PrimaryKey WalletId) where deriving instance Show (PrimaryKey WalletId) +instance Arbitrary Address where + -- No Shrinking + arbitrary = oneof + [ pure $ Address "ADDR01" + , pure $ Address "ADDR02" + , pure $ Address "ADDR03" + , pure $ Address "ADDR04" + , pure $ Address "ADDR05" + , pure $ Address "ADDR06" + , pure $ Address "ADDR07" + , pure $ Address "ADDR08" + , pure $ Address "ADDR09" + , pure $ Address "ADDR10" + ] + +instance Arbitrary (SeqState DummyTarget) where + shrink (SeqState intPool extPool ixs) = + (\(i, e) -> SeqState i e ixs) <$> shrink (intPool, extPool) + arbitrary = do + intPool <- arbitrary + extPool <- arbitrary + return $ SeqState intPool extPool emptyPendingIxs + +instance Typeable chain => Arbitrary (AddressPool DummyTarget chain) where + shrink pool = + let + key = accountPubKey pool + g = gap pool + addrs = addresses pool + in case length addrs of + k | k == fromEnum g && g == minBound -> + [] + k | k == fromEnum g && g > minBound -> + [ mkAddressPool key minBound [] ] + k -> + [ mkAddressPool key minBound [] + , mkAddressPool key g [] + , mkAddressPool key g (take (k - (fromEnum g `div` 5)) addrs) + ] + arbitrary = do + g <- unsafeMkAddressPoolGap <$> choose + (getAddressPoolGap minBound, 2 * getAddressPoolGap minBound) + n <- choose (0, 2 * fromEnum g) + let addrs = take n (ourAddresses (changeChain @chain)) + return $ mkAddressPool ourAccount g addrs + +unsafeMkAddressPoolGap :: (Integral a, Show a) => a -> AddressPoolGap +unsafeMkAddressPoolGap g = case (mkAddressPoolGap $ fromIntegral g) of + Right a -> a + Left _ -> error $ "unsafeMkAddressPoolGap: bad argument: " <> show g + +ourAccount + :: Key 'AccountK XPub +ourAccount = publicKey $ unsafeGenerateKeyFromSeed (seed, mempty) mempty + where + seed = Passphrase $ BA.convert $ BS.replicate 32 0 + +ourAddresses + :: ChangeChain + -> [Address] +ourAddresses cc = + keyToAddress @DummyTarget . deriveAddressPublicKey ourAccount cc + <$> [minBound..maxBound] + instance Arbitrary (Hash "Tx") where shrink _ = [] arbitrary = do @@ -182,7 +281,7 @@ instance Arbitrary TxMeta where arbitrary = TxMeta <$> elements [Pending, InLedger, Invalidated] <*> elements [Incoming, Outgoing] - <*> (SlotId <$> arbitrary <*> choose (0, 21600)) + <*> (SlotId <$> choose (0, 1000) <*> choose (0, 21599)) <*> fmap (Quantity . fromIntegral) (arbitrary @Word32) customizedGen :: Gen Percentage @@ -198,14 +297,6 @@ instance Arbitrary WalletMetadata where <*> oneof [pure Ready, Restoring . Quantity <$> customizedGen] <*> pure NotDelegating -instance Arbitrary Address where - -- No Shrinking - arbitrary = oneof - [ pure $ Address "ADDR01" - , pure $ Address "ADDR02" - , pure $ Address "ADDR03" - ] - instance Arbitrary Coin where -- No Shrinking arbitrary = Coin <$> choose (1, 100000) @@ -549,11 +640,9 @@ prop_parallelPut putOp readOp resolve dbLayer (KeyValPairs pairs) = dbPropertyTests :: (Arbitrary (Wallet s DummyTarget), Show s, Eq s, IsOurs s, NFData s) - => IO (DBLayer IO s DummyTarget) - -> Spec -dbPropertyTests dbLayer = do - beforeAll dbLayer $ beforeWith cleanDB $ - describe "Extra Properties about DB initialization" $ do + => SpecWith (DBLayer IO s DummyTarget) +dbPropertyTests = do + describe "Extra Properties about DB initialization" $ do it "createWallet . listWallets yields expected results" (property . prop_createListWallet) it "creating same wallet twice yields an error" @@ -561,8 +650,7 @@ dbPropertyTests dbLayer = do it "removing the same wallet twice yields an error" (property . prop_removeWalletTwice) - beforeAll dbLayer $ beforeWith cleanDB $ - describe "put . read yields a result" $ do + describe "put . read yields a result" $ do it "Checkpoint" (property . (prop_readAfterPut putCheckpoint readCheckpoint)) it "Wallet Metadata" @@ -572,8 +660,7 @@ dbPropertyTests dbLayer = do it "Private Key" (property . (prop_readAfterPut putPrivateKey readPrivateKey)) - beforeAll dbLayer $ beforeWith cleanDB $ - describe "can't put before wallet exists" $ do + describe "can't put before wallet exists" $ do it "Checkpoint" (property . (prop_putBeforeInit putCheckpoint readCheckpoint Nothing)) it "Wallet Metadata" @@ -583,8 +670,7 @@ dbPropertyTests dbLayer = do it "Private Key" (property . (prop_putBeforeInit putPrivateKey readPrivateKey Nothing)) - beforeAll dbLayer $ beforeWith cleanDB $ - describe "put doesn't affect other resources" $ do + describe "put doesn't affect other resources" $ do it "Checkpoint vs Wallet Metadata & Tx History & Private Key" (property . (prop_isolation putCheckpoint readWalletMeta @@ -604,8 +690,7 @@ dbPropertyTests dbLayer = do readPrivateKey) ) - beforeAll dbLayer $ beforeWith cleanDB $ - describe "can't read after delete" $ do + describe "can't read after delete" $ do it "Checkpoint" (property . (prop_readAfterDelete readCheckpoint Nothing)) it "Wallet Metadata" @@ -615,8 +700,7 @@ dbPropertyTests dbLayer = do it "Private Key" (property . (prop_readAfterDelete readPrivateKey Nothing)) - beforeAll dbLayer $ beforeWith cleanDB $ - describe "sequential puts replace values in order" $ do + describe "sequential puts replace values in order" $ do it "Checkpoint" (checkCoverage . (prop_sequentialPut putCheckpoint readCheckpoint lrp)) it "Wallet Metadata" @@ -626,8 +710,7 @@ dbPropertyTests dbLayer = do it "Private Key" (checkCoverage . (prop_sequentialPut putPrivateKey readPrivateKey lrp)) - beforeAll dbLayer $ beforeWith cleanDB $ - describe "parallel puts replace values in _any_ order" $ do + describe "parallel puts replace values in _any_ order" $ do it "Checkpoint" (checkCoverage . (prop_parallelPut putCheckpoint readCheckpoint (length . lrp @Maybe))) @@ -641,5 +724,11 @@ dbPropertyTests dbLayer = do (checkCoverage . (prop_parallelPut putPrivateKey readPrivateKey (length . lrp @Maybe))) +-- | Clean a database by removing all wallets. cleanDB :: Monad m => DBLayer m s t -> m (DBLayer m s t) cleanDB db = listWallets db >>= mapM_ (runExceptT . removeWallet db) >> pure db + +-- | Provide a DBLayer to a Spec that requires it. The database is initialised +-- once, and cleared with 'cleanDB' before each test. +withDB :: IO (DBLayer IO s t) -> SpecWith (DBLayer IO s t) -> Spec +withDB create = beforeAll create . beforeWith cleanDB