Try #3338:

lib/core/cardano-wallet-core.cabal

@@ -208,6 +208,8 @@ library
       Cardano.Wallet.DB.Sqlite.Stores
       Cardano.Wallet.DB.Sqlite.Types
       Cardano.Wallet.DB.Store.Checkpoints
+      Cardano.Wallet.DB.Store.Meta.Model
+      Cardano.Wallet.DB.Store.Meta.Store
       Cardano.Wallet.DB.Store.Transactions.Model
       Cardano.Wallet.DB.Store.Transactions.Store
       Cardano.Wallet.DB.WalletState
@@ -462,14 +464,16 @@ test-suite unit
       Cardano.Wallet.CoinSelection.Internal.BalanceSpec
       Cardano.Wallet.CoinSelection.Internal.CollateralSpec
       Cardano.Wallet.DB.Arbitrary
+      Cardano.Wallet.DB.Fixtures
       Cardano.Wallet.DB.LayerSpec
       Cardano.Wallet.DB.Properties
       Cardano.Wallet.DB.Pure.ImplementationSpec
       Cardano.Wallet.DB.Sqlite.StoresSpec
       Cardano.Wallet.DB.Sqlite.TypesSpec
       Cardano.Wallet.DB.StateMachine
+      Cardano.Wallet.DB.Store.Meta.ModelSpec
+      Cardano.Wallet.DB.Store.Meta.StoreSpec
       Cardano.Wallet.DB.Store.Transactions.StoreSpec
-      Cardano.Wallet.DB.Fixtures
       Cardano.Wallet.DummyTarget.Primitive.Types
       Cardano.Wallet.Network.LightSpec
       Cardano.Wallet.Network.PortsSpec

lib/core/src/Cardano/Wallet/DB/Store/Meta/Model.hs

