Merge pull request #681 from IntersectMBO/smelc/fix-same-action-id-vo…

…te-losing

Throw an error on identical action-ids in votes of one voter

cardano-cli/cardano-cli.cabal

@@ -317,6 +317,7 @@ test-suite cardano-cli-test
                         Test.Cli.Pipes
                         Test.Cli.VerificationKey
                         Test.Cli.Shelley.Run.Query
+                        Test.Cli.Shelley.Transaction.Build
 
   ghc-options:          -threaded -rtsopts "-with-rtsopts=-N -T"
 

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

@@ -429,6 +429,8 @@ runTxBuildRaw sbe
       <- createTxMintValue sbe valuesWithScriptWits
     validatedTxScriptValidity
       <- first TxCmdScriptValidityValidationError $ validateTxScriptValidity era mScriptValidity
+    validatedVotingProcedures
+      <- first TxCmdTxGovDuplicateVotes $ convertToTxVotingProcedures votingProcedures
     let txBodyContent =
           TxBodyContent
             { txIns = validatedTxIns
@@ -450,7 +452,7 @@ runTxBuildRaw sbe
             , txMintValue = validatedMintValue
             , txScriptValidity = validatedTxScriptValidity
             , txProposalProcedures = forEraInEonMaybe era (`Featured` (shelleyBasedEraConstraints sbe $ convToTxProposalProcedures proposals))
-            , txVotingProcedures = forEraInEonMaybe era (`Featured` convertToTxVotingProcedures votingProcedures)
+            , txVotingProcedures = forEraInEonMaybe era (`Featured` validatedVotingProcedures)
             }
     first TxCmdTxBodyError $ createAndValidateTransactionBody sbe txBodyContent
 
@@ -528,6 +530,7 @@ runTxBuild
   validatedTxCerts <- hoistEither (first TxCmdTxCertificatesValidationError $ validateTxCertificates era certsAndMaybeScriptWits)
   validatedMintValue <- hoistEither $ createTxMintValue sbe valuesWithScriptWits
   validatedTxScriptValidity <- hoistEither (first TxCmdScriptValidityValidationError $ validateTxScriptValidity era mScriptValidity)
+  validatedVotingProcedures <- hoistEither (first TxCmdTxGovDuplicateVotes $ convertToTxVotingProcedures votingProcedures)
 
   let allTxInputs = inputsThatRequireWitnessing ++ allReferenceInputs ++ txinsc
       localNodeConnInfo = LocalNodeConnectInfo
@@ -577,7 +580,7 @@ runTxBuild
           , txMintValue = validatedMintValue
           , txScriptValidity = validatedTxScriptValidity
           , txProposalProcedures = forEraInEonMaybe era (`Featured` convToTxProposalProcedures proposals)
-          , txVotingProcedures = forEraInEonMaybe era (`Featured` convertToTxVotingProcedures votingProcedures)
+          , txVotingProcedures = forEraInEonMaybe era (`Featured` validatedVotingProcedures)
           }
 
   firstExceptT TxCmdTxInsDoNotExist

cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs

@@ -93,6 +93,7 @@ data TxCmdError
   | TxCmdTxUpdateProposalValidationError TxUpdateProposalValidationError
   | TxCmdScriptValidityValidationError TxScriptValidityValidationError
   | TxCmdProtocolParamsConverstionError ProtocolParametersConversionError
+  | forall era. TxCmdTxGovDuplicateVotes (TxGovDuplicateVotes era)
 
 renderTxCmdError :: TxCmdError -> Doc ann
 renderTxCmdError = \case
@@ -233,6 +234,8 @@ renderTxCmdError = \case
     prettyError e
   TxCmdScriptValidityValidationError e ->
     prettyError e
+  TxCmdTxGovDuplicateVotes e ->
+    prettyError e
 
 prettyPolicyIdList :: [PolicyId] -> Doc ann
 prettyPolicyIdList =

cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs

