wip Add transaction expiry slot for pending transactions

lib/core/src/Cardano/Wallet.hs

@@ -277,6 +277,7 @@ import Cardano.Wallet.Primitive.Types
     , IsDelegatingTo (..)
     , NetworkParameters (..)
     , PassphraseScheme (..)
+    , PendingTx
     , PoolId (..)
     , PoolLifeCycleStatus (..)
     , ProtocolParameters (..)
@@ -300,6 +301,7 @@ import Cardano.Wallet.Primitive.Types
     , computeUtxoStatistics
     , dlgCertPoolId
     , fromTransactionInfo
+    , fromTransactionInfoPending
     , log10
     , wholeRange
     , withdrawals
@@ -622,13 +624,13 @@ readWallet
     :: forall ctx s k. HasDBLayer s k ctx
     => ctx
     -> WalletId
-    -> ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set Tx)
+    -> ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set PendingTx)
 readWallet ctx wid = db & \DBLayer{..} -> mapExceptT atomically $ do
     let pk = PrimaryKey wid
     cp <- withNoSuchWallet wid $ readCheckpoint pk
     meta <- withNoSuchWallet wid $ readWalletMeta pk
     pending <- lift $ readTxHistory pk Nothing Descending wholeRange (Just Pending)
-    pure (cp, meta, Set.fromList (fromTransactionInfo <$> pending))
+    pure (cp, meta, Set.fromList (fromTransactionInfoPending <$> pending))
   where
     db = ctx ^. dbLayer @s @k
 

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

@@ -224,10 +224,9 @@ data DBLayer m s k = forall stm. (MonadIO stm, MonadFail stm) => DBLayer
         -> Maybe (Quantity "lovelace" Natural)
         -> SortOrder
         -> Range SlotNo
-        -> Maybe TxStatus
         -> stm [TransactionInfo]
         -- ^ Fetch the current transaction history of a known wallet, ordered by
-        -- descending slot number.
+        -- slot number.
         --
         -- Returns an empty list if the wallet isn't found.
 
@@ -240,6 +239,16 @@ data DBLayer m s k = forall stm. (MonadIO stm, MonadFail stm) => DBLayer
         --
         -- If the wallet doesn't exist, this operation returns an error.
 
+    , readTxPending
+        :: PrimaryKey WalletId
+        -> SortOrder
+        -> Range SlotId
+        -> stm [TransactionInfo]
+        -- ^ Fetch the current transaction history of a known wallet, ordered by
+        -- slot number first submitted.
+        --
+        -- Returns an empty list if the wallet isn't found.
+
     , removePendingTx
         :: PrimaryKey WalletId
         -> Hash "Tx"

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

@@ -81,6 +81,7 @@ import Cardano.Wallet.DB.Sqlite.TH
     , TxIn (..)
     , TxMeta (..)
     , TxOut (..)
+    , TxPending (..)
     , TxWithdrawal (..)
     , UTxO (..)
     , Wallet (..)
@@ -625,16 +626,14 @@ newDBLayer trace defaultFieldValues mDatabaseFile timeInterpreter = do
                     deleteDelegationCertificates wid
                         [ CertSlot >. nearestPoint
                         ]
