Merge #2267

2267: Add CLI option for transaction TTL r=rvl a=rvl

### Issue Number

ADP-93 / #1840

### Overview

- [x] Hide shelley-specific CLI options in `cardano-wallet-jormungandr` (fixes #2169)
- [x] Add option `cardano-wallet transaction create [--ttl=SECONDS]`
- [ ] Update wiki page after merging.

### Comments

- Based on PR #2262 branch - merge that first.


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

lib/cli/cardano-wallet-cli.cabal

@@ -47,6 +47,7 @@ library
     , servant-client-core
     , text
     , text-class
+    , time
     , optparse-applicative
   hs-source-dirs:
       src

lib/cli/src/Cardano/CLI.hs

@@ -35,6 +35,7 @@ module Cardano.CLI
     , cmdWalletCreate
     , cmdByronWalletCreate
     , cmdTransaction
+    , cmdTransactionJormungandr
     , cmdAddress
     , cmdStakePool
     , cmdNetwork
@@ -155,6 +156,8 @@ import Cardano.Wallet.Api.Types
     )
 import Cardano.Wallet.Network
     ( ErrNetworkUnavailable (..) )
+import Cardano.Wallet.Orphans
+    ()
 import Cardano.Wallet.Primitive.AddressDerivation
     ( Depth (..)
     , DerivationType (..)
@@ -207,6 +210,8 @@ import Data.Text.Class
     ( FromText (..), TextDecodingError (..), ToText (..), showT )
 import Data.Text.Read
     ( decimal )
+import Data.Time.Clock
+    ( NominalDiffTime )
 import Data.Void
     ( Void )
 import Fmt
@@ -683,19 +688,38 @@ cmdWalletGetUtxoStatistics mkClient =
                             Commands - 'transaction'
 -------------------------------------------------------------------------------}
 
+data TransactionFeatures = NoShelleyFeatures | ShelleyFeatures
+    deriving (Show, Eq)
+
 -- | cardano-wallet transaction
 cmdTransaction
     :: ToJSON wallet
     => TransactionClient
     -> WalletClient wallet
     -> Mod CommandFields (IO ())
-cmdTransaction mkTxClient mkWalletClient =
+cmdTransaction = cmdTransactionBase ShelleyFeatures
+
+-- | cardano-wallet-jormungandr transaction
+cmdTransactionJormungandr
+    :: ToJSON wallet
+    => TransactionClient
+    -> WalletClient wallet
+    -> Mod CommandFields (IO ())
+cmdTransactionJormungandr = cmdTransactionBase NoShelleyFeatures
+
+cmdTransactionBase
+    :: ToJSON wallet
+    => TransactionFeatures
+    -> TransactionClient
+    -> WalletClient wallet
+    -> Mod CommandFields (IO ())
+cmdTransactionBase isShelley mkTxClient mkWalletClient =
     command "transaction" $ info (helper <*> cmds) $ mempty
         <> progDesc "About transactions"
   where
     cmds = subparser $ mempty
-        <> cmdTransactionCreate mkTxClient mkWalletClient
-        <> cmdTransactionFees mkTxClient mkWalletClient
+        <> cmdTransactionCreate isShelley mkTxClient mkWalletClient
+        <> cmdTransactionFees isShelley mkTxClient mkWalletClient
         <> cmdTransactionList mkTxClient
         <> cmdTransactionSubmit mkTxClient
         <> cmdTransactionForget mkTxClient
@@ -707,23 +731,31 @@ data TransactionCreateArgs t = TransactionCreateArgs
     , _id :: WalletId
     , _payments :: NonEmpty Text
     , _metadata :: ApiTxMetadata
+    , _timeToLive :: Maybe NominalDiffTime
     }
 
+whenShelley :: a -> Parser a -> TransactionFeatures -> Parser a
+whenShelley j s = \case
+    NoShelleyFeatures -> pure j
+    ShelleyFeatures -> s
+
 cmdTransactionCreate
     :: ToJSON wallet
-    => TransactionClient
+    => TransactionFeatures
+    -> TransactionClient
     -> WalletClient wallet
     -> Mod CommandFields (IO ())
