Merge pull request #203 from input-output-hk/newhoggy/write-voting-pr…

…ocedures-files-instead-of-voting-entry-files

Read and write `VotingProcedures` files instead of `VotingEntry` files

cabal.project

@@ -14,7 +14,7 @@ repository cardano-haskell-packages
 -- you need to run if you change them
 index-state:
   , hackage.haskell.org 2023-08-08T19:56:09Z
-  , cardano-haskell-packages 2023-08-23T09:29:34Z
+  , cardano-haskell-packages 2023-08-24T08:58:33Z
 
 packages:
   cardano-cli

cardano-cli/cardano-cli.cabal

@@ -167,7 +167,7 @@ library
                       , binary
                       , bytestring
                       , canonical-json
-                      , cardano-api ^>= 8.16
+                      , cardano-api ^>= 8.16.1
                       , cardano-binary
                       , cardano-crypto
                       , cardano-crypto-class ^>= 2.1.2
@@ -258,7 +258,7 @@ test-suite cardano-cli-test
                       , base16-bytestring
                       , bech32 >= 1.1.0
                       , bytestring
-                      , cardano-api:{cardano-api, internal} ^>= 8.16
+                      , cardano-api:{cardano-api, internal} ^>= 8.16.1
                       , cardano-api-gen ^>= 8.1.1.0
                       , cardano-cli
                       , cardano-cli:cardano-cli-test-lib
@@ -302,7 +302,7 @@ test-suite cardano-cli-golden
   build-depends:        aeson >= 1.5.6.0
                       , base16-bytestring
                       , bytestring
-                      , cardano-api:{cardano-api, gen} ^>= 8.16
+                      , cardano-api:{cardano-api, gen} ^>= 8.16.1
                       , cardano-binary
                       , cardano-cli
                       , cardano-cli:cardano-cli-test-lib

cardano-cli/src/Cardano/CLI/Commands/Governance.hs

@@ -7,6 +7,7 @@ import           Cardano.Api
 import qualified Cardano.Api.Ledger as Ledger
 import           Cardano.Api.Shelley
 
+import           Cardano.CLI.Read (singletonVotingProcedures)
 import           Cardano.CLI.Types.Common
 import           Cardano.CLI.Types.Errors.GovernanceCmdError
 import           Cardano.CLI.Types.Governance
@@ -21,8 +22,8 @@ import           Data.Text (Text)
 import qualified Data.Text.Encoding as Text
 import           Data.Word
 
-runGovernanceCreateVoteCmd
-  :: AnyShelleyBasedEra
+runGovernanceCreateVoteCmd :: ()
+  => AnyShelleyBasedEra
   -> Vote
   -> VType
   -> (TxId, Word32)
@@ -31,41 +32,34 @@ runGovernanceCreateVoteCmd
   -> ExceptT GovernanceCmdError IO ()
 runGovernanceCreateVoteCmd anyEra vChoice vType (govActionTxId, govActionIndex) votingStakeCred oFp = do
   AnyShelleyBasedEra sbe <- pure anyEra
-  vStakePoolKey <- firstExceptT ReadFileError . newExceptT $ readVerificationKeyOrFile AsStakePoolKey votingStakeCred
-  let stakePoolKeyHash = verificationKeyHash vStakePoolKey
-      vStakeCred = StakeCredentialByKey . (verificationKeyHash . castVerificationKey) $ vStakePoolKey
-  case vType of
-    VCC -> do
-      votingCred <- hoistEither $ first VotingCredentialDecodeGovCmdEror $ toVotingCredential sbe vStakeCred
-      let voter = VoterCommittee votingCred
-          govActIdentifier = shelleyBasedEraConstraints sbe $ createGovernanceActionId govActionTxId govActionIndex
-          voteProcedure = createVotingProcedure sbe vChoice Nothing
-          votingEntry = VotingEntry { votingEntryVoter = voter
-                                    , votingEntryGovActionId = GovernanceActionId govActIdentifier
-                                    , votingEntryVotingProcedure = voteProcedure
-                                    }
-      firstExceptT WriteFileError . newExceptT $ shelleyBasedEraConstraints sbe $ writeFileTextEnvelope oFp Nothing votingEntry
 
