Merge #2262 #2282

2262: Allow deleting expired transactions from the API r=rvl a=rvl ### Issue Number ADP-93 / #1840 ### Overview - [x] Using the existing transaction delete endpoint, also permit removing expired transactions. - [x] Simplify DB model and state machine tests for this function - [x] Integration test ### Comments - Based on PR #2167 branch - merge that first. 2282: Increase bors timeout from 2h to 3h r=Anviking a=Anviking # Issue Number #2279 # Overview  - [x] Increase bors timeout from 2h to 3h # Comments It seems hydra is often slow to schedule/run the jobs, causing ≈18% of bors r+ to fail. It should be better to increase the timeout to 3h, than to have it fail. This doesn't affect the timeout of buildkite or hydra themselves.   Co-authored-by: Rodney Lorrimar <[email protected]> Co-authored-by: Johannes Lund <[email protected]>
cardano-foundation · Nov 2, 2020 · 35d3cea · 35d3cea
3 parents 9c56a88 + 737ffd3 + bc9e214
commit 35d3cea
Show file tree

Hide file tree

Showing 11 changed files with 166 additions and 111 deletions.
diff --git a/bors.toml b/bors.toml
@@ -2,6 +2,6 @@ status = [
   "buildkite/cardano-wallet",
   "ci/hydra-build:required",
 ]
-timeout_sec = 7200
+timeout_sec = 10800
 required_approvals = 1
 delete_merged_branches = false
diff --git a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/Transactions.hs b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/Transactions.hs
@@ -2186,6 +2186,45 @@ spec = describe "SHELLEY_TRANSACTIONS" $ do
         txDeleteFromDifferentWalletTest emptyWallet "wallets"
         txDeleteFromDifferentWalletTest emptyRandomWallet "byron-wallets"
 
