Skip to content

Commit

Permalink
Merge pull request #4823 from input-output-hk/newhoggy/straight-line-…
Browse files Browse the repository at this point in the history 
…code-for-tx-commands

Straight line code for tx commands
  • Loading branch information
@newhoggy
newhoggy committed Mar 20, 2023
2 parents 18d5ce9 + 8cf9027 commit 7f52046
Showing 1 changed file with 80 additions and 100 deletions.
180 changes: 80 additions & 100 deletions cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -18,11 +18,12 @@ module Cardano.CLI.Shelley.Run.Transaction
, toTxOutInAnyEra
) where

import Control.Monad (forM_, void)
import Control.Monad (forM, forM_, void)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans (MonadTrans (..))
import Control.Monad.Trans.Except (ExceptT)
import Control.Monad.Trans.Except.Extra (firstExceptT, hoistEither, hoistMaybe, left,
newExceptT, onNothing)
newExceptT, onLeft, onNothing)
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Bifunctor (Bifunctor (..))
import qualified Data.ByteString.Char8 as BS
Expand Down Expand Up @@ -349,18 +350,16 @@ runTxBuildCmd
-- We cannot use the user specified era to construct a query against a node because it may differ
-- from the node's era and this will result in the 'QueryEraMismatch' failure.

SocketPath sockPath <- firstExceptT ShelleyTxCmdSocketEnvError
$ newExceptT readEnvSocketPath
SocketPath sockPath <- lift readEnvSocketPath & onLeft (left . ShelleyTxCmdSocketEnvError)

let localNodeConnInfo = LocalNodeConnectInfo
{ localConsensusModeParams = cModeParams
, localNodeNetworkId = nid
, localNodeSocketPath = sockPath
}

AnyCardanoEra nodeEra
<- firstExceptT (ShelleyTxCmdQueryConvenienceError . AcqFailure)
. newExceptT $ determineEra cModeParams localNodeConnInfo
AnyCardanoEra nodeEra <- lift (determineEra cModeParams localNodeConnInfo)
& onLeft (left . ShelleyTxCmdQueryConvenienceError . AcqFailure)

inputsAndMaybeScriptWits <- firstExceptT ShelleyTxCmdScriptWitnessError $ readScriptWitnessFiles cEra txins
certFilesAndMaybeScriptWits <- firstExceptT ShelleyTxCmdScriptWitnessError $ readScriptWitnessFiles cEra certs
Expand All @@ -377,19 +376,13 @@ runTxBuildCmd
scripts <- firstExceptT ShelleyTxCmdScriptFileError $
mapM (readFileScriptInAnyLang . unScriptFile) scriptFiles
txAuxScripts <- hoistEither $ first ShelleyTxCmdAuxScriptsValidationError $ validateTxAuxScripts cEra scripts
mpparams <- case mPparams of
Just ppFp -> Just <$> firstExceptT ShelleyTxCmdProtocolParamsError (readProtocolParametersSourceSpec ppFp)
Nothing -> return Nothing

mProp <- case mUpProp of
Just (UpdateProposalFile upFp) ->
Just <$> firstExceptT ShelleyTxCmdReadTextViewFileError
(newExceptT $ readFileTextEnvelope AsUpdateProposal upFp)
Nothing -> return Nothing
mpparams <- forM mPparams $ \ppFp ->
firstExceptT ShelleyTxCmdProtocolParamsError (readProtocolParametersSourceSpec ppFp)

mProp <- forM mUpProp $ \(UpdateProposalFile upFp) ->
firstExceptT ShelleyTxCmdReadTextViewFileError (newExceptT $ readFileTextEnvelope AsUpdateProposal upFp)
requiredSigners <- mapM (firstExceptT ShelleyTxCmdRequiredSignerError . newExceptT . readRequiredSigner) reqSigners
mReturnCollateral <- case mReturnColl of
Just retCol -> Just <$> toTxOutInAnyEra cEra retCol
Nothing -> return Nothing
mReturnCollateral <- forM mReturnColl $ toTxOutInAnyEra cEra

txOuts <- mapM (toTxOutInAnyEra cEra) txouts

Expand Down Expand Up @@ -419,46 +412,47 @@ runTxBuildCmd
case outputOptions of
OutputScriptCostOnly fp -> do
let BuildTxWith mTxProtocolParams = txProtocolParams txBodycontent
case mTxProtocolParams of
Just pparams ->
case protocolParamPrices pparams of
Just executionUnitPrices -> do
let consensusMode = consensusModeOnly cModeParams
bpp = bundleProtocolParams cEra pparams
case consensusMode of
CardanoMode -> do
(nodeEraUTxO, _, eraHistory, systemStart, _)
<- firstExceptT ShelleyTxCmdQueryConvenienceError
. newExceptT $ queryStateForBalancedTx nodeEra nid allTxInputs
-- Why do we cast the era? The user can specify an era prior to the era that the node is currently in.
-- We cannot use the user specified era to construct a query against a node because it may differ
-- from the node's era and this will result in the 'QueryEraMismatch' failure.
txEraUtxo <-
case first ShelleyTxCmdTxEraCastErr (eraCast cEra nodeEraUTxO) of
Right txEraUtxo -> return txEraUtxo
Left e -> left e

