Try #1879:

lib/core-integration/src/Test/Integration/Framework/DSL.hs

@@ -167,6 +167,7 @@ import Cardano.Wallet.Api.Types
     , ApiNetworkInformation
     , ApiNetworkParameters (..)
     , ApiT (..)
+    , ApiTimeReference (..)
     , ApiTransaction
     , ApiTxId (ApiTxId)
     , ApiUtxoStatistics (..)
@@ -180,7 +181,6 @@ import Cardano.Wallet.Api.Types
     , Iso8601Time (..)
     , WalletStyle (..)
     , insertedAt
-    , time
     )
 import Cardano.Wallet.Primitive.AddressDerivation
     ( AccountingStyle (..)

lib/core-integration/src/Test/Integration/Scenario/API/Shelley/Transactions.hs

@@ -25,6 +25,7 @@ import Cardano.Wallet.Api.Types
     , ApiByronWallet
     , ApiFee (..)
     , ApiT (..)
+    , ApiTimeReference (..)
     , ApiTransaction
     , ApiTxId (..)
     , ApiWallet
@@ -34,7 +35,6 @@ import Cardano.Wallet.Api.Types
     , WalletStyle (..)
     , insertedAt
     , pendingSince
-    , time
     )
 import Cardano.Wallet.Primitive.AddressDerivation
     ( PaymentAddress )