-    VDR -> do
-      votingCred <- hoistEither $ first VotingCredentialDecodeGovCmdEror $ toVotingCredential sbe vStakeCred
-      let voter = VoterDRep votingCred
-          govActIdentifier = shelleyBasedEraConstraints sbe $ createGovernanceActionId govActionTxId govActionIndex
-          voteProcedure = createVotingProcedure sbe vChoice Nothing
-          votingEntry = VotingEntry { votingEntryVoter = voter
-                                    , votingEntryGovActionId = GovernanceActionId govActIdentifier
-                                    , votingEntryVotingProcedure = voteProcedure
-                                    }
-      firstExceptT WriteFileError . newExceptT $ shelleyBasedEraConstraints sbe $ writeFileTextEnvelope oFp Nothing votingEntry
+  shelleyBasedEraConstraints sbe $ do
+    vStakePoolKey <- firstExceptT ReadFileError . newExceptT $ readVerificationKeyOrFile AsStakePoolKey votingStakeCred
+    let stakePoolKeyHash = verificationKeyHash vStakePoolKey
+        vStakeCred = StakeCredentialByKey . (verificationKeyHash . castVerificationKey) $ vStakePoolKey
+    case vType of
+      VCC -> do
+        votingCred <- hoistEither $ first VotingCredentialDecodeGovCmdEror $ toVotingCredential sbe vStakeCred
+        let voter = Ledger.CommitteeVoter (Ledger.coerceKeyRole (unVotingCredential votingCred)) -- TODO Conway - remove coerceKeyRole
+            govActIdentifier = createGovernanceActionId govActionTxId govActionIndex
+            voteProcedure = createVotingProcedure sbe vChoice Nothing
+            votingProcedures = singletonVotingProcedures sbe voter govActIdentifier (unVotingProcedure voteProcedure)
+        firstExceptT WriteFileError . newExceptT $ writeFileTextEnvelope oFp Nothing votingProcedures
 
-    VSP -> do
-      let voter = VoterSpo stakePoolKeyHash
-          govActIdentifier = shelleyBasedEraConstraints sbe $ createGovernanceActionId govActionTxId govActionIndex
-          voteProcedure = createVotingProcedure sbe vChoice Nothing
-          votingEntry = VotingEntry { votingEntryVoter = voter
-                                    , votingEntryGovActionId = GovernanceActionId govActIdentifier
-                                    , votingEntryVotingProcedure = voteProcedure
-                                    }
-      firstExceptT WriteFileError . newExceptT $ shelleyBasedEraConstraints sbe $ writeFileTextEnvelope oFp Nothing votingEntry
+      VDR -> do
+        votingCred <- hoistEither $ first VotingCredentialDecodeGovCmdEror $ toVotingCredential sbe vStakeCred
+        let voter = Ledger.DRepVoter (unVotingCredential votingCred)
+            govActIdentifier = createGovernanceActionId govActionTxId govActionIndex
+            voteProcedure = createVotingProcedure sbe vChoice Nothing
+            votingProcedures = singletonVotingProcedures sbe voter govActIdentifier (unVotingProcedure voteProcedure)
+        firstExceptT WriteFileError . newExceptT $ writeFileTextEnvelope oFp Nothing votingProcedures
+
+      VSP -> do
+        let voter = Ledger.StakePoolVoter (unStakePoolKeyHash stakePoolKeyHash)
+            govActIdentifier = createGovernanceActionId govActionTxId govActionIndex
+            voteProcedure = createVotingProcedure sbe vChoice Nothing
+            votingProcedures = singletonVotingProcedures sbe voter govActIdentifier (unVotingProcedure voteProcedure)
+        firstExceptT WriteFileError . newExceptT $ writeFileTextEnvelope oFp Nothing votingProcedures
 
 
 runGovernanceNewConstitutionCmd

cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Vote.hs

@@ -8,9 +8,12 @@ module Cardano.CLI.EraBased.Run.Governance.Vote
   ( runGovernanceVoteCmds
   ) where
 
+import           Cardano.Api
+import qualified Cardano.Api.Ledger as Ledger
 import           Cardano.Api.Shelley
 
 import           Cardano.CLI.EraBased.Commands.Governance.Vote
+import           Cardano.CLI.Read (singletonVotingProcedures)
 import           Cardano.CLI.Types.Errors.CmdError
 import           Cardano.CLI.Types.Errors.GovernanceVoteCmdError
 import           Cardano.CLI.Types.Governance
@@ -35,48 +38,38 @@ runGovernanceVoteCreateCmd
   -> ExceptT GovernanceVoteCmdError IO ()
 runGovernanceVoteCreateCmd (ConwayOnwardsVote cOnwards voteChoice (govActionTxId, govActionIndex) voteStakeCred oFp) = do
   let sbe = conwayEraOnwardsToShelleyBasedEra cOnwards -- TODO: Conway era - update vote creation related function to take ConwayEraOnwards