scriptExecUnitsMap <-
firstExceptT ShelleyTxCmdTxExecUnitsErr $ hoistEither
$ evaluateTransactionExecutionUnits
systemStart (toLedgerEpochInfo eraHistory)
bpp txEraUtxo balancedTxBody

scriptCostOutput <-
firstExceptT ShelleyTxCmdPlutusScriptCostErr $ hoistEither
$ renderScriptCosts
txEraUtxo
executionUnitPrices
(collectTxBodyScriptWitnesses txBodycontent)
scriptExecUnitsMap
liftIO $ LBS.writeFile fp $ encodePretty scriptCostOutput
_ -> left ShelleyTxCmdPlutusScriptsRequireCardanoMode
Nothing -> left ShelleyTxCmdPParamExecutionUnitsNotAvailable
Nothing -> left ShelleyTxCmdProtocolParametersNotPresentInTxBody

pparams <- pure mTxProtocolParams & onNothing (left ShelleyTxCmdProtocolParametersNotPresentInTxBody)


executionUnitPrices <- pure (protocolParamPrices pparams) & onNothing (left ShelleyTxCmdPParamExecutionUnitsNotAvailable)

let consensusMode = consensusModeOnly cModeParams
bpp = bundleProtocolParams cEra pparams

case consensusMode of
CardanoMode -> do
(nodeEraUTxO, _, eraHistory, systemStart, _) <-
lift (queryStateForBalancedTx nodeEra nid allTxInputs)
& onLeft (left . ShelleyTxCmdQueryConvenienceError)

-- Why do we cast the era? The user can specify an era prior to the era that the node is currently in.
-- We cannot use the user specified era to construct a query against a node because it may differ
-- from the node's era and this will result in the 'QueryEraMismatch' failure.
txEraUtxo <- pure (eraCast cEra nodeEraUTxO) & onLeft (left . ShelleyTxCmdTxEraCastErr)

scriptExecUnitsMap <-
firstExceptT ShelleyTxCmdTxExecUnitsErr $ hoistEither
$ evaluateTransactionExecutionUnits
systemStart (toLedgerEpochInfo eraHistory)
bpp txEraUtxo balancedTxBody

scriptCostOutput <-
firstExceptT ShelleyTxCmdPlutusScriptCostErr $ hoistEither
$ renderScriptCosts
txEraUtxo
executionUnitPrices
(collectTxBodyScriptWitnesses txBodycontent)
scriptExecUnitsMap
liftIO $ LBS.writeFile fp $ encodePretty scriptCostOutput
_ -> left ShelleyTxCmdPlutusScriptsRequireCardanoMode

OutputTxBodyOnly (TxBodyFile fpath) ->
let noWitTx = makeSignedTransaction [] balancedTxBody
in firstExceptT ShelleyTxCmdWriteFileError . newExceptT $
writeTxFileTextEnvelopeCddl fpath noWitTx
in lift (writeTxFileTextEnvelopeCddl fpath noWitTx)
& onLeft (left . ShelleyTxCmdWriteFileError)


runTxBuildRawCmd
:: AnyCardanoEra
Expand Down Expand Up @@ -504,18 +498,15 @@ runTxBuildRawCmd
scripts <- firstExceptT ShelleyTxCmdScriptFileError $
mapM (readFileScriptInAnyLang . unScriptFile) scriptFiles
txAuxScripts <- hoistEither $ first ShelleyTxCmdAuxScriptsValidationError $ validateTxAuxScripts cEra scripts
pparams <- case mpparams of
Just ppFp -> Just <$> firstExceptT ShelleyTxCmdProtocolParamsError (readProtocolParametersSourceSpec ppFp)
Nothing -> return Nothing
mProp <- case mUpProp of
Just (UpdateProposalFile upFp) ->
Just <$> firstExceptT ShelleyTxCmdReadTextViewFileError
(newExceptT $ readFileTextEnvelope AsUpdateProposal upFp)
Nothing -> return Nothing

pparams <- forM mpparams $ \ppFp ->
firstExceptT ShelleyTxCmdProtocolParamsError (readProtocolParametersSourceSpec ppFp)