@@ -43,6 +43,7 @@ import Cardano.Wallet.Primitive.AddressDerivation.Icarus
 import Cardano.Wallet.Primitive.Types
     ( Direction (..)
     , Hash (..)
+    , SlotNo (SlotNo)
     , SortOrder (..)
     , TxMetadata (..)
     , TxMetadataValue (..)
@@ -593,6 +594,36 @@ spec = describe "SHELLEY_TRANSACTIONS" $ do
                 (#balance . #available)
                 (`shouldBe` Quantity (faucetAmt - feeEstMax - amt)) ra2
 
+    it "TRANS_CREATE_10 - Pending transaction expiry" $ \ctx -> do
+        (wa, wb) <- (,) <$> fixtureWallet ctx <*> fixtureWallet ctx
+        let amt = minUTxOValue :: Natural
+
+        payload <- mkTxPayload ctx wb amt fixturePassphrase
+
+        r <- request @(ApiTransaction n) ctx
+            (Link.createTransaction @'Shelley wa) Default payload
+
+        verify r
+            [ expectSuccess
+            , expectResponseCode HTTP.status202
+            , expectField (#direction . #getApiT) (`shouldBe` Outgoing)
+            , expectField (#status . #getApiT) (`shouldBe` Pending)
+            , expectField #expiresAt (`shouldSatisfy` isJust)
+            ]
+
+        -- This stuff would be easier with Control.Lens...
+
+        -- Get insertion slot and out of response.
+        let (_, Right apiTx) = r
+        let (Just (ApiTimeReference _ sinceBlock)) = apiTx ^. #pendingSince
+        let sl = sinceBlock ^. #absoluteSlotNumber . #getApiT
+
+        -- The expected expiry slot (adds the hardcoded default ttl)
+        let ttl = sl + SlotNo 7200
+
+        (view #absoluteSlotNumber <$> (apiTx ^. #expiresAt))
+            `shouldBe` Just (ApiT ttl)
+
     it "TRANSMETA_CREATE_01 - Transaction with metadata" $ \ctx -> do
         (wa, wb) <- (,) <$> fixtureWallet ctx <*> emptyWallet ctx
         let amt = (minUTxOValue :: Natural)
@@ -1394,7 +1425,7 @@ spec = describe "SHELLEY_TRANSACTIONS" $ do
                 , replicate 10 (2 * minUTxOValue)
                 ]
         txs <- listAllTransactions @n ctx w
-        let [Just t2, Just t1] = fmap (fmap time . insertedAt) txs
+        let [Just t2, Just t1] = fmap (fmap (view #time) . insertedAt) txs
         let matrix :: [TestCase [ApiTransaction n]] =
                 [ TestCase -- 1
                     { query = toQueryString
@@ -2412,7 +2443,7 @@ spec = describe "SHELLEY_TRANSACTIONS" $ do
         :: [ApiTransaction n]
         -> UTCTime
     unsafeGetTransactionTime txs =
-        case fmap time . insertedAt <$> txs of
+        case fmap (view #time) . insertedAt <$> txs of
             (Just t):_ -> t
             _ -> error "Expected at least one transaction with a time."
 

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

@@ -176,6 +176,7 @@ import Cardano.Wallet.Api.Types
     , ApiPostRandomAddressData (..)
     , ApiPutAddressesData (..)
     , ApiSelectCoinsData (..)
+    , ApiSlotReference (..)
     , ApiT (..)
     , ApiTimeReference (..)
     , ApiTransaction (..)
@@ -1332,9 +1333,11 @@ mkApiTransactionFromInfo ti (TransactionInfo txid ins outs ws meta depth txtime
         case meta ^. #status of
             Pending  -> #pendingSince
             InLedger -> #insertedAt
+            Expired  -> #pendingSince
     return $ case meta ^. #status of
         Pending  -> apiTx
         InLedger -> apiTx { depth = Just depth  }
+        Expired  -> apiTx
   where
       drop2nd (a,_,c) = (a,c)
 
@@ -1801,14 +1804,16 @@ mkApiTransaction
     -> m (ApiTransaction n)
 mkApiTransaction ti txid ins outs ws (meta, timestamp) txMeta setTimeReference = do
     timeRef <- timeReference
-    return $ tx & setTimeReference .~ Just timeRef
+    expRef <- expirySlotReference
+    return $ tx & setTimeReference .~ Just timeRef & #expiresAt .~ expRef
   where
     tx :: ApiTransaction n
     tx = ApiTransaction
         { id = ApiT txid
         , 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]
@@ -1836,6 +1841,16 @@ mkApiTransaction ti txid ins outs ws (meta, timestamp) txMeta setTimeReference =
                     , absoluteSlotNumber = ApiT $ meta ^. #slotNo
                     }
 
+    expirySlotReference :: m (Maybe ApiSlotReference)
+    expirySlotReference = case meta ^. #expiry of
+        Just expirySlot -> do
+            expiryTimestamp <- ti (startTime expirySlot)
+            pure $ Just $ ApiSlotReference
+                { time = expiryTimestamp
+                , absoluteSlotNumber = ApiT expirySlot
+                }
+        Nothing -> pure Nothing
+
     toAddressAmount :: TxOut -> AddressAmount (ApiT Address, Proxy n)
     toAddressAmount (TxOut addr c) =
         AddressAmount (ApiT addr, Proxy @n) (mkApiCoin c)

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

@@ -80,6 +80,7 @@ module Cardano.Wallet.Api.Types
     , NtpSyncingStatus (..)
     , ApiNetworkClock (..)
     , ApiBlockReference (..)
+    , ApiSlotReference (..)
     , ApiNetworkTip (..)
     , Iso8601Time (..)
     , MinWithdrawal (..)
@@ -606,6 +607,7 @@ data ApiTransaction (n :: NetworkDiscriminant) = ApiTransaction
     , amount :: !(Quantity "lovelace" Natural)
     , insertedAt :: !(Maybe ApiTimeReference)
     , pendingSince :: !(Maybe ApiTimeReference)
+    , expiresAt :: !(Maybe ApiSlotReference)
     , depth :: !(Maybe (Quantity "block" Natural))
     , direction :: !(ApiT Direction)
     , inputs :: ![ApiTxInput n]
@@ -663,6 +665,11 @@ data ApiBlockReference = ApiBlockReference
     , absoluteSlotNumber :: !(ApiT SlotNo)
     } deriving (Eq, Generic, Show)
 
+data ApiSlotReference = ApiSlotReference
+    { time :: !UTCTime
+    , absoluteSlotNumber :: !(ApiT SlotNo)
+    } deriving (Eq, Generic, Show)
+
 data ApiNetworkTip = ApiNetworkTip
     { epochNumber :: !(ApiT EpochNo)
     , slotNumber :: !(ApiT SlotInEpoch)
@@ -1300,6 +1307,11 @@ instance FromJSON ApiBlockReference where
 instance ToJSON ApiBlockReference where
     toJSON = genericToJSON defaultRecordTypeOptions
 
+instance FromJSON ApiSlotReference where
+    parseJSON = genericParseJSON defaultRecordTypeOptions
+instance ToJSON ApiSlotReference where
+    toJSON = genericToJSON defaultRecordTypeOptions
+
 instance FromJSON (ApiT EpochNo) where
     parseJSON = fmap (ApiT . unsafeEpochNo) . parseJSON
 instance ToJSON (ApiT EpochNo) where

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

@@ -812,6 +812,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
@@ -1158,6 +1165,7 @@ mkTxMetaEntity wid txid meta derived = TxMeta
     , txMetaSlot = derived ^. #slotNo
     , txMetaBlockHeight = getQuantity (derived ^. #blockHeight)
     , txMetaAmount = getQuantity (derived ^. #amount)
+    , txMetaSlotExpires = derived ^. #expiry
     , txMetaData = meta
     }
 
@@ -1222,6 +1230,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
@@ -1483,6 +1492,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