Merge pull request #951 from IntersectMBO/hash-check-in-transaction-b…

…uild

Add anchor hash checks to `transaction build`

cardano-cli/cardano-cli.cabal

@@ -116,6 +116,7 @@ library
     Cardano.CLI.EraBased.Run.StakePool
     Cardano.CLI.EraBased.Run.TextView
     Cardano.CLI.EraBased.Run.Transaction
+    Cardano.CLI.EraBased.Transaction.HashCheck
     Cardano.CLI.Helpers
     Cardano.CLI.IO.Lazy
     Cardano.CLI.Json.Friendly

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

@@ -45,6 +45,8 @@ import qualified Cardano.Binary as CBOR
 import qualified Cardano.CLI.EraBased.Commands.Transaction as Cmd
 import           Cardano.CLI.EraBased.Run.Genesis.Common (readProtocolParameters)
 import           Cardano.CLI.EraBased.Run.Query
+import           Cardano.CLI.EraBased.Transaction.HashCheck (checkCertificateHashes,
+                   checkProposalHashes, checkVotingProcedureHashes)
 import           Cardano.CLI.Read
 import           Cardano.CLI.Types.Common
 import           Cardano.CLI.Types.Errors.BootstrapWitnessError
@@ -66,6 +68,7 @@ import qualified Data.ByteString.Char8 as BS
 import qualified Data.ByteString.Lazy.Char8 as LBS
 import           Data.Containers.ListUtils (nubOrd)
 import           Data.Data ((:~:) (..))
+import           Data.Foldable (forM_)
 import qualified Data.Foldable as Foldable
 import           Data.Function ((&))
 import qualified Data.List as List
@@ -162,6 +165,9 @@ runTransactionBuildCmd
             )
         | (CertificateFile certFile, mSwit) <- certFilesAndMaybeScriptWits
         ]
+
+    forM_ certsAndMaybeScriptWits (checkCertificateHashes . fst)
+
     withdrawalsAndMaybeScriptWits <-
       firstExceptT TxCmdScriptWitnessError $
         readScriptWitnessFilesTuple eon withdrawals
@@ -193,11 +199,15 @@ runTransactionBuildCmd
         (\w -> firstExceptT TxCmdVoteError $ ExceptT (readVotingProceduresFiles w voteFiles))
         era'
 
+    forM_ votingProceduresAndMaybeScriptWits (checkVotingProcedureHashes eon . fst)
+
     proposals <-
       newExceptT $
         first TxCmdProposalError
           <$> readTxGovernanceActions eon proposalFiles
 
+    forM_ proposals (checkProposalHashes eon . fst)
+
     -- the same collateral input can be used for several plutus scripts
     let filteredTxinsc = nubOrd txinsc
 

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

