Fix CLI support for TxValidityUpperBound

IntersectMBO · Oct 27, 2023 · eda3544 · eda3544
1 parent 486d011
commit eda3544
Show file tree

Hide file tree

Showing 9 changed files with 84 additions and 52 deletions.
diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Transaction.hs
@@ -62,7 +62,7 @@ data TransactionBuildRawCmdArgs era = TransactionBuildRawCmdArgs
     -- ^ Multi-Asset value with script witness
   , mValidityLowerBound   :: !(Maybe SlotNo)
     -- ^ Transaction validity lower bound
-  , mValidityUpperBound   :: !(Maybe SlotNo)
+  , mValidityUpperBound   :: !(TxValidityUpperBound era)
     -- ^ Transaction validity upper bound
   , fee                   :: !(Maybe Lovelace)
     -- ^ Transaction fee
@@ -110,7 +110,7 @@ data TransactionBuildCmdArgs era = TransactionBuildCmdArgs
     -- ^ Multi-Asset value with script witness
   , mValidityLowerBound     :: !(Maybe SlotNo)
     -- ^ Transaction validity lower bound
-  , mValidityUpperBound     :: !(Maybe SlotNo)
+  , mValidityUpperBound     :: !(TxValidityUpperBound era)
     -- ^ Transaction validity upper bound
   , certificates            :: ![(CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake))]
     -- ^ Certificates with potential script witness

diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs
@@ -2077,30 +2077,62 @@ pInvalidBefore = fmap SlotNo $ asum
     ]
   ]
 
-pInvalidHereafter :: Parser SlotNo
-pInvalidHereafter =
+pLegacyInvalidHereafter :: Parser SlotNo
+pLegacyInvalidHereafter =
   fmap SlotNo $ asum
-  [ Opt.option (bounded "SLOT") $ mconcat
-    [ Opt.long "invalid-hereafter"
-    , Opt.metavar "SLOT"
-    , Opt.help "Time that transaction is valid until (in slots)."
-    ]
-  , Opt.option (bounded "SLOT") $ mconcat
-    [ Opt.long "upper-bound"
-    , Opt.metavar "SLOT"
-    , Opt.help $ mconcat
-      [ "Time that transaction is valid until (in slots) "
-      , "(deprecated; use --invalid-hereafter instead)."
+    [ Opt.option (bounded "SLOT") $ mconcat
+      [ Opt.long "invalid-hereafter"
+      , Opt.metavar "SLOT"
+      , Opt.help "Time that transaction is valid until (in slots)."
+      ]
+    , Opt.option (bounded "SLOT") $ mconcat
+      [ Opt.long "upper-bound"
+      , Opt.metavar "SLOT"
+      , Opt.help $ mconcat
+        [ "Time that transaction is valid until (in slots) "
+        , "(deprecated; use --invalid-hereafter instead)."
+        ]
+      , Opt.internal
+      ]
+    , Opt.option (bounded "SLOT") $ mconcat
+      [ Opt.long "ttl"
+      , Opt.metavar "SLOT"
+      , Opt.help "Time to live (in slots) (deprecated; use --invalid-hereafter instead)."
+      , Opt.internal
       ]
-    , Opt.internal
-    ]
-  , Opt.option (bounded "SLOT") $ mconcat
-    [ Opt.long "ttl"
-    , Opt.metavar "SLOT"
-    , Opt.help "Time to live (in slots) (deprecated; use --invalid-hereafter instead)."
-    , Opt.internal
     ]
-  ]
+
+pInvalidHereafter :: ()
+  => CardanoEra era
+  -> Parser (TxValidityUpperBound era)
+pInvalidHereafter =
+  caseByronOrShelleyBasedEra
+    (pure . TxValidityNoUpperBound)
+    (\eon ->
+      fmap (TxValidityUpperBound eon) $ asum
+        [ fmap (Just . SlotNo) $ Opt.option (bounded "SLOT") $ mconcat
+          [ Opt.long "invalid-hereafter"
+          , Opt.metavar "SLOT"
+          , Opt.help "Time that transaction is valid until (in slots)."
+          ]
+        , fmap (Just . SlotNo) $ Opt.option (bounded "SLOT") $ mconcat
+          [ Opt.long "upper-bound"
+          , Opt.metavar "SLOT"
+          , Opt.help $ mconcat
+            [ "Time that transaction is valid until (in slots) "
+            , "(deprecated; use --invalid-hereafter instead)."
+            ]
+          , Opt.internal
+          ]
+        , fmap (Just . SlotNo) $ Opt.option (bounded "SLOT") $ mconcat
+          [ Opt.long "ttl"
+          , Opt.metavar "SLOT"
+          , Opt.help "Time to live (in slots) (deprecated; use --invalid-hereafter instead)."
+          , Opt.internal
+          ]
+        , pure Nothing
+        ]
+    )
 
 pTxFee :: Parser Lovelace
 pTxFee =

diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Transaction.hs
@@ -155,9 +155,9 @@ pTransactionBuildCmd era envCli = do
         ]
   where
     pCmd :: ShelleyBasedEra era ->  Parser (TransactionCmds era)
-    pCmd w =
+    pCmd sbe =
       fmap TransactionBuildCmd $
-        TransactionBuildCmdArgs w
+        TransactionBuildCmdArgs sbe
           <$> pSocketPath envCli
           <*> pConsensusModeParams
           <*> pNetworkId envCli
@@ -173,7 +173,7 @@ pTransactionBuildCmd era envCli = do
           <*> pChangeAddress
           <*> optional (pMintMultiAsset AutoBalance)
           <*> optional pInvalidBefore
-          <*> optional pInvalidHereafter
+          <*> pInvalidHereafter (shelleyBasedToCardanoEra sbe)
           <*> many (pCertificateFile AutoBalance)
           <*> many (pWithdrawal AutoBalance)
           <*> pTxMetadataJsonSchema
@@ -182,7 +182,7 @@ pTransactionBuildCmd era envCli = do
                       Nothing
                       "Filepath of auxiliary script(s)")
           <*> many pMetadataFile
