Implement mkTxVotingProcedures

Author: Jimbo4350

cardano-api/src/Cardano/Api/Experimental/Tx.hs

@@ -128,6 +128,7 @@ module Cardano.Api.Experimental.Tx
   , TxBodyContent (..)
   , defaultTxBodyContent
   , mkTxCertificates
+  , mkTxVotingProcedures
   , setTxAuxScripts
   , setTxCertificates
   , setTxCollateral

cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent/New.hs

@@ -26,6 +26,7 @@ module Cardano.Api.Experimental.Tx.Internal.BodyContent.New
   , extractAllIndexedPlutusScriptWitnesses
   , txMintValueToValue
   , mkTxCertificates
+  , mkTxVotingProcedures
 
     -- * Getters and Setters
   , setTxAuxScripts
@@ -74,6 +75,10 @@ import Cardano.Api.Experimental.Tx.Internal.TxScriptWitnessRequirements
   , getTxScriptWitnessesRequirements
   )
 import Cardano.Api.Experimental.Tx.Internal.Type
+import Cardano.Api.Governance.Internal.Action.VotingProcedure
+  ( VotesMergingConflict (..)
+  , mergeVotingProcedures
+  )
 import Cardano.Api.Key.Internal
 import Cardano.Api.Ledger.Internal.Reexport (StrictMaybe (..))
 import Cardano.Api.Ledger.Internal.Reexport qualified as L
@@ -424,6 +429,45 @@ data TxVotingProcedures era
       (Map L.Voter (AnyWitness era))
   deriving (Eq, Show)
 
+-- | Create voting procedures from map of voting procedures and optional witnesses.
+-- Validates the function argument, to make sure the list of votes is legal.
+-- See 'mergeVotingProcedures' for validation rules.
+mkTxVotingProcedures
+  :: forall era
+   . [(L.VotingProcedures (LedgerEra era), AnyWitness (LedgerEra era))]
+  -> Either (VotesMergingConflict (LedgerEra era)) (TxVotingProcedures (LedgerEra era))
+mkTxVotingProcedures votingProcedures = do
+  procedure <-
+    foldM f (L.VotingProcedures Map.empty) votingProcedures
+  pure $ TxVotingProcedures procedure votingScriptWitnessMap
+ where
+  votingScriptWitnessMap :: Map L.Voter (AnyWitness (LedgerEra era))
+  votingScriptWitnessMap =
+    foldl
+      (\acc next -> acc `Map.union` uncurry votingScriptWitnessSingleton next)
+      Map.empty
+      votingProcedures
+
+  f
+    :: L.VotingProcedures (LedgerEra era)
+    -> (L.VotingProcedures (LedgerEra era), AnyWitness (LedgerEra era))
+    -> Either (VotesMergingConflict (LedgerEra era)) (L.VotingProcedures (LedgerEra era))
+  f acc (procedure, _witness) = mergeVotingProcedures acc procedure
+
+  votingScriptWitnessSingleton
+    :: L.VotingProcedures (LedgerEra era)
+    -> AnyWitness (LedgerEra era)
+    -> Map L.Voter (AnyWitness (LedgerEra era))
+  votingScriptWitnessSingleton votingProcedures' scriptWitness = do
+    let voter = fromJust $ getVotingScriptCredentials votingProcedures'
+    Map.singleton voter scriptWitness
+
+  getVotingScriptCredentials
+    :: L.VotingProcedures (LedgerEra era)
+    -> Maybe L.Voter
+  getVotingScriptCredentials (L.VotingProcedures m) =
+    listToMaybe $ Map.keys m
+
 data TxBodyContent era
   = TxBodyContent
   { txIns :: [(TxIn, AnyWitness era)]

cardano-api/src/Cardano/Api/Governance/Internal/Action/VotingProcedure.hs

@@ -153,17 +153,17 @@ instance Error (VotesMergingConflict era) where
 -- or fails if the votes are incompatible.
 mergeVotingProcedures
   :: ()
-  => VotingProcedures era
+  => L.VotingProcedures era
   -- ^ Votes to merge
-  -> VotingProcedures era
+  -> L.VotingProcedures era
   -- ^ Votes to merge
-  -> Either (VotesMergingConflict era) (VotingProcedures era)
+  -> Either (VotesMergingConflict era) (L.VotingProcedures era)
   -- ^ Either the conflict found, or the merged votes
 mergeVotingProcedures vpsa vpsb =
-  VotingProcedures . L.VotingProcedures <$> foldM mergeVotesOfOneVoter Map.empty allVoters
+  L.VotingProcedures <$> foldM mergeVotesOfOneVoter Map.empty allVoters
  where
-  mapa = L.unVotingProcedures (unVotingProcedures vpsa)
-  mapb = L.unVotingProcedures (unVotingProcedures vpsb)
+  mapa = L.unVotingProcedures vpsa
+  mapb = L.unVotingProcedures vpsb
   allVoters = Set.union (Map.keysSet mapa) (Map.keysSet mapb)
   mergeVotesOfOneVoter acc voter =
     Map.union acc <$> case (Map.lookup voter mapa, Map.lookup voter mapb) of

cardano-api/src/Cardano/Api/Tx/Internal/Body.hs

@@ -734,18 +734,19 @@ deriving instance Show (TxVotingProcedures build era)
 mkTxVotingProcedures
   :: Applicative (BuildTxWith build)
   => [(VotingProcedures era, Maybe (ScriptWitness WitCtxStake era))]
-  -> Either (VotesMergingConflict era) (TxVotingProcedures build era)
+  -> Either (VotesMergingConflict (ShelleyLedgerEra era)) (TxVotingProcedures build era)
 mkTxVotingProcedures votingProcedures = do
-  VotingProcedures procedure <-
-    foldM f emptyVotingProcedures votingProcedures
+  procedure <-
+    foldM f (L.VotingProcedures Map.empty) votingProcedures
   pure $ TxVotingProcedures procedure (pure votingScriptWitnessMap)
  where
   votingScriptWitnessMap =
     foldl
       (\acc next -> acc `Map.union` uncurry votingScriptWitnessSingleton next)
       Map.empty
       votingProcedures
-  f acc (procedure, _witness) = mergeVotingProcedures acc procedure
+
+  f acc (VotingProcedures procedure, _witness) = mergeVotingProcedures acc procedure
 
   votingScriptWitnessSingleton
     :: VotingProcedures era