-                    updateTxMetas wid
-                        [ TxMetaDirection ==. W.Outgoing
-                        , TxMetaSlot >. nearestPoint
+                    deleteTxMetas wid
+                        [ TxMetaSlot >. nearestPoint
                         ]
-                        [ TxMetaStatus =. W.Pending
-                        , TxMetaSlot =. nearestPoint
+                    updateWhere
+                        [ TxPendingWalletId ==. wid
+                        , TxPendingAccepted >. Just nearestPoint
                         ]
-                    deleteTxMetas wid
-                        [ TxMetaDirection ==. W.Incoming
-                        , TxMetaSlot >. nearestPoint
+                        [ TxPendingAccepted =. Nothing
                         ]
                     deleteStakeKeyCerts wid
                         [ StakeKeyCertSlot >. nearestPoint
@@ -714,12 +713,16 @@ newDBLayer trace defaultFieldValues mDatabaseFile timeInterpreter = do
                     putTxs txins txouts txws
                     pure $ Right ()
 
-        , readTxHistory = \(PrimaryKey wid) minWithdrawal order range status -> do
-            selectTxHistory
-                timeInterpreter wid minWithdrawal order $ catMaybes
+        , readTxHistory = \(PrimaryKey wid) minWithdrawal order range -> do
+            selectTxHistory timeInterpreter wid minWithdrawal order $ catMaybes
                 [ (TxMetaSlot >=.) <$> W.inclusiveLowerBound range
                 , (TxMetaSlot <=.) <$> W.inclusiveUpperBound range
-                , (TxMetaStatus ==.) <$> status
+                ]
+
+        , readTxPending = \(PrimaryKey wid) order range -> do
+            selectTxPending wid order $ catMaybes
+                [ (TxPendingSlotCreated >=.) <$> W.inclusiveLowerBound range
+                , (TxPendingSlotCreated <=.) <$> W.inclusiveUpperBound range
                 ]
 
         , removePendingTx = \(PrimaryKey wid) tid -> ExceptT $ do
@@ -732,14 +735,13 @@ newDBLayer trace defaultFieldValues mDatabaseFile timeInterpreter = do
             selectWallet wid >>= \case
                 Nothing -> pure errNoSuchWallet
                 Just _  -> do
-                    metas <- selectPendingTxs wid (TxId tid)
-                    let isPending meta = txMetaStatus meta == W.Pending
-                    case metas of
-                        [] -> pure errNoSuchTransaction
-                        txs | any isPending txs -> do
-                            deletePendingTx wid (TxId tid)
-                            pure $ Right ()
-                        _ -> pure errNoMorePending
+                    txs <- selectPendingTxs wid (TxId tid)
+                    deletePendingTx wid (TxId tid)
+                    pure $ case txs of
+                        [] -> errNoSuchTransaction
+                        txs | all (isJust . txPendingAccepted) txs ->
+                              errNoMorePending
+                        _ -> Right ()
 
         , getTx = \(PrimaryKey wid) tid -> ExceptT $ do
             selectWallet wid >>= \case
@@ -748,7 +750,9 @@ newDBLayer trace defaultFieldValues mDatabaseFile timeInterpreter = do
                     metas <- selectTxHistory
                         timeInterpreter wid Nothing W.Descending
                             [ TxMetaTxId ==. (TxId tid) ]
-                    case metas of
+                    pendings <- selectTxPending wid W.Descending
+                            [ TxPendingTxId ==. (TxId tid) ]
+                    case metas ++ pendings of
                         [] -> pure (Right Nothing)
                         meta:_ -> pure (Right $ Just meta)
 
@@ -1058,7 +1062,6 @@ mkTxMetaEntity :: W.WalletId -> W.Hash "Tx" -> W.TxMeta -> TxMeta
 mkTxMetaEntity wid txid meta = TxMeta
     { txMetaTxId = TxId txid
     , txMetaWalletId = wid
-    , txMetaStatus = meta ^. #status
     , txMetaDirection = meta ^. #direction
     , txMetaSlot = meta ^. #slotNo
     , txMetaBlockHeight = getQuantity (meta ^. #blockHeight)
@@ -1125,6 +1128,60 @@ txHistoryFromEntity ti tip metas ins outs ws =
         , W.amount = Quantity (txMetaAmount m)
         }
 
+txHistoryFromPendingEntity
+    :: W.SlotParameters
+    -> W.BlockHeader
+    -> [TxPending]
+    -> [(TxIn, Maybe TxOut)]
+    -> [TxOut]
+    -> [W.TransactionInfo]
+txHistoryFromPendingEntity sp tip pendings ins outs =
+    map mkItem pendings
+  where
+    mkItem m = mkTxWith (txMetaTxId m) (mkTxMeta m)
+    mkTxWith txid meta = W.TransactionInfo
+        { W.txInfoId =
+            getTxId txid
+        , W.txInfoInputs =
+            map mkTxIn $ filter ((== txid) . txInputTxId . fst) ins
+        , W.txInfoOutputs =
+            map mkTxOut $ filter ((== txid) . txOutputTxId) outs
+        , W.txInfoWithdrawals =
+            Map.fromList $ map mkTxWithdrawal $ filter ((== txid) . txWithdrawalTxId) ws
+        , W.txInfoMeta =
+            meta
+        , W.txInfoDepth =
+            Quantity $ fromIntegral $ if tipH > txH then tipH - txH else 0
+        , W.txInfoTime =
+            W.slotStartTime sp (meta ^. #slotId)
+        }
+      where
+        txH  = getQuantity (meta ^. #blockHeight)
+        tipH = getQuantity (tip ^. #blockHeight)
+    mkTxIn (tx, out) =
+        ( W.TxIn
+            { W.inputId = getTxId (txInputSourceTxId tx)
+            , W.inputIx = txInputSourceIndex tx
+            }
+        , txInputSourceAmount tx
+        , mkTxOut <$> out
+        )
+    mkTxOut tx = W.TxOut
+        { W.address = txOutputAddress tx
+        , W.coin = txOutputAmount tx
+        }
+    mkTxWithdrawal w =
+        ( txWithdrawalAccount w
+        , txWithdrawalAmount w
+        )
+    mkTxMeta m = W.TxMeta
+        { W.status = txMetaStatus m
+        , W.direction = txMetaDirection m
+        , W.slotId = txMetaSlot m
+        , W.blockHeight = Quantity (txMetaBlockHeight m)
+        , W.amount = Quantity (txMetaAmount m)
+        }
+
 mkProtocolParametersEntity
     :: W.WalletId
     -> W.ProtocolParameters
@@ -1208,14 +1265,6 @@ deleteStakeKeyCerts
 deleteStakeKeyCerts wid filters =
     deleteWhere ((StakeKeyCertWalletId ==. wid) : filters)
 
-updateTxMetas
-    :: W.WalletId
-    -> [Filter TxMeta]
-    -> [Update TxMeta]
-    -> SqlPersistT IO ()
-updateTxMetas wid filters =
-    updateWhere ((TxMetaWalletId ==. wid) : filters)
-
 -- | Add new TxMeta rows, overwriting existing ones.
 putTxMetas :: [TxMeta] -> SqlPersistT IO ()
 putTxMetas metas = dbChunked repsertMany
@@ -1376,20 +1425,48 @@ selectTxHistory ti wid minWithdrawal order conditions = do
         W.Ascending -> [Asc TxMetaSlot, Desc TxMetaTxId]
         W.Descending -> [Desc TxMetaSlot, Asc TxMetaTxId]
 
+selectTxPending
+    :: W.WalletId
+    -> W.SortOrder
+    -> [Filter TxPending]
+    -> SqlPersistT IO [W.TransactionInfo]
+selectTxPending wid order conditions = do
+    selectLatestCheckpoint wid >>= \case
+        Nothing -> pure []
+        Just cp -> do
+            pendings <- fmap entityVal <$> selectList
+                ((TxPendingWalletId ==. wid):conditions)
+                sortOpt
+
+            let txids = map txPendingTxId pendings
+            (ins, outs, _) <- selectTxs txids
+
+            let wal = checkpointFromEntity cp [] ()
+            let tip = W.currentTip wal
+            let slp = W.slotParams $ W.blockchainParameters wal
+
+            return $ txHistoryFromEntity slp tip pendings ins outs
+  where
+    -- Note: The secondary sort by TxId is to make the ordering stable
+    -- so that testing with random data always works.
+    sortOpt = case order of
+        W.Ascending -> [Asc TxPendingSlotCreated, Desc TxPendingTxId]
+        W.Descending -> [Desc TxPendingSlotCreated, Asc TxPendingTxId]
+
 selectPendingTxs
     :: W.WalletId
     -> TxId
-    -> SqlPersistT IO [TxMeta]
+    -> SqlPersistT IO [TxPending]
 selectPendingTxs wid tid =
     fmap entityVal <$> selectList
-        [TxMetaWalletId ==. wid, TxMetaTxId ==. tid] []
+        [TxPendingWalletId ==. wid, TxPendingTxId ==. tid] []
 
 deletePendingTx
     :: W.WalletId
     -> TxId
     -> SqlPersistT IO ()
 deletePendingTx wid tid = deleteWhere
-    [TxMetaWalletId ==. wid, TxMetaTxId ==. tid, TxMetaStatus ==. W.Pending ]
+    [TxPendingWalletId ==. wid, TxPendingTxId ==. tid]
 
 selectPrivateKey
     :: (MonadIO m, PersistPrivateKey (k 'RootK))

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

@@ -90,7 +90,6 @@ PrivateKey                             sql=private_key
 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
@@ -100,7 +99,26 @@ TxMeta
     Foreign Wallet fk_wallet_tx_meta txMetaWalletId ! ON DELETE CASCADE
     deriving Show Generic
 
--- A transaction input associated with TxMeta.
+-- Metadata for a transaction which has been submitted but has
+-- not yet appeared in a stable block of the ledger.
+--
+-- A transaction is removed from the wallet pending set once
+-- it appears in the ledger -- i.e. txPendingAccepted is not
+-- Nothing. However, it is not removed from this table until
+-- it can never be rolled back.
+TxPending
+    txPendingTxId          TxId            sql=tx_id
+    txPendingWalletId      W.WalletId      sql=wallet_id
+    txPendingAmount        Natural         sql=amount
+    txPendingSlotCreated   W.SlotId        sql=slot_created
+    txPendingSlotExpires   W.SlotId        sql=slot_expires
+    txPendingSlotAccepted  W.SlotId Maybe  sql=slot_accepted
+
+    Primary txPendingTxId txPendingWalletId
+    Foreign Wallet fk_wallet_pending_tx txPendingWalletId ! ON DELETE CASCADE
+    deriving Show Generic
+
+-- A transaction input associated with TxMeta or TxPending.
 --
 -- There is no wallet ID because these values depend only on the transaction,
 -- not the wallet. txInputTxId is referred to by TxMeta
@@ -114,7 +132,7 @@ TxIn
     Primary txInputTxId txInputSourceTxId txInputSourceIndex
     deriving Show Generic
 
--- A transaction output associated with TxMeta.
+-- A transaction output associated with TxMeta or TxPending.
 --
 -- There is no wallet ID because these values depend only on the transaction,
 -- not the wallet. txOutputTxId is referred to by TxMeta

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

@@ -65,6 +65,7 @@ import Cardano.Wallet.Primitive.Types
     , Direction (..)
     , Dom (..)
     , GenesisParameters (..)
+    , PendingTx (..)
     , Tx (..)
     , TxIn (..)
     , TxMeta (..)
@@ -285,14 +286,17 @@ applyBlocks (block0 :| blocks) cp =
 -------------------------------------------------------------------------------}
 
 -- | Available balance = 'balance' . 'availableUTxO'
-availableBalance :: Set Tx -> Wallet s -> Natural
+--
+-- fixme: not sure whether to "infect" this module with PendingTx.
+-- Maybe better to extract 'pendingTx' before calling these functions.
+availableBalance :: Set PendingTx -> Wallet s -> Natural
 availableBalance pending =
     balance . availableUTxO pending
 
 -- | Total balance = 'balance' . 'totalUTxO' +? rewards
 totalBalance
     :: (IsOurs s Address, IsOurs s ChimericAccount)
-    => Set Tx
+    => Set PendingTx
     -> Quantity "lovelace" Natural
     -> Wallet s
     -> Natural
@@ -309,16 +313,16 @@ totalBalance pending (Quantity rewards) s =
 
 -- | Available UTxO = @pending ⋪ utxo@
 availableUTxO
-    :: Set Tx
+    :: Set PendingTx
     -> Wallet s
     -> UTxO
 availableUTxO pending (Wallet u _ _ _) =
-    u  `excluding` txIns pending
+    u  `excluding` txIns (Set.map pendingTx pending)
 
 -- | Total UTxO = 'availableUTxO' @<>@ 'changeUTxO'
 totalUTxO
     :: IsOurs s Address
-    => Set Tx
+    => Set PendingTx
     -> Wallet s
     -> UTxO
 totalUTxO pending wallet@(Wallet _ _ s _) =
@@ -418,11 +422,11 @@ prefilterBlock b u0 = runState $ do
 -- therefore use in a read-only mode here.
 changeUTxO
     :: IsOurs s Address
-    => Set Tx
+    => Set PendingTx
     -> s
     -> UTxO
 changeUTxO pending = evalState $
-    mconcat <$> mapM (state . utxoOurs) (Set.toList pending)
+    mconcat <$> mapM (state . utxoOurs . pendingTx) (Set.toList pending)
 
 -- | Construct our _next_ UTxO (possible empty) from a transaction by selecting
 -- outputs that are ours. It is important for the transaction outputs to be