Use Tx TTL value from API payment request

lib/core/src/Cardano/Wallet.hs

@@ -280,6 +280,7 @@ import Cardano.Wallet.Primitive.Model
 import Cardano.Wallet.Primitive.Slotting
     ( PastHorizonException (..)
     , TimeInterpreter
+    , ceilingSlotAt
     , slotRangeFromTimeRange
     , startTime
     )
@@ -391,7 +392,7 @@ import Data.List
 import Data.List.NonEmpty
     ( NonEmpty )
 import Data.Maybe
-    ( fromJust, isJust, mapMaybe )
+    ( fromJust, fromMaybe, isJust, mapMaybe )
 import Data.Proxy
     ( Proxy )
 import Data.Quantity
@@ -401,7 +402,7 @@ import Data.Set
 import Data.Text.Class
     ( ToText (..) )
 import Data.Time.Clock
-    ( UTCTime, getCurrentTime )
+    ( NominalDiffTime, UTCTime, addUTCTime, getCurrentTime )
 import Data.Type.Equality
     ( (:~:) (..), testEquality )
 import Data.Vector.Shuffle
@@ -1273,15 +1274,16 @@ selectCoinsForPayment
     -> Maybe TxMetadata
     -> ExceptT (ErrSelectForPayment e) IO CoinSelection
 selectCoinsForPayment ctx wid recipients withdrawal md = do
-    (utxo, pending, txp, minUtxo) <- withExceptT ErrSelectForPaymentNoSuchWallet $
+    (utxo, pending, txp, minUtxo) <-
+        withExceptT ErrSelectForPaymentNoSuchWallet $
         selectCoinsSetup @ctx @s @k ctx wid
 
     let pendingWithdrawal = Set.lookupMin $ Set.filter hasWithdrawal pending
     when (withdrawal /= Quantity 0 && isJust pendingWithdrawal) $ throwE $
         ErrSelectForPaymentAlreadyWithdrawing (fromJust pendingWithdrawal)
 
-    cs <-
-        selectCoinsForPaymentFromUTxO @ctx @t @k @e ctx utxo txp minUtxo recipients withdrawal md
+    cs <- selectCoinsForPaymentFromUTxO @ctx @t @k @e
+        ctx utxo txp minUtxo recipients withdrawal md
     withExceptT ErrSelectForPaymentMinimumUTxOValue $ except $
         guardCoinSelection minUtxo cs
     pure cs
@@ -1301,7 +1303,8 @@ selectCoinsSetup
 selectCoinsSetup ctx wid = do
     (wal, _, pending) <- readWallet @ctx @s @k ctx wid
     txp <- txParameters <$> readWalletProtocolParameters @ctx @s @k ctx wid
-    minUTxO <- minimumUTxOvalue <$> readWalletProtocolParameters @ctx @s @k ctx wid
+    minUTxO <- minimumUTxOvalue <$>
+        readWalletProtocolParameters @ctx @s @k ctx wid
     let utxo = availableUTxO @s pending wal
     return (utxo, pending, txp, minUTxO)
 
@@ -1397,8 +1400,8 @@ estimateFeeForDelegation ctx wid = db & \DBLayer{..} -> do
         $ isStakeKeyRegistered (PrimaryKey wid)
 
     let action = if isKeyReg then Join pid else RegisterKeyAndJoin pid
-    let selectCoins =
-            selectCoinsForDelegationFromUTxO @_ @t @k ctx utxo txp minUtxo action
+    let selectCoins = selectCoinsForDelegationFromUTxO @_ @t @k
+            ctx utxo txp minUtxo action
     estimateFeeForCoinSelection $ Fee . feeBalance <$> selectCoins
   where
     db  = ctx ^. dbLayer @s @k
@@ -1511,7 +1514,8 @@ estimateFeeForPayment ctx wid recipients withdrawal md = do
     (utxo, _, txp, minUtxo) <- withExceptT ErrSelectForPaymentNoSuchWallet $
         selectCoinsSetup @ctx @s @k ctx wid
 