-cmdTransactionCreate mkTxClient mkWalletClient =
+cmdTransactionCreate isShelley mkTxClient mkWalletClient =
     command "create" $ info (helper <*> cmd) $ mempty
         <> progDesc "Create and submit a new transaction."
   where
     cmd = fmap exec $ TransactionCreateArgs
         <$> portOption
         <*> walletIdArgument
         <*> fmap NE.fromList (some paymentOption)
-        <*> metadataOption
-    exec (TransactionCreateArgs wPort wId wAddressAmounts md) = do
+        <*> whenShelley (ApiTxMetadata Nothing) metadataOption isShelley
+        <*> whenShelley Nothing timeToLiveOption isShelley
+    exec (TransactionCreateArgs wPort wId wAddressAmounts md ttl) = do
         wPayments <- either (fail . getTextDecodingError) pure $
             traverse (fromText @(AddressAmount Text)) wAddressAmounts
         res <- sendRequest wPort $ getWallet mkWalletClient $ ApiT wId
@@ -737,26 +769,29 @@ cmdTransactionCreate mkTxClient mkWalletClient =
                         [ "payments" .= wPayments
                         , "passphrase" .= ApiT wPwd
                         , "metadata" .= md
+                        , "time_to_live" .= ttl
                         ]
                     )
             Left _ ->
                 handleResponse Aeson.encodePretty res
 
 cmdTransactionFees
     :: ToJSON wallet
-    => TransactionClient
+    => TransactionFeatures
+    -> TransactionClient
     -> WalletClient wallet
     -> Mod CommandFields (IO ())
-cmdTransactionFees mkTxClient mkWalletClient =
+cmdTransactionFees isShelley mkTxClient mkWalletClient =
     command "fees" $ info (helper <*> cmd) $ mempty
         <> progDesc "Estimate fees for a transaction."
   where
     cmd = fmap exec $ TransactionCreateArgs
         <$> portOption
         <*> walletIdArgument
         <*> fmap NE.fromList (some paymentOption)
-        <*> metadataOption
-    exec (TransactionCreateArgs wPort wId wAddressAmounts md) = do
+        <*> whenShelley (ApiTxMetadata Nothing) metadataOption isShelley
+        <*> whenShelley Nothing timeToLiveOption isShelley
+    exec (TransactionCreateArgs wPort wId wAddressAmounts md ttl) = do
         wPayments <- either (fail . getTextDecodingError) pure $
             traverse (fromText @(AddressAmount Text)) wAddressAmounts
         res <- sendRequest wPort $ getWallet mkWalletClient $ ApiT wId
@@ -768,6 +803,7 @@ cmdTransactionFees mkTxClient mkWalletClient =
                     (Aeson.object
                         [ "payments" .= wPayments
                         , "metadata" .= md
+                        , "time_to_live" .= ttl
                         ])
             Left _ ->
                 handleResponse Aeson.encodePretty res
@@ -1339,7 +1375,7 @@ walletIdArgument :: Parser WalletId
 walletIdArgument = argumentT $ mempty
     <> metavar "WALLET_ID"
 
--- | <stake=STAKE>
+-- | [--stake=STAKE]
 stakeOption :: Parser (Maybe Coin)
 stakeOption = optional $ optionT $ mempty
     <> long "stake"
@@ -1369,7 +1405,7 @@ transactionSubmitPayloadArgument = argumentT $ mempty
     <> metavar "BINARY_BLOB"
     <> help "hex-encoded binary blob of externally-signed transaction."
 
--- | <metadata=JSON>
+-- | [--metadata=JSON]
 --
 -- Note: we decode the JSON just so that we can validate more client-side.
 metadataOption :: Parser ApiTxMetadata
