[wip] - validityRange split

IntersectMBO · Oct 26, 2023 · cd50a2b · cd50a2b
1 parent 04bd8aa
commit cd50a2b
Show file tree

Hide file tree

Showing 4 changed files with 83 additions and 45 deletions.
diff --git a/cardano-cli/src/Cardano/CLI/Byron/Tx.hs b/cardano-cli/src/Cardano/CLI/Byron/Tx.hs
@@ -158,10 +158,8 @@ txSpendGenesisUTxOByronPBFT gc nId sk (ByronAddress bAddr) outs = do
             , txTotalCollateral = TxTotalCollateralNone
             , txReturnCollateral = TxReturnCollateralNone
             , txFee = TxFeeImplicit ByronEraOnlyByron
-            , txValidityRange =
-                ( TxValidityNoLowerBound
-                , defaultTxValidityUpperBound ByronEra
-                )
+            , txValidityLowerBound = TxValidityNoLowerBound
+            , txValidityUpperBound = defaultTxValidityUpperBound ByronEra
             , txMetadata = TxMetadataNone
             , txAuxScripts = TxAuxScriptsNone
             , txExtraKeyWits = TxExtraKeyWitnessesNone
@@ -207,10 +205,8 @@ txSpendUTxOByronPBFT nId sk txIns outs = do
           , txTotalCollateral = TxTotalCollateralNone
           , txReturnCollateral = TxReturnCollateralNone
           , txFee = TxFeeImplicit ByronEraOnlyByron
-          , txValidityRange =
-              ( TxValidityNoLowerBound
-              , defaultTxValidityUpperBound ByronEra
-              )
+          , txValidityLowerBound = TxValidityNoLowerBound
+          , txValidityUpperBound = defaultTxValidityUpperBound ByronEra
           , txMetadata = TxMetadataNone
           , txAuxScripts = TxAuxScriptsNone
           , txExtraKeyWits = TxExtraKeyWitnessesNone

diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs
@@ -418,8 +418,10 @@ runTxBuildRaw era
       <- first TxCmdReturnCollateralValidationError $ validateTxReturnCollateral era mReturnCollateral
     validatedFee
       <- first TxCmdTxFeeValidationError $ validateTxFee era mFee
-    validatedBounds <- (,) <$> first TxCmdTxValidityLowerBoundValidationError (validateTxValidityLowerBound era mLowerBound)
-                           <*> first TxCmdTxValidityUpperBoundValidationError (validateTxValidityUpperBound era mUpperBound)
+    validatedLowerBound
+      <- first TxCmdTxValidityLowerBoundValidationError (validateTxValidityLowerBound era mLowerBound)
+    validatedUpperBound
+      <- first TxCmdTxValidityUpperBoundValidationError (validateTxValidityUpperBound era mUpperBound)
     validatedReqSigners
       <- first TxCmdRequiredSignersValidationError $ validateRequiredSigners era reqSigners
     validatedPParams
@@ -443,7 +445,8 @@ runTxBuildRaw era
             , txTotalCollateral = validatedTotCollateral
             , txReturnCollateral = validatedRetCol
             , txFee = validatedFee
-            , txValidityRange = validatedBounds
+            , txValidityLowerBound = validatedLowerBound
+            , txValidityUpperBound = validatedUpperBound
             , txMetadata = txMetadata
             , txAuxScripts = txAuxScripts
             , txExtraKeyWits = validatedReqSigners
@@ -528,8 +531,8 @@ runTxBuild
   validatedRetCol
     <- hoistEither $ first TxCmdReturnCollateralValidationError $ validateTxReturnCollateral era mReturnCollateral
   dFee <- hoistEither $ first TxCmdTxFeeValidationError $ validateTxFee era dummyFee
-  validatedBounds <- (,) <$> hoistEither (first TxCmdTxValidityLowerBoundValidationError $ validateTxValidityLowerBound era mLowerBound)
-                         <*> hoistEither (first TxCmdTxValidityUpperBoundValidationError $ validateTxValidityUpperBound era mUpperBound)
+  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)
@@ -579,7 +582,8 @@ runTxBuild
               , txTotalCollateral = validatedTotCollateral
               , txReturnCollateral = validatedRetCol
               , txFee = dFee
-              , txValidityRange = validatedBounds
+              , txValidityLowerBound = validatedLowerBound
+              , txValidityUpperBound = validatedUpperBound
               , 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
@@ -10,6 +10,12 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeOperators #-}
 
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# OPTIONS_GHC -Wno-unused-matches #-}
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+{-# OPTIONS_GHC -Wno-unused-local-binds #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
+
 -- | User-friendly pretty-printing for textual user interfaces (TUI)
 module Cardano.CLI.Json.Friendly
   ( friendlyTx
@@ -151,7 +157,8 @@ friendlyTxBodyImpl
       , txReturnCollateral
       , txInsReference
       , txUpdateProposal
-      , txValidityRange
+      , txValidityLowerBound
+       ,txValidityUpperBound
       , txWithdrawals
       }) =
     [ "auxiliary scripts" .= friendlyAuxScripts txAuxScripts
@@ -169,7 +176,8 @@ friendlyTxBodyImpl
     , "required signers (payment key hashes needed for scripts)" .=
         friendlyExtraKeyWits txExtraKeyWits
     , "update proposal" .= friendlyUpdateProposal txUpdateProposal
-    , "validity range" .= friendlyValidityRange era txValidityRange
+    , "validity lower bound" .= friendlyValidityLowerBound era txValidityLowerBound
+    , "validity upper bound" .= friendlyValidityUpperBound era txValidityUpperBound
     , "withdrawals" .= friendlyWithdrawals txWithdrawals
     ]
 