-  case voteStakeCred of
-    AnyDRepVerificationKeyOrHashOrFile stake -> do
-      DRepKeyHash h <- firstExceptT  GovernanceVoteCmdReadError
-                               . newExceptT $ readVerificationKeyOrHashOrTextEnvFile AsDRepKey stake
-      let vStakeCred = StakeCredentialByKey . StakeKeyHash $ coerceKeyRole h
 
-      votingCred <- hoistEither $ first GovernanceVoteCmdCredentialDecodeError $ toVotingCredential sbe vStakeCred
-      let voter = VoterDRep votingCred
-          govActIdentifier = shelleyBasedEraConstraints sbe $ createGovernanceActionId govActionTxId govActionIndex
-          voteProcedure = createVotingProcedure sbe voteChoice Nothing
-          votingEntry = VotingEntry { votingEntryVoter = voter
-                                    , votingEntryGovActionId = GovernanceActionId govActIdentifier
-                                    , votingEntryVotingProcedure = voteProcedure
-                                    }
-      firstExceptT GovernanceVoteCmdWriteError . newExceptT $ shelleyBasedEraConstraints sbe
-        $ writeFileTextEnvelope oFp Nothing votingEntry
+  shelleyBasedEraConstraints sbe $ do
+    case voteStakeCred of
+      AnyDRepVerificationKeyOrHashOrFile stake -> do
+        DRepKeyHash h <- firstExceptT  GovernanceVoteCmdReadError
+                                . newExceptT $ readVerificationKeyOrHashOrTextEnvFile AsDRepKey stake
+        let vStakeCred = StakeCredentialByKey . StakeKeyHash $ coerceKeyRole h
 
-    AnyStakePoolVerificationKeyOrHashOrFile stake -> do
-      h <- firstExceptT GovernanceVoteCmdReadError
-             . newExceptT $ readVerificationKeyOrHashOrTextEnvFile AsStakePoolKey stake
+        votingCred <- hoistEither $ first GovernanceVoteCmdCredentialDecodeError $ toVotingCredential sbe vStakeCred
+        let voter = Ledger.DRepVoter (unVotingCredential votingCred)
+            govActIdentifier = createGovernanceActionId govActionTxId govActionIndex
+            voteProcedure = createVotingProcedure sbe voteChoice Nothing
+            votingProcedures = singletonVotingProcedures sbe voter govActIdentifier (unVotingProcedure voteProcedure)
+        firstExceptT GovernanceVoteCmdWriteError . newExceptT $ writeFileTextEnvelope oFp Nothing votingProcedures
 
-      let voter = VoterSpo h
-          govActIdentifier = shelleyBasedEraConstraints sbe $ createGovernanceActionId govActionTxId govActionIndex
-          voteProcedure = createVotingProcedure sbe voteChoice Nothing
-          votingEntry = VotingEntry { votingEntryVoter = voter
-                                    , votingEntryGovActionId = GovernanceActionId govActIdentifier
-                                    , votingEntryVotingProcedure = voteProcedure
-                                    }
-      firstExceptT GovernanceVoteCmdWriteError . newExceptT $ shelleyBasedEraConstraints sbe
-        $ writeFileTextEnvelope oFp Nothing votingEntry
+      AnyStakePoolVerificationKeyOrHashOrFile stake -> do
+        h <- firstExceptT GovernanceVoteCmdReadError
+              . newExceptT $ readVerificationKeyOrHashOrTextEnvFile AsStakePoolKey stake
 