-          <*> pFeatured (shelleyBasedToCardanoEra w) (optional pUpdateProposalFile)
+          <*> pFeatured (shelleyBasedToCardanoEra sbe) (optional pUpdateProposalFile)
           <*> many (pFileInDirection "vote-file" "Filepath of the vote.")
           <*> many (pFileInDirection "proposal-file" "Filepath of the proposal.")
           <*> (OutputTxBodyOnly <$> pTxBodyFileOut <|> pCalculatePlutusScriptCost)
@@ -209,7 +209,7 @@ pTransactionBuildRaw era =
       <*> many pTxOut
       <*> optional (pMintMultiAsset ManualBalance)
       <*> optional pInvalidBefore
-      <*> optional pInvalidHereafter
+      <*> pInvalidHereafter era
       <*> optional pTxFee
       <*> many (pCertificateFile ManualBalance )
       <*> many (pWithdrawal ManualBalance)

diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs
@@ -376,7 +376,7 @@ runTxBuildRaw :: ()
   -> [TxOut CtxTx era]
   -> Maybe SlotNo
   -- ^ Tx lower bound
-  -> Maybe SlotNo
+  -> TxValidityUpperBound era
   -- ^ Tx upper bound
   -> Maybe Lovelace
   -- ^ Tx fee
@@ -420,8 +420,6 @@ runTxBuildRaw era
       <- first TxCmdTxFeeValidationError $ validateTxFee era mFee
     validatedLowerBound
       <- first TxCmdTxValidityLowerBoundValidationError (validateTxValidityLowerBound era mLowerBound)
-    validatedUpperBound
-      <- first TxCmdTxValidityUpperBoundValidationError (validateTxValidityUpperBound era mUpperBound)
     validatedReqSigners
       <- first TxCmdRequiredSignersValidationError $ validateRequiredSigners era reqSigners
     validatedPParams
