Add two TRANS_TTL integration tests

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

@@ -114,6 +114,7 @@ module Test.Integration.Framework.DSL
     , rootPrvKeyFromMnemonics
     , unsafeGetTransactionTime
     , getTxId
+    , getTTLSlots
 
     -- * Delegation helpers
     , mkEpochInfo
@@ -278,7 +279,7 @@ import Data.Quantity
 import Data.Text
     ( Text )
 import Data.Time
-    ( UTCTime )
+    ( NominalDiffTime, UTCTime )
 import Data.Time.Text
     ( iso8601ExtendedUtc, utcTimeToText )
 import Data.Word
@@ -533,8 +534,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
 
 --
@@ -1795,7 +1797,7 @@ pubKeyFromMnemonics mnemonics =
 -- Helper for delegation statuses
 --
 getSlotParams
-    :: (Context t)
+    :: Context t
     -> IO (EpochNo, SlotParameters)
 getSlotParams ctx = do
     r1 <- request @ApiNetworkInformation ctx
@@ -1814,11 +1816,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/Scenario/API/Shelley/Transactions.hs

@@ -73,7 +73,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
@@ -85,7 +85,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
@@ -113,6 +113,7 @@ import Test.Integration.Framework.DSL
     , fixtureWallet
     , fixtureWalletWith
     , getFromResponse
+    , getTTLSlots
     , json
     , listAddresses
     , listAllTransactions
@@ -593,7 +594,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
 
@@ -604,8 +609,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)
             ]
@@ -614,13 +617,83 @@ 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)
-        let ttl = sl + defaultTxTTL
+        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 absSlotB = view (#absoluteSlotNumber . #getApiT)
+        let Just sl = absSlotB <$> apiTx ^. #pendingSince
+
+        -- The expected expiry slot (adds the hardcoded default ttl)
+        ttl <- getTTLSlots ctx testTTL
+        let txExpectedExp = sl + ttl
+
+        -- The actual expiry slot
+        let absSlotS = view (#absoluteSlotNumber . #getApiT)
+        let Just txActualExp = absSlotS <$> apiTx ^. #expiresAt
 
-        (view #absoluteSlotNumber <$> (apiTx ^. #expiresAt))
-            `shouldBe` Just (ApiT ttl)
+        -- Expected and actual are fairly close
+        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 "TRANSMETA_CREATE_01 - Transaction with metadata" $ \ctx -> do
         (wa, wb) <- (,) <$> fixtureWallet ctx <*> emptyWallet ctx
@@ -2529,6 +2602,11 @@ spec = describe "SHELLEY_TRANSACTIONS" $ do
                 "passphrase": #{passphrase}
             }|]
 
+    addTxTTL :: Double -> Payload -> Payload
+    addTxTTL t (Json (Aeson.Object o)) = Json (Aeson.Object (o <> ttl))
+        where ttl = "ttl" .= Aeson.Object ("seconds" .= t)
+    addTxTTL _ _ = error "can't do that"
+
     addTxMetadata :: Aeson.Value -> Payload -> Payload
     addTxMetadata md (Json (Aeson.Object o)) =
         Json (Aeson.Object (o <> ("metadata" .= md)))