-    let selectCoins = selectCoinsForPaymentFromUTxO @ctx @t @k @e ctx utxo txp minUtxo recipients withdrawal md
+    let selectCoins = selectCoinsForPaymentFromUTxO @ctx @t @k @e
+            ctx utxo txp minUtxo recipients withdrawal md
 
     cs <- selectCoins `catchE` handleNotSuccessfulCoinSelection
     withExceptT ErrSelectForPaymentMinimumUTxOValue $ except $
@@ -1589,12 +1593,13 @@ signPayment
        -- ^ Reward account derived from the root key (or somewhere else).
     -> Passphrase "raw"
     -> Maybe W.TxMetadata
+    -> Maybe NominalDiffTime
     -> CoinSelection
     -> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx)
-signPayment ctx wid argGenChange mkRewardAccount pwd md cs = db & \DBLayer{..} -> do
+signPayment ctx wid argGenChange mkRewardAccount pwd md ttl cs = db & \DBLayer{..} -> do
+    txExp <- liftIO $ getTxExpiry ti ttl
     withRootKey @_ @s ctx wid pwd ErrSignPaymentWithRootKey $ \xprv scheme -> do
         let pwdP = preparePassphrase scheme pwd
-        nodeTip <- withExceptT ErrSignPaymentNetwork $ currentNodeTip nl
         mapExceptT atomically $ do
             cp <- withExceptT ErrSignPaymentNoSuchWallet $ withNoSuchWallet wid $
                 readCheckpoint (PrimaryKey wid)
@@ -1604,8 +1609,9 @@ signPayment ctx wid argGenChange mkRewardAccount pwd md cs = db & \DBLayer{..} -
 
             let keyFrom = isOwned (getState cp) (xprv, pwdP)
             let rewardAcnt = mkRewardAccount (xprv, pwdP)
-            (tx, sealedTx, txExp) <- withExceptT ErrSignPaymentMkTx $ ExceptT $
-                pure $ mkStdTx tl rewardAcnt keyFrom (nodeTip ^. #slotNo) md cs'
+
+            (tx, sealedTx) <- withExceptT ErrSignPaymentMkTx $ ExceptT $
+                pure $ mkStdTx tl rewardAcnt keyFrom txExp md cs'
 
             (time, meta) <- liftIO $ mkTxMeta ti (currentTip cp) s' tx cs' txExp
             return (tx, meta, time, sealedTx)
@@ -1616,6 +1622,27 @@ signPayment ctx wid argGenChange mkRewardAccount pwd md cs = db & \DBLayer{..} -
     tl = ctx ^. transactionLayer @t @k
     nl = ctx ^. networkLayer @t
 
+-- | Calculate the transaction expiry slot, given a 'TimeInterpreter', and an
+-- optional TTL in seconds.
+--
+-- If no TTL is provided, a default of 2 hours is used (note: there is no
+-- particular reason why we chose that duration).
+getTxExpiry
+    :: TimeInterpreter IO
+    -- ^ Context for time to slot calculation.
+    -> Maybe NominalDiffTime
+    -- ^ Time to live (TTL) in seconds from now.
+    -> IO SlotNo
+getTxExpiry ti maybeTTL = do
+    expTime <- addUTCTime ttl <$> getCurrentTime
+    -- fixme: this will explode if the user provides a TTL past the horizon.
+    ti $ ceilingSlotAt expTime
+  where
+    ttl = fromMaybe defaultTTL maybeTTL
+
+    defaultTTL :: NominalDiffTime
+    defaultTTL = 7200  -- that's 2 hours
+
 -- | Very much like 'signPayment', but doesn't not generate change addresses.
 signTx
     :: forall ctx s t k.
@@ -1632,21 +1659,23 @@ signTx
     -> WalletId
     -> Passphrase "raw"
     -> Maybe TxMetadata
+    -> Maybe NominalDiffTime
     -> UnsignedTx (TxIn, TxOut)
     -> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx)
-signTx ctx wid pwd md (UnsignedTx inpsNE outsNE) = db & \DBLayer{..} -> do
+signTx ctx wid pwd md ttl (UnsignedTx inpsNE outsNE) = db & \DBLayer{..} -> do
+    txExp <- liftIO $ getTxExpiry ti ttl
     withRootKey @_ @s ctx wid pwd ErrSignPaymentWithRootKey $ \xprv scheme -> do
         let pwdP = preparePassphrase scheme pwd