@@ -187,37 +195,67 @@ 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
-  :: SlotNo -> (TxValidityLowerBound era, TxValidityUpperBound era)
-pattern ShelleyTtl ttl <-
-  ( TxValidityNoLowerBound
-  , TxValidityUpperBound _ ttl
-  )
+-- -- | 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
+friendlyValidityLowerBound
   :: CardanoEra era
-  -> (TxValidityLowerBound era, TxValidityUpperBound era)
+  -> TxValidityLowerBound era
   -> Aeson.Value
-friendlyValidityRange era = \case
-  ShelleyTtl ttl -> object ["time to live" .= ttl]
-  (lowerBound, upperBound)
-    | isLowerBoundSupported || isUpperBoundSupported ->
-        object
-          [ "lower bound" .=
-                case lowerBound of
-                  TxValidityNoLowerBound -> Null
-                  TxValidityLowerBound _ s -> toJSON s
-          , "upper bound" .=
-              case upperBound of
-                TxValidityNoUpperBound _ -> Null
-                TxValidityUpperBound _ s -> toJSON s
-          ]
-    | otherwise -> Null
- where
-  isLowerBoundSupported = isJust $ inEonForEraMaybe TxValidityLowerBound era
-  isUpperBoundSupported = isJust $ inEonForEraMaybe TxValidityUpperBound era
+friendlyValidityLowerBound era =  \case 
+  TxValidityNoLowerBound ->  Null
+  TxValidityLowerBound _ s -> if isLowerBoundSupported then toJSON s else Null
+    where isLowerBoundSupported = isJust $ inEonForEraMaybe TxValidityLowerBound era
+-- friendlyValidityLowerBound era = \case
+--   ShelleyTtl ttl -> object ["time to live" .= ttl]
+--   (TxValidityNoLowerBound, TxValidityUpperBound _ ttl) -> object ["time to live" .= ttl]
+--   (lowerBound, upperBound)
+--     | isLowerBoundSupported || isUpperBoundSupported ->
+--         object
+--           [ "lower bound" .=
+--                 case lowerBound of
+--                   TxValidityNoLowerBound -> Null
+--                   TxValidityLowerBound _ s -> toJSON s
+--           , "upper bound" .=
+--               case upperBound of
+--                 TxValidityNoUpperBound _ -> Null
+--                 TxValidityUpperBound _ s -> toJSON s
+--           ]
+--     | otherwise -> Null
+--  where
+--   isLowerBoundSupported = isJust $ inEonForEraMaybe TxValidityLowerBound era
+--   isUpperBoundSupported = isJust $ inEonForEraMaybe TxValidityUpperBound era
+
+friendlyValidityUpperBound
+  :: CardanoEra era
+  -> TxValidityUpperBound era
+  -> Aeson.Value
+friendlyValidityUpperBound era = undefined 
+  -- where isLowerBoundSupported = isJust $ inEonForEraMaybe TxValidityLowerBound era
+-- friendlyValidityUpperBound era = \case
+--   ShelleyTtl ttl -> object ["time to live" .= ttl]
+--   (lowerBound, upperBound)
+--     | isLowerBoundSupported || isUpperBoundSupported ->
+--         object
+--           [ "lower bound" .=
+--                 case lowerBound of
+--                   TxValidityNoLowerBound -> Null
+--                   TxValidityLowerBound _ s -> toJSON s
+--           , "upper bound" .=
+--               case upperBound of
+--                 TxValidityNoUpperBound _ -> Null
+--                 TxValidityUpperBound _ s -> toJSON s
+--           ]
+--     | otherwise -> Null
+--  where
+--   isLowerBoundSupported = isJust $ inEonForEraMaybe TxValidityLowerBound era
+--   isUpperBoundSupported = isJust $ inEonForEraMaybe TxValidityUpperBound era
 
 friendlyWithdrawals :: TxWithdrawals ViewTx era -> Aeson.Value
 friendlyWithdrawals TxWithdrawalsNone = Null

diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs
@@ -157,7 +157,7 @@ validateTxValidityUpperBound
 validateTxValidityUpperBound era = \case
   Just slot -> do
     supported <- conjureWitness era TxValidityUpperBoundNotSupported
-    pure $ TxValidityUpperBound supported slot
+    pure $ TxValidityUpperBound supported (Just slot)
   Nothing -> do
     supported <- conjureWitness era TxValidityUpperBoundNotSupported
     pure $ TxValidityNoUpperBound supported