add tx meta store code

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,15 @@ 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.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,144 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{- |
+ Copyright: © 2018-2022 IOHK
+ License: Apache-2.0
+
+Low level meta transactions pure model. Meta transactions are encoded "as" expressed in DB
+tables.
+
+-}
+module Cardano.Wallet.DB.Store.Meta.Model
+    ( DeltaTxMetaHistory(..)
+    , ManipulateTxMetaHistory(..)
+    , TxMetaHistory(..)
+    , mkTxMetaHistory
+    , overTxMetaHistory ) 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.Foldable
+    ( fold )
+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
+
+-- | Metas indexedby transaction identifier
+newtype TxMetaHistory =
+    TxMetaHistory { txMetaHistory_relations :: Map TxId TxMeta }
+    deriving ( Generic, Eq, Show, Monoid, Semigroup )
+
+instance Buildable TxMetaHistory where
+    build txs =
+        "TxMetaHistory "
+        <> build (length $ txMetaHistory_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 changes, including expanding that 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 (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 (Manipulate (AgeTxMetaHistory tip)) (TxMetaHistory txs) =
+        TxMetaHistory
+        $ txs <&> \meta@TxMeta {..} -> if txMetaStatus == W.Pending
+            && case txMetaSlotExpires of
+                    Nothing -> False
+                    Just tip' -> tip' <= tip
+            then meta { txMetaStatus = W.Expired }
+            else meta
+    apply (Manipulate (RollBackTxMetaHistory point)) (TxMetaHistory txs) =
+        TxMetaHistory $ Map.mapMaybe (rescheduleOrForget point) txs
+      where
+        rescheduleOrForget :: W.SlotNo -> TxMeta -> Maybe TxMeta
+        rescheduleOrForget forkSlot meta =
+            let
+                isAfter = txMetaSlot meta > point
+                isIncoming = txMetaDirection meta == W.Incoming
+            in case (isAfter, isIncoming) of
+                   (True,True) -> mzero
+                   (True,False) -> Just
+                       $ meta
+                       { txMetaSlot = forkSlot, 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 $ fold $ do
+    (tx,meta) <- txs
+    let relation = mkTxMetaEntity wid tx meta
+    pure $ Map.singleton (TxId $ tx ^. #txId) relation
+
+overTxMetaHistory :: TxMetaHistory
+    -> (Map TxId TxMeta -> Map TxId TxMeta)
+    -> TxMetaHistory
+overTxMetaHistory
+    (TxMetaHistory x)
+    f = TxMetaHistory $ f x

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

@@ -0,0 +1,110 @@
+
+{-# LANGUAGE LambdaCase #-}
+
+{- |
+ Copyright: © 2018-2022 IOHK
+ License: Apache-2.0
+
+Low level meta transactions store. Meta transactions are specific to a wallet.
+
+-}
+module Cardano.Wallet.DB.Store.Meta.Store ( mkStoreTransactionsMeta ) 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)
+    , SelectOpt (Desc)
+    , 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
+mkStoreTransactionsMeta :: WalletId
+    -> Store (SqlPersistT IO) DeltaTxMetaHistory
+mkStoreTransactionsMeta
+    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 nearestPoint) -> do
+        deleteWhere
+            [ TxMetaWalletId ==. wid
+            , TxMetaDirection ==. W.Incoming
+            , TxMetaSlot >. nearestPoint
+            ]
+        updateWhere
+            [ TxMetaWalletId ==. wid
+            , TxMetaDirection ==. W.Outgoing
+            , TxMetaSlot >. nearestPoint
+            ]
+            [TxMetaStatus =. W.Pending, TxMetaSlot =. nearestPoint]
+
+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] [Desc TxMetaSlot]
+
+--  Insert multiple transactions, removing old instances first. No assertion on
+-- the wallet id is done.
+putMetas :: TxMetaHistory -> SqlPersistT IO ()
+putMetas (TxMetaHistory metas) =
+    repsertMany [(fromJust keyFromRecordM x, x) | x <- toList metas]