-        nodeTip <- withExceptT ErrSignPaymentNetwork $ currentNodeTip nl
         mapExceptT atomically $ do
-            cp <- withExceptT ErrSignPaymentNoSuchWallet $ withNoSuchWallet wid $
+            cp <- withExceptT ErrSignPaymentNoSuchWallet $
+                withNoSuchWallet wid $
                 readCheckpoint (PrimaryKey wid)
 
             let cs = mempty { inputs = inps, outputs = outs }
             let keyFrom = isOwned (getState cp) (xprv, pwdP)
             let rewardAcnt = getRawKey $ deriveRewardAccount @k pwdP xprv
-            (tx, sealedTx, txExp) <- withExceptT ErrSignPaymentMkTx $ ExceptT $
-                pure $ mkStdTx tl (rewardAcnt, pwdP) keyFrom (nodeTip ^. #slotNo) md cs
+            (tx, sealedTx) <- withExceptT ErrSignPaymentMkTx $ ExceptT $
+                pure $ mkStdTx tl (rewardAcnt, pwdP) keyFrom txExp md cs
 
             (time, meta) <- liftIO $
                 mkTxMeta ti (currentTip cp) (getState cp) tx cs txExp
@@ -1720,7 +1749,7 @@ signDelegation
     -> DelegationAction
     -> ExceptT ErrSignDelegation IO (Tx, TxMeta, UTCTime, SealedTx)
 signDelegation ctx wid argGenChange pwd coinSel action = db & \DBLayer{..} -> do
-    nodeTip <- withExceptT ErrSignDelegationNetwork $ currentNodeTip nl
+    expirySlot <- liftIO $ getTxExpiry ti Nothing
     withRootKey @_ @s ctx wid pwd ErrSignDelegationWithRootKey $ \xprv scheme -> do
         let pwdP = preparePassphrase scheme pwd
         mapExceptT atomically $ do
@@ -1733,31 +1762,31 @@ 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, txExp) <- withExceptT ErrSignDelegationMkTx $ ExceptT $ pure $
+            (tx, sealedTx) <- withExceptT ErrSignDelegationMkTx $ ExceptT $ pure $
                 case action of
                     RegisterKeyAndJoin poolId ->
                         mkDelegationJoinTx tl poolId
                             (rewardAcnt, pwdP)
                             keyFrom