@@ -0,0 +1,145 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{- |
+ Copyright: © 2018-2022 IOHK
+ License: Apache-2.0
+
+Pure, low level model for a collection of "meta transactions",
+i.e. additional data ('TxMeta') that the wallet stores for each transaction.
+Meta transactions are encoded "as" expressed in DB tables.
+
+-}
+module Cardano.Wallet.DB.Store.Meta.Model
+    ( DeltaTxMetaHistory(..)
+    , ManipulateTxMetaHistory(..)
+    , TxMetaHistory(..)
+    , mkTxMetaHistory
+    )
+    where
+
+import Prelude
+
+import Cardano.Wallet.DB.Sqlite.Schema
+    ( TxMeta (..) )
+import Cardano.Wallet.DB.Sqlite.Types
+    ( TxId (..) )
+import Control.Monad
+    ( MonadPlus (mzero) )
+import Data.Delta
+    ( Delta (..) )
+import Data.Functor
+    ( (<&>) )
+import Data.Generics.Internal.VL
+    ( (^.) )
+import Data.Map.Strict
+    ( Map )
+import Data.Quantity
+    ( Quantity (getQuantity) )
+import Fmt
+    ( Buildable (build) )
+import GHC.Generics
+    ( Generic )
+
+import qualified Cardano.Wallet.Primitive.Types as W
+import qualified Cardano.Wallet.Primitive.Types.Coin as W
+import qualified Cardano.Wallet.Primitive.Types.Tx as W
+import qualified Data.Map.Strict as Map
+
+-- | A collection of `TxMeta`, indexed by transaction identifier.
+newtype TxMetaHistory =
+    TxMetaHistory { relations :: Map TxId TxMeta }
+    deriving ( Generic, Eq, Show, Monoid, Semigroup )
+
+instance Buildable TxMetaHistory where
+    build txs =
+        "TxMetaHistory "
+        <> build (length $ relations txs)
+
+-- | Meta changes that can be issued independently from the transaction store.
+data ManipulateTxMetaHistory
+    = PruneTxMetaHistory TxId
+    | AgeTxMetaHistory W.SlotNo
+    | RollBackTxMetaHistory W.SlotNo
+    deriving ( Eq, Show )
+
+-- | All meta-transactions changes, including the addition of new
+-- meta-transactions, which has to be done in sync with the transactions store.
+data DeltaTxMetaHistory
+    = Manipulate ManipulateTxMetaHistory
+    | Expand TxMetaHistory
+    deriving (Show, Eq)
+
+instance Buildable DeltaTxMetaHistory where
+    build = build . show
+
+instance Delta DeltaTxMetaHistory where
+    type Base DeltaTxMetaHistory = TxMetaHistory
+    apply (Expand txs) h = h <> txs
+    apply (Manipulate d) h = apply d h
+
+instance Delta ManipulateTxMetaHistory where
+    type Base ManipulateTxMetaHistory = TxMetaHistory
+    apply (PruneTxMetaHistory tid) (TxMetaHistory txs) =
+        TxMetaHistory $ Map.alter f tid txs
+      where
+        f (Just tx@(TxMeta {..})) =
+            if txMetaStatus == W.InLedger
+                then Just tx
+                else Nothing
+        f Nothing = Nothing
+    apply (AgeTxMetaHistory tip) (TxMetaHistory txs) =
+        TxMetaHistory
+        $ txs <&> \meta@TxMeta {..} ->
+            if txMetaStatus == W.Pending && isExpired txMetaSlotExpires
+            then meta { txMetaStatus = W.Expired }
+            else meta
+      where
+        isExpired Nothing = False
+        isExpired (Just tip') = tip' <= tip
+    apply (RollBackTxMetaHistory point) (TxMetaHistory txs) =
+        TxMetaHistory $ Map.mapMaybe rescheduleOrForget txs
+      where
+        rescheduleOrForget :: TxMeta -> Maybe TxMeta
+        rescheduleOrForget meta =
+            let
+                isAfter = txMetaSlot meta > point
+                isIncoming = txMetaDirection meta == W.Incoming
+            in case (isAfter, isIncoming) of
+                   (True,True) -> mzero
+                   (True,False) -> Just
+                       $ meta
+                       { txMetaSlot = point, txMetaStatus = W.Pending }
+                   _ -> Just meta
+
+mkTxMetaEntity :: W.WalletId -> W.Tx -> W.TxMeta -> TxMeta
+mkTxMetaEntity wid tx derived =
+    TxMeta
+    { txMetaTxId = TxId $ tx ^. #txId
+    , txMetaWalletId = wid
+    , txMetaStatus = derived ^. #status
+    , txMetaDirection = derived ^. #direction
+    , txMetaSlot = derived ^. #slotNo
+    , txMetaBlockHeight = getQuantity
+          (derived ^. #blockHeight)
+    , txMetaAmount = derived ^. #amount
+    , txMetaFee = fromIntegral . W.unCoin <$> W.fee tx
+    , txMetaSlotExpires = derived ^. #expiry
+    , txMetadata = W.metadata tx
+    , txMetaScriptValidity = W.scriptValidity tx <&> \case
+          W.TxScriptValid -> True
+          W.TxScriptInvalid -> False
+    }
+
+mkTxMetaHistory :: W.WalletId -> [(W.Tx, W.TxMeta)] -> TxMetaHistory
+mkTxMetaHistory wid txs = TxMetaHistory $
+    Map.fromList
+        [ (TxId $ tx ^. #txId, mkTxMetaEntity wid tx meta)
+            | (tx, meta) <- txs
+        ]
+
+

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

@@ -0,0 +1,114 @@
+
+{-# LANGUAGE LambdaCase #-}
+
+{- |
+ Copyright: © 2018-2022 IOHK
+ License: Apache-2.0
+
+Low level 'Store' for a collection of meta-transactions,
+i.e. additional data ('TxMeta') that the wallet stores for each transaction.
+Meta-transactions are specific to a wallet.
+
+-}
+module Cardano.Wallet.DB.Store.Meta.Store ( mkStoreMetaTransactions ) where
+
+import Prelude
+
+import Cardano.Wallet.DB.Sqlite.Schema
+    ( EntityField (..), TxMeta (..) )
+import Cardano.Wallet.DB.Store.Meta.Model
+    ( DeltaTxMetaHistory (..)
+    , ManipulateTxMetaHistory (..)
+    , TxMetaHistory (..)
+    )
+import Cardano.Wallet.Primitive.Types
+    ( WalletId )
+import Control.Arrow
+    ( (&&&) )
+import Control.Exception
+    ( SomeException )
+import Control.Monad
+    ( void )
+import Data.DBVar
+    ( Store (Store, loadS, updateS, writeS) )
+import Data.Foldable
+    ( Foldable (toList) )
+import Data.Maybe
+    ( fromJust )
+import Database.Persist.Sql
+    ( Entity (entityVal)
+    , PersistEntity (keyFromRecordM)
+    , PersistQueryRead (selectFirst)
+    , SqlPersistT
+    , deleteWhere
+    , deleteWhereCount
+    , repsertMany
+    , selectList
+    , updateWhere
+    , (<-.)
+    , (<=.)
+    , (=.)
+    , (==.)
+    , (>.)
+    )
+
+import qualified Cardano.Wallet.Primitive.Types.Tx as W
+import qualified Data.Map.Strict as Map
+
+-- | Create an SQL store to hold meta transactions for a wallet.
+mkStoreMetaTransactions :: WalletId
+    -> Store (SqlPersistT IO) DeltaTxMetaHistory
+mkStoreMetaTransactions
+    wid = Store { loadS = load wid, writeS = write wid, updateS = update wid }
+
+update :: WalletId -> TxMetaHistory -> DeltaTxMetaHistory -> SqlPersistT IO ()
+update wid _ change = case change of
+    Expand txs -> putMetas txs
+    Manipulate (PruneTxMetaHistory tid) -> do
+        let filt = [TxMetaWalletId ==. wid, TxMetaTxId ==. tid]
+        selectFirst ((TxMetaStatus ==. W.InLedger) : filt) [] >>= \case
+            Just _ -> pure () -- marked in ledger - refuse to delete
+            Nothing -> void
+                $ deleteWhereCount
+                $ (TxMetaStatus <-. [W.Pending, W.Expired]) : filt
+    Manipulate (AgeTxMetaHistory tip) -> updateWhere
+        [ TxMetaWalletId ==. wid
+        , TxMetaStatus ==. W.Pending
+        , TxMetaSlotExpires <=. Just tip
+        ]
+        [TxMetaStatus =. W.Expired]
+    Manipulate (RollBackTxMetaHistory point) -> do
+        let
+          isAfter = TxMetaSlot >. point
+          isIncoming = TxMetaDirection ==. W.Incoming
+          notIncoming = TxMetaDirection ==. W.Outgoing
+        deleteWhere
+            [ TxMetaWalletId ==. wid
+            , isAfter, isIncoming
+            ]
+        updateWhere
+            [ TxMetaWalletId ==. wid
+            , isAfter, notIncoming
+            ]
+            [ TxMetaSlot =. point, TxMetaStatus =. W.Pending ]
+
+write :: WalletId -> TxMetaHistory -> SqlPersistT IO ()
+write wid txs = do
+    deleteWhere [TxMetaWalletId ==. wid]
+    putMetas txs
+
+load :: WalletId
+    -> SqlPersistT IO (Either SomeException TxMetaHistory)
+load wid =
+    Right
+    . TxMetaHistory
+    . Map.fromList
+    . fmap ((txMetaTxId &&& id) . entityVal)
+    <$> selectList [TxMetaWalletId ==. wid] []
+
+-- | Insert multiple meta-transactions, overwriting the previous version in
+-- case of the same transaction index.
+-- Only one meta-transaction can be stored per transaction for a given wallet.
+putMetas :: TxMetaHistory -> SqlPersistT IO ()
+putMetas (TxMetaHistory metas) =
+    repsertMany [(fromJust keyFromRecordM x, x) | x <- toList metas]