-    AnyCommitteeHotVerificationKeyOrHashOrFile stake -> do
-      CommitteeHotKeyHash h <- firstExceptT GovernanceVoteCmdReadError
-                                 . newExceptT $ readVerificationKeyOrHashOrTextEnvFile AsCommitteeHotKey stake
-      let vStakeCred = StakeCredentialByKey . StakeKeyHash $ coerceKeyRole h
-      votingCred <- hoistEither $ first GovernanceVoteCmdCredentialDecodeError $ toVotingCredential sbe vStakeCred
-      let voter = VoterCommittee votingCred
-          govActIdentifier = shelleyBasedEraConstraints sbe $ createGovernanceActionId govActionTxId govActionIndex
-          voteProcedure = createVotingProcedure sbe voteChoice Nothing
-          votingEntry = VotingEntry { votingEntryVoter = voter
-                                    , votingEntryGovActionId = GovernanceActionId govActIdentifier
-                                    , votingEntryVotingProcedure = voteProcedure
-                                    }
-      firstExceptT GovernanceVoteCmdWriteError . newExceptT $ shelleyBasedEraConstraints sbe
-        $ writeFileTextEnvelope oFp Nothing votingEntry
+        let voter = Ledger.StakePoolVoter (unStakePoolKeyHash h)
+            govActIdentifier = createGovernanceActionId govActionTxId govActionIndex
+            voteProcedure = createVotingProcedure sbe voteChoice Nothing
+            votingProcedures = singletonVotingProcedures sbe voter govActIdentifier (unVotingProcedure voteProcedure)
+        firstExceptT GovernanceVoteCmdWriteError . newExceptT $ writeFileTextEnvelope oFp Nothing votingProcedures
+
+      AnyCommitteeHotVerificationKeyOrHashOrFile stake -> do
+        CommitteeHotKeyHash h <- firstExceptT GovernanceVoteCmdReadError
+                                  . newExceptT $ readVerificationKeyOrHashOrTextEnvFile AsCommitteeHotKey stake
+        let vStakeCred = StakeCredentialByKey . StakeKeyHash $ coerceKeyRole h
+        votingCred <- hoistEither $ first GovernanceVoteCmdCredentialDecodeError $ toVotingCredential sbe vStakeCred
+        let voter = Ledger.CommitteeVoter (Ledger.coerceKeyRole (unVotingCredential votingCred)) -- TODO Conway - remove coerceKeyRole
+            govActIdentifier = createGovernanceActionId govActionTxId govActionIndex
+            voteProcedure = createVotingProcedure sbe voteChoice Nothing
+            votingProcedures = singletonVotingProcedures sbe voter govActIdentifier (unVotingProcedure voteProcedure)
+        firstExceptT GovernanceVoteCmdWriteError . newExceptT $ writeFileTextEnvelope oFp Nothing votingProcedures

cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs

@@ -174,8 +174,8 @@ runTxBuildCmd
   -- Conway related
   votes <-
     featureInEra
-      (pure TxVotesNone)
-      (\w -> firstExceptT ShelleyTxCmdVoteError $ ExceptT (readTxVotes w conwayVotes))
+      (pure emptyVotingProcedures)
+      (\w -> firstExceptT ShelleyTxCmdVoteError $ ExceptT (readVotingProceduresFiles w conwayVotes))
       cEra
 
   proposals <- newExceptT $ first ShelleyTxCmdConstitutionError
@@ -473,7 +473,7 @@ runTxBuild
   -> TxMetadataInEra era
   -> Maybe UpdateProposal
   -> Maybe Word
-  -> TxVotes era
+  -> VotingProcedures era
   -> TxGovernanceActions era
   -> TxBuildOutputOptions
   -> ExceptT ShelleyTxCmdError IO (BalancedTxBody era)
@@ -545,6 +545,7 @@ runTxBuild
 
       validatedPParams <- hoistEither $ first ShelleyTxCmdProtocolParametersValidationError
                                       $ validateProtocolParameters era (Just pparams)
+
       let validatedTxGovernanceActions = proposals
           validatedTxVotes =  votes
           txBodyContent = TxBodyContent
@@ -566,7 +567,7 @@ runTxBuild
                           validatedMintValue
                           validatedTxScriptValidity
                           validatedTxGovernanceActions
-                          validatedTxVotes
+                          (inEraFeature era TxVotesNone (`votingProceduresToTxVotes` validatedTxVotes)) -- TODO Conway this should probably error if era not supported
 
       firstExceptT ShelleyTxCmdTxInsDoNotExist
         . hoistEither $ txInsExistInUTxO allTxInputs nodeEraUTxO

cardano-cli/src/Cardano/CLI/Read.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 
@@ -71,17 +72,27 @@ module Cardano.CLI.Read
   , getStakeCredentialFromVerifier
   , getStakeCredentialFromIdentifier
   , getStakeAddressFromVerifier
+
+  , emptyVotingProcedures
+  , singletonVotingProcedures
+  , mergeVotingProcedures
+  , readVotingProceduresFiles
+  , readVotingProceduresFile
+  , votingProceduresToTxVotes
   ) where
 
 import           Cardano.Api as Api
-import           Cardano.Api.Shelley
+import qualified Cardano.Api.Ledger as Ledger
+import           Cardano.Api.Shelley as Api
 
 import qualified Cardano.Binary as CBOR
 import           Cardano.CLI.Types.Common
 import           Cardano.CLI.Types.Errors.ScriptDecodeError
 import           Cardano.CLI.Types.Errors.StakeCredentialError
 import           Cardano.CLI.Types.Governance
 import           Cardano.CLI.Types.Key
+import qualified Cardano.Ledger.Conway.Governance as Ledger
+import           Ouroboros.Consensus.Shelley.Eras (StandardCrypto)
 
 import           Prelude
 