+    it "TRANS_TTL_DELETE_01 - Shelley: can remove expired tx" $ \ctx -> do
+        (wa, wb) <- (,) <$> fixtureWallet ctx <*> emptyWallet ctx
+        let amt = minUTxOValue :: Natural
+
+        -- this transaction is going to expire really soon.
+        basePayload <- mkTxPayload ctx wb amt fixturePassphrase
+        let payload = addTxTTL 0.1 basePayload
+
+        ra <- request @(ApiTransaction n) ctx
+            (Link.createTransaction @'Shelley wa) Default payload
+
+        expectSuccess ra
+
+        let txid = ApiTxId (getFromResponse #id ra)
+        let linkSrc = Link.getTransaction @'Shelley wa txid
+
+        rb <- eventually "transaction is no longer pending" $ do
+            rr <- request @(ApiTransaction n) ctx linkSrc Default Empty
+            verify rr
+                [ expectSuccess
+                , expectField (#status . #getApiT) (`shouldNotBe` Pending)
+                ]
+            pure rr
+
+        -- it should be expired
+        expectField (#status . #getApiT) (`shouldBe` Expired) rb
+
+        -- remove it
+        let linkDel = Link.deleteTransaction @'Shelley wa txid
+        request @(ApiTransaction n) ctx linkDel Default Empty
+            >>= expectResponseCode @IO HTTP.status204
+
+        -- it should be gone
+        request @(ApiTransaction n) ctx linkSrc Default Empty
+            >>= expectResponseCode @IO HTTP.status404
+        -- yes, gone
+        request @(ApiTransaction n) ctx linkDel Default Empty
+            >>= expectResponseCode @IO HTTP.status404
+
     it "BYRON_TRANS_DELETE -\
         \ Cannot delete tx on Byron wallet using shelley ep" $ \ctx -> do
             w <- emptyRandomWallet ctx

diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs
@@ -146,7 +146,7 @@ module Cardano.Wallet
     , handleCannotCover
 
     -- ** Transaction
-    , forgetPendingTx
+    , forgetTx
     , listTransactions
     , getTransaction
     , submitExternalTx
@@ -155,7 +155,7 @@ module Cardano.Wallet
     , ErrMkTx (..)
     , ErrSubmitTx (..)
     , ErrSubmitExternalTx (..)
-    , ErrRemovePendingTx (..)
+    , ErrRemoveTx (..)
     , ErrPostTx (..)
     , ErrDecodeSignedTx (..)
     , ErrListTransactions (..)
@@ -198,7 +198,7 @@ import Cardano.Slotting.Slot
 import Cardano.Wallet.DB
     ( DBLayer (..)
     , ErrNoSuchWallet (..)
-    , ErrRemovePendingTx (..)
+    , ErrRemoveTx (..)
     , ErrWalletAlreadyExists (..)
     , PrimaryKey (..)
     , SparseCheckpointsConfig (..)
@@ -1945,18 +1945,22 @@ submitExternalTx ctx bytes = do
     nw = ctx ^. networkLayer @t
     tl = ctx ^. transactionLayer @t @k
 
--- | Forget pending transaction. This happens at the request of the user and
--- will remove the transaction from the history.
-forgetPendingTx
+-- | Remove a pending or expired transaction from the transaction history. This
+-- happens at the request of the user. If the transaction is already on chain,
+-- or is missing from the transaction history, an error will be returned.
+--
+-- If a 'Pending' transaction is removed, but later appears in a block, it will
+-- be added back to the transaction history.
+forgetTx
     :: forall ctx s k.
         ( HasDBLayer s k ctx
         )
     => ctx
     -> WalletId
     -> Hash "Tx"
-    -> ExceptT ErrRemovePendingTx IO ()
-forgetPendingTx ctx wid tid = db & \DBLayer{..} -> do
-    mapExceptT atomically $ removePendingTx (PrimaryKey wid) tid
+    -> ExceptT ErrRemoveTx IO ()
+forgetTx ctx wid tid = db & \DBLayer{..} -> do
+    mapExceptT atomically $ removePendingOrExpiredTx (PrimaryKey wid) tid
   where
     db = ctx ^. dbLayer @s @k
 

diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs
@@ -125,7 +125,7 @@ import Cardano.Wallet
     , ErrPostTx (..)
     , ErrQuitStakePool (..)
     , ErrReadChimericAccount (..)
-    , ErrRemovePendingTx (..)
+    , ErrRemoveTx (..)
     , ErrSelectCoinsExternal (..)
     , ErrSelectForDelegation (..)
     , ErrSelectForMigration (..)
@@ -1386,7 +1386,7 @@ deleteTransaction
     -> Handler NoContent
 deleteTransaction ctx (ApiT wid) (ApiTxId (ApiT (tid))) = do
     withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $
-        W.forgetPendingTx wrk wid tid
+        W.forgetTx wrk wid tid
     return NoContent
 
 listTransactions
@@ -2491,18 +2491,18 @@ instance LiftHandler ErrSubmitExternalTx where
             , errReasonPhrase = errReasonPhrase err400
             }
 
-instance LiftHandler ErrRemovePendingTx where
+instance LiftHandler ErrRemoveTx where
     handler = \case
-        ErrRemovePendingTxNoSuchWallet wid -> handler wid
-        ErrRemovePendingTxNoSuchTransaction tid ->
+        ErrRemoveTxNoSuchWallet wid -> handler wid
+        ErrRemoveTxNoSuchTransaction tid ->
             apiError err404 NoSuchTransaction $ mconcat
                 [ "I couldn't find a transaction with the given id: "
                 , toText tid
                 ]
-        ErrRemovePendingTxTransactionNoMorePending tid ->
-            apiError err403 TransactionNotPending $ mconcat
+        ErrRemoveTxAlreadyInLedger tid ->
+            apiError err403 TransactionAlreadyInLedger $ mconcat
                 [ "The transaction with id: ", toText tid,
-                  " cannot be forgotten as it is not pending anymore."
+                  " cannot be forgotten as it is already in the ledger."
                 ]
 
 instance LiftHandler ErrPostTx where

diff --git a/lib/core/src/Cardano/Wallet/Api/Types.hs b/lib/core/src/Cardano/Wallet/Api/Types.hs
@@ -776,7 +776,7 @@ newtype ApiVerificationKey = ApiVerificationKey
 data ApiErrorCode
     = NoSuchWallet
     | NoSuchTransaction
-    | TransactionNotPending
+    | TransactionAlreadyInLedger
     | WalletAlreadyExists
     | NoRootKey
     | WrongEncryptionPassphrase

diff --git a/lib/core/src/Cardano/Wallet/DB.hs b/lib/core/src/Cardano/Wallet/DB.hs
@@ -27,7 +27,7 @@ module Cardano.Wallet.DB
     , gapSize
 
       -- * Errors
-    , ErrRemovePendingTx (..)
+    , ErrRemoveTx (..)
     , ErrNoSuchWallet(..)
     , ErrWalletAlreadyExists(..)
     ) where
@@ -252,10 +252,10 @@ data DBLayer m s k = forall stm. (MonadIO stm, MonadFail stm) => DBLayer
         -- ^ Removes any expired transactions from the pending set and marks
         -- their status as expired.
 
-    , removePendingTx
+    , removePendingOrExpiredTx
         :: PrimaryKey WalletId
         -> Hash "Tx"
-        -> ExceptT ErrRemovePendingTx stm ()
+        -> ExceptT ErrRemoveTx stm ()
         -- ^ Manually remove a pending transaction.
 
     , putPrivateKey
@@ -310,11 +310,11 @@ newtype ErrNoSuchWallet
     = ErrNoSuchWallet WalletId -- Wallet is gone or doesn't exist yet
     deriving (Eq, Show)
 
--- | Can't perform removing pending transaction
-data ErrRemovePendingTx
-    = ErrRemovePendingTxNoSuchWallet ErrNoSuchWallet
-    | ErrRemovePendingTxNoSuchTransaction (Hash "Tx")
-    | ErrRemovePendingTxTransactionNoMorePending (Hash "Tx")
+-- | Can't remove pending or expired transaction.
+data ErrRemoveTx
+    = ErrRemoveTxNoSuchWallet ErrNoSuchWallet
+    | ErrRemoveTxNoSuchTransaction (Hash "Tx")
+    | ErrRemoveTxAlreadyInLedger (Hash "Tx")
     deriving (Eq, Show)
 
 -- | Can't perform given operation because there's no transaction

diff --git a/lib/core/src/Cardano/Wallet/DB/MVar.hs b/lib/core/src/Cardano/Wallet/DB/MVar.hs
@@ -23,14 +23,13 @@ import Cardano.Address.Derivation
 import Cardano.Wallet.DB
     ( DBLayer (..)
     , ErrNoSuchWallet (..)
-    , ErrRemovePendingTx (..)
+    , ErrRemoveTx (..)
     , ErrWalletAlreadyExists (..)
     , PrimaryKey (..)
     )
 import Cardano.Wallet.DB.Model
     ( Database
     , Err (..)
-    , ErrErasePendingTx (..)
     , ModelOp
     , emptyDatabase
     , mCheckWallet
@@ -51,7 +50,7 @@ import Cardano.Wallet.DB.Model
     , mReadProtocolParameters
     , mReadTxHistory
     , mReadWalletMeta
-    , mRemovePendingTx
+    , mRemovePendingOrExpiredTx
     , mRemoveWallet
     , mRollbackTo
     , mUpdatePendingTxForExpiry
@@ -178,8 +177,8 @@ newDBLayer timeInterpreter = do
         , updatePendingTxForExpiry = \pk tip -> ExceptT $ do
             alterDB errNoSuchWallet db (mUpdatePendingTxForExpiry pk tip)
 
-        , removePendingTx = \pk tid -> ExceptT $ do
-            alterDB errCannotRemovePendingTx db (mRemovePendingTx pk tid)
+        , removePendingOrExpiredTx = \pk tid -> ExceptT $ do
+            alterDB errCannotRemovePendingTx db (mRemovePendingOrExpiredTx pk tid)
 
         {-----------------------------------------------------------------------
                                  Protocol Parameters
@@ -238,13 +237,13 @@ errNoSuchWallet :: Err (PrimaryKey WalletId) -> Maybe ErrNoSuchWallet
 errNoSuchWallet (NoSuchWallet (PrimaryKey wid)) = Just (ErrNoSuchWallet wid)
 errNoSuchWallet _ = Nothing
 
-errCannotRemovePendingTx :: Err (PrimaryKey WalletId) -> Maybe ErrRemovePendingTx
-errCannotRemovePendingTx (CannotRemovePendingTx (ErrErasePendingTxNoSuchWallet (PrimaryKey wid))) =
-    Just (ErrRemovePendingTxNoSuchWallet (ErrNoSuchWallet wid))
-errCannotRemovePendingTx (CannotRemovePendingTx (ErrErasePendingTxNoTx tid)) =
-    Just (ErrRemovePendingTxNoSuchTransaction tid)
-errCannotRemovePendingTx (CannotRemovePendingTx (ErrErasePendingTxNoPendingTx tid)) =
-    Just (ErrRemovePendingTxTransactionNoMorePending tid)
+errCannotRemovePendingTx :: Err (PrimaryKey WalletId) -> Maybe ErrRemoveTx
+errCannotRemovePendingTx (NoSuchWallet (PrimaryKey wid)) =
+    Just (ErrRemoveTxNoSuchWallet (ErrNoSuchWallet wid))
+errCannotRemovePendingTx (NoSuchTx _ tid) =
+    Just (ErrRemoveTxNoSuchTransaction tid)
+errCannotRemovePendingTx (CantRemoveTxInLedger _ tid) =
+    Just (ErrRemoveTxAlreadyInLedger tid)
 errCannotRemovePendingTx _ = Nothing
 
 errWalletAlreadyExists

diff --git a/lib/core/src/Cardano/Wallet/DB/Model.hs b/lib/core/src/Cardano/Wallet/DB/Model.hs
@@ -38,7 +38,6 @@ module Cardano.Wallet.DB.Model
     -- * Model Operation Types
     , ModelOp
     , Err (..)
-    , ErrErasePendingTx (..)
     -- * Model database functions
     , mCleanDB
     , mInitializeWallet
@@ -55,7 +54,7 @@ module Cardano.Wallet.DB.Model
     , mPutTxHistory
     , mReadTxHistory
     , mUpdatePendingTxForExpiry
-    , mRemovePendingTx
+    , mRemovePendingOrExpiredTx
     , mPutPrivateKey
     , mReadPrivateKey
     , mPutProtocolParameters
@@ -183,13 +182,8 @@ type ModelOp wid s xprv a =
 data Err wid
     = NoSuchWallet wid
     | WalletAlreadyExists wid
-    | CannotRemovePendingTx (ErrErasePendingTx wid)
-    deriving (Show, Eq, Functor, Foldable, Traversable)
-
-data ErrErasePendingTx wid
-    = ErrErasePendingTxNoSuchWallet wid
-    | ErrErasePendingTxNoTx (Hash "Tx")
-    | ErrErasePendingTxNoPendingTx (Hash "Tx")
+    | NoSuchTx wid (Hash "Tx")
+    | CantRemoveTxInLedger wid (Hash "Tx")
     deriving (Show, Eq, Functor, Foldable, Traversable)
 
 {-------------------------------------------------------------------------------
@@ -272,20 +266,15 @@ mUpdatePendingTxForExpiry wid currentTip = alterModel wid $ \wal ->
         _ ->
             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 ->
-        ( Left (CannotRemovePendingTx (ErrErasePendingTxNoSuchWallet wid)), db )
-    Just wal -> case Map.lookup tid (txHistory wal) of
+mRemovePendingOrExpiredTx :: Ord wid => wid -> Hash "Tx" -> ModelOp wid s xprv ()
+mRemovePendingOrExpiredTx wid tid = alterModelErr wid $ \wal ->
+    case Map.lookup tid (txHistory wal) of
         Nothing ->
-            ( Left (CannotRemovePendingTx (ErrErasePendingTxNoTx tid)), db )
-        Just txMeta ->
-            if (status :: TxMeta -> TxStatus) txMeta == Pending then
-                ( Right (), Database updateWallets txs )
-            else ( Left (CannotRemovePendingTx (ErrErasePendingTxNoPendingTx tid)), db )
-    where
-        updateWallets = Map.adjust changeTxMeta wid wallets
-        changeTxMeta meta = meta { txHistory = Map.delete tid (txHistory meta) }
+            ( Left (NoSuchTx wid tid), wal )
+        Just txMeta | txMeta ^. #status == InLedger ->
+            ( Left (CantRemoveTxInLedger wid tid), wal )
+        Just _ ->
+            ( Right (), wal { txHistory = Map.delete tid (txHistory wal) } )
 
 mRollbackTo :: Ord wid => wid -> SlotNo -> ModelOp wid s xprv SlotNo
 mRollbackTo wid requested db@(Database wallets txs) = case Map.lookup wid wallets of
@@ -508,14 +497,29 @@ mReadDelegationRewardBalance wid db@(Database wallets _) =
                              Model function helpers
 -------------------------------------------------------------------------------}
 
+-- | Create a 'ModelOp' which mutates the database for a certain wallet id.
+--
+-- The given function returns a value and a modified wallet database.
 alterModel
     :: Ord wid
     => wid
     -> (WalletDatabase s xprv -> (a, WalletDatabase s xprv))
     -> ModelOp wid s xprv a
-alterModel wid f db@Database{wallets,txs} = case f <$> Map.lookup wid wallets of
-    Just (a, wal) -> (Right a, Database (Map.insert wid wal wallets) txs)
-    Nothing -> (Left (NoSuchWallet wid), db)
+alterModel wid f = alterModelErr wid (first Right . f)
+
+-- | Create a 'ModelOp' which mutates the database for a certain wallet id.
+--
+-- The given function returns a either a value or error, and a modified wallet
+-- database.
+alterModelErr
+    :: Ord wid
+    => wid
+    -> (WalletDatabase s xprv -> (Either (Err wid) a, WalletDatabase s xprv))
+    -> ModelOp wid s xprv a
+alterModelErr wid f db@Database{wallets,txs} =
+    case f <$> Map.lookup wid wallets of
+        Just (a, wal) -> (a, Database (Map.insert wid wal wallets) txs)
+        Nothing -> (Left (NoSuchWallet wid), db)
 
 -- | Apply optional filters on slotNo and sort using the default sort order
 -- (first time/slotNo, then by TxId) to a 'TxHistory'.