From be4a088c0a8b2664269de1bfdbb99ce6e91488e9 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Tue, 1 Jun 2021 21:42:04 +0100 Subject: [PATCH 01/17] Switch the API for minting to use ScriptWitness rather than Witness Instead of using a Map PolicyId (Witness WitCtxMint era) we instead use Map PolicyId (ScriptWitness WitCtxMint era) Whereas other uses of witnesses in the tx body allow either key or script witnesses, the minting only uses script witnesses, not key witnesses. Using the more specific type is logically the right thing to do, and will also make the job for the cli slightly easier. --- cardano-api/src/Cardano/Api/TxBody.hs | 5 +++-- cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs | 7 +++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/cardano-api/src/Cardano/Api/TxBody.hs b/cardano-api/src/Cardano/Api/TxBody.hs index 97b95f4a98c..7ddf84c9bc9 100644 --- a/cardano-api/src/Cardano/Api/TxBody.hs +++ b/cardano-api/src/Cardano/Api/TxBody.hs @@ -1028,7 +1028,8 @@ data TxMintValue build era where TxMintValue :: MultiAssetSupportedInEra era -> Value - -> BuildTxWith build (Map PolicyId (Witness WitCtxMint era)) + -> BuildTxWith build + (Map PolicyId (ScriptWitness WitCtxMint era)) -> TxMintValue build era deriving instance Eq (TxMintValue build era) @@ -2257,7 +2258,7 @@ collectTxBodyScriptWitnesses TxBodyContent { -- The minting policies are indexed in policy id order in the value | let ValueNestedRep bundle = valueToNestedRep value , (ix, ValueNestedBundle policyid _) <- zip [0..] bundle - , ScriptWitness _ witness <- maybeToList (Map.lookup policyid witnesses) + , witness <- maybeToList (Map.lookup policyid witnesses) ] diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs index 08ca2252c3e..2199710f604 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs @@ -543,7 +543,7 @@ validateTxMintValue era (Just (val, scripts)) = pairAllPolIdsWithScripts :: Value -> [ScriptFile] - -> ExceptT ShelleyTxCmdError IO [(PolicyId, Witness WitCtxMint era)] + -> ExceptT ShelleyTxCmdError IO [(PolicyId, ScriptWitness WitCtxMint era)] pairAllPolIdsWithScripts vals sFiles = do sInLangs <- sequence [ firstExceptT ShelleyTxCmdScriptFileError $ @@ -556,7 +556,7 @@ validateTxMintValue era (Just (val, scripts)) = pairPolIdWithScriptWit :: [PolicyId] -> ScriptInAnyLang - -> ExceptT ShelleyTxCmdError IO (PolicyId, Witness WitCtxMint era) + -> ExceptT ShelleyTxCmdError IO (PolicyId, ScriptWitness WitCtxMint era) pairPolIdWithScriptWit valuePids (ScriptInAnyLang sLang script) = do let scriptHash = PolicyId $ hashScript script if scriptHash `elem` valuePids @@ -568,8 +568,7 @@ validateTxMintValue era (Just (val, scripts)) = case script of SimpleScript sVer sScript -> return ( scriptHash - , ScriptWitness ScriptWitnessForMinting - $ SimpleScriptWitness sLangInEra sVer sScript + , SimpleScriptWitness sLangInEra sVer sScript ) PlutusScript _ _ -> panic "TODO alonzo: reateScriptWitness: Plutus scripts not supported yet." From 44f342ffb3b6fb9cf2be7968444c106bd1e83047 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Tue, 1 Jun 2021 22:25:33 +0100 Subject: [PATCH 02/17] Refactor the validateTxMintValue helper Make it simpler and clearer. Check both for too few as well as too many witnesses being provided for minting. Alsoange it to use the existing createScriptWitness utility. This will mean we can extend it for Plutus scripts more easily, since we will only have to change that utility function, and not validateTxMintValue. --- cardano-api/src/Cardano/Api.hs | 2 + cardano-api/src/Cardano/Api/Value.hs | 5 + .../Cardano/CLI/Shelley/Run/Transaction.hs | 97 ++++++++++--------- 3 files changed, 56 insertions(+), 48 deletions(-) diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index eaef670b662..1f53971ffdd 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -105,6 +105,7 @@ module Cardano.Api ( -- ** Multi-asset values Quantity(..), PolicyId(..), + scriptPolicyId, AssetName(..), AssetId(..), Value, @@ -316,6 +317,7 @@ module Cardano.Api ( ScriptWitnessInCtx(..), ScriptDatum(..), ScriptRedeemer, + scriptWitnessScript, -- *** Languages supported in each era ScriptLanguageInEra(..), diff --git a/cardano-api/src/Cardano/Api/Value.hs b/cardano-api/src/Cardano/Api/Value.hs index 99f795eafe1..98d4bf520c1 100644 --- a/cardano-api/src/Cardano/Api/Value.hs +++ b/cardano-api/src/Cardano/Api/Value.hs @@ -13,6 +13,7 @@ module Cardano.Api.Value -- * Multi-asset values , Quantity(..) , PolicyId(..) + , scriptPolicyId , AssetName(..) , AssetId(..) , Value @@ -145,6 +146,10 @@ instance SerialiseAsRawBytes PolicyId where deserialiseFromRawBytes AsPolicyId bs = PolicyId <$> deserialiseFromRawBytes AsScriptHash bs +scriptPolicyId :: Script lang -> PolicyId +scriptPolicyId = PolicyId . hashScript + + newtype AssetName = AssetName ByteString deriving stock (Eq, Ord) deriving newtype (Show) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs index 2199710f604..83613bdac6f 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs @@ -19,6 +19,7 @@ import qualified Data.Aeson as Aeson import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.Map.Strict as Map +import qualified Data.Set as Set import qualified Data.Text as Text import Data.Type.Equality (TestEquality (..)) @@ -84,7 +85,8 @@ data ShelleyTxCmdError | ShelleyTxCmdWitnessEraMismatch AnyCardanoEra AnyCardanoEra WitnessFile | ShelleyTxCmdScriptLanguageNotSupportedInEra AnyScriptLanguage AnyCardanoEra | ShelleyTxCmdGenesisCmdError !ShelleyGenesisCmdError - | ShelleyTxCmdPolicyIdNotSpecified PolicyId + | ShelleyTxCmdPolicyIdsMissing [PolicyId] + | ShelleyTxCmdPolicyIdsExcess [PolicyId] deriving Show data SomeTxBodyError where @@ -165,10 +167,16 @@ renderShelleyTxCmdError err = "Submitting " <> renderEra era <> " era transaction (" <> show fp <> ") is not supported in the " <> renderMode mode <> " consensus mode." ShelleyTxCmdGenesisCmdError e -> renderShelleyGenesisCmdError e - ShelleyTxCmdPolicyIdNotSpecified sWit -> - "A script provided to witness minting does not correspond to the policy id \ - \of any asset specified in the \"--mint\" field. The script hash is: " - <> serialiseToRawBytesHexText sWit + ShelleyTxCmdPolicyIdsMissing policyids -> + "The \"--mint\" flag specifies an asset with a policy Id, but no \ + \corresponding monetary policy script has been provided as a witness \ + \(via the \"--minting-script-file\" flag). The policy Id in question is: " + <> Text.intercalate ", " (map serialiseToRawBytesHexText policyids) + + ShelleyTxCmdPolicyIdsExcess policyids -> + "A script provided to witness minting does not correspond to the policy \ + \id of any asset specified in the \"--mint\" field. The script hash is: " + <> Text.intercalate ", " (map serialiseToRawBytesHexText policyids) renderEra :: AnyCardanoEra -> Text renderEra (AnyCardanoEra ByronEra) = "Byron" @@ -530,50 +538,43 @@ validateTxMintValue :: forall era. IsCardanoEra era validateTxMintValue _ Nothing = return TxMintNone validateTxMintValue era (Just (val, scripts)) = case multiAssetSupportedInEra era of - Left _ -> txFeatureMismatch era TxFeatureMintValue - Right supported -> do - pidsAndWits <- pairAllPolIdsWithScripts val scripts - return (TxMintValue supported val - . BuildTxWith $ Map.fromList pidsAndWits - ) + Left _ -> txFeatureMismatch era TxFeatureMintValue + Right supported -> do + -- The set of policy ids for which we need witnesses: + let witnessesNeededSet :: Set PolicyId + witnessesNeededSet = + Set.fromList [ pid | (AssetId pid _, _) <- valueToList val ] + + -- The set (and map) of policy ids for which we have witnesses: + witnesses <- mapM (createScriptWitness era) scripts + let witnessesProvidedMap :: Map PolicyId (ScriptWitness WitCtxMint era) + witnessesProvidedMap = Map.fromList + [ (scriptWitnessPolicyId witness, witness) + | witness <- witnesses ] + witnessesProvidedSet = Map.keysSet witnessesProvidedMap + + -- Check not too many, nor too few: + validateAllWitnessesProvided witnessesNeededSet witnessesProvidedSet + validateNoUnnecessaryWitnesses witnessesNeededSet witnessesProvidedSet + + return (TxMintValue supported val (BuildTxWith witnessesProvidedMap)) where - extractPolicyIds :: Value -> [PolicyId] - extractPolicyIds v = map (\(AssetId polId _, _) -> polId) (valueToList v) - - - pairAllPolIdsWithScripts - :: Value -> [ScriptFile] - -> ExceptT ShelleyTxCmdError IO [(PolicyId, ScriptWitness WitCtxMint era)] - pairAllPolIdsWithScripts vals sFiles = do - sInLangs <- sequence - [ firstExceptT ShelleyTxCmdScriptFileError $ - readFileScriptInAnyLang file - | ScriptFile file <- sFiles ] - let valPids = extractPolicyIds vals - mapM (pairPolIdWithScriptWit valPids) sInLangs - - -- Check that the script hash exists in the minted multi asset - pairPolIdWithScriptWit - :: [PolicyId] - -> ScriptInAnyLang - -> ExceptT ShelleyTxCmdError IO (PolicyId, ScriptWitness WitCtxMint era) - pairPolIdWithScriptWit valuePids (ScriptInAnyLang sLang script) = do - let scriptHash = PolicyId $ hashScript script - if scriptHash `elem` valuePids - then case scriptLanguageSupportedInEra era sLang of - Nothing -> left $ ShelleyTxCmdScriptLanguageNotSupportedInEra - (AnyScriptLanguage sLang) - (AnyCardanoEra era) - Just sLangInEra -> - case script of - SimpleScript sVer sScript -> - return ( scriptHash - , SimpleScriptWitness sLangInEra sVer sScript - ) - PlutusScript _ _ -> - panic "TODO alonzo: reateScriptWitness: Plutus scripts not supported yet." - - else left $ ShelleyTxCmdPolicyIdNotSpecified scriptHash + validateAllWitnessesProvided witnessesNeeded witnessesProvided + | null witnessesMissing = return () + | otherwise = left (ShelleyTxCmdPolicyIdsMissing witnessesMissing) + where + witnessesMissing = Set.elems (witnessesNeeded Set.\\ witnessesProvided) + + validateNoUnnecessaryWitnesses witnessesNeeded witnessesProvided + | null witnessesExtra = return () + | otherwise = left (ShelleyTxCmdPolicyIdsExcess witnessesExtra) + where + witnessesExtra = Set.elems (witnessesProvided Set.\\ witnessesNeeded) + +scriptWitnessPolicyId :: ScriptWitness witctx era -> PolicyId +scriptWitnessPolicyId witness = + case scriptWitnessScript witness of + ScriptInEra _ script -> scriptPolicyId script createScriptWitness From 8fa063115baaf0812902e9cc8dbfdb762179a11b Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Tue, 1 Jun 2021 22:32:23 +0100 Subject: [PATCH 03/17] Change CLI tx builder to use ScriptWitnessFiles rather than ScriptFile To be able to support plutus scripts for witnesses, we need to deal with script witnesses rather than just scripts. In the CLI this means dealing with the files needed to make a script witness, rather than just the single file needed to make a simple script witness. So we add a new ScriptWitnessFiles GADT that covers both the simple and the plutus witness case, that contains the various files: not just the script file but also files for the datum and redeemer, and also the exection units. This patch does not actually add in the cases to actually support the plutus case, it just switches the types over in preparation. Both the parser and the createScriptWitness helper will need to be extended for that. --- cardano-api/src/Cardano/Api.hs | 4 ++ cardano-api/src/Cardano/Api/Script.hs | 12 ++++ .../src/Cardano/CLI/Shelley/Commands.hs | 8 +-- .../src/Cardano/CLI/Shelley/Parsers.hs | 43 +++++++++--- .../Cardano/CLI/Shelley/Run/Transaction.hs | 70 ++++++++++--------- cardano-cli/src/Cardano/CLI/Types.hs | 39 +++++++++++ 6 files changed, 131 insertions(+), 45 deletions(-) diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 1f53971ffdd..8b354d7e919 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -311,6 +311,7 @@ module Cardano.Api ( -- * Use of a script in an era as a witness WitCtxTxIn, WitCtxMint, WitCtxStake, + WitCtx(..), ScriptWitness(..), Witness(..), KeyWitnessInCtx(..), @@ -338,6 +339,9 @@ module Cardano.Api ( -- ** Script data ScriptData(..), + -- * Script execution units + ExecutionUnits(..), + -- ** Script addresses -- | Making addresses from scripts. ScriptHash, diff --git a/cardano-api/src/Cardano/Api/Script.hs b/cardano-api/src/Cardano/Api/Script.hs index 9aa97f4d084..eb7af7f2eba 100644 --- a/cardano-api/src/Cardano/Api/Script.hs +++ b/cardano-api/src/Cardano/Api/Script.hs @@ -33,6 +33,7 @@ module Cardano.Api.Script ( -- * Use of a script in an era as a witness WitCtxTxIn, WitCtxMint, WitCtxStake, + WitCtx(..), ScriptWitness(..), Witness(..), KeyWitnessInCtx(..), @@ -599,6 +600,17 @@ data WitCtxMint -- data WitCtxStake + +-- | This GADT provides a value-level representation of all the witness +-- contexts. This enables pattern matching on the context to allow them to be +-- treated in a non-uniform way. +-- +data WitCtx witctx where + WitCtxTxIn :: WitCtx WitCtxTxIn + WitCtxMint :: WitCtx WitCtxMint + WitCtxStake :: WitCtx WitCtxStake + + -- | A /use/ of a script within a transaction body to witness that something is -- being used in an authorised manner. That can be -- diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs index beadd84d607..fc169dda21a 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs @@ -162,10 +162,10 @@ renderKeyCmd cmd = data TransactionCmd = TxBuildRaw AnyCardanoEra - [(TxIn, Maybe ScriptFile)] + [(TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn))] -- ^ Transaction inputs with optional spending scripts [TxOutAnyEra] - (Maybe (Value, [ScriptFile])) + (Maybe (Value, [ScriptWitnessFiles WitCtxMint])) -- ^ Multi-Asset value with script witness (Maybe SlotNo) -- ^ Transaction lower bound @@ -173,9 +173,9 @@ data TransactionCmd -- ^ Transaction upper bound (Maybe Lovelace) -- ^ Tx fee - [(CertificateFile, Maybe ScriptFile)] + [(CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake))] -- ^ Certificates with potential script witness - [(StakeAddress, Lovelace, Maybe ScriptFile)] + [(StakeAddress, Lovelace, Maybe (ScriptWitnessFiles WitCtxStake))] TxMetadataJsonSchema [ScriptFile] -- ^ Auxillary scripts diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs index db648ecae2c..aec8dacd7ac 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs @@ -211,6 +211,14 @@ pScriptFor name help = ScriptFile <$> Opt.strOption <> Opt.completer (Opt.bashCompleter "file") ) +pScriptWitnessFiles :: WitCtx witctx + -> String + -> String + -> Parser (ScriptWitnessFiles witctx) +pScriptWitnessFiles _ name help = + -- Just the simple case for now. TODO: extend to Plutus witnesses. + SimpleScriptWitnessFile <$> pScriptFor name help + pStakeAddressCmd :: Parser StakeAddressCmd pStakeAddressCmd = asum @@ -515,7 +523,9 @@ pTransaction = <*> many pCertificateFile <*> many pWithdrawal <*> pTxMetadataJsonSchema - <*> many (pScriptFor "auxiliary-script-file" "Filepath of auxiliary script(s)") + <*> many (pScriptFor + "auxiliary-script-file" + "Filepath of auxiliary script(s)") <*> many pMetadataFile <*> optional pUpdateProposalFile <*> pTxBodyFile Output @@ -1079,7 +1089,8 @@ pProtocolParamsFile = <> Opt.completer (Opt.bashCompleter "file") ) -pCertificateFile :: Parser (CertificateFile, Maybe ScriptFile) +pCertificateFile :: Parser (CertificateFile, + Maybe (ScriptWitnessFiles WitCtxStake)) pCertificateFile = (,) <$> (CertificateFile <$> ( Opt.strOption @@ -1092,7 +1103,10 @@ pCertificateFile = Opt.strOption (Opt.long "certificate" <> Opt.internal) ) ) - <*> optional (pScriptFor "certificate-script-file" "Filepath of the certificate script witness") + <*> optional (pScriptWitnessFiles + WitCtxStake + "certificate-script-file" + "Filepath of the certificate script witness") where helpText = "Filepath of the certificate. This encompasses all \ \types of certificates (stake pool certificates, \ @@ -1153,7 +1167,9 @@ pMetadataFile = <> Opt.completer (Opt.bashCompleter "file") ) -pWithdrawal :: Parser (StakeAddress, Lovelace, Maybe ScriptFile) +pWithdrawal :: Parser (StakeAddress, + Lovelace, + Maybe (ScriptWitnessFiles WitCtxStake)) pWithdrawal = (\(stakeAddr,lovelace) maybeScriptFp -> (stakeAddr, lovelace, maybeScriptFp)) <$> Opt.option (readerFromAttoParser parseWithdrawal) @@ -1161,7 +1177,10 @@ pWithdrawal = <> Opt.metavar "WITHDRAWAL" <> Opt.help helpText ) - <*> optional (pScriptFor "withdrawal-script-file" "Filepath of the withdrawal script witness.") + <*> optional (pScriptWitnessFiles + WitCtxStake + "withdrawal-script-file" + "Filepath of the withdrawal script witness.") where helpText = "The reward withdrawal as StakeAddress+Lovelace where \ \StakeAddress is the Bech32-encoded stake address \ @@ -1606,14 +1625,17 @@ pCardanoEra = asum , pure (AnyCardanoEra MaryEra) ] -pTxIn :: Parser (TxIn, Maybe ScriptFile) +pTxIn :: Parser (TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn)) pTxIn = (,) <$> Opt.option (readerFromAttoParser parseTxIn) ( Opt.long "tx-in" <> Opt.metavar "TX-IN" <> Opt.help "TxId#TxIx" ) - <*> optional (pScriptFor "txin-script-file" "Filepath of the spending script witness") + <*> optional (pScriptWitnessFiles + WitCtxTxIn + "txin-script-file" + "Filepath of the spending script witness") parseTxIn :: Atto.Parser TxIn parseTxIn = TxIn <$> parseTxId <*> (Atto.char '#' *> parseTxIx) @@ -1657,7 +1679,7 @@ pMultiAsset = <> Opt.help "Multi-asset value(s) with the multi-asset cli syntax" ) -pMintMultiAsset :: Parser (Value, [ScriptFile]) +pMintMultiAsset :: Parser (Value, [ScriptWitnessFiles WitCtxMint]) pMintMultiAsset = (,) <$> Opt.option (readerFromParsecParser parseValue) @@ -1665,7 +1687,10 @@ pMintMultiAsset = <> Opt.metavar "VALUE" <> Opt.help helpText ) - <*> some (pScriptFor "minting-script-file" "Filepath of the multi-asset witness script.") + <*> some (pScriptWitnessFiles + WitCtxMint + "minting-script-file" + "Filepath of the multi-asset witness script.") where helpText = "Mint multi-asset value(s) with the multi-asset cli syntax. \ diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs index 83613bdac6f..8c6e0699f52 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs @@ -234,7 +234,7 @@ runTransactionCmd cmd = runTxBuildRaw :: AnyCardanoEra - -> [(TxIn, Maybe ScriptFile)] + -> [(TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn))] -- ^ TxIn with potential script witness -> [TxOutAnyEra] -> Maybe SlotNo @@ -243,11 +243,11 @@ runTxBuildRaw -- ^ Tx upper bound -> Maybe Lovelace -- ^ Tx fee - -> Maybe (Value, [ScriptFile]) + -> Maybe (Value, [ScriptWitnessFiles WitCtxMint]) -- ^ Multi-Asset value(s) - -> [(CertificateFile, Maybe ScriptFile)] + -> [(CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake))] -- ^ Certificate with potential script witness - -> [(StakeAddress, Lovelace, Maybe ScriptFile)] + -> [(StakeAddress, Lovelace, Maybe (ScriptWitnessFiles WitCtxStake))] -> TxMetadataJsonSchema -> [ScriptFile] -> [MetadataFile] @@ -316,19 +316,22 @@ txFeatureMismatch era feature = left (ShelleyTxCmdTxFeatureMismatch (anyCardanoEra era) feature) validateTxIns - :: forall era. IsCardanoEra era + :: forall era. + IsCardanoEra era => CardanoEra era - -> [(TxIn, Maybe ScriptFile)] - -> ExceptT ShelleyTxCmdError IO [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))] + -> [(TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn))] + -> ExceptT ShelleyTxCmdError IO + [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))] validateTxIns era = mapM convert where convert - :: (TxIn, Maybe ScriptFile) - -> ExceptT ShelleyTxCmdError IO (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era)) - convert (txin, mScriptFile) = - case mScriptFile of - Just sFp -> do - sWit <- createScriptWitness era sFp + :: (TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn)) + -> ExceptT ShelleyTxCmdError IO + (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era)) + convert (txin, mScriptWitnessFiles) = + case mScriptWitnessFiles of + Just scriptWitnessFiles -> do + sWit <- createScriptWitness era scriptWitnessFiles return ( txin , BuildTxWith $ ScriptWitness ScriptWitnessForSpending sWit ) @@ -445,7 +448,7 @@ validateTxAuxScripts era files = validateTxWithdrawals :: forall era. IsCardanoEra era => CardanoEra era - -> [(StakeAddress, Lovelace, Maybe ScriptFile)] + -> [(StakeAddress, Lovelace, Maybe (ScriptWitnessFiles WitCtxStake))] -> ExceptT ShelleyTxCmdError IO (TxWithdrawals BuildTx era) validateTxWithdrawals _ [] = return TxWithdrawalsNone validateTxWithdrawals era withdrawals = @@ -456,13 +459,15 @@ validateTxWithdrawals era withdrawals = return (TxWithdrawals supported convWithdrawals) where convert - :: (StakeAddress, Lovelace, Maybe ScriptFile) + :: (StakeAddress, Lovelace, Maybe (ScriptWitnessFiles WitCtxStake)) -> ExceptT ShelleyTxCmdError IO - (StakeAddress, Lovelace, BuildTxWith BuildTx (Witness WitCtxStake era)) - convert (sAddr, ll, mScriptFile) = - case mScriptFile of - Just sFp -> do - sWit <- createScriptWitness era sFp + (StakeAddress, + Lovelace, + BuildTxWith BuildTx (Witness WitCtxStake era)) + convert (sAddr, ll, mScriptWitnessFiles) = + case mScriptWitnessFiles of + Just scriptWitnessFiles -> do + sWit <- createScriptWitness era scriptWitnessFiles return ( sAddr , ll , BuildTxWith $ ScriptWitness ScriptWitnessForStakeAddr sWit @@ -472,7 +477,7 @@ validateTxWithdrawals era withdrawals = validateTxCertificates :: forall era. IsCardanoEra era => CardanoEra era - -> [(CertificateFile, Maybe ScriptFile)] + -> [(CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake))] -> ExceptT ShelleyTxCmdError IO (TxCertificates BuildTx era) validateTxCertificates era certFiles = case certificatesSupportedInEra era of @@ -502,16 +507,17 @@ validateTxCertificates era certFiles = _ -> return Nothing convert - :: (CertificateFile, Maybe ScriptFile) - -> ExceptT ShelleyTxCmdError IO (Maybe (StakeCredential, Witness WitCtxStake era)) - convert (cert, mScript) = do + :: (CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake)) + -> ExceptT ShelleyTxCmdError IO + (Maybe (StakeCredential, Witness WitCtxStake era)) + convert (cert, mScriptWitnessFiles) = do mStakeCred <- deriveStakeCredentialWitness cert case mStakeCred of Nothing -> return Nothing Just sCred -> - case mScript of - Just sFp -> do - sWit <- createScriptWitness era sFp + case mScriptWitnessFiles of + Just scriptWitnessFiles -> do + sWit <- createScriptWitness era scriptWitnessFiles return $ Just ( sCred , ScriptWitness ScriptWitnessForStakeAddr sWit ) @@ -533,10 +539,10 @@ validateTxUpdateProposal era (Just (UpdateProposalFile file)) = validateTxMintValue :: forall era. IsCardanoEra era => CardanoEra era - -> Maybe (Value, [ScriptFile]) + -> Maybe (Value, [ScriptWitnessFiles WitCtxMint]) -> ExceptT ShelleyTxCmdError IO (TxMintValue BuildTx era) validateTxMintValue _ Nothing = return TxMintNone -validateTxMintValue era (Just (val, scripts)) = +validateTxMintValue era (Just (val, scriptWitnessFiles)) = case multiAssetSupportedInEra era of Left _ -> txFeatureMismatch era TxFeatureMintValue Right supported -> do @@ -546,7 +552,7 @@ validateTxMintValue era (Just (val, scripts)) = Set.fromList [ pid | (AssetId pid _, _) <- valueToList val ] -- The set (and map) of policy ids for which we have witnesses: - witnesses <- mapM (createScriptWitness era) scripts + witnesses <- mapM (createScriptWitness era) scriptWitnessFiles let witnessesProvidedMap :: Map PolicyId (ScriptWitness WitCtxMint era) witnessesProvidedMap = Map.fromList [ (scriptWitnessPolicyId witness, witness) @@ -580,9 +586,9 @@ scriptWitnessPolicyId witness = createScriptWitness :: IsCardanoEra era => CardanoEra era - -> ScriptFile + -> ScriptWitnessFiles witctx -> ExceptT ShelleyTxCmdError IO (ScriptWitness witctx era) -createScriptWitness era (ScriptFile fp) = do +createScriptWitness era (SimpleScriptWitnessFile (ScriptFile fp)) = do ScriptInAnyLang sLang script <- firstExceptT ShelleyTxCmdScriptFileError $ readFileScriptInAnyLang fp case scriptLanguageSupportedInEra era sLang of diff --git a/cardano-cli/src/Cardano/CLI/Types.hs b/cardano-cli/src/Cardano/CLI/Types.hs index d744b6367b1..c7942d93083 100644 --- a/cardano-cli/src/Cardano/CLI/Types.hs +++ b/cardano-cli/src/Cardano/CLI/Types.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} module Cardano.CLI.Types ( CBORObject (..) @@ -11,6 +13,10 @@ module Cardano.CLI.Types , SigningKeyFile (..) , SocketPath (..) , ScriptFile (..) + , ScriptDataOrFile (..) + , ScriptRedeemerOrFile + , ScriptWitnessFiles (..) + , ScriptDatumOrFile (..) , TransferDirection(..) , TxOutAnyEra (..) , UpdateProposalFile (..) @@ -145,6 +151,39 @@ newtype VerificationKeyFile newtype ScriptFile = ScriptFile { unScriptFile :: FilePath } deriving (Eq, Show) +data ScriptDataOrFile = ScriptDataFile FilePath -- ^ By reference to a file + | ScriptDataValue ScriptData -- ^ By value + deriving (Eq, Show) + +type ScriptRedeemerOrFile = ScriptDataOrFile + +-- | This type is like 'ScriptWitness', but the file paths from which to load +-- the script witness data representation. +-- +-- It is era-independent, but witness context-dependent. +-- +data ScriptWitnessFiles witctx where + SimpleScriptWitnessFile :: ScriptFile + -> ScriptWitnessFiles witctx + + PlutusScriptWitnessFiles :: ScriptFile + -> ScriptDatumOrFile witctx + -> ScriptRedeemerOrFile + -> ExecutionUnits + -> ScriptWitnessFiles witctx + +deriving instance Show (ScriptWitnessFiles witctx) + +data ScriptDatumOrFile witctx where + ScriptDatumOrFileForTxIn :: ScriptDataOrFile + -> ScriptDatumOrFile WitCtxTxIn + + NoScriptDatumOrFileForMint :: ScriptDatumOrFile WitCtxMint + NoScriptDatumOrFileForStake :: ScriptDatumOrFile WitCtxStake + +deriving instance Show (ScriptDatumOrFile witctx) + + -- | Determines the direction in which the MIR certificate will transfer ADA. data TransferDirection = TransferToReserves | TransferToTreasury deriving Show From 344544740ba79e8e781ce495d9790f1f5ea65bfe Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Wed, 2 Jun 2021 10:33:07 +0100 Subject: [PATCH 04/17] Trivial refactoring: drop unnecessary IsCardanoEra constraints --- .../Cardano/CLI/Shelley/Run/Transaction.hs | 20 +++++++++---------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs index 8c6e0699f52..09c10dc0a03 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs @@ -317,8 +317,7 @@ txFeatureMismatch era feature = validateTxIns :: forall era. - IsCardanoEra era - => CardanoEra era + CardanoEra era -> [(TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn))] -> ExceptT ShelleyTxCmdError IO [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))] @@ -446,8 +445,8 @@ validateTxAuxScripts era files = panic "TODO alonzo: validateTxAuxScripts AuxScriptsInAlonzoEra" validateTxWithdrawals - :: forall era. IsCardanoEra era - => CardanoEra era + :: forall era. + CardanoEra era -> [(StakeAddress, Lovelace, Maybe (ScriptWitnessFiles WitCtxStake))] -> ExceptT ShelleyTxCmdError IO (TxWithdrawals BuildTx era) validateTxWithdrawals _ [] = return TxWithdrawalsNone @@ -475,8 +474,8 @@ validateTxWithdrawals era withdrawals = Nothing -> return (sAddr,ll, BuildTxWith $ KeyWitness KeyWitnessForStakeAddr) validateTxCertificates - :: forall era. IsCardanoEra era - => CardanoEra era + :: forall era. + CardanoEra era -> [(CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake))] -> ExceptT ShelleyTxCmdError IO (TxCertificates BuildTx era) validateTxCertificates era certFiles = @@ -537,8 +536,8 @@ validateTxUpdateProposal era (Just (UpdateProposalFile file)) = return (TxUpdateProposal supported prop) -validateTxMintValue :: forall era. IsCardanoEra era - => CardanoEra era +validateTxMintValue :: forall era. + CardanoEra era -> Maybe (Value, [ScriptWitnessFiles WitCtxMint]) -> ExceptT ShelleyTxCmdError IO (TxMintValue BuildTx era) validateTxMintValue _ Nothing = return TxMintNone @@ -584,8 +583,7 @@ scriptWitnessPolicyId witness = createScriptWitness - :: IsCardanoEra era - => CardanoEra era + :: CardanoEra era -> ScriptWitnessFiles witctx -> ExceptT ShelleyTxCmdError IO (ScriptWitness witctx era) createScriptWitness era (SimpleScriptWitnessFile (ScriptFile fp)) = do @@ -601,7 +599,7 @@ createScriptWitness era (SimpleScriptWitnessFile (ScriptFile fp)) = do Nothing -> left $ ShelleyTxCmdScriptLanguageNotSupportedInEra (AnyScriptLanguage sLang) - (AnyCardanoEra era) + (anyCardanoEra era) -- ---------------------------------------------------------------------------- -- Transaction signing From 4e714a3e4b327122e337e4ff8a85087fbd6338f8 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Wed, 2 Jun 2021 20:32:04 +0100 Subject: [PATCH 05/17] Extend createScriptWitness in the cli for Plutus script witnesses The remaining TODO here relies on the ScriptData JSON support. --- .../Cardano/CLI/Shelley/Run/Transaction.hs | 91 ++++++++++++++++--- 1 file changed, 77 insertions(+), 14 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs index 09c10dc0a03..c636d6bc866 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs @@ -84,6 +84,8 @@ data ShelleyTxCmdError | ShelleyTxCmdNotImplemented Text | ShelleyTxCmdWitnessEraMismatch AnyCardanoEra AnyCardanoEra WitnessFile | ShelleyTxCmdScriptLanguageNotSupportedInEra AnyScriptLanguage AnyCardanoEra + | ShelleyTxCmdScriptExpectedSimple FilePath AnyScriptLanguage + | ShelleyTxCmdScriptExpectedPlutus FilePath AnyScriptLanguage | ShelleyTxCmdGenesisCmdError !ShelleyGenesisCmdError | ShelleyTxCmdPolicyIdsMissing [PolicyId] | ShelleyTxCmdPolicyIdsExcess [PolicyId] @@ -163,6 +165,17 @@ renderShelleyTxCmdError err = ShelleyTxCmdScriptLanguageNotSupportedInEra (AnyScriptLanguage lang) era -> "The script language " <> show lang <> " is not supported in the " <> renderEra era <> " era." + + ShelleyTxCmdScriptExpectedSimple file (AnyScriptLanguage lang) -> + Text.pack file <> ": expected a script in the simple script language, " <> + "but it is actually using " <> show lang <> ". Alternatively, to use " <> + "a Plutus script, you must also specify the redeemer " <> + "(datum if appropriate) and script execution units." + + ShelleyTxCmdScriptExpectedPlutus file (AnyScriptLanguage lang) -> + Text.pack file <> ": expected a script in the Plutus script language, " <> + "but it is actually using " <> show lang <> "." + ShelleyTxCmdEraConsensusModeMismatch fp mode era -> "Submitting " <> renderEra era <> " era transaction (" <> show fp <> ") is not supported in the " <> renderMode mode <> " consensus mode." @@ -586,20 +599,70 @@ createScriptWitness :: CardanoEra era -> ScriptWitnessFiles witctx -> ExceptT ShelleyTxCmdError IO (ScriptWitness witctx era) -createScriptWitness era (SimpleScriptWitnessFile (ScriptFile fp)) = do - ScriptInAnyLang sLang script <- firstExceptT ShelleyTxCmdScriptFileError - $ readFileScriptInAnyLang fp - case scriptLanguageSupportedInEra era sLang of - Just sLangInEra -> - case script of - SimpleScript sVer sScript -> - return $ SimpleScriptWitness sLangInEra sVer sScript - PlutusScript _ _ -> panic "TODO alonzo: createScriptWitness: Plutus scripts not supported yet." - - Nothing -> - left $ ShelleyTxCmdScriptLanguageNotSupportedInEra - (AnyScriptLanguage sLang) - (anyCardanoEra era) +createScriptWitness era (SimpleScriptWitnessFile (ScriptFile scriptFile)) = do + script@(ScriptInAnyLang lang _) <- firstExceptT ShelleyTxCmdScriptFileError $ + readFileScriptInAnyLang scriptFile + ScriptInEra langInEra script' <- validateScriptSupportedInEra era script + case script' of + SimpleScript version sscript -> + return $ SimpleScriptWitness + langInEra version sscript + + -- If the supplied cli flags were for a simple script (i.e. the user did + -- not supply the datum, redeemer or ex units), but the script file turns + -- out to be a valid plutus script, then we must fail. + PlutusScript{} -> + left $ ShelleyTxCmdScriptExpectedSimple + scriptFile + (AnyScriptLanguage lang) + +createScriptWitness era (PlutusScriptWitnessFiles + (ScriptFile scriptFile) + datumOrFile + redeemerOrFile + execUnits) = do + script@(ScriptInAnyLang lang _) <- firstExceptT ShelleyTxCmdScriptFileError $ + readFileScriptInAnyLang scriptFile + ScriptInEra langInEra script' <- validateScriptSupportedInEra era script + case script' of + PlutusScript version pscript -> do + datum <- readScriptDatumOrFile datumOrFile + redeemer <- readScriptRedeemerOrFile redeemerOrFile + return $ PlutusScriptWitness + langInEra version pscript + datum + redeemer + execUnits + + -- If the supplied cli flags were for a plutus script (i.e. the user did + -- supply the datum, redeemer and ex units), but the script file turns + -- out to be a valid simple script, then we must fail. + SimpleScript{} -> + left $ ShelleyTxCmdScriptExpectedPlutus + scriptFile + (AnyScriptLanguage lang) + + +readScriptDatumOrFile :: ScriptDatumOrFile witctx + -> ExceptT ShelleyTxCmdError IO (ScriptDatum witctx) +readScriptDatumOrFile (ScriptDatumOrFileForTxIn df) = ScriptDatumForTxIn <$> + readScriptDataOrFile df +readScriptDatumOrFile NoScriptDatumOrFileForMint = pure NoScriptDatumForMint +readScriptDatumOrFile NoScriptDatumOrFileForStake = pure NoScriptDatumForStake + +readScriptRedeemerOrFile :: ScriptRedeemerOrFile + -> ExceptT ShelleyTxCmdError IO ScriptRedeemer +readScriptRedeemerOrFile = readScriptDataOrFile + +readScriptDataOrFile :: ScriptDataOrFile + -> ExceptT ShelleyTxCmdError IO ScriptData +readScriptDataOrFile (ScriptDataValue d) = return d +readScriptDataOrFile (ScriptDataFile _f) = do + panic "TODO alonzo: readScriptDataOrFile" + -- This needs the JSON instance, or TxMetadata-like JSON schema support + --firstExceptT ShelleyTxCmdScriptDataFileError $ + -- newExceptT $ readFileJSON AsScriptData f + -- ---------------------------------------------------------------------------- -- Transaction signing From 32e618709b1969c72b15a8b6e6ef63a16cf09f33 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Wed, 2 Jun 2021 21:28:10 +0100 Subject: [PATCH 06/17] Extend the CLI tx parser for Plutus script witnesses This also relies on the JSON instance for ScriptData, which is not included yet. --- .../src/Cardano/CLI/Shelley/Parsers.hs | 76 ++++++++++++++++--- 1 file changed, 64 insertions(+), 12 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs index aec8dacd7ac..1fe8569c3e0 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} module Cardano.CLI.Shelley.Parsers @@ -211,13 +212,64 @@ pScriptFor name help = ScriptFile <$> Opt.strOption <> Opt.completer (Opt.bashCompleter "file") ) -pScriptWitnessFiles :: WitCtx witctx +pScriptWitnessFiles :: forall witctx. + WitCtx witctx -> String -> String -> Parser (ScriptWitnessFiles witctx) -pScriptWitnessFiles _ name help = - -- Just the simple case for now. TODO: extend to Plutus witnesses. - SimpleScriptWitnessFile <$> pScriptFor name help +pScriptWitnessFiles witctx scriptFlagPrefix help = + toScriptWitnessFiles + <$> pScriptFor (scriptFlagPrefix ++ "-script-file") + ("The file containing the script to witness " ++ help) + <*> optional ((,,) <$> pScriptDatumOrFile + <*> pScriptRedeemerOrFile + <*> pExecutionUnits) + where + toScriptWitnessFiles :: ScriptFile + -> Maybe (ScriptDatumOrFile witctx, + ScriptRedeemerOrFile, + ExecutionUnits) + -> ScriptWitnessFiles witctx + toScriptWitnessFiles sf Nothing = SimpleScriptWitnessFile sf + toScriptWitnessFiles sf (Just (d,r,e)) = PlutusScriptWitnessFiles sf d r e + + pScriptDatumOrFile :: Parser (ScriptDatumOrFile witctx) + pScriptDatumOrFile = + case witctx of + WitCtxTxIn -> ScriptDatumOrFileForTxIn <$> pScriptDataOrFile "datum" + WitCtxMint -> pure NoScriptDatumOrFileForMint + WitCtxStake -> pure NoScriptDatumOrFileForStake + + pScriptRedeemerOrFile :: Parser ScriptDataOrFile + pScriptRedeemerOrFile = pScriptDataOrFile "redeemer" + + pScriptDataOrFile :: String -> Parser ScriptDataOrFile + pScriptDataOrFile dataFlagPrefix = + ScriptDataFile <$> pScriptDataFile dataFlagPrefix + <|> ScriptDataValue <$> pScriptDataValue dataFlagPrefix + + pScriptDataFile dataFlagPrefix = + Opt.strOption + ( Opt.long (dataFlagPrefix ++ "-file") + <> Opt.metavar "FILE" + <> Opt.help ("The file containing the script input " + ++ dataFlagPrefix ++ ".") + ) + + pScriptDataValue dataFlagPrefix = + Opt.option (fail "TODO alonzo: use proper JSON parsing here") + ( Opt.long (dataFlagPrefix ++ "-value") + <> Opt.metavar "JSON" + <> Opt.help ("The value for the script input " ++ dataFlagPrefix ++ ".") + ) + + pExecutionUnits = + uncurry ExecutionUnits <$> + Opt.option Opt.auto + ( Opt.long "execution-units" + <> Opt.metavar "(INT, INT)" + <> Opt.help "The time and space units needed by the script." + ) pStakeAddressCmd :: Parser StakeAddressCmd pStakeAddressCmd = @@ -1105,8 +1157,8 @@ pCertificateFile = ) <*> optional (pScriptWitnessFiles WitCtxStake - "certificate-script-file" - "Filepath of the certificate script witness") + "certificate" + "the use of the certificate.") where helpText = "Filepath of the certificate. This encompasses all \ \types of certificates (stake pool certificates, \ @@ -1179,8 +1231,8 @@ pWithdrawal = ) <*> optional (pScriptWitnessFiles WitCtxStake - "withdrawal-script-file" - "Filepath of the withdrawal script witness.") + "withdrawal" + "the withdrawal of rewards.") where helpText = "The reward withdrawal as StakeAddress+Lovelace where \ \StakeAddress is the Bech32-encoded stake address \ @@ -1634,8 +1686,8 @@ pTxIn = ) <*> optional (pScriptWitnessFiles WitCtxTxIn - "txin-script-file" - "Filepath of the spending script witness") + "txin" + "the spending of the transaction input.") parseTxIn :: Atto.Parser TxIn parseTxIn = TxIn <$> parseTxId <*> (Atto.char '#' *> parseTxIx) @@ -1689,8 +1741,8 @@ pMintMultiAsset = ) <*> some (pScriptWitnessFiles WitCtxMint - "minting-script-file" - "Filepath of the multi-asset witness script.") + "minting" + "the minting of assets for a particular policy Id.") where helpText = "Mint multi-asset value(s) with the multi-asset cli syntax. \ From 8c403db51177656bd8a142cbcbaaeb256907a393 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Wed, 2 Jun 2021 22:08:31 +0100 Subject: [PATCH 07/17] Add trivial example Plutus scripts to the API And also as concrete data files in the repo. These scripts always succeed, or always fail, so are only useful for quick sanity tests. --- cardano-api/src/Cardano/Api.hs | 2 + cardano-api/src/Cardano/Api/Script.hs | 47 +++++++++++++++++++++ scripts/plutus/always-fails-mint.plutus | 5 +++ scripts/plutus/always-fails-stake.plutus | 5 +++ scripts/plutus/always-fails-txin.plutus | 5 +++ scripts/plutus/always-succeeds-mint.plutus | 5 +++ scripts/plutus/always-succeeds-stake.plutus | 5 +++ scripts/plutus/always-succeeds-txin.plutus | 5 +++ 8 files changed, 79 insertions(+) create mode 100644 scripts/plutus/always-fails-mint.plutus create mode 100644 scripts/plutus/always-fails-stake.plutus create mode 100644 scripts/plutus/always-fails-txin.plutus create mode 100644 scripts/plutus/always-succeeds-mint.plutus create mode 100644 scripts/plutus/always-succeeds-stake.plutus create mode 100644 scripts/plutus/always-succeeds-txin.plutus diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 8b354d7e919..317c4e335e9 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -335,6 +335,8 @@ module Cardano.Api ( -- ** Plutus scripts PlutusScript, + examplePlutusScriptAlwaysSucceeds, + examplePlutusScriptAlwaysFails, -- ** Script data ScriptData(..), diff --git a/cardano-api/src/Cardano/Api/Script.hs b/cardano-api/src/Cardano/Api/Script.hs index eb7af7f2eba..de59ca74017 100644 --- a/cardano-api/src/Cardano/Api/Script.hs +++ b/cardano-api/src/Cardano/Api/Script.hs @@ -56,6 +56,8 @@ module Cardano.Api.Script ( -- * The Plutus script language PlutusScript(..), + examplePlutusScriptAlwaysSucceeds, + examplePlutusScriptAlwaysFails, -- * Script data ScriptData(..), @@ -105,6 +107,7 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) import Data.Typeable (Typeable) +import Numeric.Natural (Natural) import Data.Aeson (Value (..), object, (.:), (.=)) import qualified Data.Aeson as Aeson @@ -137,6 +140,7 @@ import qualified Cardano.Ledger.Alonzo.Language as Alonzo import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo import qualified Plutus.V1.Ledger.Api as Plutus +import qualified Plutus.V1.Ledger.Examples as Plutus import Cardano.Api.Eras import Cardano.Api.HasTypeProxy @@ -1009,6 +1013,49 @@ instance (IsPlutusScriptLanguage lang, Typeable lang) => PlutusScriptV1 -> "PlutusScriptV1" +-- | An example Plutus script that always succeeds, irrespective of inputs. +-- +-- For example, if one were to use this for a payment address then it would +-- allow anyone to spend from it. +-- +-- The exact script depends on the context in which it is to be used. +-- +examplePlutusScriptAlwaysSucceeds :: WitCtx witctx + -> PlutusScript PlutusScriptV1 +examplePlutusScriptAlwaysSucceeds = + PlutusScriptSerialised + . Plutus.alwaysSucceedingNAryFunction + . scriptArityForWitCtx + +-- | An example Plutus script that always fails, irrespective of inputs. +-- +-- For example, if one were to use this for a payment address then it would +-- be impossible for anyone to ever spend from it. +-- +-- The exact script depends on the context in which it is to be used. +-- +examplePlutusScriptAlwaysFails :: WitCtx witctx + -> PlutusScript PlutusScriptV1 +examplePlutusScriptAlwaysFails = + PlutusScriptSerialised + . Plutus.alwaysFailingNAryFunction + . scriptArityForWitCtx + +-- | The expected arity of the Plutus function, depending on the context in +-- which it is used. +-- +-- The script inputs consist of +-- +-- * the optional datum (for txins) +-- * the redeemer +-- * the Plutus representation of the tx and environment +-- +scriptArityForWitCtx :: WitCtx witctx -> Natural +scriptArityForWitCtx WitCtxTxIn = 3 +scriptArityForWitCtx WitCtxMint = 2 +scriptArityForWitCtx WitCtxStake = 2 + + -- ---------------------------------------------------------------------------- -- Conversion functions -- diff --git a/scripts/plutus/always-fails-mint.plutus b/scripts/plutus/always-fails-mint.plutus new file mode 100644 index 00000000000..7f5c68c6972 --- /dev/null +++ b/scripts/plutus/always-fails-mint.plutus @@ -0,0 +1,5 @@ +{ + "type": "PlutusScriptV1", + "description": "An example Plutus script (for minting context) that always fails", + "cborHex": "4701000020020061" +} diff --git a/scripts/plutus/always-fails-stake.plutus b/scripts/plutus/always-fails-stake.plutus new file mode 100644 index 00000000000..1822187d2e5 --- /dev/null +++ b/scripts/plutus/always-fails-stake.plutus @@ -0,0 +1,5 @@ +{ + "type": "PlutusScriptV1", + "description": "An example Plutus script (for stake context) that always fails", + "cborHex": "4701000020020061" +} diff --git a/scripts/plutus/always-fails-txin.plutus b/scripts/plutus/always-fails-txin.plutus new file mode 100644 index 00000000000..15322da6b57 --- /dev/null +++ b/scripts/plutus/always-fails-txin.plutus @@ -0,0 +1,5 @@ +{ + "type": "PlutusScriptV1", + "description": "An example Plutus script (for tx in context) that always fails", + "cborHex": "49010000200200200601" +} diff --git a/scripts/plutus/always-succeeds-mint.plutus b/scripts/plutus/always-succeeds-mint.plutus new file mode 100644 index 00000000000..e9ffdd1801f --- /dev/null +++ b/scripts/plutus/always-succeeds-mint.plutus @@ -0,0 +1,5 @@ +{ + "type": "PlutusScriptV1", + "description": "An example Plutus script (for minting context) that always succeeds", + "cborHex": "4a01000020020020000101" +} diff --git a/scripts/plutus/always-succeeds-stake.plutus b/scripts/plutus/always-succeeds-stake.plutus new file mode 100644 index 00000000000..0d65781488b --- /dev/null +++ b/scripts/plutus/always-succeeds-stake.plutus @@ -0,0 +1,5 @@ +{ + "type": "PlutusScriptV1", + "description": "An example Plutus script (for stake context) that always succeeds", + "cborHex": "4a01000020020020000101" +} diff --git a/scripts/plutus/always-succeeds-txin.plutus b/scripts/plutus/always-succeeds-txin.plutus new file mode 100644 index 00000000000..d306ead80bb --- /dev/null +++ b/scripts/plutus/always-succeeds-txin.plutus @@ -0,0 +1,5 @@ +{ + "type": "PlutusScriptV1", + "description": "An example Plutus script (for tx in context) that always succeeds", + "cborHex": "4b0100002002002002000011" +} From 2eebaa3fe39ba282dc8fca9d605ef12c9ae39ae4 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Thu, 3 Jun 2021 00:17:24 +0100 Subject: [PATCH 08/17] Split ScriptData out of the Script module It'll be getting larger once we add JSON serialisation. --- cardano-api/cardano-api.cabal | 1 + cardano-api/src/Cardano/Api/Script.hs | 78 +------------- cardano-api/src/Cardano/Api/ScriptData.hs | 124 ++++++++++++++++++++++ 3 files changed, 128 insertions(+), 75 deletions(-) create mode 100644 cardano-api/src/Cardano/Api/ScriptData.hs diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 51eb78229bd..1aa89f03275 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -72,6 +72,7 @@ library Cardano.Api.ProtocolParameters Cardano.Api.Query Cardano.Api.Script + Cardano.Api.ScriptData Cardano.Api.SerialiseBech32 Cardano.Api.SerialiseCBOR Cardano.Api.SerialiseJSON diff --git a/cardano-api/src/Cardano/Api/Script.hs b/cardano-api/src/Cardano/Api/Script.hs index de59ca74017..1340a2fd30a 100644 --- a/cardano-api/src/Cardano/Api/Script.hs +++ b/cardano-api/src/Cardano/Api/Script.hs @@ -95,7 +95,6 @@ module Cardano.Api.Script ( import Prelude import Data.Word (Word64) -import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.ByteString.Short (ShortByteString) import qualified Data.ByteString.Short as SBS @@ -128,24 +127,22 @@ import Cardano.Slotting.Slot (SlotNo) import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Era as Ledger -import qualified Cardano.Ledger.SafeHash as Ledger import qualified Cardano.Ledger.ShelleyMA.Timelocks as Timelock import Ouroboros.Consensus.Shelley.Eras (StandardCrypto) import qualified Cardano.Ledger.Keys as Shelley import qualified Shelley.Spec.Ledger.Scripts as Shelley -import qualified Cardano.Ledger.Alonzo.Data as Alonzo import qualified Cardano.Ledger.Alonzo.Language as Alonzo import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo -import qualified Plutus.V1.Ledger.Api as Plutus import qualified Plutus.V1.Ledger.Examples as Plutus import Cardano.Api.Eras import Cardano.Api.HasTypeProxy import Cardano.Api.Hash import Cardano.Api.KeysShelley +import Cardano.Api.ScriptData import Cardano.Api.SerialiseCBOR import Cardano.Api.SerialiseJSON import Cardano.Api.SerialiseRaw @@ -669,6 +666,8 @@ instance Eq (ScriptWitness witctx era) where (==) _ _ = False +type ScriptRedeemer = ScriptData + data ScriptDatum witctx where ScriptDatumForTxIn :: ScriptData -> ScriptDatum WitCtxTxIn NoScriptDatumForMint :: ScriptDatum WitCtxMint @@ -720,77 +719,6 @@ deriving instance Eq (ScriptWitnessInCtx witctx) deriving instance Show (ScriptWitnessInCtx witctx) --- ---------------------------------------------------------------------------- --- Script data --- - -type ScriptRedeemer = ScriptData - -data ScriptData = ScriptDataConstructor Integer [ScriptData] - | ScriptDataMap [(ScriptData, ScriptData)] - | ScriptDataList [ScriptData] - | ScriptDataNumber Integer - | ScriptDataBytes BS.ByteString - deriving (Eq, Ord, Show) - -- Note the order of constructors is the same as the Plutus definitions - -- so that the Ord instance is consistent with the Plutus one. - -- This is checked by prop_ord_distributive_ScriptData - -instance HasTypeProxy ScriptData where - data AsType ScriptData = AsScriptData - proxyToAsType _ = AsScriptData - -toAlonzoData :: ScriptData -> Alonzo.Data ledgerera -toAlonzoData = Alonzo.Data . toPlutusData - -fromAlonzoData :: Alonzo.Data ledgerera -> ScriptData -fromAlonzoData = fromPlutusData . Alonzo.getPlutusData - - -toPlutusData :: ScriptData -> Plutus.Data -toPlutusData (ScriptDataConstructor int xs) - = Plutus.Constr int - [ toPlutusData x | x <- xs ] -toPlutusData (ScriptDataMap kvs) = Plutus.Map - [ (toPlutusData k, toPlutusData v) - | (k,v) <- kvs ] -toPlutusData (ScriptDataList xs) = Plutus.List - [ toPlutusData x | x <- xs ] -toPlutusData (ScriptDataNumber n) = Plutus.I n -toPlutusData (ScriptDataBytes bs) = Plutus.B bs - -fromPlutusData :: Plutus.Data -> ScriptData -fromPlutusData (Plutus.Constr int xs) - = ScriptDataConstructor int - [ fromPlutusData x | x <- xs ] -fromPlutusData (Plutus.Map kvs) = ScriptDataMap - [ (fromPlutusData k, fromPlutusData v) - | (k,v) <- kvs ] -fromPlutusData (Plutus.List xs) = ScriptDataList - [ fromPlutusData x | x <- xs ] -fromPlutusData (Plutus.I n) = ScriptDataNumber n -fromPlutusData (Plutus.B bs) = ScriptDataBytes bs - - -newtype instance Hash ScriptData = - ScriptDataHash (Alonzo.DataHash StandardCrypto) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash ScriptData) - -instance SerialiseAsRawBytes (Hash ScriptData) where - serialiseToRawBytes (ScriptDataHash dh) = - Crypto.hashToBytes (Ledger.extractHash dh) - - deserialiseFromRawBytes (AsHash AsScriptData) bs = - ScriptDataHash . Ledger.unsafeMakeSafeHash <$> Crypto.hashFromBytes bs - -instance ToJSON (Hash ScriptData) where - toJSON = toJSON . serialiseToRawBytesHexText - -instance Aeson.ToJSONKey (Hash ScriptData) where - toJSONKey = Aeson.toJSONKeyText serialiseToRawBytesHexText - - -- ---------------------------------------------------------------------------- -- Script execution units -- diff --git a/cardano-api/src/Cardano/Api/ScriptData.hs b/cardano-api/src/Cardano/Api/ScriptData.hs new file mode 100644 index 00000000000..83c223f0b64 --- /dev/null +++ b/cardano-api/src/Cardano/Api/ScriptData.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Api.ScriptData ( + -- * Script data + ScriptData(..), + + -- * Internal conversion functions + toPlutusData, + fromPlutusData, + toAlonzoData, + fromAlonzoData, + + -- * Data family instances + AsType(..), + Hash(..), + ) where + +import Prelude + +import qualified Data.ByteString as BS +import Data.String (IsString) + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson + +import qualified Cardano.Crypto.Hash.Class as Crypto + +import qualified Cardano.Ledger.SafeHash as Ledger + +import Ouroboros.Consensus.Shelley.Eras (StandardCrypto) + +import qualified Cardano.Ledger.Alonzo.Data as Alonzo + +import qualified Plutus.V1.Ledger.Api as Plutus + +import Cardano.Api.Eras +import Cardano.Api.HasTypeProxy +import Cardano.Api.Hash +import Cardano.Api.KeysShelley +import Cardano.Api.SerialiseJSON +import Cardano.Api.SerialiseRaw + + +-- ---------------------------------------------------------------------------- +-- Script data +-- + +data ScriptData = ScriptDataConstructor Integer [ScriptData] + | ScriptDataMap [(ScriptData, ScriptData)] + | ScriptDataList [ScriptData] + | ScriptDataNumber Integer + | ScriptDataBytes BS.ByteString + deriving (Eq, Ord, Show) + -- Note the order of constructors is the same as the Plutus definitions + -- so that the Ord instance is consistent with the Plutus one. + -- This is checked by prop_ord_distributive_ScriptData + +instance HasTypeProxy ScriptData where + data AsType ScriptData = AsScriptData + proxyToAsType _ = AsScriptData + + +-- ---------------------------------------------------------------------------- +-- Script data hash +-- + +newtype instance Hash ScriptData = + ScriptDataHash (Alonzo.DataHash StandardCrypto) + deriving stock (Eq, Ord) + deriving (Show, IsString) via UsingRawBytesHex (Hash ScriptData) + +instance SerialiseAsRawBytes (Hash ScriptData) where + serialiseToRawBytes (ScriptDataHash dh) = + Crypto.hashToBytes (Ledger.extractHash dh) + + deserialiseFromRawBytes (AsHash AsScriptData) bs = + ScriptDataHash . Ledger.unsafeMakeSafeHash <$> Crypto.hashFromBytes bs + +instance ToJSON (Hash ScriptData) where + toJSON = toJSON . serialiseToRawBytesHexText + +instance Aeson.ToJSONKey (Hash ScriptData) where + toJSONKey = Aeson.toJSONKeyText serialiseToRawBytesHexText + + +-- ---------------------------------------------------------------------------- +-- Conversion functions +-- + +toAlonzoData :: ScriptData -> Alonzo.Data ledgerera +toAlonzoData = Alonzo.Data . toPlutusData + +fromAlonzoData :: Alonzo.Data ledgerera -> ScriptData +fromAlonzoData = fromPlutusData . Alonzo.getPlutusData + + +toPlutusData :: ScriptData -> Plutus.Data +toPlutusData (ScriptDataConstructor int xs) + = Plutus.Constr int + [ toPlutusData x | x <- xs ] +toPlutusData (ScriptDataMap kvs) = Plutus.Map + [ (toPlutusData k, toPlutusData v) + | (k,v) <- kvs ] +toPlutusData (ScriptDataList xs) = Plutus.List + [ toPlutusData x | x <- xs ] +toPlutusData (ScriptDataNumber n) = Plutus.I n +toPlutusData (ScriptDataBytes bs) = Plutus.B bs + + +fromPlutusData :: Plutus.Data -> ScriptData +fromPlutusData (Plutus.Constr int xs) + = ScriptDataConstructor int + [ fromPlutusData x | x <- xs ] +fromPlutusData (Plutus.Map kvs) = ScriptDataMap + [ (fromPlutusData k, fromPlutusData v) + | (k,v) <- kvs ] +fromPlutusData (Plutus.List xs) = ScriptDataList + [ fromPlutusData x | x <- xs ] +fromPlutusData (Plutus.I n) = ScriptDataNumber n +fromPlutusData (Plutus.B bs) = ScriptDataBytes bs + From 2501924386fa8c533a6534b0a5e4dfa78c2cf7c4 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Thu, 3 Jun 2021 01:48:20 +0100 Subject: [PATCH 09/17] Add JSON serialisation for ScriptData Following the style of the TxMetadata --- cardano-api/src/Cardano/Api/ScriptData.hs | 448 +++++++++++++++++++++- cardano-api/src/Cardano/Api/TxMetadata.hs | 6 + 2 files changed, 450 insertions(+), 4 deletions(-) diff --git a/cardano-api/src/Cardano/Api/ScriptData.hs b/cardano-api/src/Cardano/Api/ScriptData.hs index 83c223f0b64..5874333d682 100644 --- a/cardano-api/src/Cardano/Api/ScriptData.hs +++ b/cardano-api/src/Cardano/Api/ScriptData.hs @@ -7,6 +7,17 @@ module Cardano.Api.ScriptData ( -- * Script data ScriptData(..), + -- * Validating metadata + validateScriptData, + ScriptDataRangeError (..), + + -- * Converstion to\/from JSON + ScriptDataJsonSchema (..), + scriptDataFromJson, + scriptDataToJson, + ScriptDataJsonError (..), + ScriptDataJsonSchemaError (..), + -- * Internal conversion functions toPlutusData, fromPlutusData, @@ -20,28 +31,45 @@ module Cardano.Api.ScriptData ( import Prelude +import Data.Bifunctor (first) +import Data.Maybe (fromMaybe) +import Data.Word +import qualified Data.Scientific as Scientific +import qualified Data.Char as Char import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.ByteString.Base16 as Base16 import Data.String (IsString) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.HashMap.Strict as HashMap +import qualified Data.List as List +import qualified Data.Vector as Vector import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Text as Aeson.Text import qualified Data.Aeson.Types as Aeson +import qualified Data.Attoparsec.ByteString.Char8 as Atto -import qualified Cardano.Crypto.Hash.Class as Crypto +import Control.Applicative (Alternative (..)) +import qualified Cardano.Crypto.Hash.Class as Crypto import qualified Cardano.Ledger.SafeHash as Ledger - import Ouroboros.Consensus.Shelley.Eras (StandardCrypto) - import qualified Cardano.Ledger.Alonzo.Data as Alonzo - import qualified Plutus.V1.Ledger.Api as Plutus import Cardano.Api.Eras +import Cardano.Api.Error import Cardano.Api.HasTypeProxy import Cardano.Api.Hash import Cardano.Api.KeysShelley import Cardano.Api.SerialiseJSON import Cardano.Api.SerialiseRaw +import Cardano.Api.TxMetadata (parseAll, pSigned, pBytes) -- ---------------------------------------------------------------------------- @@ -122,3 +150,415 @@ fromPlutusData (Plutus.List xs) = ScriptDataList fromPlutusData (Plutus.I n) = ScriptDataNumber n fromPlutusData (Plutus.B bs) = ScriptDataBytes bs + +-- ---------------------------------------------------------------------------- +-- Validate script data +-- + +-- | Validate script data. This is for use with existing constructed script +-- data values, e.g. constructed manually or decoded from CBOR directly. +-- +validateScriptData :: ScriptData -> Either ScriptDataRangeError () +validateScriptData d = + case collect d of + [] -> Right () + err:_ -> Left err + where + -- collect all errors in a monoidal fold style: + collect (ScriptDataNumber n) = + [ ScriptDataNumberOutOfRange n + | n > fromIntegral (maxBound :: Word64) + || n < negate (fromIntegral (maxBound :: Word64)) + ] + collect (ScriptDataBytes bs) = + [ ScriptDataBytesTooLong len + | let len = BS.length bs + , len > scriptDataByteStringMaxLength + ] + collect (ScriptDataList xs) = + foldMap collect xs + + collect (ScriptDataMap kvs) = + foldMap (\(k, v) -> collect k + <> collect v) + kvs + + collect (ScriptDataConstructor n xs) = + [ ScriptDataConstructorOutOfRange n + | n > fromIntegral (maxBound :: Word64) || n < 0 ] + <> foldMap collect xs + + +-- | The maximum length of a script data byte string value. +scriptDataByteStringMaxLength :: Int +scriptDataByteStringMaxLength = 64 + + +-- | An error in script data due to an out-of-range value. +-- +data ScriptDataRangeError = + + -- | The number is outside the maximum range of @-2^64-1 .. 2^64-1@. + -- + ScriptDataNumberOutOfRange !Integer + + -- | The number is outside the maximum range of @-2^64-1 .. 2^64-1@. + -- + | ScriptDataConstructorOutOfRange !Integer + + -- | The length of a byte string metadatum value exceeds the maximum of + -- 64 bytes. + -- + | ScriptDataBytesTooLong !Int + deriving (Eq, Show) + +instance Error ScriptDataRangeError where + displayError (ScriptDataNumberOutOfRange n) = + "Number in script data value " + <> show n + <> " is outside the range -(2^64-1) .. 2^64-1." + displayError (ScriptDataConstructorOutOfRange n) = + "Constructor numbers in script data value " + <> show n + <> " is outside the range 0 .. 2^64-1." + displayError (ScriptDataBytesTooLong actualLen) = + "Byte strings in script data must consist of at most " + <> show scriptDataByteStringMaxLength + <> " bytes, but it consists of " + <> show actualLen + <> " bytes." + + +-- ---------------------------------------------------------------------------- +-- JSON conversion +-- + +-- | Script data is similar to JSON but not exactly the same. It has some +-- deliberate limitations such as no support for floating point numbers or +-- special forms for null or boolean values. It also has limitations on the +-- length of strings. On the other hand, unlike JSON, it distinguishes between +-- byte strings and text strings. It also supports any value as map keys rather +-- than just string. It also supports alternatives \/ tagged unions, used for +-- representing constructors for Plutus data values. +-- +-- We provide two different mappings between script data and JSON, useful +-- for different purposes: +-- +-- 1. A mapping that allows almost any JSON value to be converted into script +-- data. This does not require a specific JSON schema for the input. It does +-- not expose the full representation capability of script data. +-- +-- 2. A mapping that exposes the full representation capability of script data, +-- but relies on a specific JSON schema for the input JSON. +-- +-- In the \"no schema"\ mapping, the idea is that (almost) any JSON can be +-- turned into script data and then converted back, without loss. That is, we +-- can round-trip the JSON. +-- +-- The subset of JSON supported is all JSON except: +-- * No null or bool values +-- * No floating point, only integers in the range of a 64bit signed integer +-- * A limitation on string lengths +-- +-- The approach for this mapping is to use whichever representation as script +-- data is most compact. In particular: +-- +-- * JSON lists and maps represented as CBOR lists and maps +-- * JSON strings represented as CBOR strings +-- * JSON hex strings with \"0x\" prefix represented as CBOR byte strings +-- * JSON integer numbers represented as CBOR signed or unsigned numbers +-- * JSON maps with string keys that parse as numbers or hex byte strings, +-- represented as CBOR map keys that are actually numbers or byte strings. +-- +-- The string length limit depends on whether the hex string representation +-- is used or not. For text strings the limit is 64 bytes for the UTF8 +-- representation of the text string. For byte strings the limit is 64 bytes +-- for the raw byte form (ie not the input hex, but after hex decoding). +-- +-- In the \"detailed schema\" mapping, the idea is that we expose the full +-- representation capability of the script data in the form of a JSON schema. +-- This means the full representation is available and can be controlled +-- precisely. It also means any script data can be converted into the JSON and +-- back without loss. That is we can round-trip the script data via the JSON and +-- also round-trip schema-compliant JSON via script data. +-- +data ScriptDataJsonSchema = + + -- | Use the \"no schema\" mapping between JSON and script data as + -- described above. + ScriptDataJsonNoSchema + + -- | Use the \"detailed schema\" mapping between JSON and script data as + -- described above. + | ScriptDataJsonDetailedSchema + deriving (Eq, Show) + + +-- | Convert a value from JSON into script data, using the given choice of +-- mapping between JSON and script data. +-- +-- This may fail with a conversion error if the JSON is outside the supported +-- subset for the chosen mapping. See 'ScriptDataJsonSchema' for the details. +-- +scriptDataFromJson :: ScriptDataJsonSchema + -> Aeson.Value + -> Either ScriptDataJsonError ScriptData +scriptDataFromJson schema v = do + d <- first (ScriptDataJsonSchemaError v) (scriptDataFromJson' v) + first (ScriptDataRangeError v) (validateScriptData d) + return d + where + scriptDataFromJson' = + case schema of + ScriptDataJsonNoSchema -> scriptDataFromJsonNoSchema + ScriptDataJsonDetailedSchema -> scriptDataFromJsonDetailedSchema + + + +-- | Convert a script data value into JSON , using the given choice of mapping +-- between JSON and script data. +-- +-- This conversion is total but is not necessarily invertible. +-- See 'ScriptDataJsonSchema' for the details. +-- +scriptDataToJson :: ScriptDataJsonSchema + -> ScriptData + -> Aeson.Value +scriptDataToJson schema = + case schema of + ScriptDataJsonNoSchema -> scriptDataToJsonNoSchema + ScriptDataJsonDetailedSchema -> scriptDataToJsonDetailedSchema + + +-- ---------------------------------------------------------------------------- +-- JSON conversion using the the "no schema" style +-- + +scriptDataToJsonNoSchema :: ScriptData -> Aeson.Value +scriptDataToJsonNoSchema = conv + where + conv :: ScriptData -> Aeson.Value + conv (ScriptDataNumber n) = Aeson.Number (fromInteger n) + conv (ScriptDataBytes bs) + | Right s <- Text.decodeUtf8' bs + , Text.all Char.isPrint s + = Aeson.String s + + | otherwise + = Aeson.String (bytesPrefix <> Text.decodeLatin1 (Base16.encode bs)) + + conv (ScriptDataList vs) = Aeson.Array (Vector.fromList (map conv vs)) + conv (ScriptDataMap kvs) = Aeson.object + [ (convKey k, conv v) + | (k, v) <- kvs ] + + conv (ScriptDataConstructor n vs) = + Aeson.Array $ + Vector.fromList + [ Aeson.Number (fromInteger n) + , Aeson.Array (Vector.fromList (map conv vs)) + ] + + + -- Script data allows any value as a key, not just string as JSON does. + -- For simple types we just convert them to string dirctly. + -- For structured keys we render them as JSON and use that as the string. + convKey :: ScriptData -> Text + convKey (ScriptDataNumber n) = Text.pack (show n) + convKey (ScriptDataBytes bs) = bytesPrefix + <> Text.decodeLatin1 (Base16.encode bs) + convKey v = Text.Lazy.toStrict + . Aeson.Text.encodeToLazyText + . conv + $ v + +scriptDataFromJsonNoSchema :: Aeson.Value + -> Either ScriptDataJsonSchemaError + ScriptData +scriptDataFromJsonNoSchema = conv + where + conv :: Aeson.Value + -> Either ScriptDataJsonSchemaError ScriptData + conv Aeson.Null = Left ScriptDataJsonNullNotAllowed + conv Aeson.Bool{} = Left ScriptDataJsonBoolNotAllowed + + conv (Aeson.Number d) = + case Scientific.floatingOrInteger d :: Either Double Integer of + Left n -> Left (ScriptDataJsonNumberNotInteger n) + Right n -> Right (ScriptDataNumber n) + + conv (Aeson.String s) + | Just s' <- Text.stripPrefix bytesPrefix s + , let bs' = Text.encodeUtf8 s' + , Right bs <- Base16.decode bs' + , not (BSC.any (\c -> c >= 'A' && c <= 'F') bs') + = Right (ScriptDataBytes bs) + + | otherwise + = Right (ScriptDataBytes (Text.encodeUtf8 s)) + + conv (Aeson.Array vs) = + fmap ScriptDataList + . traverse conv + $ Vector.toList vs + + conv (Aeson.Object kvs) = + fmap ScriptDataMap + . traverse (\(k,v) -> (,) (convKey k) <$> conv v) + . List.sortOn fst + $ HashMap.toList kvs + + convKey :: Text -> ScriptData + convKey s = + fromMaybe (ScriptDataBytes (Text.encodeUtf8 s)) $ + parseAll ((fmap ScriptDataNumber pSigned <* Atto.endOfInput) + <|> (fmap ScriptDataBytes pBytes <* Atto.endOfInput)) s + +-- | JSON strings that are base16 encoded and prefixed with 'bytesPrefix' will +-- be encoded as CBOR bytestrings. +bytesPrefix :: Text +bytesPrefix = "0x" + + +-- ---------------------------------------------------------------------------- +-- JSON conversion using the "detailed schema" style +-- + +scriptDataToJsonDetailedSchema :: ScriptData -> Aeson.Value +scriptDataToJsonDetailedSchema = conv + where + conv :: ScriptData -> Aeson.Value + conv (ScriptDataNumber n) = singleFieldObject "int" + . Aeson.Number + $ fromInteger n + conv (ScriptDataBytes bs) = singleFieldObject "bytes" + . Aeson.String + $ Text.decodeLatin1 (Base16.encode bs) + conv (ScriptDataList vs) = singleFieldObject "list" + . Aeson.Array + $ Vector.fromList (map conv vs) + conv (ScriptDataMap kvs) = singleFieldObject "map" + . Aeson.Array + $ Vector.fromList + [ Aeson.object [ ("k", conv k), ("v", conv v) ] + | (k, v) <- kvs ] + + conv (ScriptDataConstructor n vs) = + Aeson.object + [ ("constructor", Aeson.Number (fromInteger n)) + , ("fields", Aeson.Array (Vector.fromList (map conv vs))) + ] + + singleFieldObject name v = Aeson.object [(name, v)] + + +scriptDataFromJsonDetailedSchema :: Aeson.Value + -> Either ScriptDataJsonSchemaError + ScriptData +scriptDataFromJsonDetailedSchema = conv + where + conv :: Aeson.Value + -> Either ScriptDataJsonSchemaError ScriptData + conv (Aeson.Object m) = + case HashMap.toList m of + [("int", Aeson.Number d)] -> + case Scientific.floatingOrInteger d :: Either Double Integer of + Left n -> Left (ScriptDataJsonNumberNotInteger n) + Right n -> Right (ScriptDataNumber n) + + [("bytes", Aeson.String s)] + | Right bs <- Base16.decode (Text.encodeUtf8 s) + -> Right (ScriptDataBytes bs) + + [("list", Aeson.Array vs)] -> + fmap ScriptDataList + . traverse conv + $ Vector.toList vs + + [("map", Aeson.Array kvs)] -> + fmap ScriptDataMap + . traverse convKeyValuePair + $ Vector.toList kvs + + [("constructor", Aeson.Number d), + ("fields", Aeson.Array vs)] -> + case Scientific.floatingOrInteger d :: Either Double Integer of + Left n -> Left (ScriptDataJsonNumberNotInteger n) + Right n -> fmap (ScriptDataConstructor n) + . traverse conv + $ Vector.toList vs + + (key, v):_ | key `elem` ["int", "bytes", "list", "map", "constructor"] -> + Left (ScriptDataJsonTypeMismatch key v) + + kvs -> Left (ScriptDataJsonBadObject kvs) + + conv v = Left (ScriptDataJsonNotObject v) + + convKeyValuePair :: Aeson.Value + -> Either ScriptDataJsonSchemaError + (ScriptData, ScriptData) + convKeyValuePair (Aeson.Object m) + | HashMap.size m == 2 + , Just k <- m HashMap.!? "k" + , Just v <- m HashMap.!? "v" + = (,) <$> conv k <*> conv v + + convKeyValuePair v = Left (ScriptDataJsonBadMapPair v) + + +-- ---------------------------------------------------------------------------- +-- Shared JSON conversion error types +-- + +data ScriptDataJsonError = + ScriptDataJsonSchemaError !Aeson.Value !ScriptDataJsonSchemaError + | ScriptDataRangeError !Aeson.Value !ScriptDataRangeError + deriving (Eq, Show) + +data ScriptDataJsonSchemaError = + -- Only used for 'ScriptDataJsonNoSchema' + ScriptDataJsonNullNotAllowed + | ScriptDataJsonBoolNotAllowed + + -- Used by both mappings + | ScriptDataJsonNumberNotInteger !Double + + -- Only used for 'ScriptDataJsonDetailedSchema' + | ScriptDataJsonNotObject !Aeson.Value + | ScriptDataJsonBadObject ![(Text, Aeson.Value)] + | ScriptDataJsonBadMapPair !Aeson.Value + | ScriptDataJsonTypeMismatch !Text !Aeson.Value + deriving (Eq, Show) + +instance Error ScriptDataJsonError where + displayError (ScriptDataJsonSchemaError v detail) = + "JSON schema error within the script data: " + ++ LBS.unpack (Aeson.encode v) ++ "\n" ++ displayError detail + displayError (ScriptDataRangeError v detail) = + "Value out of range within the script data: " + ++ LBS.unpack (Aeson.encode v) ++ "\n" ++ displayError detail + +instance Error ScriptDataJsonSchemaError where + displayError ScriptDataJsonNullNotAllowed = + "JSON null values are not supported." + displayError ScriptDataJsonBoolNotAllowed = + "JSON bool values are not supported." + displayError (ScriptDataJsonNumberNotInteger d) = + "JSON numbers must be integers. Unexpected value: " ++ show d + displayError (ScriptDataJsonNotObject v) = + "JSON object expected. Unexpected value: " + ++ LBS.unpack (Aeson.encode v) + displayError (ScriptDataJsonBadObject v) = + "JSON object does not match the schema.\nExpected a single field named " + ++ "\"int\", \"bytes\", \"string\", \"list\" or \"map\".\n" + ++ "Unexpected object field(s): " + ++ LBS.unpack (Aeson.encode (Aeson.object v)) + displayError (ScriptDataJsonBadMapPair v) = + "Expected a list of key/value pair { \"k\": ..., \"v\": ... } objects." + ++ "\nUnexpected value: " ++ LBS.unpack (Aeson.encode v) + displayError (ScriptDataJsonTypeMismatch k v) = + "The value in the field " ++ show k ++ " does not have the type " + ++ "required by the schema.\nUnexpected value: " + ++ LBS.unpack (Aeson.encode v) + diff --git a/cardano-api/src/Cardano/Api/TxMetadata.hs b/cardano-api/src/Cardano/Api/TxMetadata.hs index ca9182d0d87..3086bfc4402 100644 --- a/cardano-api/src/Cardano/Api/TxMetadata.hs +++ b/cardano-api/src/Cardano/Api/TxMetadata.hs @@ -27,6 +27,12 @@ module Cardano.Api.TxMetadata ( toShelleyMetadata, fromShelleyMetadata, + -- * Shared parsing utils + parseAll, + pUnsigned, + pSigned, + pBytes, + -- * Data family instances AsType(..) ) where From 5b64a7a4f60cf025645ae0ad9edb2dfd2a058639 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Thu, 3 Jun 2021 13:31:08 +0100 Subject: [PATCH 10/17] Complete readScriptDataOrFile for reading script data JSON files Relying on the new JSON support. --- cardano-api/src/Cardano/Api.hs | 14 +++++++- .../Cardano/CLI/Shelley/Run/Transaction.hs | 32 ++++++++++++++++--- 2 files changed, 40 insertions(+), 6 deletions(-) diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 317c4e335e9..ec43371dd3d 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -338,9 +338,20 @@ module Cardano.Api ( examplePlutusScriptAlwaysSucceeds, examplePlutusScriptAlwaysFails, - -- ** Script data + -- * Script data ScriptData(..), + -- ** Validation + ScriptDataRangeError (..), + validateScriptData, + + -- ** Conversion to\/from JSON + ScriptDataJsonSchema (..), + scriptDataFromJson, + scriptDataToJson, + ScriptDataJsonError (..), + ScriptDataJsonSchemaError (..), + -- * Script execution units ExecutionUnits(..), @@ -553,6 +564,7 @@ import Cardano.Api.OperationalCertificate import Cardano.Api.ProtocolParameters import Cardano.Api.Query (SlotsInEpoch(..), SlotsToEpochEnd(..), slotToEpoch) import Cardano.Api.Script +import Cardano.Api.ScriptData import Cardano.Api.SerialiseBech32 import Cardano.Api.SerialiseCBOR import Cardano.Api.SerialiseJSON diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs index c636d6bc866..212698c1438 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs @@ -70,6 +70,9 @@ data ShelleyTxCmdError | ShelleyTxCmdMetadataJsonParseError !FilePath !String | ShelleyTxCmdMetadataConversionError !FilePath !TxMetadataJsonError | ShelleyTxCmdMetaValidationError !FilePath ![(Word64, TxMetadataRangeError)] + | ShelleyTxCmdScriptDataJsonParseError FilePath String + | ShelleyTxCmdScriptDataConversionError FilePath ScriptDataJsonError + | ShelleyTxCmdScriptDataValidationError FilePath ScriptDataRangeError | ShelleyTxCmdMetaDecodeError !FilePath !CBOR.DecoderError | ShelleyTxCmdBootstrapWitnessError !ShelleyBootstrapWitnessError | ShelleyTxCmdSocketEnvError !EnvSocketError @@ -119,6 +122,17 @@ renderShelleyTxCmdError err = Text.intercalate "\n" [ "key " <> show k <> ":" <> Text.pack (displayError valErr) | (k, valErr) <- errs ] + + ShelleyTxCmdScriptDataJsonParseError fp jsonErr -> + "Invalid JSON format in file: " <> show fp <> + "\nJSON parse error: " <> Text.pack jsonErr + ShelleyTxCmdScriptDataConversionError fp cerr -> + "Error reading metadata at: " <> show fp + <> "\n" <> Text.pack (displayError cerr) + ShelleyTxCmdScriptDataValidationError fp verr -> + "Error validating script data at: " <> show fp <> ":\n" <> + Text.pack (displayError verr) + ShelleyTxCmdSocketEnvError envSockErr -> renderEnvSocketError envSockErr ShelleyTxCmdAesonDecodeProtocolParamsError fp decErr -> "Error while decoding the protocol parameters at: " <> show fp @@ -657,11 +671,19 @@ readScriptRedeemerOrFile = readScriptDataOrFile readScriptDataOrFile :: ScriptDataOrFile -> ExceptT ShelleyTxCmdError IO ScriptData readScriptDataOrFile (ScriptDataValue d) = return d -readScriptDataOrFile (ScriptDataFile _f) = do - panic "TODO alonzo: readScriptDataOrFile" - -- This needs the JSON instance, or TxMetadata-like JSON schema support - --firstExceptT ShelleyTxCmdScriptDataFileError $ - -- newExceptT $ readFileJSON AsScriptData f +readScriptDataOrFile (ScriptDataFile fp) = do + bs <- handleIOExceptT (ShelleyTxCmdReadFileError . FileIOError fp) $ + LBS.readFile fp + v <- firstExceptT (ShelleyTxCmdScriptDataJsonParseError fp) $ + hoistEither $ + Aeson.eitherDecode' bs + sd <- firstExceptT (ShelleyTxCmdScriptDataConversionError fp) $ + hoistEither $ + scriptDataFromJson ScriptDataJsonDetailedSchema v + firstExceptT (ShelleyTxCmdScriptDataValidationError fp) $ + hoistEither $ + validateScriptData sd + return sd -- ---------------------------------------------------------------------------- From 823aa4b64f1d2804616590c55daf1c5e3d1cc027 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Thu, 3 Jun 2021 13:33:26 +0100 Subject: [PATCH 11/17] Fill in the cli parser for --datum-value / --redeemer-value flags Supporting the simple schema-less JSON representation of script data. --- cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs index 1fe8569c3e0..4d97ebad1d7 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs @@ -45,6 +45,7 @@ import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.Encoding as Text +import qualified Data.Aeson.Parser as Aeson.Parser import qualified Data.Attoparsec.ByteString.Char8 as Atto import qualified Options.Applicative as Opt import qualified Text.Parsec as Parsec @@ -257,12 +258,18 @@ pScriptWitnessFiles witctx scriptFlagPrefix help = ) pScriptDataValue dataFlagPrefix = - Opt.option (fail "TODO alonzo: use proper JSON parsing here") + Opt.option readerScriptData ( Opt.long (dataFlagPrefix ++ "-value") <> Opt.metavar "JSON" <> Opt.help ("The value for the script input " ++ dataFlagPrefix ++ ".") ) + readerScriptData = do + v <- readerFromAttoParser Aeson.Parser.json + case scriptDataFromJson ScriptDataJsonNoSchema v of + Left err -> fail (displayError err) + Right sd -> return sd + pExecutionUnits = uncurry ExecutionUnits <$> Opt.option Opt.auto From 738f3116c927826860e219892b28d44017e07c34 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Thu, 3 Jun 2021 13:34:37 +0100 Subject: [PATCH 12/17] Extend the cli file format support for the Alonzo era --- cardano-api/src/Cardano/Api.hs | 1 + cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs | 2 ++ 2 files changed, 3 insertions(+) diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index ec43371dd3d..fe47d8c5260 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -16,6 +16,7 @@ module Cardano.Api ( ShelleyEra, AllegraEra, MaryEra, + AlonzoEra, CardanoEra(..), IsCardanoEra(..), AnyCardanoEra(..), diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs index 212698c1438..f87ee5b1b7e 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs @@ -1121,6 +1121,7 @@ readFileInAnyCardanoEra , HasTextEnvelope (thing ShelleyEra) , HasTextEnvelope (thing AllegraEra) , HasTextEnvelope (thing MaryEra) + , HasTextEnvelope (thing AlonzoEra) ) => (forall era. AsType era -> AsType (thing era)) -> FilePath @@ -1134,6 +1135,7 @@ readFileInAnyCardanoEra asThing file = , FromSomeType (asThing AsShelleyEra) (InAnyCardanoEra ShelleyEra) , FromSomeType (asThing AsAllegraEra) (InAnyCardanoEra AllegraEra) , FromSomeType (asThing AsMaryEra) (InAnyCardanoEra MaryEra) + , FromSomeType (asThing AsAlonzoEra) (InAnyCardanoEra AlonzoEra) ] file From 8f9fe7e3dc9233d2b0df762b5ad0203aff65a1a5 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Thu, 3 Jun 2021 16:38:14 +0100 Subject: [PATCH 13/17] Add cli plumbing for tx inputs for collateral Collateral inouts are needed for every tx that uses Plutus scripts. --- .../src/Cardano/CLI/Shelley/Commands.hs | 2 ++ .../src/Cardano/CLI/Shelley/Parsers.hs | 9 +++++++ .../Cardano/CLI/Shelley/Run/Transaction.hs | 26 +++++++++++++++---- 3 files changed, 32 insertions(+), 5 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs index fc169dda21a..fde1225fdb3 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs @@ -164,6 +164,8 @@ data TransactionCmd AnyCardanoEra [(TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn))] -- ^ Transaction inputs with optional spending scripts + [TxIn] + -- ^ Transaction inputs for collateral, only key witnesses, no scripts. [TxOutAnyEra] (Maybe (Value, [ScriptWitnessFiles WitCtxMint])) -- ^ Multi-Asset value with script witness diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs index 4d97ebad1d7..dab24d03811 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs @@ -574,6 +574,7 @@ pTransaction = pTransactionBuild :: Parser TransactionCmd pTransactionBuild = TxBuildRaw <$> pCardanoEra <*> some pTxIn + <*> many pTxInCollateral <*> many pTxOut <*> optional pMintMultiAsset <*> optional pInvalidBefore @@ -1696,6 +1697,14 @@ pTxIn = "txin" "the spending of the transaction input.") +pTxInCollateral :: Parser TxIn +pTxInCollateral = + Opt.option (readerFromAttoParser parseTxIn) + ( Opt.long "tx-in-collateral" + <> Opt.metavar "TX-IN" + <> Opt.help "TxId#TxIx" + ) + parseTxIn :: Atto.Parser TxIn parseTxIn = TxIn <$> parseTxId <*> (Atto.char '#' *> parseTxIx) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs index f87ee5b1b7e..a6e5fffc310 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs @@ -232,10 +232,10 @@ renderFeature TxFeatureCollateral = "Collateral inputs" runTransactionCmd :: TransactionCmd -> ExceptT ShelleyTxCmdError IO () runTransactionCmd cmd = case cmd of - TxBuildRaw era txins txouts mValue mLowBound mUpperBound + TxBuildRaw era txins txinsc txouts mValue mLowBound mUpperBound fee certs wdrls metadataSchema scriptFiles metadataFiles mUpProp out -> - runTxBuildRaw era txins txouts mLowBound mUpperBound + runTxBuildRaw era txins txinsc txouts mLowBound mUpperBound fee mValue certs wdrls metadataSchema scriptFiles metadataFiles mUpProp out TxSign txinfile skfiles network txoutfile -> @@ -263,6 +263,8 @@ runTxBuildRaw :: AnyCardanoEra -> [(TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn))] -- ^ TxIn with potential script witness + -> [TxIn] + -- ^ TxIn for collateral -> [TxOutAnyEra] -> Maybe SlotNo -- ^ Tx lower bound @@ -281,8 +283,10 @@ runTxBuildRaw -> Maybe UpdateProposalFile -> TxBodyFile -> ExceptT ShelleyTxCmdError IO () -runTxBuildRaw (AnyCardanoEra era) inputsAndScripts txouts mLowerBound - mUpperBound mFee mValue +runTxBuildRaw (AnyCardanoEra era) + inputsAndScripts inputsCollateral txouts + mLowerBound mUpperBound + mFee mValue certFiles withdrawals metadataSchema scriptFiles metadataFiles mUpdatePropFile @@ -290,7 +294,8 @@ runTxBuildRaw (AnyCardanoEra era) inputsAndScripts txouts mLowerBound txBodyContent <- TxBodyContent <$> validateTxIns era inputsAndScripts - <*> pure TxInsCollateralNone --TODO alonzo: support this + <*> validateTxInsCollateral + era inputsCollateral <*> validateTxOuts era txouts <*> validateTxFee era mFee <*> ((,) <$> validateTxValidityLowerBound era mLowerBound @@ -363,6 +368,17 @@ validateTxIns era = mapM convert ) Nothing -> return (txin, BuildTxWith $ KeyWitness KeyWitnessForSpending) + +validateTxInsCollateral :: CardanoEra era + -> [TxIn] + -> ExceptT ShelleyTxCmdError IO (TxInsCollateral era) +validateTxInsCollateral _ [] = return TxInsCollateralNone +validateTxInsCollateral era txins = + case collateralSupportedInEra era of + Nothing -> txFeatureMismatch era TxFeatureCollateral + Just supported -> return (TxInsCollateral supported txins) + + validateTxOuts :: forall era. CardanoEra era -> [TxOutAnyEra] From 2f66529530a69714f57b2984a7060f2aef0b5a0b Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Thu, 3 Jun 2021 16:54:46 +0100 Subject: [PATCH 14/17] Correct the check for TxBodyMissingProtocolParams It was inverted. Oops. Now we correctly reject txs that do not specify protocol params. Unfortunately, the cli for providing them is not wired up yet, so not yet possible to make a proper Alonzo tx. --- cardano-api/src/Cardano/Api/TxBody.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/cardano-api/src/Cardano/Api/TxBody.hs b/cardano-api/src/Cardano/Api/TxBody.hs index 7ddf84c9bc9..135b63f892e 100644 --- a/cardano-api/src/Cardano/Api/TxBody.hs +++ b/cardano-api/src/Cardano/Api/TxBody.hs @@ -2077,9 +2077,9 @@ makeShelleyTransactionBody era@ShelleyBasedEraAlonzo TxMintNone -> return () TxMintValue _ v _ -> guard (selectLovelace v == 0) ?! TxBodyMintAdaError case txProtocolParams of - BuildTxWith Just{} -> return () - BuildTxWith Nothing -> guard (not (Set.null languages)) - ?! TxBodyMissingProtocolParams + BuildTxWith Nothing | not (Set.null languages) + -> Left TxBodyMissingProtocolParams + _ -> return () return $ ShelleyTxBody era From acf4e2e8f3069e1f07e64c111c784bd76231d608 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Thu, 3 Jun 2021 16:55:48 +0100 Subject: [PATCH 15/17] Add cli tx body validation for txins for collateral Transaction that use Plutus scripts have to provide collateral inputs. --- cardano-api/src/Cardano/Api/TxBody.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/cardano-api/src/Cardano/Api/TxBody.hs b/cardano-api/src/Cardano/Api/TxBody.hs index 135b63f892e..8d14079636d 100644 --- a/cardano-api/src/Cardano/Api/TxBody.hs +++ b/cardano-api/src/Cardano/Api/TxBody.hs @@ -1341,6 +1341,7 @@ instance IsCardanoEra era => HasTextEnvelope (TxBody era) where data TxBodyError era = TxBodyEmptyTxIns + | TxBodyEmptyTxInsCollateral | TxBodyEmptyTxOuts | TxBodyOutputNegative Quantity (TxOut era) | TxBodyOutputOverflow Quantity (TxOut era) @@ -1353,6 +1354,8 @@ data TxBodyError era = instance Error (TxBodyError era) where displayError TxBodyEmptyTxIns = "Transaction body has no inputs" + displayError TxBodyEmptyTxInsCollateral = + "Transaction body has no collateral inputs, but uses Plutus scripts" displayError TxBodyEmptyTxOuts = "Transaction body has no outputs" displayError (TxBodyOutputNegative (Quantity q) txout) = "Negative quantity (" ++ show q ++ ") in transaction output: " ++ @@ -2076,6 +2079,10 @@ makeShelleyTransactionBody era@ShelleyBasedEraAlonzo case txMintValue of TxMintNone -> return () TxMintValue _ v _ -> guard (selectLovelace v == 0) ?! TxBodyMintAdaError + case txInsCollateral of + TxInsCollateralNone | not (Set.null languages) + -> Left TxBodyEmptyTxInsCollateral + _ -> return () case txProtocolParams of BuildTxWith Nothing | not (Set.null languages) -> Left TxBodyMissingProtocolParams From 95d3b1cb9f1b226dd26022729e49eca46cd528f2 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Thu, 3 Jun 2021 17:18:13 +0100 Subject: [PATCH 16/17] Add support for --protocol-params-file for cli tx construction One of the necessary pieces for making valid Alonzo era txs. Not yet tested. --- cardano-api/src/Cardano/Api.hs | 2 + .../src/Cardano/CLI/Shelley/Commands.hs | 1 + .../src/Cardano/CLI/Shelley/Parsers.hs | 1 + .../Cardano/CLI/Shelley/Run/Transaction.hs | 47 ++++++++++++------- 4 files changed, 35 insertions(+), 16 deletions(-) diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index fe47d8c5260..e44790882ac 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -200,6 +200,7 @@ module Cardano.Api ( TxMetadataSupportedInEra(..), AuxScriptsSupportedInEra(..), TxExtraKeyWitnessesSupportedInEra(..), + ScriptDataSupportedInEra(..), WithdrawalsSupportedInEra(..), CertificatesSupportedInEra(..), UpdateProposalSupportedInEra(..), @@ -217,6 +218,7 @@ module Cardano.Api ( withdrawalsSupportedInEra, certificatesSupportedInEra, updateProposalSupportedInEra, + scriptDataSupportedInEra, -- * Signing transactions -- | Creating transaction witnesses one by one, or all in one go. diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs index fde1225fdb3..c5e8471359a 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs @@ -182,6 +182,7 @@ data TransactionCmd [ScriptFile] -- ^ Auxillary scripts [MetadataFile] + (Maybe ProtocolParamsSourceSpec) (Maybe UpdateProposalFile) TxBodyFile | TxSign TxBodyFile [WitnessSigningData] (Maybe NetworkId) TxFile diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs index dab24d03811..1fe9e3e84a8 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs @@ -587,6 +587,7 @@ pTransaction = "auxiliary-script-file" "Filepath of auxiliary script(s)") <*> many pMetadataFile + <*> optional pProtocolParamsSourceSpec <*> optional pUpdateProposalFile <*> pTxBodyFile Output diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs index a6e5fffc310..0442290b379 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs @@ -228,16 +228,17 @@ renderFeature TxFeatureMultiAssetOutputs = "Multi-Asset outputs" renderFeature TxFeatureScriptWitnesses = "Script witnesses" renderFeature TxFeatureShelleyKeys = "Shelley keys" renderFeature TxFeatureCollateral = "Collateral inputs" +renderFeature TxFeatureProtocolParameters = "Protocol parameters" runTransactionCmd :: TransactionCmd -> ExceptT ShelleyTxCmdError IO () runTransactionCmd cmd = case cmd of TxBuildRaw era txins txinsc txouts mValue mLowBound mUpperBound fee certs wdrls metadataSchema scriptFiles - metadataFiles mUpProp out -> + metadataFiles mpparams mUpProp out -> runTxBuildRaw era txins txinsc txouts mLowBound mUpperBound fee mValue certs wdrls metadataSchema - scriptFiles metadataFiles mUpProp out + scriptFiles metadataFiles mpparams mUpProp out TxSign txinfile skfiles network txoutfile -> runTxSign txinfile skfiles network txoutfile TxSubmit anyConensusModeParams network txFp -> @@ -280,6 +281,7 @@ runTxBuildRaw -> TxMetadataJsonSchema -> [ScriptFile] -> [MetadataFile] + -> Maybe ProtocolParamsSourceSpec -> Maybe UpdateProposalFile -> TxBodyFile -> ExceptT ShelleyTxCmdError IO () @@ -289,7 +291,7 @@ runTxBuildRaw (AnyCardanoEra era) mFee mValue certFiles withdrawals metadataSchema scriptFiles - metadataFiles mUpdatePropFile + metadataFiles mpparams mUpdatePropFile (TxBodyFile fpath) = do txBodyContent <- TxBodyContent @@ -304,7 +306,7 @@ runTxBuildRaw (AnyCardanoEra era) <*> validateTxAuxScripts era scriptFiles <*> pure TxAuxScriptDataNone --TODO alonzo: support this <*> pure TxExtraKeyWitnessesNone --TODO alonzo: support this - <*> pure (BuildTxWith Nothing) --TODO alonzo: support this + <*> validateProtocolParameters era mpparams <*> validateTxWithdrawals era withdrawals <*> validateTxCertificates era certFiles <*> validateTxUpdateProposal era mUpdatePropFile @@ -339,6 +341,7 @@ data TxFeature = TxFeatureShelleyAddresses | TxFeatureScriptWitnesses | TxFeatureShelleyKeys | TxFeatureCollateral + | TxFeatureProtocolParameters deriving Show txFeatureMismatch :: CardanoEra era @@ -566,6 +569,18 @@ validateTxCertificates era certFiles = Nothing -> return $ Just (sCred, KeyWitness KeyWitnessForStakeAddr) +validateProtocolParameters + :: CardanoEra era + -> Maybe ProtocolParamsSourceSpec + -> ExceptT ShelleyTxCmdError IO + (BuildTxWith BuildTx (Maybe ProtocolParameters)) +validateProtocolParameters _ Nothing = return (BuildTxWith Nothing) +validateProtocolParameters era (Just pparamsspec) = + case scriptDataSupportedInEra era of + Nothing -> txFeatureMismatch era TxFeatureProtocolParameters + Just _ -> BuildTxWith . Just <$> + readProtocolParametersSourceSpec pparamsspec + validateTxUpdateProposal :: CardanoEra era -> Maybe UpdateProposalFile -> ExceptT ShelleyTxCmdError IO (TxUpdateProposal era) @@ -792,13 +807,7 @@ runTxCalculateMinFee (TxBodyFile txbodyFile) nw protocolParamsSourceSpec onlyInShelleyBasedEras "calculate-min-fee for Byron era transactions" =<< readFileTxBody txbodyFile - pparams <- - case protocolParamsSourceSpec of - ParamsFromGenesis (GenesisFile f) -> - fromShelleyPParams . sgProtocolParams <$> - firstExceptT ShelleyTxCmdGenesisCmdError - (readShelleyGenesis f identity) - ParamsFromFile f -> readProtocolParameters f + pparams <- readProtocolParametersSourceSpec protocolParamsSourceSpec let tx = makeSignedTransaction [] txbody Lovelace fee = estimateTransactionFee @@ -820,11 +829,7 @@ runTxCalculateMinValue -> Value -> ExceptT ShelleyTxCmdError IO () runTxCalculateMinValue protocolParamsSourceSpec value = do - pp <- case protocolParamsSourceSpec of - ParamsFromGenesis (GenesisFile f) -> - fromShelleyPParams . sgProtocolParams <$> - firstExceptT ShelleyTxCmdGenesisCmdError (readShelleyGenesis f identity) - ParamsFromFile f -> readProtocolParameters f + pp <- readProtocolParametersSourceSpec protocolParamsSourceSpec let minValues = case protocolParamMinUTxOValue pp of @@ -841,6 +846,16 @@ runTxCreatePolicyId (ScriptFile sFile) = do readFileScriptInAnyLang sFile liftIO . putTextLn . serialiseToRawBytesHexText $ hashScript script +readProtocolParametersSourceSpec :: ProtocolParamsSourceSpec + -> ExceptT ShelleyTxCmdError IO + ProtocolParameters +readProtocolParametersSourceSpec (ParamsFromGenesis (GenesisFile f)) = + fromShelleyPParams . sgProtocolParams <$> + firstExceptT ShelleyTxCmdGenesisCmdError + (readShelleyGenesis f identity) +readProtocolParametersSourceSpec (ParamsFromFile f) = + readProtocolParameters f + --TODO: eliminate this and get only the necessary params, and get them in a more -- helpful way rather than requiring them as a local file. readProtocolParameters :: ProtocolParamsFile From 89eb334d85d597f294e02bcd237df1bddccd7734 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Mon, 7 Jun 2021 09:53:51 +0100 Subject: [PATCH 17/17] Backwards compat for pre-Alonzo era tx body files made by the cli The API's TxBody binary format is not an externally defined format. It does not appear on the chain. It is an intermediate format used by the cli and is not guaranteed to be stable or interoperable. External tools should not rely on this format. Nevertheless, for now since it's easy, we'll adjust the output to be the same as pre-Alonzo eras when not using any Alonzo-era features. --- cardano-api/src/Cardano/Api/TxBody.hs | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/cardano-api/src/Cardano/Api/TxBody.hs b/cardano-api/src/Cardano/Api/TxBody.hs index 8d14079636d..05ec191f31d 100644 --- a/cardano-api/src/Cardano/Api/TxBody.hs +++ b/cardano-api/src/Cardano/Api/TxBody.hs @@ -1268,14 +1268,24 @@ serialiseShelleyBasedTxBody -> TxBodyScriptData era -> Maybe (Ledger.AuxiliaryData ledgerera) -> ByteString -serialiseShelleyBasedTxBody _era txbody txscripts redeemers txmetadata = +serialiseShelleyBasedTxBody _era txbody txscripts + TxBodyNoScriptData txmetadata = + -- Backwards compat for pre-Alonzo era tx body files + CBOR.serializeEncoding' $ + CBOR.encodeListLen 3 + <> CBOR.toCBOR txbody + <> CBOR.toCBOR txscripts + <> CBOR.encodeNullMaybe CBOR.toCBOR txmetadata + +serialiseShelleyBasedTxBody _era txbody txscripts + (TxBodyScriptData _ datums redeemers) + txmetadata = CBOR.serializeEncoding' $ CBOR.encodeListLen 5 <> CBOR.toCBOR txbody <> CBOR.toCBOR txscripts - <> (case redeemers of - TxBodyNoScriptData -> CBOR.encodeNull <> CBOR.encodeNull - TxBodyScriptData _ ds rs -> CBOR.toCBOR ds <> CBOR.toCBOR rs) + <> CBOR.toCBOR datums + <> CBOR.toCBOR redeemers <> CBOR.encodeNullMaybe CBOR.toCBOR txmetadata deserialiseShelleyBasedTxBody