diff --git a/lib/wallet/cardano-wallet.cabal b/lib/wallet/cardano-wallet.cabal index 3f9f90193e5..b26efee8a8d 100644 --- a/lib/wallet/cardano-wallet.cabal +++ b/lib/wallet/cardano-wallet.cabal @@ -241,6 +241,7 @@ library Cardano.Wallet.DB.Sqlite.Stores Cardano.Wallet.DB.Sqlite.Types Cardano.Wallet.DB.Store.Checkpoints + Cardano.Wallet.DB.Store.Meta.Layer Cardano.Wallet.DB.Store.Meta.Model Cardano.Wallet.DB.Store.Meta.Store Cardano.Wallet.DB.Store.QueryStore diff --git a/lib/wallet/src/Cardano/Wallet/DB/Layer.hs b/lib/wallet/src/Cardano/Wallet/DB/Layer.hs index 7ca45c50115..a8fb688052d 100644 --- a/lib/wallet/src/Cardano/Wallet/DB/Layer.hs +++ b/lib/wallet/src/Cardano/Wallet/DB/Layer.hs @@ -142,8 +142,6 @@ import Cardano.Wallet.Primitive.Passphrase.Types ( PassphraseHash ) import Cardano.Wallet.Primitive.Slotting ( TimeInterpreter, firstSlotInEpoch, hoistTimeInterpreter, interpretQuery ) -import Cardano.Wallet.Primitive.Types - ( SortOrder (..) ) import Cardano.Wallet.Read.Eras ( EraValue ) import Cardano.Wallet.Read.Tx.CBOR @@ -170,12 +168,8 @@ import Data.Functor ( (<&>) ) import Data.Generics.Internal.VL.Lens ( view, (^.) ) -import Data.List - ( sortOn ) import Data.Maybe ( catMaybes, fromMaybe, isJust, maybeToList ) -import Data.Ord - ( Down (..) ) import Data.Proxy ( Proxy (..) ) import Data.Quantity @@ -219,7 +213,6 @@ import UnliftIO.Exception import UnliftIO.MVar ( modifyMVar, modifyMVar_, newMVar, readMVar, withMVar ) -import qualified Cardano.Wallet.DB.Sqlite.Schema as DB import qualified Cardano.Wallet.Primitive.Model as W import qualified Cardano.Wallet.Primitive.Passphrase as W import qualified Cardano.Wallet.Primitive.Types as W @@ -523,7 +516,7 @@ newDBLayerWith _cacheBehavior _tr ti SqliteContext{runQuery} = mdo -- FIXME LATER during ADP-1043: -- Handle the case where loading the database fails. walletsDB <- runQuery $ loadDBVar mkStoreWallets - transactionsQS <- runQuery newQueryStoreTxWalletsHistory + let transactionsQS = newQueryStoreTxWalletsHistory -- NOTE -- The cache will not work properly unless 'atomically' is protected by a @@ -624,35 +617,21 @@ newDBLayerWith _cacheBehavior _tr ti SqliteContext{runQuery} = mdo Tx History -----------------------------------------------------------------------} let + lookupTx = queryS transactionsQS . GetByTxId + lookupTxOut = queryS transactionsQS . GetTxOut dbTxHistory = DBTxHistory { putTxHistory_ = \wid -> updateS (store transactionsQS) Nothing . ExpandTxWalletsHistory wid , readTxHistory_ = \range tip mlimit order -> do - allTransactions <- queryS transactionsQS All - let whichMeta DB.TxMeta{..} = and $ catMaybes - [ (txMetaSlot >=) <$> W.inclusiveLowerBound range - , (txMetaSlot <=) <$> W.inclusiveUpperBound range - ] - reorder = case order of - Ascending -> sortOn txMetaSlot - Descending -> sortOn $ Down . txMetaSlot - - transactions - = maybe id (take . fromIntegral) mlimit - $ reorder - $ filter whichMeta allTransactions - lookupTx = queryS transactionsQS . GetByTxId - lookupTxOut = queryS transactionsQS . GetTxOut - forM transactions $ + txs <- queryS transactionsQS $ SomeMetas range mlimit order + forM txs $ selectTransactionInfo ti tip lookupTx lookupTxOut , getTx_ = \txid tip -> do - transactions <- queryS transactionsQS $ One $ TxId txid - let lookupTx = queryS transactionsQS . GetByTxId - lookupTxOut = queryS transactionsQS . GetTxOut - forM transactions $ + txm <- queryS transactionsQS $ OneMeta $ TxId txid + forM txm $ selectTransactionInfo ti tip lookupTx lookupTxOut , mkDecorator_ = mkDecorator transactionsQS diff --git a/lib/wallet/src/Cardano/Wallet/DB/Store/Meta/Layer.hs b/lib/wallet/src/Cardano/Wallet/DB/Store/Meta/Layer.hs new file mode 100644 index 00000000000..c092021cdb4 --- /dev/null +++ b/lib/wallet/src/Cardano/Wallet/DB/Store/Meta/Layer.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Wallet.DB.Store.Meta.Layer + ( QueryTxMeta (..) + , mkQueryStoreTxMeta + ) where + +import Prelude + +import Cardano.Slotting.Slot + ( SlotNo ) +import Cardano.Wallet.DB.Sqlite.Schema + ( EntityField (..), TxMeta (..) ) +import Cardano.Wallet.DB.Sqlite.Types + ( TxId (..) ) +import Cardano.Wallet.DB.Store.Meta.Model + ( DeltaTxMetaHistory, TxMetaHistory (..) ) +import Cardano.Wallet.DB.Store.Meta.Store + ( mkStoreMetaTransactions ) +import Cardano.Wallet.DB.Store.QueryStore + ( Query (..), QueryStore (..) ) +import Cardano.Wallet.Primitive.Types + ( Range (..), SortOrder (..) ) +import Data.Foldable + ( toList ) +import Data.List + ( sortOn ) +import Data.Maybe + ( catMaybes ) +import Data.Ord + ( Down (..) ) +import Data.Set + ( Set ) +import Database.Persist.Sql + ( Entity (entityVal) + , Filter + , PersistQueryRead (selectFirst) + , SelectOpt (..) + , SqlPersistT + , selectList + , (<=.) + , (==.) + , (>.) + , (>=.) + ) +import GHC.Natural + ( Natural ) + +import qualified Cardano.Wallet.DB.Sqlite.Schema as DB +import qualified Cardano.Wallet.Primitive.Types as W +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +{----------------------------------------------------------------------------- + DB for 'TxMeta' +------------------------------------------------------------------------------} + +-- | A query to the 'TxMeta' database. +data QueryTxMeta b where + GetSome + :: Range SlotNo + -> Maybe Natural + -> SortOrder + -> QueryTxMeta [DB.TxMeta] + GetAfterSlot :: SlotNo -> QueryTxMeta (Set TxId) + GetOne :: TxId -> QueryTxMeta (Maybe DB.TxMeta) + +filterMetas :: Bool -> Range SlotNo -> [Filter TxMeta] +filterMetas _ (Range Nothing Nothing) = [] +filterMetas True (Range (Just low) Nothing) = [TxMetaSlot >=. low] +filterMetas False (Range (Just low) Nothing) = [TxMetaSlot >. low] +filterMetas _ (Range Nothing (Just high)) = [TxMetaSlot <=. high] +filterMetas b (Range low high) = filterMetas b (Range Nothing high) + <> filterMetas b (Range low Nothing) + +limitMetas :: Maybe Natural -> [SelectOpt record] +limitMetas Nothing = [] +limitMetas (Just l) = [LimitTo $ fromIntegral l] + +orderMetas :: SortOrder -> [SelectOpt TxMeta] +orderMetas Ascending = [Asc TxMetaSlot, Asc TxMetaTxId] +orderMetas Descending = [Desc TxMetaSlot, Asc TxMetaTxId] + +-- | A 'QueryStore' for 'TxMeta'. +mkQueryStoreTxMeta :: QueryStore (SqlPersistT IO) QueryTxMeta DeltaTxMetaHistory +mkQueryStoreTxMeta = + QueryStore + { queryS = \case + GetSome range limit order -> + fmap entityVal + <$> selectList @DB.TxMeta + (filterMetas True range) + (limitMetas limit <> orderMetas order) + GetOne txId -> + fmap entityVal + <$> selectFirst @_ @_ @DB.TxMeta + [TxMetaTxId ==. txId] + [] + GetAfterSlot slot -> + foldMap ((Set.singleton . txMetaTxId) . entityVal) + <$> selectList @DB.TxMeta + (filterMetas False $ Range (Just slot) Nothing) + [] + , store = mkStoreMetaTransactions + } + +instance Query QueryTxMeta where + type World QueryTxMeta = TxMetaHistory + query :: QueryTxMeta b -> World QueryTxMeta -> b + query q (TxMetaHistory allTransactions) = case q of + GetSome range mlimit order -> + let whichMeta DB.TxMeta{..} = + and + $ catMaybes + [ (txMetaSlot >=) <$> W.inclusiveLowerBound range + , (txMetaSlot <=) <$> W.inclusiveUpperBound range + ] + reorder = case order of + Ascending -> sortOn ((,) <$> txMetaSlot <*> txMetaTxId) + Descending -> sortOn ((,) <$> Down . txMetaSlot <*> txMetaTxId) + in maybe id (take . fromIntegral) mlimit + $ reorder + $ filter whichMeta + $ toList allTransactions + GetOne ti -> Map.lookup ti allTransactions + GetAfterSlot slot -> + let whichMeta DB.TxMeta{..} = txMetaSlot > slot + in Set.fromList + $ fmap txMetaTxId + $ filter whichMeta + $ toList allTransactions diff --git a/lib/wallet/src/Cardano/Wallet/DB/Store/Wallets/Layer.hs b/lib/wallet/src/Cardano/Wallet/DB/Store/Wallets/Layer.hs index 76d9dccde8b..23e9cde864c 100644 --- a/lib/wallet/src/Cardano/Wallet/DB/Store/Wallets/Layer.hs +++ b/lib/wallet/src/Cardano/Wallet/DB/Store/Wallets/Layer.hs @@ -18,44 +18,54 @@ module Cardano.Wallet.DB.Store.Wallets.Layer import Prelude +import Cardano.Slotting.Slot + ( SlotNo ) import Cardano.Wallet.DB.Sqlite.Schema ( CBOR, TxMeta (..) ) import Cardano.Wallet.DB.Sqlite.Types ( TxId (..) ) -import Cardano.Wallet.DB.Store.Meta.Model - ( TxMetaHistory (relations) ) -import Cardano.Wallet.DB.Store.Meta.Store - ( mkStoreMetaTransactions ) +import Cardano.Wallet.DB.Store.Meta.Layer + ( QueryTxMeta (..), mkQueryStoreTxMeta ) import Cardano.Wallet.DB.Store.QueryStore ( QueryStore (..) ) +import Cardano.Wallet.DB.Store.Transactions.Layer + ( mkQueryStoreTxSet ) import Cardano.Wallet.DB.Store.Transactions.Model ( TxRelation ) import Cardano.Wallet.DB.Store.Wallets.Model ( DeltaTxWalletsHistory (..) ) import Cardano.Wallet.DB.Store.Wallets.Store ( mkStoreTxWalletsHistory ) -import Data.DBVar - ( Store (..), newCachedStore ) -import Data.Foldable - ( toList ) +import Cardano.Wallet.Primitive.Types + ( Range (..), SortOrder ) import Data.Word ( Word32 ) import Database.Persist.Sql ( SqlPersistT ) - +import GHC.Natural + ( Natural ) import qualified Cardano.Wallet.DB.Store.Transactions.Layer as TxSet import qualified Cardano.Wallet.Primitive.Types.Tx.TxOut as W -import qualified Data.Map.Strict as Map {----------------------------------------------------------------------------- Query type ------------------------------------------------------------------------------} data QueryTxWalletsHistory b where - GetByTxId :: TxId -> QueryTxWalletsHistory (Maybe (Either TxRelation CBOR)) - GetTxOut :: (TxId, Word32) -> QueryTxWalletsHistory (Maybe W.TxOut) - One :: TxId -> QueryTxWalletsHistory (Maybe TxMeta) - All :: QueryTxWalletsHistory [TxMeta] + GetByTxId + :: TxId + -> QueryTxWalletsHistory (Maybe (Either TxRelation CBOR)) + GetTxOut + :: (TxId, Word32) + -> QueryTxWalletsHistory (Maybe W.TxOut) + OneMeta + :: TxId + -> QueryTxWalletsHistory (Maybe TxMeta) + SomeMetas + :: Range SlotNo + -> Maybe Natural + -> SortOrder + -> QueryTxWalletsHistory [TxMeta] {----------------------------------------------------------------------------- Query Store type @@ -64,34 +74,20 @@ type QueryStoreTxWalletsHistory = QueryStore (SqlPersistT IO) QueryTxWalletsHistory DeltaTxWalletsHistory newQueryStoreTxWalletsHistory - :: forall m. m ~ SqlPersistT IO - => m QueryStoreTxWalletsHistory -newQueryStoreTxWalletsHistory = do - let txsQueryStore = TxSet.mkQueryStoreTxSet - let storeTransactions = store txsQueryStore - - storeMetas <- newCachedStore mkStoreMetaTransactions - let storeTxWalletsHistory = mkStoreTxWalletsHistory - storeTransactions -- on disk - storeMetas -- in memory - - let readAllMetas :: m [TxMeta] - readAllMetas = do - Right wmetas <- loadS storeMetas - pure $ (toList . relations) wmetas - - query :: forall a. QueryTxWalletsHistory a -> SqlPersistT IO a - query = \case - GetByTxId txid -> do - queryS txsQueryStore $ TxSet.GetByTxId txid - GetTxOut key -> do - queryS txsQueryStore $ TxSet.GetTxOut key - One txid -> do - Right wmetas <- loadS storeMetas - pure $ Map.lookup txid . relations $ wmetas - All -> readAllMetas - - pure QueryStore - { queryS = query - , store = storeTxWalletsHistory + :: QueryStore (SqlPersistT IO) QueryTxWalletsHistory DeltaTxWalletsHistory +newQueryStoreTxWalletsHistory = + QueryStore + { queryS = \case + GetByTxId txid -> queryS txs $ TxSet.GetByTxId txid + GetTxOut key -> queryS txs $ TxSet.GetTxOut key + OneMeta txId -> queryS metas $ GetOne txId + SomeMetas range limit order -> queryS metas + $ GetSome range limit order + , store = + mkStoreTxWalletsHistory + (store txs) + metas } + where + txs = mkQueryStoreTxSet + metas = mkQueryStoreTxMeta diff --git a/lib/wallet/src/Cardano/Wallet/DB/Store/Wallets/Store.hs b/lib/wallet/src/Cardano/Wallet/DB/Store/Wallets/Store.hs index 110a72f820b..4fbba682206 100644 --- a/lib/wallet/src/Cardano/Wallet/DB/Store/Wallets/Store.hs +++ b/lib/wallet/src/Cardano/Wallet/DB/Store/Wallets/Store.hs @@ -1,7 +1,5 @@ -{-# OPTIONS_GHC -Wno-redundant-constraints#-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -21,66 +19,60 @@ module Cardano.Wallet.DB.Store.Wallets.Store import Prelude +import Cardano.Wallet.DB.Store.Meta.Layer + ( QueryTxMeta (..) ) import Cardano.Wallet.DB.Store.Meta.Model ( DeltaTxMetaHistory, mkTxMetaHistory ) +import Cardano.Wallet.DB.Store.QueryStore + ( QueryStore (..) ) import Cardano.Wallet.DB.Store.Transactions.Model ( DeltaTxSet (..), mkTxSet ) import Cardano.Wallet.DB.Store.Wallets.Model ( DeltaTxWalletsHistory (..) ) import Control.Applicative ( liftA2 ) -import Control.Exception - ( SomeException (..) ) -import Control.Monad.Class.MonadThrow - ( MonadThrow, throwIO ) import Data.DBVar ( Store (..) ) -import Data.Delta - ( Base, Delta ) +import Database.Persist.Sql + ( SqlPersistT ) import qualified Cardano.Wallet.DB.Store.Meta.Model as TxMetaStore + mkStoreTxWalletsHistory - :: (Monad m, MonadThrow m) - => Store m DeltaTxSet - -> Store m DeltaTxMetaHistory - -> Store m DeltaTxWalletsHistory + :: Store (SqlPersistT IO) DeltaTxSet + -> QueryStore (SqlPersistT IO) QueryTxMeta DeltaTxMetaHistory + -> Store (SqlPersistT IO) DeltaTxWalletsHistory mkStoreTxWalletsHistory storeTransactions storeMeta = - let load = liftA2 (,) - <$> loadS storeTransactions - <*> loadS storeMeta - write = \(txSet,txMetaHistory) -> do + let load = + liftA2 (,) + <$> loadS storeTransactions + <*> loadS (store storeMeta) + write = \(txSet, txMetaHistory) -> do writeS storeTransactions txSet - writeS storeMeta txMetaHistory + writeS (store storeMeta) txMetaHistory update ma delta = - let (mTxSet,mWmetas) = (fst <$> ma, snd <$> ma) + let (mTxSet, mWmetas) = (fst <$> ma, snd <$> ma) in case delta of - RollbackTxWalletsHistory slot -> do - wmetas <- loadWhenNothing mWmetas storeMeta - updateS storeMeta (Just wmetas) - $ TxMetaStore.Rollback slot - let ( _metas', toBeDeletedTxSet) - = TxMetaStore.rollbackTxMetaHistory slot wmetas - updateS storeTransactions mTxSet - $ DeleteTxs toBeDeletedTxSet - - ExpandTxWalletsHistory wid cs -> do - wmetas <- loadWhenNothing mWmetas storeMeta - updateS storeTransactions mTxSet - $ Append - $ mkTxSet - $ fst <$> cs - updateS storeMeta (Just wmetas) - $ TxMetaStore.Expand - $ mkTxMetaHistory wid cs - in Store { loadS = load, writeS = write, updateS = update } - --- | Call 'loadS' from a 'Store' if the value is not already in memory. -loadWhenNothing - :: (Monad m, MonadThrow m, Delta da) - => Maybe (Base da) -> Store m da -> m (Base da) -loadWhenNothing (Just a) _ = pure a -loadWhenNothing Nothing store = - loadS store >>= \case - Left (SomeException e) -> throwIO e - Right a -> pure a + RollbackTxWalletsHistory slot -> do + tbd <- case mWmetas of + Nothing -> queryS storeMeta $ GetAfterSlot slot + Just metas -> + pure + $ snd + $ TxMetaStore.rollbackTxMetaHistory + slot + metas + updateS (store storeMeta) (mWmetas) + $ TxMetaStore.Rollback slot + updateS storeTransactions mTxSet + $ DeleteTxs tbd + ExpandTxWalletsHistory wid cs -> do + updateS storeTransactions mTxSet + $ Append + $ mkTxSet + $ fst <$> cs + updateS (store storeMeta) mWmetas + $ TxMetaStore.Expand + $ mkTxMetaHistory wid cs + in Store{loadS = load, writeS = write, updateS = update} diff --git a/lib/wallet/test/unit/Cardano/Wallet/DB/Fixtures.hs b/lib/wallet/test/unit/Cardano/Wallet/DB/Fixtures.hs index 0cf2c85c6f9..052177c3972 100644 --- a/lib/wallet/test/unit/Cardano/Wallet/DB/Fixtures.hs +++ b/lib/wallet/test/unit/Cardano/Wallet/DB/Fixtures.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -20,6 +22,7 @@ module Cardano.Wallet.DB.Fixtures , withStoreProp , StoreProperty , elementsOrArbitrary + , queryLaw ) where import Prelude @@ -30,6 +33,8 @@ import Cardano.Wallet.DB.Sqlite.Schema ( Wallet (..), migrateAll ) import Cardano.Wallet.DB.Sqlite.Types ( BlockId (..) ) +import Cardano.Wallet.DB.Store.QueryStore + ( Query (..), QueryStore (..), World ) import Cardano.Wallet.Primitive.Types ( WalletId (..) ) import Cardano.Wallet.Primitive.Types.Hash @@ -72,8 +77,10 @@ import Test.QuickCheck.Monadic import UnliftIO.Exception ( bracket ) + import qualified Cardano.Wallet.DB.Sqlite.Schema as TH + {------------------------------------------------------------------------------- DB setup -------------------------------------------------------------------------------} @@ -168,7 +175,8 @@ withInitializedWalletProp => (WalletId -> RunQuery -> PropertyM IO a) -> WalletProperty withInitializedWalletProp prop db wid = monadicIO $ do - let runQ = run .runQuery db + let runQ :: SqlPersistT IO a -> PropertyM IO a + runQ = run . runQuery db runQ $ initializeWallet wid prop wid runQ @@ -182,3 +190,12 @@ unsafeLoadS s = fromRight (error "store law is broken") <$> loadS s -- Natural for use with 'foldM'. unsafeUpdateS :: Applicative m => Store m da -> Base da -> da -> m (Base da) unsafeUpdateS store ba da = updateS store (Just ba) da *> unsafeLoadS store + +-- | Property that a pure query returns the same result as the store one. +queryLaw :: (Monad m, Eq b, Query qa, MonadFail m, Base da ~ World qa, Show b) + => QueryStore m qa da -- ^ the store to test + -> World qa -- ^ the world to query + -> qa b -- ^ the query to run + -> m Bool -- ^ if the pure query returns the same result as the store one +queryLaw QueryStore{queryS} z r = + (query r z ==) <$> queryS r diff --git a/lib/wallet/test/unit/Cardano/Wallet/DB/Store/Meta/StoreSpec.hs b/lib/wallet/test/unit/Cardano/Wallet/DB/Store/Meta/StoreSpec.hs index 12e67f44218..0dabcb75a4d 100644 --- a/lib/wallet/test/unit/Cardano/Wallet/DB/Store/Meta/StoreSpec.hs +++ b/lib/wallet/test/unit/Cardano/Wallet/DB/Store/Meta/StoreSpec.hs @@ -4,38 +4,68 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -module Cardano.Wallet.DB.Store.Meta.StoreSpec - ( spec ) - where +module Cardano.Wallet.DB.Store.Meta.StoreSpec (spec) +where import Prelude import Cardano.DB.Sqlite ( ForeignKeysSetting (..) ) +import Cardano.Slotting.Slot + ( SlotNo ) import Cardano.Wallet.DB.Arbitrary () import Cardano.Wallet.DB.Fixtures - ( WalletProperty, logScale, withDBInMemory, withInitializedWalletProp ) + ( WalletProperty + , assertWith + , logScale + , queryLaw + , withDBInMemory + , withInitializedWalletProp + ) +import Cardano.Wallet.DB.Sqlite.Schema + ( TxMeta (..) ) +import Cardano.Wallet.DB.Sqlite.Types + ( TxId (TxId) ) +import Cardano.Wallet.DB.Store.Meta.Layer + ( QueryTxMeta (..), mkQueryStoreTxMeta ) import Cardano.Wallet.DB.Store.Meta.Model ( DeltaTxMetaHistory (..), TxMetaHistory (..) ) import Cardano.Wallet.DB.Store.Meta.ModelSpec ( genExpand, genRollback ) import Cardano.Wallet.DB.Store.Meta.Store ( mkStoreMetaTransactions ) +import Cardano.Wallet.DB.Store.QueryStore + ( QueryStore (..) ) import Cardano.Wallet.Primitive.Types - ( WalletId ) + ( Range (..), SortOrder (Ascending, Descending), WalletId ) +import Control.Monad + ( forM_, (<=<) ) +import Data.DBVar + ( Store (..) ) +import Data.Foldable + ( toList ) +import GHC.Natural + ( Natural ) import Test.DBVar ( prop_StoreUpdates ) import Test.Hspec ( Spec, around, describe, it ) import Test.QuickCheck - ( Gen, arbitrary, frequency, property ) + ( Gen, arbitrary, elements, frequency, property ) +import Test.QuickCheck.Monadic + ( forAllM, pick ) + +import qualified Data.Map.Strict as Map spec :: Spec spec = around (withDBInMemory ForeignKeysEnabled) $ do describe "meta-transactions store" $ do it "respects store laws" $ property . prop_StoreMetaLaws + describe "mkQueryStoreTxMeta" + $ it "respects query law" + $ property . prop_QueryLaw genDeltas :: WalletId -> TxMetaHistory -> Gen DeltaTxMetaHistory genDeltas wid history = @@ -51,3 +81,48 @@ prop_StoreMetaLaws = withInitializedWalletProp $ \wid runQ -> mkStoreMetaTransactions (pure mempty) (logScale . genDeltas wid) + +prop_QueryLaw :: WalletProperty +prop_QueryLaw = + withInitializedWalletProp $ \wid runQ -> + forAllM (genExpand wid arbitrary) $ \history -> do + runQ $ writeS (store mkQueryStoreTxMeta) history + unknownTxId <- TxId <$> pick arbitrary + let txIds = unknownTxId : Map.keys (relations history) + forM_ txIds $ \txId -> do + assertWith "GetOne" + <=< runQ + $ queryLaw mkQueryStoreTxMeta history + $ GetOne txId + range <- pick $ genRange history + limit <- pick $ genLimit history + order <- pick genSortOrder + assertWith "GetSome" + <=< runQ + $ queryLaw mkQueryStoreTxMeta history + $ GetSome range limit order + slot <- pick $ genSlot history + assertWith "GetAfterSlot" + <=< runQ + $ queryLaw mkQueryStoreTxMeta history + $ GetAfterSlot slot + +genSortOrder :: Gen SortOrder +genSortOrder = elements [Ascending, Descending] + +genRange :: TxMetaHistory -> Gen (Range SlotNo) +genRange (TxMetaHistory history) = + Range + <$> elements slots + <*> elements slots + where + slots = Nothing : map (Just . txMetaSlot) (toList history) + +genLimit :: TxMetaHistory -> Gen (Maybe Natural) +genLimit (TxMetaHistory history) = + elements $ Nothing : (Just <$> [1 .. fromIntegral (length history)]) + +genSlot :: TxMetaHistory -> Gen SlotNo +genSlot (TxMetaHistory history) = do + unknownSlot <- arbitrary + elements $ unknownSlot : (txMetaSlot <$> toList history) diff --git a/lib/wallet/test/unit/Cardano/Wallet/DB/Store/Transactions/StoreSpec.hs b/lib/wallet/test/unit/Cardano/Wallet/DB/Store/Transactions/StoreSpec.hs index bcc20db66a1..2557d55bb8e 100644 --- a/lib/wallet/test/unit/Cardano/Wallet/DB/Store/Transactions/StoreSpec.hs +++ b/lib/wallet/test/unit/Cardano/Wallet/DB/Store/Transactions/StoreSpec.hs @@ -18,11 +18,17 @@ import Cardano.DB.Sqlite import Cardano.Wallet.DB.Arbitrary () import Cardano.Wallet.DB.Fixtures - ( StoreProperty, assertWith, logScale, withDBInMemory, withStoreProp ) + ( StoreProperty + , assertWith + , logScale + , queryLaw + , withDBInMemory + , withStoreProp + ) import Cardano.Wallet.DB.Sqlite.Types ( TxId (TxId) ) import Cardano.Wallet.DB.Store.QueryStore - ( Query (..), QueryStore (..), World ) + ( QueryStore (..) ) import Cardano.Wallet.DB.Store.Transactions.Decoration ( DecoratedTxIns , decorateTxInsForRelation @@ -43,7 +49,7 @@ import Cardano.Wallet.DB.Store.Transactions.Store import Cardano.Wallet.Primitive.Types.Tx ( Tx (..) ) import Control.Monad - ( forM_ ) + ( forM_, (<=<) ) import Data.DBVar ( Store (..) ) import Data.Delta @@ -188,23 +194,14 @@ prop_QueryLaw = forAllM genTxSet $ \txs -> do runQ $ writeS (store TxSet.mkQueryStoreTxSet) txs forM_ (take 10 $ Map.keys $ relations txs) $ \txId -> do - assertWith "GetTxById correct" - =<< runQ ( queryLaw TxSet.mkQueryStoreTxSet txs $ - TxSet.GetByTxId txId ) + assertWith "GetTxById" <=< runQ + $ queryLaw TxSet.mkQueryStoreTxSet txs + $ TxSet.GetByTxId txId index <- pick $ choose (0,5) - assertWith "GetTxOut correct" - =<< runQ ( queryLaw TxSet.mkQueryStoreTxSet txs $ - TxSet.GetTxOut (txId,index) ) - --- Note: We make a top-level definition here because we would like --- to write down a type signature, due to the (implied) `forall b.` -queryLaw :: (Monad m, Eq b, Query qa, MonadFail m, Base da ~ World qa) - => QueryStore m qa da - -> World qa - -> qa b - -> m Bool -queryLaw QueryStore{queryS} z r = - (query r z ==) <$> queryS r + assertWith "GetTxOut" <=< runQ + $ queryLaw TxSet.mkQueryStoreTxSet txs + $ TxSet.GetTxOut (txId,index) + {----------------------------------------------------------------------------- Generators diff --git a/lib/wallet/test/unit/Cardano/Wallet/DB/Store/Wallets/LayerSpec.hs b/lib/wallet/test/unit/Cardano/Wallet/DB/Store/Wallets/LayerSpec.hs index 9c2018f1283..c0f871639a9 100644 --- a/lib/wallet/test/unit/Cardano/Wallet/DB/Store/Wallets/LayerSpec.hs +++ b/lib/wallet/test/unit/Cardano/Wallet/DB/Store/Wallets/LayerSpec.hs @@ -35,7 +35,7 @@ spec = do prop_StoreWalletsLaws :: WalletProperty prop_StoreWalletsLaws = withInitializedWalletProp $ \wid runQ -> do - qs <- runQ newQueryStoreTxWalletsHistory + let qs = newQueryStoreTxWalletsHistory prop_StoreUpdates runQ (store qs) diff --git a/lib/wallet/test/unit/Cardano/Wallet/DB/Store/Wallets/StoreSpec.hs b/lib/wallet/test/unit/Cardano/Wallet/DB/Store/Wallets/StoreSpec.hs index b239ee979ca..3c8680e21cf 100644 --- a/lib/wallet/test/unit/Cardano/Wallet/DB/Store/Wallets/StoreSpec.hs +++ b/lib/wallet/test/unit/Cardano/Wallet/DB/Store/Wallets/StoreSpec.hs @@ -18,10 +18,10 @@ import Cardano.Wallet.DB.Fixtures ( WalletProperty, logScale, withDBInMemory, withInitializedWalletProp ) import Cardano.Wallet.DB.Sqlite.Schema ( TxMeta (..) ) +import Cardano.Wallet.DB.Store.Meta.Layer + ( mkQueryStoreTxMeta ) import Cardano.Wallet.DB.Store.Meta.Model ( TxMetaHistory (..) ) -import Cardano.Wallet.DB.Store.Meta.Store - ( mkStoreMetaTransactions ) import Cardano.Wallet.DB.Store.Wallets.Model ( DeltaTxWalletsHistory (..) ) import Cardano.Wallet.DB.Store.Wallets.Store @@ -53,7 +53,7 @@ prop_StoreWalletsLaws = -- Note: We have already tested `mkStoreTransactions`, -- so we use `newStore` here for a faster test. storeTransactions <- runQ newStore - let storeWalletsMeta = mkStoreMetaTransactions + let storeWalletsMeta = mkQueryStoreTxMeta storeTxWalletsHistory = mkStoreTxWalletsHistory storeTransactions storeWalletsMeta