@@ -10,6 +10,7 @@ module Cardano.CLI.Types.Errors.TxValidationError
   ( TxAuxScriptsValidationError(..)
   , TxCertificatesValidationError(..)
   , TxFeeValidationError(..)
+  , TxGovDuplicateVotes(..)
   , TxProtocolParametersValidationError
   , TxScriptValidityValidationError(..)
   , TxUpdateProposalValidationError(..)
@@ -43,11 +44,14 @@ import           Cardano.CLI.Types.Common
 
 import           Prelude
 
+import           Control.Monad (foldM)
 import           Data.Bifunctor (first)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe
 import qualified Data.OSet.Strict as OSet
+import qualified Data.Set as Set
+import           Prettyprinter (viaShow)
 
 data ScriptLanguageValidationError
   = ScriptLanguageValidationError AnyScriptLanguage AnyCardanoEra
@@ -321,22 +325,48 @@ votingScriptWitnessSingleton votingProcedures (Just scriptWitness) =
   let voter = fromJust $ getVotingScriptCredentials votingProcedures
   in Map.singleton voter scriptWitness
 
+newtype TxGovDuplicateVotes era =
+  TxGovDuplicateVotes [L.GovActionId (L.EraCrypto (ShelleyLedgerEra era))]
+
+instance Error (TxGovDuplicateVotes era) where
+  prettyError (TxGovDuplicateVotes actionIds) =
+    "Trying to merge votes with similar action identifiers: " <> viaShow actionIds <>
+      ". This would cause ignoring some of the votes, so not proceeding."
+
 -- TODO: We fold twice, we can do it in a single fold
 convertToTxVotingProcedures
  :: [(VotingProcedures era, Maybe (ScriptWitness WitCtxStake era))]
- -> TxVotingProcedures BuildTx era
-convertToTxVotingProcedures votingProcedures =
-  let votingScriptWitnessMap = BuildTxWith
-                                 $ foldl (\acc next -> acc `Map.union` uncurry votingScriptWitnessSingleton next )
-                                   Map.empty
-                                   votingProcedures
-      allVotes = unVotingProcedures
-                   $ foldl
-                       (\acc next -> acc `unsafeMergeVotingProcedures` fst next)
-                       emptyVotingProcedures
-                       votingProcedures
-
-  in TxVotingProcedures allVotes votingScriptWitnessMap
+ -> Either (TxGovDuplicateVotes era) (TxVotingProcedures BuildTx era)
+convertToTxVotingProcedures votingProcedures = do
+  VotingProcedures procedure <- foldM f emptyVotingProcedures votingProcedures
+  pure $ TxVotingProcedures procedure (BuildTxWith votingScriptWitnessMap)
+  where
+    votingScriptWitnessMap = foldl (\acc next -> acc `Map.union` uncurry votingScriptWitnessSingleton next)
+                               Map.empty
+                               votingProcedures
+    f acc (procedure, _witness) = mergeVotingProcedures acc procedure
+
+mergeVotingProcedures :: ()
+  => VotingProcedures era
+  -> VotingProcedures era
+  -> Either (TxGovDuplicateVotes era) (VotingProcedures era) -- ^ Either an error message, or the merged voting procedures
+mergeVotingProcedures vpsa vpsb =
+  VotingProcedures . L.VotingProcedures <$> foldM mergeVotesOfOneVoter Map.empty allVoters
+  where
+    mapa = L.unVotingProcedures (unVotingProcedures vpsa)
+    mapb = L.unVotingProcedures (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
+        (Just v, Nothing) -> Right $ Map.singleton voter v -- Take only available value
+        (Nothing, Just v) -> Right $ Map.singleton voter v -- Take only available value
+        (Nothing, Nothing) -> Right Map.empty -- No value
+        (Just va, Just vb) -> -- Here's the case where we're unioning different votes for the same voter
+          if null intersection -- No conflict: sets of keys from left and right is disjoint
+          then Right $ Map.singleton voter (Map.union va vb)
+          else Left $ TxGovDuplicateVotes intersection -- Ooops conflict! Let's report it!
+          where
+            intersection = Map.keys $ Map.intersection va vb
 
 proposingScriptWitnessSingleton
   :: Proposal era

cardano-cli/test/cardano-cli-test/Test/Cli/Shelley/Transaction/Build.hs

@@ -0,0 +1,34 @@
+module Test.Cli.Shelley.Transaction.Build where
+
+import           Data.List (isInfixOf)
+import           System.Exit (ExitCode (..))
+
+import           Test.Cardano.CLI.Util (execDetailCardanoCLI, propertyOnce)
+
+import           Hedgehog
+import qualified Hedgehog as H
+import qualified Hedgehog.Extras.Test.Base as H
+
+{- HLINT ignore "Use camelCase" -}
+{- HLINT ignore "Redundant bracket" -}
+
+-- | This is a test of https://github.com/IntersectMBO/cardano-cli/issues/662
+-- Execute me with:
+-- @cabal test cardano-cli-test --test-options '-p "/conway transaction build one voter many votes/"'@
+hprop_conway_transaction_build_one_voter_many_votes :: Property
+hprop_conway_transaction_build_one_voter_many_votes = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do
+  outFile <- H.noteTempFile tempDir "tx.traw"
+
+  (exitCode, _stdout, stderr) <- H.noteShowM $ execDetailCardanoCLI
+    [ "conway", "transaction", "build-raw"
+    , "--tx-in", "6e8c947816e82627aeccb55300074f2894a2051332f62a1c8954e7b588a18be7#0"
+    , "--tx-out", "addr_test1vpfwv0ezc5g8a4mkku8hhy3y3vp92t7s3ul8g778g5yegsgalc6gc+24910487859"
+    , "--invalid-hereafter", "24325742"
+    , "--fee" , "178569"
+    , "--vote-file", "test/cardano-cli-test/files/input/shelley/transaction/vote1.drep.json"
+    , "--vote-file", "test/cardano-cli-test/files/input/shelley/transaction/vote2.drep.json"
+    , "--out-file", outFile
+    ]
+
+  exitCode H.=== (ExitFailure 1)
+  H.assertWith stderr ("This would cause ignoring some of the votes" `isInfixOf`)

cardano-cli/test/cardano-cli-test/files/input/shelley/transaction/vote1.drep.json

@@ -0,0 +1,5 @@
+{
+    "type": "Governance voting procedures",
+    "description": "",
+    "cborHex": "a18202581c8f4fefcf28017a57b41517a67d56ef4c0dc04181a11d35178dd53f4ca1825820704e5c60c51dd0f3732991980b273402fbad0581c3407d682f8ea5b808a530fc008201f6"
+}

cardano-cli/test/cardano-cli-test/files/input/shelley/transaction/vote2.drep.json

@@ -0,0 +1,5 @@
+{
+    "type": "Governance voting procedures",
+    "description": "",
+    "cborHex": "a18202581c8f4fefcf28017a57b41517a67d56ef4c0dc04181a11d35178dd53f4ca1825820704e5c60c51dd0f3732991980b273402fbad0581c3407d682f8ea5b808a530fc008200f6"
+}