mProp <- forM mUpProp $ \(UpdateProposalFile upFp) ->
firstExceptT ShelleyTxCmdReadTextViewFileError (newExceptT $ readFileTextEnvelope AsUpdateProposal upFp)

requiredSigners <- mapM (firstExceptT ShelleyTxCmdRequiredSignerError . newExceptT . readRequiredSigner) reqSigners
mReturnCollateral <- case mReturnColl of
Just retCol -> Just <$> toTxOutInAnyEra cEra retCol
Nothing -> return Nothing
mReturnCollateral <- forM mReturnColl $ toTxOutInAnyEra cEra
txOuts <- mapM (toTxOutInAnyEra cEra) txouts

-- the same collateral input can be used for several plutus scripts
Expand All @@ -527,8 +518,9 @@ runTxBuildRawCmd
txMetadata pparams mProp

let noWitTx = makeSignedTransaction [] txBody
firstExceptT ShelleyTxCmdWriteFileError . newExceptT $
getIsCardanoEraConstraint cEra $ writeTxFileTextEnvelopeCddl out noWitTx
lift (getIsCardanoEraConstraint cEra $ writeTxFileTextEnvelopeCddl out noWitTx)
& onLeft (left . ShelleyTxCmdWriteFileError)


runTxBuildRaw
:: CardanoEra era
Expand Down Expand Up @@ -706,18 +698,16 @@ runTxBuild era (AnyConsensusModeParams cModeParams) networkId mScriptValidity
& onNothing (left (ShelleyTxCmdEraConsensusModeMismatchTxBalance outputOptions
(AnyConsensusMode CardanoMode) (AnyCardanoEra era)))

SocketPath sockPath <- firstExceptT ShelleyTxCmdSocketEnvError
$ newExceptT readEnvSocketPath
SocketPath sockPath <- lift readEnvSocketPath & onLeft (left . ShelleyTxCmdSocketEnvError)

let allTxInputs = inputsThatRequireWitnessing ++ allReferenceInputs ++ txinsc
localNodeConnInfo = LocalNodeConnectInfo
{ localConsensusModeParams = CardanoModeParams $ EpochSlots 21600
, localNodeNetworkId = networkId
, localNodeSocketPath = sockPath
}
AnyCardanoEra nodeEra
<- firstExceptT (ShelleyTxCmdQueryConvenienceError . AcqFailure)
. newExceptT $ determineEra cModeParams localNodeConnInfo
AnyCardanoEra nodeEra <- lift (determineEra cModeParams localNodeConnInfo)
& onLeft (left . ShelleyTxCmdQueryConvenienceError . AcqFailure)

(nodeEraUTxO, pparams, eraHistory, systemStart, stakePools) <-
firstExceptT ShelleyTxCmdQueryConvenienceError . newExceptT
Expand Down Expand Up @@ -750,17 +740,13 @@ runTxBuild era (AnyConsensusModeParams cModeParams) networkId mScriptValidity
firstExceptT ShelleyTxCmdQueryNotScriptLocked
. hoistEither $ notScriptLockedTxIns txinsc nodeEraUTxO

let cAddr = case anyAddressInEra era changeAddr of
Right addr -> addr
Left _ -> error $ "runTxBuild: Byron address used: " <> show changeAddr
cAddr <- pure (anyAddressInEra era changeAddr)
& onLeft (error $ "runTxBuild: Byron address used: " <> show changeAddr) -- should this throw instead?

-- Why do we cast the era? The user can specify an era prior to the era that the node is currently in.
-- We cannot use the user specified era to construct a query against a node because it may differ
-- from the node's era and this will result in the 'QueryEraMismatch' failure.
txEraUtxo <- case first ShelleyTxCmdTxEraCastErr (eraCast era nodeEraUTxO) of
Right txEraUtxo -> return txEraUtxo
Left e -> left e

txEraUtxo <- pure (eraCast era nodeEraUTxO) & onLeft (left . ShelleyTxCmdTxEraCastErr)

balancedTxBody@(BalancedTxBody _ _ _ fee) <-
firstExceptT ShelleyTxCmdBalanceTxBody
Expand Down Expand Up @@ -1071,9 +1057,9 @@ runTxSign txOrTxBody witSigningData mnw (TxFile outTxFile) = do
let (sksByron, sksShelley) = partitionSomeWitnesses $ map categoriseSomeWitness sks

case txOrTxBody of
(InputTxFile (TxFile inputTxFilePath)) -> do
InputTxFile (TxFile inputTxFilePath) -> do
inputTxFile <- liftIO $ fileOrPipe inputTxFilePath
anyTx <- firstExceptT ShelleyTxCmdCddlError . newExceptT $ readFileTx inputTxFile
anyTx <- lift (readFileTx inputTxFile) & onLeft (left . ShelleyTxCmdCddlError)

