diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs index ce2607d317..ed984cda1a 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs @@ -1117,6 +1117,33 @@ pScriptDataOrFile dataFlagPrefix helpTextForValue helpTextForFile = Left err -> fail $ docToString $ prettyError err Right sd -> return sd + +pVoteFiles + :: ShelleyBasedEra era + -> BalanceTxExecUnits + -> Parser [(VoteFile In, [ScriptWitnessFiles WitCtxStake])] +pVoteFiles sbe bExUnits= caseShelleyToBabbageOrConwayEraOnwards + (const $ pure []) + (const . many $ pVoteFile bExUnits) + sbe + +pVoteFile :: BalanceTxExecUnits -> Parser (VoteFile In, [ScriptWitnessFiles WitCtxStake]) +pVoteFile balExUnits = (,) <$> pFileInDirection "vote-file" "Filepath of the vote." + <*> many (pVoteScriptOrReferenceScriptWitness balExUnits) + + where + pVoteScriptOrReferenceScriptWitness + :: BalanceTxExecUnits -> Parser (ScriptWitnessFiles WitCtxStake) + pVoteScriptOrReferenceScriptWitness bExUnits = + pScriptWitnessFiles + WitCtxStake + bExUnits + "vote" + Nothing + "a vote" -- TODO: Potentially improve. Wait for feedback. + + + -------------------------------------------------------------------------------- pPaymentVerifier :: Parser PaymentVerifier diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Transaction.hs index b6a407fc06..bcc0880314 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Transaction.hs @@ -220,31 +220,6 @@ pTransactionBuildRaw era = <*> pProposalFiles era <*> pTxBodyFileOut -pVoteFiles - :: ShelleyBasedEra era - -> BalanceTxExecUnits - -> Parser [(VoteFile In, [ScriptWitnessFiles WitCtxStake])] -pVoteFiles sbe bExUnits= caseShelleyToBabbageOrConwayEraOnwards - (const $ pure []) - (const . many $ pVoteFile bExUnits) - sbe -pVoteFile :: BalanceTxExecUnits -> Parser (VoteFile In, [ScriptWitnessFiles WitCtxStake]) -pVoteFile balExUnits = (,) <$> pFileInDirection "vote-file" "Filepath of the vote." - <*> many (pVoteScriptOrReferenceScriptWitness balExUnits) - - where - pVoteScriptOrReferenceScriptWitness - :: BalanceTxExecUnits -> Parser (ScriptWitnessFiles WitCtxStake) - pVoteScriptOrReferenceScriptWitness bExUnits = - pScriptWitnessFiles - WitCtxStake - bExUnits - "vote" - Nothing - "a vote" -- TODO: Potentially improve. Wait for feedback. - - - pProposalFiles :: ShelleyBasedEra era -> Parser [ProposalFile In] pProposalFiles = caseShelleyToBabbageOrConwayEraOnwards (const $ pure []) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Vote.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Vote.hs index 2e38f5428f..cf1c57511f 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Vote.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Vote.hs @@ -92,8 +92,8 @@ runGovernanceVoteViewCmd let sbe = conwayEraOnwardsToShelleyBasedEra eon shelleyBasedEraConstraints sbe $ do - voteProcedures <- firstExceptT GovernanceVoteCmdReadVoteFileError . newExceptT $ - readVotingProceduresFile eon voteFile + voteProcedures <- fmap fst . firstExceptT GovernanceVoteCmdReadVoteFileError . newExceptT $ + readVotingProceduresFile eon (voteFile, []) firstExceptT GovernanceVoteCmdWriteError . newExceptT . (case outFormat of @@ -104,4 +104,4 @@ runGovernanceVoteViewCmd writeLazyByteStringOutput mOutFile . encodePretty' (defConfig {confCompare = compare})) . unVotingProcedures $ - voteProcedures \ No newline at end of file + voteProcedures diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs index 6098add3c0..3f0fd9aa64 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs @@ -173,7 +173,7 @@ runTransactionBuildCmd -- TODO: Left off here. Update readVotingProceduresFiles to return potential script witnesses votingProceduresAndMaybeScriptWits <- inEonForEra - (pure emptyVotingProcedures) + (pure mempty) (\w -> firstExceptT TxCmdVoteError $ ExceptT (readVotingProceduresFiles w voteFiles)) era @@ -194,14 +194,15 @@ runTransactionBuildCmd let mScriptWits = forEraInEon era [] $ \sbe -> collectTxBodyScriptWitnesses sbe txBodyContent - + -- TODO: Left off here let allReferenceInputs = getAllReferenceInputs inputsAndMaybeScriptWits (snd valuesWithScriptWits) certsAndMaybeScriptWits withdrawalsAndMaybeScriptWits - readOnlyReferenceInputs votingProceduresAndMaybeScriptWits + readOnlyReferenceInputs + let inputsThatRequireWitnessing = [input | (input,_) <- inputsAndMaybeScriptWits] allTxInputs = inputsThatRequireWitnessing ++ allReferenceInputs ++ filteredTxinsc @@ -326,10 +327,10 @@ runTransactionBuildRawCmd let filteredTxinsc = Set.toList $ Set.fromList txInsCollateral -- Conway related - votingProcedures <- + votingProceduresAndMaybeScriptWits <- inEonForShelleyBasedEra - (pure emptyVotingProcedures) - (\w -> firstExceptT TxCmdVoteError $ ExceptT (readVotingProceduresFiles w voteFiles)) + (pure mempty) + (\w -> firstExceptT TxCmdVoteError $ ExceptT $ conwayEraOnwardsConstraints w $ (readVotingProceduresFiles w voteFiles)) eon proposals <- @@ -348,7 +349,7 @@ runTransactionBuildRawCmd eon mScriptValidity inputsAndMaybeScriptWits readOnlyRefIns filteredTxinsc mReturnCollateral mTotalCollateral txOuts mValidityLowerBound mValidityUpperBound fee valuesWithScriptWits certsAndMaybeScriptWits withdrawalsAndMaybeScriptWits requiredSigners txAuxScripts - txMetadata mLedgerPParams txUpdateProposal votingProcedures proposals + txMetadata mLedgerPParams txUpdateProposal votingProceduresAndMaybeScriptWits proposals let noWitTx = makeSignedTransaction [] txBody lift (writeTxFileTextEnvelopeCddl eon txBodyOutFile noWitTx) @@ -387,7 +388,7 @@ runTxBuildRaw :: () -> TxMetadataInEra era -> Maybe (LedgerProtocolParameters era) -> TxUpdateProposal era - -> VotingProcedures era + -> (VotingProcedures era, [ScriptWitness WitCtxStake era]) -> [Proposal era] -> Either TxCmdError (TxBody era) runTxBuildRaw sbe @@ -405,7 +406,9 @@ runTxBuildRaw sbe (snd valuesWithScriptWits) certsAndMaybeSriptWits withdrawals + votingProcedures readOnlyRefIns + validatedTxIns = validateTxIns inputsAndMaybeScriptWits validatedCollateralTxIns <- validateTxInsCollateral era txinsc validatedRefInputs <- validateTxInsReference era allReferenceInputs @@ -491,7 +494,7 @@ runTxBuild :: () -> TxMetadataInEra era -> TxUpdateProposal era -> Maybe Word - -> (VotingProcedures era, [Maybe (ScriptWitness WitCtxStake era)]) + -> (VotingProcedures era, [ScriptWitness WitCtxStake era]) -> [Proposal era] -> TxBuildOutputOptions -> ExceptT TxCmdError IO (BalancedTxBody era) @@ -513,6 +516,7 @@ runTxBuild (snd valuesWithScriptWits) certsAndMaybeScriptWits withdrawals + votingProcedures readOnlyRefIns validatedCollateralTxIns <- hoistEither $ validateTxInsCollateral era txinsc @@ -660,18 +664,21 @@ getAllReferenceInputs -> [ScriptWitness WitCtxMint era] -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))] -> [(StakeAddress, Lovelace, Maybe (ScriptWitness WitCtxStake era))] + -> (VotingProcedures era, [ScriptWitness WitCtxStake era]) -> [TxIn] -- ^ Read only reference inputs -> [TxIn] -getAllReferenceInputs txins mintWitnesses certFiles withdrawals readOnlyRefIns = do +getAllReferenceInputs txins mintWitnesses certFiles withdrawals votingProceduresAndMaybeScriptWits readOnlyRefIns = do let txinsWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- txins] mintingRefInputs = map getReferenceInput mintWitnesses certsWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- certFiles] withdrawalsWitByRefInputs = [getReferenceInput sWit | (_, _, Just sWit) <- withdrawals] + votesWitByRefInputs = [getReferenceInput sWit | sWit <- snd votingProceduresAndMaybeScriptWits] catMaybes $ concat [ txinsWitByRefInputs , mintingRefInputs , certsWitByRefInputs , withdrawalsWitByRefInputs + , votesWitByRefInputs , map Just readOnlyRefIns ] where diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Commands/Transaction.hs b/cardano-cli/src/Cardano/CLI/Legacy/Commands/Transaction.hs index ce53dceed8..9ae5e51a44 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Commands/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Commands/Transaction.hs @@ -90,7 +90,7 @@ data LegacyTransactionCmds -- ^ Auxiliary scripts [MetadataFile] (Maybe UpdateProposalFile) - [VoteFile In] + [(VoteFile In, [ScriptWitnessFiles WitCtxStake])] [ProposalFile In] TxBuildOutputOptions | TransactionSignCmd diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Options.hs b/cardano-cli/src/Cardano/CLI/Legacy/Options.hs index 866c9a9268..a09069a26e 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Options.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Options.hs @@ -336,7 +336,7 @@ pTransaction envCli = "Filepath of auxiliary script(s)") <*> many pMetadataFile <*> optional pUpdateProposalFile - <*> many (pFileInDirection "vote-file" "Filepath of the vote.") + <*> pVoteFiles ShelleyBasedEraConway AutoBalance <*> many (pFileInDirection "proposal-file" "Filepath of the proposal.") <*> (OutputTxBodyOnly <$> pTxBodyFileOut <|> pCalculatePlutusScriptCost) diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs index bdf1408e31..2ac997d090 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs @@ -90,7 +90,7 @@ runLegacyTransactionBuildCmd :: () -> [ScriptFile] -> [MetadataFile] -> Maybe UpdateProposalFile - -> [VoteFile In] + -> [(VoteFile In, [ScriptWitnessFiles WitCtxStake])] -> [ProposalFile In] -> TxBuildOutputOptions -> ExceptT TxCmdError IO () diff --git a/cardano-cli/src/Cardano/CLI/Read.hs b/cardano-cli/src/Cardano/CLI/Read.hs index fe0215335e..e94c1fbbf7 100644 --- a/cardano-cli/src/Cardano/CLI/Read.hs +++ b/cardano-cli/src/Cardano/CLI/Read.hs @@ -4,6 +4,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} module Cardano.CLI.Read ( -- * Metadata @@ -98,6 +100,7 @@ module Cardano.CLI.Read ) where import Cardano.Api as Api +import Cardano.Api.Ledger (EraCrypto) import qualified Cardano.Api.Ledger as L import Cardano.Api.Pretty import Cardano.Api.Shelley as Api @@ -120,6 +123,7 @@ import qualified Cardano.Ledger.Crypto as Ledger import qualified Cardano.Ledger.Keys as Ledger import qualified Cardano.Ledger.SafeHash as L import qualified Cardano.Ledger.SafeHash as Ledger +import Cardano.Prelude (catMaybes) import Prelude @@ -227,6 +231,7 @@ data ScriptWitnessError | ScriptWitnessErrorExpectedPlutus !FilePath !AnyScriptLanguage | ScriptWitnessErrorReferenceScriptsNotSupportedInEra !AnyShelleyBasedEra | ScriptWitnessErrorScriptData ScriptDataError + deriving Show renderScriptWitnessError :: ScriptWitnessError -> Doc ann renderScriptWitnessError = \case @@ -387,6 +392,7 @@ data ScriptDataError = | ScriptDataErrorValidation !FilePath !ScriptDataRangeError | ScriptDataErrorMetadataDecode !FilePath !CBOR.DecoderError | ScriptDataErrorJsonBytes !ScriptDataJsonBytesError + deriving Show renderScriptDataError :: ScriptDataError -> Doc ann renderScriptDataError = \case @@ -783,6 +789,7 @@ readRequiredSigner (RequiredSignerSkeyFile skFile) = do data VoteError = VoteErrorFile (FileError TextEnvelopeError) | VoteErrorTextNotUnicode Text.UnicodeException + | VoteErrorScriptWitness ScriptWitnessError deriving Show instance Error VoteError where @@ -791,17 +798,60 @@ instance Error VoteError where prettyError e VoteErrorTextNotUnicode e -> "Vote text file not UTF8-encoded: " <> pretty (displayException e) + VoteErrorScriptWitness e -> + renderScriptWitnessError e readVotingProceduresFiles :: () + => EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto => ConwayEraOnwards era - -> [VoteFile In] - -> IO (Either VoteError (VotingProcedures era)) + -> [(VoteFile In, [ScriptWitnessFiles WitCtxStake])] + -> IO (Either VoteError (VotingProcedures era, [ScriptWitness WitCtxStake era])) readVotingProceduresFiles w = \case - [] -> return $ Right $ VotingProcedures $ Ledger.VotingProcedures Map.empty + [] -> return $ Right (VotingProcedures $ Ledger.VotingProcedures Map.empty, []) files -> runExceptT $ do vpss <- forM files (ExceptT . readVotingProceduresFile w) + let (voteProcedures, scriptWitnesses) = unzip vpss + mergedVoteProcedures = foldl unsafeMergeVotingProcedures emptyVotingProcedures voteProcedures + allScriptWitnesses = concat scriptWitnesses + mapM_ (hoistEither . checkVotingScriptCredentialExists mergedVoteProcedures) allScriptWitnesses + + pure (mergedVoteProcedures, allScriptWitnesses) + +-- NB: When using a Plutus voting script, the 'Voter' that is being witnessed +-- must have a credential containing the script hash of the witnessing +-- Plutus script. This check does not work for reference scripts +-- because we do not have access to the script. +-- TODO: This is very inefficient. We should calculate all voters +-- once +checkVotingScriptCredentialExists + :: EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto + => VotingProcedures era + -> ScriptWitness WitCtxStake era + -> Either VoteError () +checkVotingScriptCredentialExists (VotingProcedures voteProceds) swit = do + ScriptHash sHash + <- case swit of + PlutusScriptWitness _ v (PScript s) _ _ _ -> + pure $ hashScript $ PlutusScript v s + PlutusScriptWitness _ _ (PReferenceScript _ (Just shash)) _ _ _ -> + pure shash + wrongWit -> Left $ error "TODO" + + let allVoters = catMaybes $ Ledger.foldlVotingProcedures folder [] voteProceds + folder acc voter _ _ = + let voterScriptCred = + case voter of + Ledger.CommitteeVoter (Ledger.ScriptHashObj sHash') -> + Just sHash' + Ledger.DRepVoter (Ledger.ScriptHashObj sHash') -> + Just sHash' + _ -> Nothing + in voterScriptCred : acc + + if sHash `elem` allVoters + then Right () + else Left $ error "TODO" - pure $ foldl unsafeMergeVotingProcedures emptyVotingProcedures vpss readTxUpdateProposal :: () => ShelleyToBabbageEra era @@ -812,11 +862,19 @@ readTxUpdateProposal w (UpdateProposalFile upFp) = do readVotingProceduresFile :: () => ConwayEraOnwards era - -> VoteFile In - -> IO (Either VoteError (VotingProcedures era)) -readVotingProceduresFile w fp = - conwayEraOnwardsConstraints w - $ first VoteErrorFile <$> readFileTextEnvelope AsVotingProcedures fp + -> (VoteFile In, [ScriptWitnessFiles WitCtxStake]) + -> IO (Either VoteError (VotingProcedures era, [ScriptWitness WitCtxStake era])) +readVotingProceduresFile w (voteFp, mScriptWitFiles) = do + votProceds <- conwayEraOnwardsConstraints w + $ first VoteErrorFile <$> readFileTextEnvelope AsVotingProcedures voteFp + case mScriptWitFiles of + [] -> pure $ (,[]) <$> votProceds + scriptWitFiles -> do + let sbe = conwayEraOnwardsToShelleyBasedEra w + runExceptT $ do + sWits <- firstExceptT VoteErrorScriptWitness + $ mapM (readScriptWitness sbe) scriptWitFiles + hoistEither $ (,sWits) <$> votProceds data ConstitutionError = ConstitutionErrorFile (FileError TextEnvelopeError) diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs index e1bd8295f7..ddcb9620c8 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs @@ -98,7 +98,7 @@ renderTxCmdError = \case TxCmdProtocolParamsConverstionError err' -> "Error while converting protocol parameters: " <> prettyError err' TxCmdVoteError voteErr -> - pshow voteErr + prettyError voteErr TxCmdConstitutionError constErr -> pshow constErr TxCmdProposalError propErr -> diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs index 0833f69f6f..f6c73adaa2 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs @@ -38,6 +38,7 @@ import Cardano.Api.Pretty import Cardano.Api.Shelley import Cardano.CLI.Types.Common +import qualified Cardano.Ledger.Conway.Governance as Conway import Prelude @@ -217,6 +218,9 @@ instance Error TxCertificatesValidationError where prettyError (TxCertificatesValidationNotSupported e) = "Transaction certificates are not supported in " <> pretty e +-- TODO: Because we have separated Byron related transaction +-- construction into separate commands, we can parameterize this +-- on ShelleyBasedEra era and remove Either TxCertificatesValidationError validateTxCertificates :: forall era. CardanoEra era @@ -298,3 +302,16 @@ conjureWitness :: Eon eon conjureWitness era errF = maybe (cardanoEraConstraints era $ Left . errF $ AnyCardanoEra era) Right $ forEraMaybeEon era + +-- TODO: Left off here +-- Get script credentials then (if any) look them up in the ScriptWitness list +getVotingScriptCredentials :: VotingProcedures era -> [ScriptHash] +getVotingScriptCredentials (VotingProcedures (Conway.VotingProcedures m)) = + let voters = Map.keys m + in error "TODO" + +convertToTxVotingProcedures + :: (VotingProcedures era, [ScriptWitness WitCtxStake era]) + -> TxVotingProcedures build era +convertToTxVotingProcedures (votingProcedures, mScriptwits) = error "todo" +