Propagate changes related to removing support for specifying a byron

collateral return output
IntersectMBO · Nov 16, 2023 · b1fcca9 · b1fcca9
1 parent d756cab
commit b1fcca9
Show file tree

Hide file tree

Showing 3 changed files with 118 additions and 37 deletions.
diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs
@@ -1848,9 +1848,9 @@ pTxInCollateral =
       <> Opt.help "TxId#TxIx"
       )
 
-pReturnCollateral :: Parser TxOutAnyEra
+pReturnCollateral :: Parser TxOutShelleyBasedEra
 pReturnCollateral =
-  Opt.option (readerFromParsecParser parseTxOutAnyEra)
+  Opt.option (readerFromParsecParser parseTxOutShelleyBasedEra)
           ( mconcat
             [ Opt.long "tx-out-return-collateral"
             , Opt.metavar "ADDRESS VALUE"
@@ -1899,6 +1899,19 @@ pTxOut =
     <*> pTxOutDatum
     <*> pRefScriptFp
 
+pTxOutShelleyBased :: Parser TxOutShelleyBasedEra
+pTxOutShelleyBased =
+  Opt.option (readerFromParsecParser parseTxOutShelleyBasedEra)
+          (  Opt.long "tx-out"
+          <> Opt.metavar "ADDRESS VALUE"
+          -- TODO alonzo: Update the help text to describe the new syntax as well.
+          <> Opt.help "The transaction output as ADDRESS VALUE where ADDRESS is \
+                      \the Bech32-encoded address followed by the value in \
+                      \Lovelace."
+          )
+    <*> pTxOutDatum
+    <*> pRefScriptFp
+
 pTxOutDatum :: Parser TxOutDatumAnyEra
 pTxOutDatum =
       pTxOutDatumByHashOnly
@@ -2998,6 +3011,25 @@ pDRepActivity =
     , Opt.help "TODO"
     ]
 
+parseTxOutShelleyBasedEra
+  :: Parsec.Parser (TxOutDatumAnyEra -> ReferenceScriptAnyEra -> TxOutShelleyBasedEra)
+parseTxOutShelleyBasedEra = do
+    addr <- parseShelleyAddress
+    Parsec.spaces
+    -- Accept the old style of separating the address and value in a
+    -- transaction output:
+    Parsec.option () (Parsec.char '+' >> Parsec.spaces)
+    val <- parseValue
+    return (TxOutShelleyBasedEra addr val)
+
+parseShelleyAddress :: Parsec.Parser (Address ShelleyAddr)
+parseShelleyAddress = do
+    str <- lexPlausibleAddressString
+    case deserialiseAddress AsShelleyAddress str of
+      Nothing   -> fail $ "invalid address: " <> Text.unpack str
+      Just addr -> pure addr
+
+
 parseTxOutAnyEra
   :: Parsec.Parser (TxOutDatumAnyEra -> ReferenceScriptAnyEra -> TxOutAnyEra)
 parseTxOutAnyEra = do

diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE EmptyCase #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
@@ -164,7 +165,7 @@ runTransactionBuildCmd
     _ -> pure TxUpdateProposalNone
 
   requiredSigners  <- mapM (firstExceptT TxCmdRequiredSignerError .  newExceptT . readRequiredSigner) reqSigners
-  mReturnCollateral <- forM mReturnColl $ toTxOutInAnyEra era
+  mReturnCollateral <- forM mReturnColl $ toTxOutInShelleyBasedEra eon
 
   txOuts <- mapM (toTxOutInAnyEra era) txouts
 
@@ -319,7 +320,11 @@ runTransactionBuildRawCmd
     _ -> pure TxUpdateProposalNone
 
   requiredSigners  <- mapM (firstExceptT TxCmdRequiredSignerError .  newExceptT . readRequiredSigner) reqSigners
-  mReturnCollateral <- forM mReturnColl $ toTxOutInAnyEra eon
+
+  mReturnCollateral <- forEraInEon eon (pure Nothing) $ \sbe ->
+                        forM mReturnColl $ toTxOutInShelleyBasedEra sbe
+
+  -- NB: We need to be able to construct txs in Byron to other Byron addresses
   txOuts <- mapM (toTxOutInAnyEra eon) txouts
 
     -- the same collateral input can be used for several plutus scripts
@@ -690,6 +695,14 @@ toAddressInAnyEra era addrAny = runExcept $ do
       pure (AddressInEra (ShelleyAddressInEra sbe) sAddr)
 
 
+toAddressInShelleyBasedEra
+  :: ShelleyBasedEra era
+  -> Address ShelleyAddr
+  -> Either TxCmdError (AddressInEra era)
+toAddressInShelleyBasedEra sbe sAddr = runExcept $
+      pure (AddressInEra (ShelleyAddressInEra sbe) sAddr)
+
+
 lovelaceToCoin :: Lovelace -> Ledger.Coin
 lovelaceToCoin (Lovelace ll) = Ledger.Coin ll
 
@@ -698,10 +711,10 @@ toTxOutValueInAnyEra
   -> Value
   -> Either TxCmdError (TxOutValue era)
 toTxOutValueInAnyEra era val =
-  caseByronOrShelleyBasedEra
-    (\w ->
+ caseByronOrShelleyBasedEra
+    (const $
       case valueToLovelace val of
-        Just l  -> return (TxOutValueByron w l)
+        Just l  -> return (TxOutValueByron l)
         Nothing -> txFeatureMismatchPure era TxFeatureMultiAssetOutputs
     )
     (\sbe ->
@@ -715,7 +728,46 @@ toTxOutValueInAnyEra era val =
         sbe
     )
     era
+toTxOutValueInShelleyBasedEra
+  :: ShelleyBasedEra era
+  -> Value
+  -> Either TxCmdError (TxOutValue era)
+toTxOutValueInShelleyBasedEra sbe val =
+  caseShelleyToAllegraOrMaryEraOnwards
+    (\_ -> case valueToLovelace val of
+      Just l  -> return (TxOutValueShelleyBased sbe $ lovelaceToCoin l)
+      Nothing -> txFeatureMismatchPure (toCardanoEra sbe) TxFeatureMultiAssetOutputs
+    )
+    (\w -> return (TxOutValueShelleyBased sbe (toLedgerValue w val))
+    )
+    sbe
+
 
+toTxOutInShelleyBasedEra
+  :: ShelleyBasedEra era
+  -> TxOutShelleyBasedEra
+  -> ExceptT TxCmdError IO (TxOut CtxTx era)
+toTxOutInShelleyBasedEra era (TxOutShelleyBasedEra addr' val' mDatumHash refScriptFp) = do
+  addr <- hoistEither $ toAddressInShelleyBasedEra era addr'
+  val <- hoistEither $ toTxOutValueInShelleyBasedEra era val'
+
+  datum <-
+    caseShelleyToMaryOrAlonzoEraOnwards
+      (const (pure TxOutDatumNone))
+      (\wa -> toTxAlonzoDatum wa mDatumHash)
+      era
+
+  refScript <- inEonForEra
+                 (pure ReferenceScriptNone)
+                 (\wb -> getReferenceScript wb refScriptFp)
+                 (toCardanoEra era)
+
+  pure $ TxOut addr val datum refScript
+
+
+-- TODO: toTxOutInAnyEra eventually will not be needed because
+-- byron related functionality will be treated
+-- separately
 toTxOutInAnyEra :: CardanoEra era
                 -> TxOutAnyEra
                 -> ExceptT TxCmdError IO (TxOut CtxTx era)
@@ -735,37 +787,35 @@ toTxOutInAnyEra era (TxOutAnyEra addr' val' mDatumHash refScriptFp) = do
     (const (pure ReferenceScriptNone))
     (\wb -> getReferenceScript wb refScriptFp)
     era
-
   pure $ TxOut addr val datum refScript
 
-  where
-    getReferenceScript :: ()
-      => BabbageEraOnwards era
-      -> ReferenceScriptAnyEra
-      -> ExceptT TxCmdError IO (ReferenceScript era)
-    getReferenceScript w = \case
-      ReferenceScriptAnyEraNone -> return ReferenceScriptNone
-      ReferenceScriptAnyEra fp -> ReferenceScript w <$> firstExceptT TxCmdScriptFileError (readFileScriptInAnyLang fp)
-
-    toTxAlonzoDatum :: ()
-      => AlonzoEraOnwards era
-      -> TxOutDatumAnyEra
-      -> ExceptT TxCmdError IO (TxOutDatum CtxTx era)
-    toTxAlonzoDatum supp cliDatum =
-      case cliDatum of
-        TxOutDatumByNone -> pure TxOutDatumNone
-        TxOutDatumByHashOnly h -> pure (TxOutDatumHash supp h)
-        TxOutDatumByHashOf sDataOrFile -> do
-          sData <- firstExceptT TxCmdScriptDataError $ readScriptDataOrFile sDataOrFile
-          pure (TxOutDatumHash supp $ hashScriptDataBytes sData)
-        TxOutDatumByValue sDataOrFile -> do
-          sData <- firstExceptT TxCmdScriptDataError $ readScriptDataOrFile sDataOrFile
-          pure (TxOutDatumInTx supp sData)
-        TxOutInlineDatumByValue sDataOrFile -> do
-          let cEra = alonzoEraOnwardsToCardanoEra supp
-          forEraInEon cEra (txFeatureMismatch cEra TxFeatureInlineDatums) $ \babbageOnwards -> do
-            sData <- firstExceptT TxCmdScriptDataError $ readScriptDataOrFile sDataOrFile
-            pure $ TxOutDatumInline babbageOnwards sData
+getReferenceScript :: ()
+  => BabbageEraOnwards era
+  -> ReferenceScriptAnyEra
+  -> ExceptT TxCmdError IO (ReferenceScript era)
+getReferenceScript w = \case
+  ReferenceScriptAnyEraNone -> return ReferenceScriptNone
+  ReferenceScriptAnyEra fp -> ReferenceScript w <$> firstExceptT TxCmdScriptFileError (readFileScriptInAnyLang fp)
+
+toTxAlonzoDatum :: ()
+  => AlonzoEraOnwards era
+  -> TxOutDatumAnyEra
+  -> ExceptT TxCmdError IO (TxOutDatum CtxTx era)
+toTxAlonzoDatum supp cliDatum =
+  case cliDatum of
+    TxOutDatumByNone -> pure TxOutDatumNone
+    TxOutDatumByHashOnly h -> pure (TxOutDatumHash supp h)
+    TxOutDatumByHashOf sDataOrFile -> do
+      sData <- firstExceptT TxCmdScriptDataError $ readScriptDataOrFile sDataOrFile
+      pure (TxOutDatumHash supp $ hashScriptDataBytes sData)
+    TxOutDatumByValue sDataOrFile -> do
+      sData <- firstExceptT TxCmdScriptDataError $ readScriptDataOrFile sDataOrFile
+      pure (TxOutDatumInTx supp sData)
+    TxOutInlineDatumByValue sDataOrFile -> do
+      let cEra = alonzoEraOnwardsToCardanoEra supp
+      forEraInEon cEra (txFeatureMismatch cEra TxFeatureInlineDatums) $ \babbageOnwards -> do
+        sData <- firstExceptT TxCmdScriptDataError $ readScriptDataOrFile sDataOrFile
+        pure $ TxOutDatumInline babbageOnwards sData
 
 -- TODO: Currently we specify the policyId with the '--mint' option on the cli
 -- and we added a separate '--policy-id' parser that parses the policy id for the

diff --git a/cardano-cli/src/Cardano/CLI/Json/Friendly.hs b/cardano-cli/src/Cardano/CLI/Json/Friendly.hs
@@ -5,7 +5,6 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeOperators #-}