Merge #2167

2167: Add transaction TTL to payments API r=rvl a=rvl

### Issue Number

ADP-93 / #1840

### Overview

- [x] Add transaction TTL to swagger spec. User provides the value in seconds.
- [x] Add transaction TTL to API types
- [x] Add TTL slot calculation to API handler function
- [x] Adjust mkStdTx to make ttl easier - it now takes the expiry slot directly.
- [x] Integration tests

### Comments

Next PRs
- [x] Allow deleting expired transactions ⇒ #2262
- [x] Add CLI option `cardano-wallet transaction create [--ttl=SECONDS]` ⇒ #2267
- [ ] Perhaps clean up the large number of function arguments and return values in transaction layer functions.


Co-authored-by: Rodney Lorrimar <rodney.lorrimar@iohk.io>

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

@@ -118,6 +118,7 @@ module Test.Integration.Framework.DSL
     , unsafeGetTransactionTime
     , getTxId
     , oneSecond
+    , getTTLSlots
 
     -- * Delegation helpers
     , mkEpochInfo
@@ -284,7 +285,7 @@ import Data.Quantity
 import Data.Text
     ( Text )
 import Data.Time
-    ( UTCTime )
+    ( NominalDiffTime, UTCTime )
 import Data.Time.Text
     ( iso8601ExtendedUtc, utcTimeToText )
 import Data.Word
@@ -542,8 +543,9 @@ walletId =
 minUTxOValue :: Natural
 minUTxOValue = 1_000_000
 
--- | Wallet server's chosen transaction TTL value (in slots) when none is given.
-defaultTxTTL :: SlotNo
+-- | Wallet server's chosen transaction TTL value (in seconds) when none is
+-- given.
+defaultTxTTL :: NominalDiffTime
 defaultTxTTL = 7200
 
 --
@@ -1882,7 +1884,7 @@ pubKeyFromMnemonics mnemonics =
 -- Helper for delegation statuses
 --
 getSlotParams
-    :: (Context t)
+    :: Context t
     -> IO (EpochNo, SlotParameters)
 getSlotParams ctx = do
     r1 <- request @ApiNetworkInformation ctx
@@ -1901,11 +1903,22 @@ getSlotParams ctx = do
     let sp = SlotParameters
             (EpochLength epochL)
             (SlotLength slotL)
-            (genesisBlockDate)
+            genesisBlockDate
             (ActiveSlotCoefficient coeff)
 
     return (currentEpoch, sp)
 
+-- | Converts a transaction TTL in seconds into a number of slots, using the
+-- slot length.
+getTTLSlots
+    :: Context t
+    -> NominalDiffTime
+    -> IO SlotNo
+getTTLSlots ctx dt = do
+    (_, SlotParameters _ (SlotLength _slotLenWrong) _ _) <- getSlotParams ctx
+    let slotLen = 0.2 -- fixme: this is the value from byron genesis
+    pure $ SlotNo $ ceiling $ dt / slotLen
+
 -- | Handy constructor for ApiEpochInfo
 mkEpochInfo
     :: EpochNo

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

@@ -75,6 +75,7 @@ module Test.Integration.Framework.TestData
     , errMsg404MinUTxOValue
     , errMsg400TxTooLarge
     , errMsg403CouldntIdentifyAddrAsMine
+    , errMsg503PastHorizon
     ) where
 
 import Prelude
@@ -442,3 +443,6 @@ errMsg403CouldntIdentifyAddrAsMine :: String
 errMsg403CouldntIdentifyAddrAsMine = "I \
     \couldn't identify this address as one of mine. It likely belongs to another wallet and I \
     \will therefore not import it."
+
+errMsg503PastHorizon :: String
+errMsg503PastHorizon = "Tried to convert something that is past the horizon"

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

@@ -75,7 +75,7 @@ import Data.Text
 import Data.Text.Class
     ( FromText (..), ToText (..) )
 import Data.Time.Clock
-    ( UTCTime, addUTCTime )
+    ( NominalDiffTime, UTCTime, addUTCTime )
 import Data.Time.Utils
     ( utcTimePred, utcTimeSucc )
 import Data.Word
@@ -87,7 +87,7 @@ import Numeric.Natural
 import Test.Hspec
     ( SpecWith, describe )
 import Test.Hspec.Expectations.Lifted
-    ( shouldBe, shouldSatisfy )
+    ( shouldBe, shouldNotBe, shouldSatisfy )
 import Test.Hspec.Extra
     ( it )
 import Test.Integration.Framework.DSL
@@ -115,6 +115,7 @@ import Test.Integration.Framework.DSL
     , fixtureWallet
     , fixtureWalletWith
     , getFromResponse
+    , getTTLSlots
     , json
     , listAddresses
     , listAllTransactions