-                            (nodeTip ^. #slotNo)
+                            expirySlot
                             coinSel'
 
                     Join poolId ->
                         mkDelegationJoinTx tl poolId
                             (rewardAcnt, pwdP)
                             keyFrom
-                            (nodeTip ^. #slotNo)
+                            expirySlot
                             coinSel'
 
                     Quit ->
                         mkDelegationQuitTx tl
                             (rewardAcnt, pwdP)
                             keyFrom
-                            (nodeTip ^. #slotNo)
+                            expirySlot
                             coinSel'
 
             (time, meta) <- liftIO $
-                mkTxMeta ti (currentTip cp) s' tx coinSel' txExp
+                mkTxMeta ti (currentTip cp) s' tx coinSel' expirySlot
             return (tx, meta, time, sealedTx)
   where
     ti :: TimeInterpreter IO

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

@@ -1311,8 +1311,9 @@ postTransaction
     -> Handler (ApiTransaction n)
 postTransaction ctx genChange (ApiT wid) body = do
     let pwd = coerce $ getApiT $ body ^. #passphrase
-    let outs = coerceCoin <$> (body ^. #payments)
+    let outs = coerceCoin <$> body ^. #payments
     let md = getApiT <$> body ^. #metadata
+    let mTTL = view #seconds <$> body ^. #ttl
 
     let selfRewardCredentials (rootK, pwdP) =
             (getRawKey $ deriveRewardAccount @k pwdP rootK, pwdP)
@@ -1340,7 +1341,7 @@ postTransaction ctx genChange (ApiT wid) body = do
         pure (selection, credentials)
 
     (tx, meta, time, wit) <- withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $
-        W.signPayment @_ @s @t @k wrk wid genChange credentials pwd md selection
+        W.signPayment @_ @s @t @k wrk wid genChange credentials pwd md mTTL selection
 
     withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $
         W.submitTx @_ @s @t @k wrk wid (tx, meta, wit)
@@ -1652,7 +1653,7 @@ migrateWallet ctx (ApiT wid) migrateData = do
 
     forM migration $ \cs -> do
         (tx, meta, time, wit) <- withWorkerCtx ctx wid liftE liftE
-            $ \wrk -> liftHandler $ W.signTx @_ @s @t @k wrk wid pwd Nothing cs
+            $ \wrk -> liftHandler $ W.signTx @_ @s @t @k wrk wid pwd Nothing Nothing cs
         withWorkerCtx ctx wid liftE liftE
             $ \wrk -> liftHandler $ W.submitTx @_ @_ @t wrk wid (tx, meta, wit)
         liftIO $ mkApiTransaction

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

@@ -26,6 +26,7 @@ module Cardano.Wallet.Primitive.Slotting
     , slotRangeFromTimeRange
     , firstSlotInEpoch
     , ongoingSlotAt
+    , ceilingSlotAt
     , endTimeOfEpoch
 
     -- ** Running queries

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

@@ -56,13 +56,13 @@ data TransactionLayer t k = TransactionLayer
         -> (Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption"))
             -- Key store
         -> SlotNo
-            -- Tip of the chain, for TTL
+            -- Transaction expiry (TTL) slot.
         -> Maybe TxMetadata
             -- User or application-defined metadata to embed in the transaction.
         -> CoinSelection
             -- A balanced coin selection where all change addresses have been
             -- assigned.
-        -> Either ErrMkTx (Tx, SealedTx, SlotNo)
+        -> Either ErrMkTx (Tx, SealedTx)
         -- ^ Construct a standard transaction
         --
         -- " Standard " here refers to the fact that we do not deal with redemption,
@@ -79,11 +79,11 @@ data TransactionLayer t k = TransactionLayer
         -> (Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption"))
             -- Key store
         -> SlotNo
-            -- Tip of the chain, for TTL
+            -- Transaction expiry (TTL) slot.
         -> CoinSelection
             -- A balanced coin selection where all change addresses have been
             -- assigned.
-        -> Either ErrMkTx (Tx, SealedTx, SlotNo)
+        -> Either ErrMkTx (Tx, SealedTx)
         -- ^ Construct a transaction containing a certificate for delegating to
         -- a stake pool.
         --
@@ -97,11 +97,11 @@ data TransactionLayer t k = TransactionLayer
         -> (Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption"))
             -- Key store
         -> SlotNo
-            -- Tip of the chain, for TTL
+            -- Transaction expiry (TTL) slot.
         -> CoinSelection
             -- A balanced coin selection where all change addresses have been
             -- assigned.
-        -> Either ErrMkTx (Tx, SealedTx, SlotNo)
+        -> Either ErrMkTx (Tx, SealedTx)
         -- ^ Construct a transaction containing a certificate for quiting from
         -- a stake pool.
         --

lib/core/test/unit/Cardano/WalletSpec.hs

@@ -531,10 +531,10 @@ walletKeyIsReencrypted (wid, wname) (xprv, pwd) newPwd =
         let credentials (rootK, pwdP) =
                 (getRawKey $ deriveRewardAccount pwdP rootK, pwdP)
         (_,_,_,txOld) <- unsafeRunExceptT $
-            W.signPayment @_ @_ @DummyTarget wl wid () credentials (coerce pwd) Nothing selection
+            W.signPayment @_ @_ @DummyTarget wl wid () credentials (coerce pwd) Nothing Nothing selection
         unsafeRunExceptT $ W.updateWalletPassphrase wl wid (coerce pwd, newPwd)
         (_,_,_,txNew) <- unsafeRunExceptT $
-            W.signPayment @_ @_ @DummyTarget wl wid () credentials newPwd Nothing selection
+            W.signPayment @_ @_ @DummyTarget wl wid () credentials newPwd Nothing Nothing selection
         txOld `shouldBe` txNew
   where
     selection = mempty
@@ -708,7 +708,7 @@ setupFixture (wid, wname, wstate) = do
 -- implements a fake signer that still produces sort of witnesses
 dummyTransactionLayer :: TransactionLayer DummyTarget JormungandrKey
 dummyTransactionLayer = TransactionLayer
-    { mkStdTx = \_ keyFrom slot _md cs -> do
+    { mkStdTx = \_ keyFrom _slot _md cs -> do
         let inps' = map (second coin) (CS.inputs cs)
         let tid = mkTxId inps' (CS.outputs cs) mempty Nothing
         let tx = Tx tid inps' (CS.outputs cs) mempty Nothing
@@ -721,7 +721,7 @@ dummyTransactionLayer = TransactionLayer
 
         -- (tx1, wit1) == (tx2, wit2) <==> fakebinary1 == fakebinary2
         let fakeBinary = SealedTx . B8.pack $ show (tx, wit)
-        return (tx, fakeBinary, slot + 1)
+        return (tx, fakeBinary)
     , initDelegationSelection =
         error "dummyTransactionLayer: initDelegationSelection not implemented"
     , mkDelegationJoinTx =

lib/jormungandr/cardano-wallet-jormungandr.cabal

@@ -156,7 +156,6 @@ test-suite unit
     , contra-tracer
     , deepseq
     , directory
-    , extra
     , filepath
     , file-embed
     , fmt

lib/jormungandr/src/Cardano/Wallet/Jormungandr/Transaction.hs

@@ -49,7 +49,6 @@ import Cardano.Wallet.Primitive.Types
     ( ChimericAccount (..)
     , Hash (..)
     , SealedTx (..)
-    , SlotNo (..)
     , Tx (..)
     , TxMetadata
     , TxOut (..)
@@ -157,7 +156,6 @@ newTransactionLayer block0H = TransactionLayer
                 , metadata = Nothing
                 }
             , finalizeFragment fragment
-            , maxBound :: SlotNo
             )
 
     -- NOTE

lib/jormungandr/test/integration/Test/Integration/Jormungandr/Scenario/API/Transactions.hs

@@ -715,8 +715,8 @@ fixtureExternalTx ctx toSend = do
             }
     tl <- newTransactionLayer <$> getBlock0H
     let rewardAcnt = error "rewardAcnt unused"
-    let curSlot = error "current slot not needed in jormungandr mkStdTx"
-    let (Right (tx, bin, _)) = mkStdTx tl rewardAcnt keystore curSlot Nothing cs
+    let expSlot = error "expiry slot not needed in jormungandr mkStdTx"
+    let (Right (tx, bin)) = mkStdTx tl rewardAcnt keystore expSlot Nothing cs
 
     return ExternalTxFixture
         { srcWallet = wSrc

lib/jormungandr/test/unit/Cardano/Wallet/Jormungandr/TransactionSpec.hs

@@ -62,8 +62,6 @@ import Data.Proxy
     ( Proxy (..) )
 import Data.Text.Class
     ( toText )
-import Data.Tuple.Extra
-    ( snd3 )
 import Test.Hspec
     ( HasCallStack, Spec, SpecWith, describe, it, shouldBe )
 import Test.QuickCheck
@@ -511,7 +509,7 @@ goldenTestStdTx tl keystore inps outs bytes' = it title $ do
     let cs = mempty { inputs = inps, outputs = outs }
     let rewardAcnt = error "unused"
     let tx = mkStdTx tl rewardAcnt keystore (SlotNo 0) Nothing cs
-    let bytes = hex . getSealedTx . snd3 <$> tx
+    let bytes = hex . getSealedTx . snd <$> tx
     bytes `shouldBe` Right bytes'
   where
     title = "golden test mkStdTx: " <> show inps <> show outs
@@ -533,7 +531,7 @@ goldenTestDelegationCertTx tl keystore pool (accountXPrv, pass) inputs outputs b
             keystore
             (SlotNo 0)
             (mempty { inputs, outputs })
-    let sealed = getSealedTx . snd3 <$> res
+    let sealed = getSealedTx . snd <$> res
     sealed `shouldBe` Right (unsafeFromHex bytes')
     & counterexample ("poolId = " <> showHex (getPoolId pool))
   where