[ADP-2871] use a query store for tx metas

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

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

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

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