@@ -446,7 +444,7 @@ runTxBuildRaw era
             , txReturnCollateral = validatedRetCol
             , txFee = validatedFee
             , txValidityLowerBound = validatedLowerBound
-            , txValidityUpperBound = validatedUpperBound
+            , txValidityUpperBound = mUpperBound
             , txMetadata = txMetadata
             , txAuxScripts = txAuxScripts
             , txExtraKeyWits = validatedReqSigners
@@ -488,7 +486,7 @@ runTxBuild :: ()
   -- ^ Multi-Asset value(s)
   -> Maybe SlotNo
   -- ^ Tx lower bound
-  -> Maybe SlotNo
+  -> TxValidityUpperBound era
   -- ^ Tx upper bound
   -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))]
   -- ^ Certificate with potential script witness
@@ -532,7 +530,6 @@ runTxBuild
     <- hoistEither $ first TxCmdReturnCollateralValidationError $ validateTxReturnCollateral era mReturnCollateral
   dFee <- hoistEither $ first TxCmdTxFeeValidationError $ validateTxFee era dummyFee
   validatedLowerBound <- hoistEither (first TxCmdTxValidityLowerBoundValidationError (validateTxValidityLowerBound era mLowerBound))
-  validatedUpperBound <- hoistEither (first TxCmdTxValidityUpperBoundValidationError (validateTxValidityUpperBound era mUpperBound))
   validatedReqSigners <- hoistEither (first TxCmdRequiredSignersValidationError $ validateRequiredSigners era reqSigners)
   validatedTxWtdrwls <- hoistEither (first TxCmdTxWithdrawalsValidationError $ validateTxWithdrawals era withdrawals)
   validatedTxCerts <- hoistEither (first TxCmdTxCertificatesValidationError $ validateTxCertificates era certsAndMaybeScriptWits)
@@ -583,7 +580,7 @@ runTxBuild
               , txReturnCollateral = validatedRetCol
               , txFee = dFee
               , txValidityLowerBound = validatedLowerBound
-              , txValidityUpperBound = validatedUpperBound
+              , txValidityUpperBound = mUpperBound
               , txMetadata = txMetadata
               , txAuxScripts = txAuxScripts
               , txExtraKeyWits = validatedReqSigners

diff --git a/cardano-cli/src/Cardano/CLI/Json/Friendly.hs b/cardano-cli/src/Cardano/CLI/Json/Friendly.hs
@@ -188,21 +188,11 @@ friendlyExtraKeyWits = \case
   TxExtraKeyWitnessesNone -> Null
   TxExtraKeyWitnesses _supported paymentKeyHashes -> toJSON paymentKeyHashes
 
--- | Special case of validity range:
--- in Shelley, upper bound is TTL, and no lower bound
-pattern ShelleyTtl
-  :: Maybe SlotNo -> (TxValidityLowerBound era, TxValidityUpperBound era)
-pattern ShelleyTtl ttl <-
-  ( TxValidityNoLowerBound
-  , TxValidityUpperBound _ ttl
-  )
-
 friendlyValidityRange
   :: CardanoEra era
   -> (TxValidityLowerBound era, TxValidityUpperBound era)
   -> Aeson.Value
 friendlyValidityRange era = \case
-  ShelleyTtl ttl -> object ["time to live" .= ttl]
   (lowerBound, upperBound)
     | isLowerBoundSupported || isUpperBoundSupported ->
         object

diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Options.hs b/cardano-cli/src/Cardano/CLI/Legacy/Options.hs
@@ -324,7 +324,7 @@ pTransaction envCli =
       <*> pChangeAddress
       <*> optional (pMintMultiAsset AutoBalance)
       <*> optional pInvalidBefore
-      <*> optional pInvalidHereafter
+      <*> optional pLegacyInvalidHereafter
       <*> many (pCertificateFile AutoBalance)
       <*> many (pWithdrawal AutoBalance)
       <*> pTxMetadataJsonSchema