@@ -91,7 +102,7 @@ import           Control.Monad.Trans.Except (ExceptT (..), runExceptT)
 import           Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither,
                    hoistMaybe, left, newExceptT)
 import qualified Data.Aeson as Aeson
-import           Data.Bifunctor (first)
+import           Data.Bifunctor
 import qualified Data.ByteString.Builder as Builder
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.ByteString.Lazy.Char8 as LBS
@@ -764,7 +775,77 @@ readVoteFile
   -> VoteFile In
   -> IO (Either VoteError (VotingEntry era))
 readVoteFile w fp =
-  first VoteErrorFile <$> conwayEraOnwardsConstraints w (readFileTextEnvelope AsVotingEntry fp)
+  conwayEraOnwardsConstraints w
+    $ first VoteErrorFile <$> readFileTextEnvelope AsVotingEntry fp
+
+emptyVotingProcedures :: VotingProcedures era
+emptyVotingProcedures = VotingProcedures $ Ledger.VotingProcedures Map.empty
+
+singletonVotingProcedures :: ()
+  => ShelleyBasedEra era
+  -> Ledger.Voter (Ledger.EraCrypto (ShelleyLedgerEra era))
+  -> Ledger.GovActionId (Ledger.EraCrypto (ShelleyLedgerEra era))
+  -> Ledger.VotingProcedure (ShelleyLedgerEra era)
+  -> VotingProcedures era
+singletonVotingProcedures _ voter govActionId votingProcedure =
+  VotingProcedures
+    $ Ledger.VotingProcedures
+    $ Map.singleton voter
+    $ Map.singleton govActionId votingProcedure
+
+mergeVotingProcedures :: ()
+  => VotingProcedures era
+  -> VotingProcedures era
+  -> VotingProcedures era
+mergeVotingProcedures vpsa vpsb =
+  VotingProcedures
+    $ Ledger.VotingProcedures
+    $ Map.unionWith (Map.unionWith const)
+        (Ledger.unVotingProcedures (unVotingProcedures vpsa))
+        (Ledger.unVotingProcedures (unVotingProcedures vpsb))
+
+fromVoterRole :: ()
+  => Ledger.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto
+  => ShelleyBasedEra era
+  -> Ledger.Voter (Ledger.EraCrypto (ShelleyLedgerEra era))
+  -> Voter era
+fromVoterRole _ = \case
+  Ledger.CommitteeVoter cred ->
+    VoterCommittee (VotingCredential (Ledger.coerceKeyRole cred))    -- TODO: Conway era - We shouldn't be using coerceKeyRole.
+  Ledger.DRepVoter cred ->
+    VoterDRep (VotingCredential cred)
+  Ledger.StakePoolVoter kh ->
+    VoterSpo (StakePoolKeyHash kh)
+
+-- TODO Conway delete this where we aren't using TxVotes anymore
+votingProceduresToTxVotes :: forall era. ConwayEraOnwards era -> VotingProcedures era -> TxVotes era
+votingProceduresToTxVotes w apiVps =
+  conwayEraOnwardsConstraints w $
+    case Map.toList (Ledger.unVotingProcedures (unVotingProcedures apiVps)) >>= reKey . first (fromVoterRole (conwayEraOnwardsToShelleyBasedEra w)) of
+      [] -> TxVotesNone
+      vps -> TxVotes w $ Map.fromList $ bimap (second GovernanceActionId) VotingProcedure <$> vps
+  where
+    reKey :: (a, Map.Map k v) -> [((a, k), v)]
+    reKey (a, m) = map (\(k, v) -> ((a, k), v)) $ Map.toList m
+
+readVotingProceduresFiles :: ()
+  => ConwayEraOnwards era
+  -> [VoteFile In]
+  -> IO (Either VoteError (VotingProcedures era))
+readVotingProceduresFiles w = \case
+  [] -> return $ Right $ VotingProcedures $ Ledger.VotingProcedures Map.empty
+  files -> runExceptT $ do
+    vpss <- forM files (ExceptT . readVotingProceduresFile w)
+
+    pure $ foldl mergeVotingProcedures emptyVotingProcedures vpss
+
+readVotingProceduresFile :: ()
+  => ConwayEraOnwards era
+  -> VoteFile In
+  -> IO (Either VoteError (VotingProcedures era))
+readVotingProceduresFile w fp =
+  conwayEraOnwardsConstraints w
+    $ first VoteErrorFile <$> readFileTextEnvelope AsVotingProcedures fp
 
 data ConstitutionError
   = ConstitutionErrorFile (FileError TextEnvelopeError)