@@ -1384,6 +1420,15 @@ metadataOption = option txMetadataReader $ mempty
 txMetadataReader :: ReadM ApiTxMetadata
 txMetadataReader = eitherReader (Aeson.eitherDecode' . BL8.pack)
 
+-- | [--ttl=DURATION]
+timeToLiveOption :: Parser (Maybe NominalDiffTime)
+timeToLiveOption = optional $ optionT $ mempty
+    <> long "ttl"
+    <> metavar "DURATION"
+    <> help ("Time-to-live value. "
+             <> "Expressed in seconds with a trailing 's'. "
+             <> "Default is 3600s (2 hours).")
+
 -- | <address=ADDRESS>
 addressIdArgument :: Parser Text
 addressIdArgument = argumentT $ mempty

lib/cli/test/unit/Cardano/CLISpec.hs

@@ -267,6 +267,7 @@ spec = do
         ["transaction", "create", "--help"] `shouldShowUsage`
             [ "Usage:  transaction create [--port INT] WALLET_ID"
             , "                           --payment PAYMENT [--metadata JSON]"
+            , "                           [--ttl DURATION]"
             , "  Create and submit a new transaction."
             , ""
             , "Available options:"
@@ -280,11 +281,14 @@ spec = do
             , "                           metadata as a JSON object. The value"
             , "                           must match the schema defined in the"
             , "                           cardano-wallet OpenAPI specification."
+            , "  --ttl DURATION           Time-to-live value. Expressed in"
+            , "                           seconds with a trailing 's'. Default"
+            , "                           is 3600s (2 hours)."
             ]
 
         ["transaction", "fees", "--help"] `shouldShowUsage`
             [ "Usage:  transaction fees [--port INT] WALLET_ID --payment PAYMENT"
-            , "                         [--metadata JSON]"
+            , "                         [--metadata JSON] [--ttl DURATION]"
             , "  Estimate fees for a transaction."
             , ""
             , "Available options:"
@@ -298,6 +302,9 @@ spec = do
             , "                           metadata as a JSON object. The value"
             , "                           must match the schema defined in the"
             , "                           cardano-wallet OpenAPI specification."
+            , "  --ttl DURATION           Time-to-live value. Expressed in"
+            , "                           seconds with a trailing 's'. Default"
+            , "                           is 3600s (2 hours)."
             ]
 
         ["transaction", "list", "--help"] `shouldShowUsage`

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

@@ -26,6 +26,8 @@ import Cardano.Wallet.Primitive.Types
     ( BlockHeader (..), SlotNo (..) )
 import Control.DeepSeq
     ( NFData (..) )
+import Data.Bifunctor
+    ( bimap )
 import Data.Quantity
     ( Percentage (..), Quantity (..), mkPercentage )
 import Data.Ratio
@@ -40,10 +42,6 @@ import GHC.Generics
     ( Generic )
 import GHC.Stack
     ( HasCallStack )
-import Safe
-    ( readMay )
-
-import qualified Data.Text as T
 
 data SyncProgress
     = Ready
@@ -82,17 +80,10 @@ mkSyncTolerance =
     pico = 1_000_000_000_000
 
 instance ToText SyncTolerance where
-    toText (SyncTolerance t) = T.pack (show t)
+    toText (SyncTolerance t) = toText t
 
 instance FromText SyncTolerance where
-    fromText t = case T.splitOn "s" t of
-        [v,""] ->
-            maybe
-                (Left errSyncTolerance)
-                (Right . mkSyncTolerance)
-                (readMay $ T.unpack v)
-        _ ->
-            Left errSyncTolerance
+    fromText = bimap (const errSyncTolerance) SyncTolerance . fromText
       where
         errSyncTolerance = TextDecodingError $ unwords
             [ "Cannot parse given time duration. Here are a few examples of"

lib/jormungandr/exe/cardano-wallet-jormungandr.hs

@@ -37,7 +37,7 @@ import Cardano.CLI
     , cmdMnemonic
     , cmdNetwork
     , cmdStakePool
-    , cmdTransaction
+    , cmdTransactionJormungandr
     , cmdVersion
     , cmdWallet
     , cmdWalletCreate
@@ -182,7 +182,7 @@ main = withUtf8Encoding $ do
         <> cmdServe
         <> cmdMnemonic
         <> cmdWallet cmdWalletCreate walletClient
-        <> cmdTransaction transactionClient walletClient
+        <> cmdTransactionJormungandr transactionClient walletClient
         <> cmdAddress addressClient
         <> cmdStakePool @ApiStakePool stakePoolClient
         <> cmdNetwork networkClient

lib/text-class/src/Data/Text/Class.hs

@@ -37,7 +37,7 @@ import Prelude
 import Control.Monad
     ( unless, (<=<) )
 import Data.Bifunctor
-    ( first )
+    ( bimap, first )
 import Data.List
     ( find )
 import Data.List.Extra
@@ -48,6 +48,8 @@ import Data.Text
     ( Text )
 import Data.Text.Read
     ( decimal, signed )
+import Data.Time.Clock
+    ( NominalDiffTime )
 import Data.Word
     ( Word32, Word64 )
 import Data.Word.Odd
@@ -69,6 +71,10 @@ import qualified Data.Text.Lazy.Builder.Int as B
 import qualified Data.Text.Lazy.Builder.RealFloat as B
 import qualified Text.Casing as Casing
 
+{-------------------------------------------------------------------------------
+                                     Types
+-------------------------------------------------------------------------------}
+
 -- | Defines a textual encoding for a type.
 class ToText a where
     -- | Encode the specified value as text.
@@ -85,6 +91,14 @@ newtype TextDecodingError = TextDecodingError
     deriving stock (Eq, Show)
     deriving newtype Buildable
 
+-- | Decode the specified text with a 'Maybe' result type.
+fromTextMaybe :: FromText a => Text -> Maybe a
+fromTextMaybe = either (const Nothing) Just . fromText
+
+{-------------------------------------------------------------------------------
+                                   Instances
+-------------------------------------------------------------------------------}
+
 instance FromText String where
     fromText = pure . T.unpack
 
@@ -162,15 +176,30 @@ instance ToText Word32 where
 instance ToText Word31 where
     toText = intToText
 
+instance ToText NominalDiffTime where
+    toText = T.pack . show
+
+-- Note: This parser doesn't allow fractional or negative durations.
+instance FromText NominalDiffTime where
+    fromText t = case T.splitOn "s" t of
+        [v,""] -> bimap (const err) (fromIntegral @Natural) (fromText v)
+        _ -> Left err
+      where
+        err = TextDecodingError $ unwords
+            [ "Cannot parse given time duration."
+            , "Values must be given as whole positive seconds, and must"
+            , "finish with \"s\". For example: \"3s\", \"3600s\", \"42s\"."
+            ]
+
 realFloatToText :: RealFloat a => a -> T.Text
 realFloatToText = TL.toStrict . B.toLazyText . B.realFloat
 
 intToText :: Integral a => a -> T.Text
 intToText = TL.toStrict . B.toLazyText . B.decimal
 
--- | Decode the specified text with a 'Maybe' result type.
-fromTextMaybe :: FromText a => Text -> Maybe a
-fromTextMaybe = either (const Nothing) Just . fromText
+{-------------------------------------------------------------------------------
+                            Formatting enums as text
+-------------------------------------------------------------------------------}
 
 -- | Represents a case style for multi-word strings.
 data CaseStyle
@@ -252,6 +281,10 @@ fromCaseStyle = \case
     ensureFirstCharUpperCase s =
         (\c -> if C.isLower c then Nothing else Just s) =<< listToMaybe s
 
+{-------------------------------------------------------------------------------
+                                    Helpers
+-------------------------------------------------------------------------------}
+
 -- | Show a data-type through its 'ToText' instance
 showT :: ToText a => a -> String
 showT = T.unpack . toText

lib/text-class/test/unit/Data/Text/ClassSpec.hs

@@ -28,6 +28,8 @@ import Data.Text.Class
     , fromTextToBoundedEnum
     , toTextFromBoundedEnum
     )
+import Data.Time.Clock
+    ( NominalDiffTime )
 import Data.Word
     ( Word32 )
 import GHC.Generics
@@ -114,6 +116,7 @@ spec = do
         textRoundtrip $ Proxy @Int
         textRoundtrip $ Proxy @Text
         textRoundtrip $ Proxy @Word32
+        textRoundtrip $ Proxy @NominalDiffTime
 
     describe "BoundedEnum" $ do
         it "fromTextToBoundedEnum s (toTextFromBoundedEnum s a) == Right a" $
@@ -163,6 +166,10 @@ instance Arbitrary Natural where
     shrink = shrinkIntegral
     arbitrary = arbitrarySizedNatural
 
+instance Arbitrary NominalDiffTime where
+    shrink = fmap fromIntegral . shrink . fromIntegral @Natural @Natural . floor
+    arbitrary = fromIntegral @Natural <$> arbitrary
+
 data TestBoundedEnum
     = A
       -- ^ 1 char