WIP

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

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 [])

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
+      voteProcedures

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

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

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)
 

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 ()

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)

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 ->