@@ -0,0 +1,68 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Cardano.CLI.EraBased.Transaction.HashCheck
+  ( checkCertificateHashes
+  , checkVotingProcedureHashes
+  , checkProposalHashes
+  )
+where
+
+import           Cardano.Api (Certificate (..), ExceptT, except, firstExceptT,
+                   getAnchorDataFromCertificate, getAnchorDataFromGovernanceAction, withExceptT)
+import qualified Cardano.Api.Ledger as L
+import qualified Cardano.Api.Shelley as Shelley
+
+import           Cardano.CLI.Run.Hash (carryHashChecks)
+import           Cardano.CLI.Types.Common (MustCheckHash (..), PotentiallyCheckedAnchor (..))
+import           Cardano.CLI.Types.Errors.TxCmdError (TxCmdError (..))
+
+import           Control.Monad (forM_)
+
+-- | Check the hash of the anchor data against the hash in the anchor
+checkAnchorMetadataHash :: L.Anchor L.StandardCrypto -> ExceptT TxCmdError IO ()
+checkAnchorMetadataHash anchor =
+  firstExceptT (TxCmdHashCheckError $ L.anchorUrl anchor) $
+    carryHashChecks
+      ( PotentiallyCheckedAnchor
+          { pcaMustCheck = CheckHash
+          , pcaAnchor = anchor
+          }
+      )
+
+-- | Find references to anchor data and check the hashes are valid
+-- and they match the linked data.
+checkCertificateHashes :: Certificate era -> ExceptT TxCmdError IO ()
+checkCertificateHashes cert = do
+  mAnchor <- withExceptT TxCmdPoolMetadataHashError $ except $ getAnchorDataFromCertificate cert
+  maybe (return mempty) checkAnchorMetadataHash mAnchor
+
+-- | Find references to anchor data in voting procedures and check the hashes are valid
+-- and they match the linked data.
+checkVotingProcedureHashes
+  :: Shelley.ShelleyBasedEra era -> Shelley.VotingProcedures era -> ExceptT TxCmdError IO ()
+checkVotingProcedureHashes eon (Shelley.VotingProcedures (L.VotingProcedures voterMap)) =
+  Shelley.shelleyBasedEraConstraints eon $
+    forM_
+      voterMap
+      ( mapM $ \(L.VotingProcedure _ mAnchor) ->
+          forM_ mAnchor checkAnchorMetadataHash
+      )
+
+-- | Find references to anchor data in proposals and check the hashes are valid
+-- and they match the linked data.
+checkProposalHashes
+  :: forall era. Shelley.ShelleyBasedEra era -> Shelley.Proposal era -> ExceptT TxCmdError IO ()
+checkProposalHashes
+  eon
+  ( Shelley.Proposal
+      ( L.ProposalProcedure
+          { L.pProcGovAction = govAction
+          , L.pProcAnchor = anchor
+          }
+        )
+    ) =
+    Shelley.shelleyBasedEraConstraints eon $ do
+      checkAnchorMetadataHash anchor
+      maybe (return ()) checkAnchorMetadataHash (getAnchorDataFromGovernanceAction govAction)
+
+-- Only the `NewConstitution` governance action contains a checkable hash with a corresponding URL.

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

@@ -15,11 +15,13 @@ module Cardano.CLI.Types.Errors.TxCmdError
 where
 
 import           Cardano.Api
+import qualified Cardano.Api.Ledger as L
 import           Cardano.Api.Shelley
 
 import           Cardano.CLI.Read
 import           Cardano.CLI.Types.Common
 import           Cardano.CLI.Types.Errors.BootstrapWitnessError
+import           Cardano.CLI.Types.Errors.HashCmdError (HashCheckError)
 import           Cardano.CLI.Types.Errors.NodeEraMismatchError
 import qualified Cardano.CLI.Types.Errors.NodeEraMismatchError as NEM
 import           Cardano.CLI.Types.Errors.ProtocolParamsError
@@ -84,6 +86,8 @@ data TxCmdError
   | TxCmdProtocolParamsConverstionError ProtocolParametersConversionError
   | forall era. TxCmdTxGovDuplicateVotes (TxGovDuplicateVotes era)
   | forall era. TxCmdFeeEstimationError (TxFeeEstimationError era)
+  | TxCmdPoolMetadataHashError AnchorDataFromCertificateError
+  | TxCmdHashCheckError L.Url HashCheckError
 
 renderTxCmdError :: TxCmdError -> Doc ann
 renderTxCmdError = \case
@@ -217,6 +221,10 @@ renderTxCmdError = \case
     prettyError e
   TxCmdFeeEstimationError e ->
     prettyError e
+  TxCmdPoolMetadataHashError e ->
+    "Hash of the pool metadata hash is not valid:" <+> prettyError e
+  TxCmdHashCheckError url e ->
+    "Hash of the file is not valid. Url:" <+> pretty (L.urlToText url) <+> prettyException e
 
 prettyPolicyIdList :: [PolicyId] -> Doc ann
 prettyPolicyIdList =