@@ -596,7 +597,11 @@ spec = describe "SHELLEY_TRANSACTIONS" $ do
                 (#balance . #available)
                 (`shouldBe` Quantity (faucetAmt - feeEstMax - amt)) ra2
 
-    it "TRANS_CREATE_10 - Pending transaction expiry" $ \ctx -> do
+    let absSlotB = view (#absoluteSlotNumber . #getApiT)
+    let absSlotS = view (#absoluteSlotNumber . #getApiT)
+    let slotDiff a b = if a > b then a - b else b - a
+
+    it "TRANS_TTL_01 - Pending transaction expiry" $ \ctx -> do
         (wa, wb) <- (,) <$> fixtureWallet ctx <*> fixtureWallet ctx
         let amt = minUTxOValue :: Natural
 
@@ -607,8 +612,6 @@ spec = describe "SHELLEY_TRANSACTIONS" $ do
 
         verify r
             [ expectSuccess
-            , expectResponseCode HTTP.status202
-            , expectField (#direction . #getApiT) (`shouldBe` Outgoing)
             , expectField (#status . #getApiT) (`shouldBe` Pending)
             , expectField #expiresAt (`shouldSatisfy` isJust)
             ]
@@ -617,13 +620,101 @@ spec = describe "SHELLEY_TRANSACTIONS" $ do
 
         -- Get insertion slot and out of response.
         let (_, Right apiTx) = r
-        let Just sl = view (#absoluteSlotNumber . #getApiT) <$> apiTx ^. #pendingSince
+        let Just sl = absSlotB <$> apiTx ^. #pendingSince
+
+        -- The expected expiry slot (adds the hardcoded default ttl)
+        ttl <- getTTLSlots ctx defaultTxTTL
+        let txExpectedExp = sl + ttl
+
+        -- The actual expiry slot
+        let Just txActualExp = absSlotS <$> apiTx ^. #expiresAt
+
+        -- Expected and actual are fairly close
+        slotDiff txExpectedExp txActualExp `shouldSatisfy` (< 50)
+
+    it "TRANS_TTL_02 - Custom transaction expiry" $ \ctx -> do
+        (wa, wb) <- (,) <$> fixtureWallet ctx <*> fixtureWallet ctx
+        let amt = minUTxOValue :: Natural
+        let testTTL = 42 :: NominalDiffTime
+
+        basePayload <- mkTxPayload ctx wb amt fixturePassphrase
+        let payload = addTxTTL (realToFrac testTTL) basePayload
+
+        r <- request @(ApiTransaction n) ctx
+            (Link.createTransaction @'Shelley wa) Default payload
+
+        verify r
+            [ expectSuccess
+            , expectField (#status . #getApiT) (`shouldBe` Pending)
+            , expectField #expiresAt (`shouldSatisfy` isJust)
+            ]
+
+        -- Get insertion slot and out of response.
+        let (_, Right apiTx) = r
+        let Just sl = absSlotB <$> apiTx ^. #pendingSince
 
         -- The expected expiry slot (adds the hardcoded default ttl)
-        let ttl = sl + defaultTxTTL
+        ttl <- getTTLSlots ctx testTTL
+        let txExpectedExp = sl + ttl
 
-        (view #absoluteSlotNumber <$> (apiTx ^. #expiresAt))
-            `shouldBe` Just (ApiT ttl)
+        -- The actual expiry slot
+        let Just txActualExp = absSlotS <$> apiTx ^. #expiresAt
+
+        -- Expected and actual are fairly close. Any difference should only be
+        -- due to slot rounding.
+        slotDiff txExpectedExp txActualExp `shouldSatisfy` (< 50)
+
+    it "TRANS_TTL_03 - Expired transactions" $ \ctx -> do
+        (wa, wb) <- (,) <$> fixtureWallet ctx <*> fixtureWallet 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
+
+        verify ra
+            [ expectSuccess
+            , expectField (#status . #getApiT) (`shouldBe` Pending)
+            , expectField #expiresAt (`shouldSatisfy` isJust)
+            ]
+
+        let txid = getFromResponse #id ra
+        let linkSrc = Link.getTransaction @'Shelley wa (ApiTxId 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
+
+        verify rb
+            [ expectField (#status . #getApiT) (`shouldBe` Expired)
+            , expectField #expiresAt (`shouldSatisfy` isJust)
+            ]
+
+    it "TRANS_TTL_04 - Large TTL" $ \ctx -> do
+        (wa, wb) <- (,) <$> fixtureWallet ctx <*> fixtureWallet ctx
+        let amt = minUTxOValue :: Natural
+        let hugeTTL = 1e9 :: NominalDiffTime
+
+        basePayload <- mkTxPayload ctx wb amt fixturePassphrase
+        let payload = addTxTTL (realToFrac hugeTTL) basePayload
+
+        r <- request @(ApiTransaction n) ctx
+            (Link.createTransaction @'Shelley wa) Default payload
+
+        -- If another HFC Era is added, then this payment request will fail
+        -- because the expiry would be past the slotting horizon.
+        verify r
+            [ expectSuccess
+            , expectField (#status . #getApiT) (`shouldBe` Pending)
+            , expectField #expiresAt (`shouldSatisfy` isJust)
+            ]
 
     it "TRANSMETA_CREATE_01 - Transaction with metadata" $ \ctx -> do
         (wa, wb) <- (,) <$> fixtureWallet ctx <*> emptyWallet ctx
@@ -2544,6 +2635,12 @@ spec = describe "SHELLEY_TRANSACTIONS" $ do
                 "passphrase": #{passphrase}
             }|]
 
+    addTxTTL :: Double -> Payload -> Payload
+    addTxTTL t (Json (Aeson.Object o)) = Json (Aeson.Object (o <> ttl))
+      where
+        ttl = "time_to_live" .= [json|{ "quantity": #{t}, "unit": "second"}|]
+    addTxTTL _ _ = error "can't do that"
+
     addTxMetadata :: Aeson.Value -> Payload -> Payload
     addTxMetadata md (Json (Aeson.Object o)) =
         Json (Aeson.Object (o <> ("metadata" .= md)))