wip Add transaction expiry slot for pending transactions

lib/core/src/Cardano/Wallet.hs

@@ -840,6 +840,7 @@ restoreBlocks ctx wid blocks nodeTip = db & \DBLayer{..} -> mapExceptT atomicall
     let k = gp ^. #getEpochStability
     let localTip = currentTip $ NE.last cps
 
+    updatePendingTx (PrimaryKey wid) (view #slotNo localTip)
     putTxHistory (PrimaryKey wid) txs
     forM_ slotPoolDelegations $ \delegation@(slotNo, cert) -> do
         liftIO $ logDelegation delegation
@@ -1595,10 +1596,10 @@ signPayment ctx wid argGenChange mkRewardAccount pwd md cs = db & \DBLayer{..} -
 
             let keyFrom = isOwned (getState cp) (xprv, pwdP)
             let rewardAcnt = mkRewardAccount (xprv, pwdP)
-            (tx, sealedTx) <- withExceptT ErrSignPaymentMkTx $ ExceptT $ pure $
-                mkStdTx tl rewardAcnt keyFrom (nodeTip ^. #slotNo) md cs'
+            (tx, sealedTx, txExp) <- withExceptT ErrSignPaymentMkTx $ ExceptT $
+                pure $ mkStdTx tl rewardAcnt keyFrom (nodeTip ^. #slotNo) md cs'
 
-            (time, meta) <- liftIO $ mkTxMeta ti (currentTip cp) s' tx cs'
+            (time, meta) <- liftIO $ mkTxMeta ti (currentTip cp) s' tx cs' txExp
             return (tx, meta, time, sealedTx)
   where
     ti :: TimeInterpreter IO
@@ -1636,10 +1637,11 @@ signTx ctx wid pwd md (UnsignedTx inpsNE outsNE) = db & \DBLayer{..} -> do
             let cs = mempty { inputs = inps, outputs = outs }
             let keyFrom = isOwned (getState cp) (xprv, pwdP)
             let rewardAcnt = getRawKey $ deriveRewardAccount @k pwdP xprv
-            (tx, sealedTx) <- withExceptT ErrSignPaymentMkTx $ ExceptT $ pure $
-                mkStdTx tl (rewardAcnt, pwdP) keyFrom (nodeTip ^. #slotNo) md cs
+            (tx, sealedTx, txExp) <- withExceptT ErrSignPaymentMkTx $ ExceptT $
+                pure $ mkStdTx tl (rewardAcnt, pwdP) keyFrom (nodeTip ^. #slotNo) md cs
 
-            (time, meta) <- liftIO $ mkTxMeta ti (currentTip cp) (getState cp) tx cs
+            (time, meta) <- liftIO $
+                mkTxMeta ti (currentTip cp) (getState cp) tx cs txExp
             return (tx, meta, time, sealedTx)
   where
     ti :: TimeInterpreter IO
@@ -1729,7 +1731,7 @@ signDelegation ctx wid argGenChange pwd coinSel action = db & \DBLayer{..} -> do
 
             let rewardAcnt = getRawKey $ deriveRewardAccount @k pwdP xprv
             let keyFrom = isOwned (getState cp) (xprv, pwdP)
-            (tx, sealedTx) <- withExceptT ErrSignDelegationMkTx $ ExceptT $ pure $
+            (tx, sealedTx, txExp) <- withExceptT ErrSignDelegationMkTx $ ExceptT $ pure $
                 case action of
                     RegisterKeyAndJoin poolId ->
                         mkDelegationJoinTx tl poolId
@@ -1753,7 +1755,7 @@ signDelegation ctx wid argGenChange pwd coinSel action = db & \DBLayer{..} -> do
                             coinSel'
 
             (time, meta) <- liftIO $
-                mkTxMeta ti (currentTip cp) s' tx coinSel'
+                mkTxMeta ti (currentTip cp) s' tx coinSel' txExp
             return (tx, meta, time, sealedTx)
   where
     ti :: TimeInterpreter IO
@@ -1762,8 +1764,8 @@ signDelegation ctx wid argGenChange pwd coinSel action = db & \DBLayer{..} -> do
     tl = ctx ^. transactionLayer @t @k
     nl = ctx ^. networkLayer @t
 
--- | Construct transaction metadata from a current block header and a list
--- of input and output.
+-- | Construct transaction metadata for a pending transaction from the block
+-- header of the current tip and a list of input and output.
 --
 -- FIXME: There's a logic duplication regarding the calculation of the transaction
 -- amount between right here, and the Primitive.Model (see prefilterBlocks).
@@ -1774,8 +1776,9 @@ mkTxMeta
     -> s
     -> Tx
     -> CoinSelection
+    -> SlotNo
     -> m (UTCTime, TxMeta)
-mkTxMeta interpretTime blockHeader wState tx cs =
+mkTxMeta interpretTime blockHeader wState tx cs expiry =
     let
         amtOuts =
             sum (mapMaybe ourCoins (outputs cs))
@@ -1794,6 +1797,7 @@ mkTxMeta interpretTime blockHeader wState tx cs =
                 , slotNo = blockHeader ^. #slotNo
                 , blockHeight = blockHeader ^. #blockHeight
                 , amount = Quantity $ distance amtInps amtOuts
+                , expiry = Just expiry
                 }
             )
   where
@@ -1848,7 +1852,8 @@ submitExternalTx ctx bytes = do
     nw = ctx ^. networkLayer @t
     tl = ctx ^. transactionLayer @t @k
 
--- | Forget pending transaction.
+-- | Forget pending transaction. This happens at the request of the user and
+-- will remove the transaction from the history.
 forgetPendingTx
     :: forall ctx s k.
         ( HasDBLayer s k ctx

lib/core/src/Cardano/Wallet/Api/Server.hs

@@ -1330,9 +1330,11 @@ mkApiTransactionFromInfo ti (TransactionInfo txid ins outs ws meta depth txtime
         case meta ^. #status of
             Pending  -> #pendingSince
             InLedger -> #insertedAt
+            Expired  -> #expiresAt
     return $ case meta ^. #status of
         Pending  -> apiTx
         InLedger -> apiTx { depth = Just depth  }
+        Expired  -> apiTx
   where
       drop2nd (a,_,c) = (a,c)
 
@@ -1805,6 +1807,7 @@ mkApiTransaction ti txid ins outs ws (meta, timestamp) txMeta setTimeReference =
         , amount = meta ^. #amount
         , insertedAt = Nothing
         , pendingSince = Nothing
+        , expiresAt = Nothing
         , depth = Nothing
         , direction = ApiT (meta ^. #direction)
         , inputs = [ApiTxInput (fmap toAddressAmount o) (ApiT i) | (i, o) <- ins]

lib/core/src/Cardano/Wallet/Api/Types.hs

@@ -569,6 +569,7 @@ data ApiTransaction (n :: NetworkDiscriminant) = ApiTransaction
     , amount :: !(Quantity "lovelace" Natural)
     , insertedAt :: !(Maybe ApiTimeReference)
     , pendingSince :: !(Maybe ApiTimeReference)
+    , expiresAt :: !(Maybe ApiTimeReference)
     , depth :: !(Maybe (Quantity "block" Natural))
     , direction :: !(ApiT Direction)
     , inputs :: ![ApiTxInput n]

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

@@ -245,11 +245,18 @@ data DBLayer m s k = forall stm. (MonadIO stm, MonadFail stm) => DBLayer
         --
         -- If the wallet doesn't exist, this operation returns an error.
 
+    , updatePendingTx
+        :: PrimaryKey WalletId
+        -> SlotNo
+        -> ExceptT ErrNoSuchWallet stm ()
+        -- ^ Removes any expired transactions from the pending set and marks
+        -- their status as expired.
+
     , removePendingTx
         :: PrimaryKey WalletId
         -> Hash "Tx"
         -> ExceptT ErrRemovePendingTx stm ()
-        -- ^ Remove a pending transaction.
+        -- ^ Manually remove a pending transaction.
 
     , putPrivateKey
         :: PrimaryKey WalletId

lib/core/src/Cardano/Wallet/DB/MVar.hs

@@ -54,6 +54,7 @@ import Cardano.Wallet.DB.Model
     , mRemovePendingTx
     , mRemoveWallet
     , mRollbackTo
+    , mUpdatePendingTx
     )
 import Cardano.Wallet.Primitive.AddressDerivation
     ( Depth (..) )
@@ -174,6 +175,9 @@ newDBLayer timeInterpreter = do
                                        Pending Tx
         -----------------------------------------------------------------------}
 
+        , updatePendingTx = \pk tip -> ExceptT $ do
+            alterDB errNoSuchWallet db (mUpdatePendingTx pk tip)
+
         , removePendingTx = \pk tid -> ExceptT $ do
             alterDB errCannotRemovePendingTx db (mRemovePendingTx pk tid)
 

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

@@ -54,6 +54,7 @@ module Cardano.Wallet.DB.Model
     , mIsStakeKeyRegistered
     , mPutTxHistory
     , mReadTxHistory
+    , mUpdatePendingTx
     , mRemovePendingTx
     , mPutPrivateKey
     , mReadPrivateKey
@@ -260,6 +261,15 @@ mListCheckpoints wid db@(Database wallets _) =
   where
     tips = map currentTip . Map.elems . checkpoints
 
+mUpdatePendingTx :: Ord wid => wid -> SlotNo -> ModelOp wid s xprv ()
+mUpdatePendingTx wid currentTip = alterModel wid $ \wal ->
+    ((), wal { txHistory = setExpired <$> txHistory wal })
+  where
+    setExpired :: TxMeta -> TxMeta
+    setExpired txMeta
+        | expiry txMeta >= Just currentTip = txMeta { status = Expired }
+        | otherwise = txMeta
+
 mRemovePendingTx :: Ord wid => wid -> (Hash "Tx") -> ModelOp wid s xprv ()
 mRemovePendingTx wid tid db@(Database wallets txs) = case Map.lookup wid wallets of
     Nothing ->

lib/core/src/Cardano/Wallet/DB/Sqlite.hs

@@ -756,6 +756,13 @@ newDBLayer trace defaultFieldValues mDatabaseFile timeInterpreter = do
                 , (TxMetaStatus ==.) <$> status
                 ]
 
+        , updatePendingTx = \(PrimaryKey wid) tip -> ExceptT $ do
+            selectWallet wid >>= \case
+                Nothing -> pure $ Left $ ErrNoSuchWallet wid
+                Just _ -> do
+                  updatePendingTxQuery wid tip
+                  pure $ Right ()
+
         , removePendingTx = \(PrimaryKey wid) tid -> ExceptT $ do
             let errNoSuchWallet =
                     Left $ ErrRemovePendingTxNoSuchWallet $ ErrNoSuchWallet wid
@@ -1102,6 +1109,7 @@ mkTxMetaEntity wid txid meta derived = TxMeta
     , txMetaSlot = derived ^. #slotNo
     , txMetaBlockHeight = getQuantity (derived ^. #blockHeight)
     , txMetaAmount = getQuantity (derived ^. #amount)
+    , txMetaSlotExpires = derived ^. #expiry
     , txMetaData = meta
     }
 
@@ -1166,6 +1174,7 @@ txHistoryFromEntity ti tip metas ins outs ws =
         , W.slotNo = txMetaSlot m
         , W.blockHeight = Quantity (txMetaBlockHeight m)
         , W.amount = Quantity (txMetaAmount m)
+        , W.expiry = txMetaSlotExpires m
         }
 
 mkProtocolParametersEntity
@@ -1438,6 +1447,21 @@ deletePendingTx wid tid = do
         [ TxMetaWalletId ==. wid, TxMetaTxId ==. tid
         , TxMetaStatus ==. W.Pending ]
 
+-- Mutates all pending transaction entries which have exceeded their TTL so that
+-- their status becomes expired. Transaction expiry is not something which can
+-- be rolled back.
+updatePendingTxQuery
+    :: W.WalletId
+    -> W.SlotNo
+    -> SqlPersistT IO ()
+updatePendingTxQuery wid tip =
+    updateWhere isExpired [TxMetaStatus =. W.Expired]
+  where
+    isExpired =
+        [ TxMetaWalletId ==. wid
+        , TxMetaStatus ==. W.Pending
+        , TxMetaSlotExpires >=. Just tip ]
+
 selectPrivateKey
     :: (MonadIO m, PersistPrivateKey (k 'RootK))
     => W.WalletId

lib/core/src/Cardano/Wallet/DB/Sqlite/TH.hs

@@ -87,15 +87,20 @@ PrivateKey                             sql=private_key
 -- TxMeta is specific to a wallet because multiple wallets may have the same
 -- transaction with different metadata values. The associated inputs and outputs
 -- of the transaction are in the TxIn and TxOut tables.
+--
+-- Transactions with status=Pending have an expiry slot.
+-- If not accepted on the chain before the expiry slot they
+-- will be removed from the pending set and get status=Expired.
 TxMeta
-    txMetaTxId         TxId               sql=tx_id
-    txMetaWalletId     W.WalletId         sql=wallet_id
-    txMetaStatus       W.TxStatus         sql=status
-    txMetaDirection    W.Direction        sql=direction
-    txMetaSlot         SlotNo             sql=slot
-    txMetaBlockHeight  Word32             sql=block_height
-    txMetaAmount       Natural            sql=amount
-    txMetaData         W.TxMetadata Maybe sql=data
+    txMetaTxId              TxId                sql=tx_id
+    txMetaWalletId          W.WalletId          sql=wallet_id
+    txMetaStatus            W.TxStatus          sql=status
+    txMetaDirection         W.Direction         sql=direction
+    txMetaSlot              SlotNo              sql=slot
+    txMetaBlockHeight       Word32              sql=block_height
+    txMetaAmount            Natural             sql=amount
+    txMetaData              W.TxMetadata Maybe  sql=data
+    txMetaSlotExpires       SlotNo Maybe        sql=slot_expires
 
     Primary txMetaTxId txMetaWalletId
     Foreign Wallet fk_wallet_tx_meta txMetaWalletId ! ON DELETE CASCADE

lib/core/src/Cardano/Wallet/Primitive/Model.hs

@@ -385,6 +385,7 @@ prefilterBlock b u0 = runState $ do
         , slotNo = b ^. #header . #slotNo
         , blockHeight = b ^. #header . #blockHeight
         , amount = Quantity amt
+        , expiry = Nothing
         }
     applyTx
         :: (IsOurs s Address, IsOurs s ChimericAccount)

lib/core/src/Cardano/Wallet/Primitive/Types.hs

@@ -918,20 +918,23 @@ data TxMeta = TxMeta
     , slotNo :: !SlotNo
     , blockHeight :: !(Quantity "block" Word32)
     , amount :: !(Quantity "lovelace" Natural)
+    , expiry :: !(Maybe SlotNo)
     } deriving (Show, Eq, Ord, Generic)
 
 instance NFData TxMeta
 
 instance Buildable TxMeta where
-    build (TxMeta s d sl (Quantity bh) (Quantity a)) = mempty
+    build (TxMeta s d sl (Quantity bh) (Quantity a) mex) = mempty
         <> (case d of; Incoming -> "+"; Outgoing -> "-")
         <> fixedF @Double 6 (fromIntegral a / 1e6)
         <> " " <> build s
+        <> maybe mempty (\ex -> " expires " <> build ex) mex
         <> " since " <> build sl <> "#" <> build bh
 
 data TxStatus
     = Pending
     | InLedger
+    | Expired
     deriving (Show, Eq, Ord, Bounded, Enum, Generic)
 
 instance NFData TxStatus
@@ -980,7 +983,7 @@ newtype SealedTx = SealedTx { getSealedTx :: ByteString }
     deriving stock (Show, Eq, Generic)
     deriving newtype (ByteArrayAccess)
 
--- | True if the given tuple refers to a pending transaction
+-- | True if the given metadata refers to a pending transaction
 isPending :: TxMeta -> Bool
 isPending = (== Pending) . (status :: TxMeta -> TxStatus)
 

lib/core/src/Cardano/Wallet/Transaction.hs

@@ -59,7 +59,7 @@ data TransactionLayer t k = TransactionLayer
         -> CoinSelection
             -- A balanced coin selection where all change addresses have been
             -- assigned.
-        -> Either ErrMkTx (Tx, SealedTx)
+        -> Either ErrMkTx (Tx, SealedTx, SlotNo)
         -- ^ Construct a standard transaction
         --
         -- " Standard " here refers to the fact that we do not deal with redemption,
@@ -80,7 +80,7 @@ data TransactionLayer t k = TransactionLayer
         -> CoinSelection
             -- A balanced coin selection where all change addresses have been
             -- assigned.
-        -> Either ErrMkTx (Tx, SealedTx)
+        -> Either ErrMkTx (Tx, SealedTx, SlotNo)
         -- ^ Construct a transaction containing a certificate for delegating to
         -- a stake pool.
         --
@@ -98,7 +98,7 @@ data TransactionLayer t k = TransactionLayer
         -> CoinSelection
             -- A balanced coin selection where all change addresses have been
             -- assigned.
-        -> Either ErrMkTx (Tx, SealedTx)
+        -> Either ErrMkTx (Tx, SealedTx, SlotNo)
         -- ^ Construct a transaction containing a certificate for quiting from
         -- a stake pool.
         --

lib/core/test/bench/db/Main.hs

@@ -518,6 +518,7 @@ mkTxHistory numTx numInputs numOutputs range =
             , slotNo = sl i
             , blockHeight = Quantity $ fromIntegral i
             , amount = Quantity (fromIntegral numOutputs)
+            , expiry = Nothing
             }
         )
     | !i <- [1..numTx]

lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs

@@ -737,6 +737,7 @@ spec = do
                     , amount = amount (x :: ApiTransaction ('Testnet 0))
                     , insertedAt = insertedAt (x :: ApiTransaction ('Testnet 0))
                     , pendingSince = pendingSince (x :: ApiTransaction ('Testnet 0))
+                    , expiresAt = expiresAt (x :: ApiTransaction ('Testnet 0))
                     , depth = depth (x :: ApiTransaction ('Testnet 0))
                     , direction = direction (x :: ApiTransaction ('Testnet 0))
                     , inputs = inputs (x :: ApiTransaction ('Testnet 0))
@@ -1302,14 +1303,19 @@ instance Arbitrary (ApiTransaction t) where
         txInsertedAt <- case txStatus of
             (ApiT Pending) -> pure Nothing
             (ApiT InLedger) -> arbitrary
+            (ApiT Expired) -> pure Nothing
         txPendingSince <- case txStatus of
             (ApiT Pending) -> arbitrary
             (ApiT InLedger) -> pure Nothing
+            (ApiT Expired) -> arbitrary
+        let txExpiresAt = txInsertedAt
+
         ApiTransaction
             <$> arbitrary
             <*> arbitrary
             <*> pure txInsertedAt
             <*> pure txPendingSince
+            <*> pure txExpiresAt
             <*> arbitrary
             <*> arbitrary
             <*> genInputs

lib/core/test/unit/Cardano/Wallet/DB/Arbitrary.hs

@@ -410,6 +410,7 @@ instance Arbitrary TxMeta where
         <*> arbitrary
         <*> fmap Quantity arbitrary
         <*> fmap (Quantity . fromIntegral) (arbitrary @Word32)
+        <*> arbitrary
 
 instance Arbitrary TxStatus where
     arbitrary = elements [Pending, InLedger]

lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs

@@ -859,7 +859,7 @@ testTxs =
         [ TxOut (Address "addr") (Coin 1) ]
         mempty
         Nothing
-      , TxMeta InLedger Incoming (SlotNo 140) (Quantity 0) (Quantity 1337144)
+      , TxMeta InLedger Incoming (SlotNo 140) (Quantity 0) (Quantity 1337144) Nothing
       )
     ]