@@ -360,7 +360,7 @@ pTransaction envCli =
       <*> many pTxOut
       <*> optional (pMintMultiAsset ManualBalance)
       <*> optional pInvalidBefore
-      <*> optional pInvalidHereafter
+      <*> optional pLegacyInvalidHereafter
       <*> optional pTxFee
       <*> many (pCertificateFile ManualBalance )
       <*> many (pWithdrawal ManualBalance)

diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs
@@ -104,11 +104,13 @@ runLegacyTransactionBuildCmd
       & hoistEither
       & firstExceptT TxCmdTxUpdateProposalValidationError
 
+  let upperBound = TxValidityUpperBound sbe mUpperBound
+
   runTransactionBuildCmd
     ( Cmd.TransactionBuildCmdArgs sbe socketPath
         consensusModeParams nid mScriptValidity mOverrideWits txins readOnlyRefIns
         reqSigners txinsc mReturnColl mTotCollateral txouts changeAddr mValue mLowBound
-        mUpperBound certs wdrls metadataSchema scriptFiles metadataFiles mfUpdateProposalFile voteFiles
+        upperBound certs wdrls metadataSchema scriptFiles metadataFiles mfUpdateProposalFile voteFiles
         proposalFiles outputOptions
     )
 
@@ -136,7 +138,7 @@ runLegacyTransactionBuildRawCmd :: ()
   -> TxBodyFile Out
   -> ExceptT TxCmdError IO ()
 runLegacyTransactionBuildRawCmd
-    (AnyCardanoEra era) mScriptValidity txins readOnlyRefIns txinsc mReturnColl
+    anyEra@(AnyCardanoEra era) mScriptValidity txins readOnlyRefIns txinsc mReturnColl
     mTotColl reqSigners txouts mValue mLowBound mUpperBound fee certs wdrls
     metadataSchema scriptFiles metadataFiles mProtocolParamsFile mUpdateProposal
     outFile = do
@@ -146,10 +148,19 @@ runLegacyTransactionBuildRawCmd
       & hoistEither
       & firstExceptT TxCmdTxUpdateProposalValidationError
 
+  upperBound <-
+    caseByronOrShelleyBasedEra
+      (\w -> case mUpperBound of
+        Nothing -> pure $ TxValidityNoUpperBound w
+        Just _ -> left $ TxCmdTxValidityUpperBoundValidationError $ TxValidityUpperBoundNotSupported anyEra
+      )
+      (\w -> pure $ TxValidityUpperBound w mUpperBound)
+      era
+
   runTransactionBuildRawCmd
     ( Cmd.TransactionBuildRawCmdArgs
         era mScriptValidity txins readOnlyRefIns txinsc mReturnColl
-        mTotColl reqSigners txouts mValue mLowBound mUpperBound fee certs wdrls
+        mTotColl reqSigners txouts mValue mLowBound upperBound fee certs wdrls
         metadataSchema scriptFiles metadataFiles mProtocolParamsFile mfUpdateProposalFile [] []
         outFile
     )

diff --git a/cardano-cli/test/cardano-cli-golden/files/golden/allegra/transaction-view.out b/cardano-cli/test/cardano-cli-golden/files/golden/allegra/transaction-view.out
@@ -22,5 +22,6 @@ return collateral: null
 total collateral: null
 update proposal: null
 validity range:
-  time to live: 101
+  lower bound: null
+  upper bound: 101
 withdrawals: null
diff --git a/cardano-cli/test/cardano-cli-golden/files/golden/shelley/transaction-view.out b/cardano-cli/test/cardano-cli-golden/files/golden/shelley/transaction-view.out
@@ -72,7 +72,8 @@ update proposal:
       transaction fee linear per byte: 76
       treasury expansion: 87/88
 validity range:
-  time to live: 33
+  lower bound: null
+  upper bound: 33
 withdrawals:
 - address: stake_test1up00fz9lyqs5sjks82k22eqz7a9srym9vysjgp3h2ua2v2cm522kg
   amount: 42 Lovelace