InAnyShelleyBasedEra _era tx <-
onlyInShelleyBasedEras "sign for Byron era transactions" anyTx
Expand All @@ -1088,10 +1074,10 @@ runTxSign txOrTxBody witSigningData mnw (TxFile outTxFile) = do
allKeyWits = existingTxKeyWits ++ newShelleyKeyWits ++ byronWitnesses
signedTx = makeSignedTransaction allKeyWits txbody

firstExceptT ShelleyTxCmdWriteFileError . newExceptT $
writeTxFileTextEnvelopeCddl outTxFile signedTx
lift (writeTxFileTextEnvelopeCddl outTxFile signedTx)
& onLeft (left . ShelleyTxCmdWriteFileError)

(InputTxBodyFile (TxBodyFile txbodyFilePath)) -> do
InputTxBodyFile (TxBodyFile txbodyFilePath) -> do
txbodyFile <- liftIO $ fileOrPipe txbodyFilePath
unwitnessed <- firstExceptT ShelleyTxCmdCddlError . newExceptT
$ readFileTxBody txbodyFile
Expand All @@ -1111,8 +1097,8 @@ runTxSign txOrTxBody witSigningData mnw (TxFile outTxFile) = do
let shelleyKeyWitnesses = map (makeShelleyKeyWitness txbody) sksShelley
tx = makeSignedTransaction (byronWitnesses ++ shelleyKeyWitnesses) txbody

firstExceptT ShelleyTxCmdWriteFileError . newExceptT $
writeTxFileTextEnvelopeCddl outTxFile tx
lift (writeTxFileTextEnvelopeCddl outTxFile tx)
& onLeft (left . ShelleyTxCmdWriteFileError)

UnwitnessedCliFormattedTxBody anyTxbody -> do
InAnyShelleyBasedEra _era txbody <-
Expand Down Expand Up @@ -1141,13 +1127,10 @@ runTxSubmit
-> FilePath
-> ExceptT ShelleyTxCmdError IO ()
runTxSubmit (AnyConsensusModeParams cModeParams) network txFilePath = do

SocketPath sockPath <- firstExceptT ShelleyTxCmdSocketEnvError
$ newExceptT readEnvSocketPath
SocketPath sockPath <- lift readEnvSocketPath & onLeft (left . ShelleyTxCmdSocketEnvError)

txFile <- liftIO $ fileOrPipe txFilePath
InAnyCardanoEra era tx <- firstExceptT ShelleyTxCmdCddlError . newExceptT
$ readFileTx txFile
InAnyCardanoEra era tx <- lift (readFileTx txFile) & onLeft (left . ShelleyTxCmdCddlError)
let cMode = AnyConsensusMode $ consensusModeOnly cModeParams
eraInMode <- hoistMaybe
(ShelleyTxCmdEraConsensusModeMismatch (Just txFilePath) cMode (AnyCardanoEra era))
Expand Down Expand Up @@ -1339,8 +1322,7 @@ runTxGetTxId txfile = do

InputTxFile (TxFile txFilePath) -> do
txFile <- liftIO $ fileOrPipe txFilePath
InAnyCardanoEra era tx <- firstExceptT ShelleyTxCmdCddlError . newExceptT
$ readFileTx txFile
InAnyCardanoEra era tx <- lift (readFileTx txFile) & onLeft (left . ShelleyTxCmdCddlError)
return . InAnyCardanoEra era $ getTxBody tx

liftIO $ BS.putStrLn $ serialiseToRawBytesHex (getTxId txbody)
Expand All @@ -1362,8 +1344,7 @@ runTxView = \case
liftIO $ BS.putStr $ friendlyTxBodyBS era txbody
InputTxFile (TxFile txFilePath) -> do
txFile <- liftIO $ fileOrPipe txFilePath
InAnyCardanoEra era tx <- firstExceptT ShelleyTxCmdCddlError . newExceptT
$ readFileTx txFile
InAnyCardanoEra era tx <- lift (readFileTx txFile) & onLeft (left . ShelleyTxCmdCddlError)
liftIO $ BS.putStr $ friendlyTxBS era tx


Expand Down Expand Up @@ -1470,8 +1451,7 @@ runTxSignWitness (TxBodyFile txbodyFilePath) witnessFiles (OutputFile oFp) = do

let tx = makeSignedTransaction witnesses txbody

firstExceptT ShelleyTxCmdWriteFileError . newExceptT $
writeTxFileTextEnvelopeCddl oFp tx
lift (writeTxFileTextEnvelopeCddl oFp tx) & onLeft (left . ShelleyTxCmdWriteFileError)


-- | Constrain the era to be Shelley based. Fail for the Byron era.
Expand Down

0 comments on commit 7f52046

Please sign in to comment.