Implement hash checks for registration-certificate and `update-cert…

…ificate`

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

@@ -51,7 +51,13 @@ data GovernanceDRepRegistrationCertificateCmdArgs era
   { eon :: !(ConwayEraOnwards era)
   , drepHashSource :: !DRepHashSource
   , deposit :: !Lovelace
-  , mAnchor :: !(Maybe (L.Anchor (L.EraCrypto (ShelleyLedgerEra era))))
+  , mPotentiallyCheckedAnchor
+      :: !( Maybe
+              ( PotentiallyCheckedAnchor
+                  DRepMetadataUrl
+                  (L.Anchor (L.EraCrypto (ShelleyLedgerEra era)))
+              )
+          )
   , outFile :: !(File () Out)
   }
 
@@ -67,7 +73,13 @@ data GovernanceDRepUpdateCertificateCmdArgs era
   = GovernanceDRepUpdateCertificateCmdArgs
   { eon :: !(ConwayEraOnwards era)
   , drepHashSource :: !DRepHashSource
-  , mAnchor :: !(Maybe (L.Anchor (L.EraCrypto (ShelleyLedgerEra era))))
+  , mPotentiallyCheckedAnchor
+      :: !( Maybe
+              ( PotentiallyCheckedAnchor
+                  DRepMetadataUrl
+                  (L.Anchor (L.EraCrypto (ShelleyLedgerEra era)))
+              )
+          )
   , outFile :: !(File () Out)
   }
 

cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs

@@ -3595,12 +3595,24 @@ pMustCheckHash flagSuffix' dataName' hashParamName' urlParamName' =
           ]
     ]
 
+pPotentiallyCheckedAnchorData
+  :: Parser (MustCheckHash anchorDataType)
+  -> Parser anchorData
+  -> Parser (PotentiallyCheckedAnchor anchorDataType anchorData)
+pPotentiallyCheckedAnchorData mustCheckHash anchorData =
+  PotentiallyCheckedAnchor
+    <$> anchorData
+    <*> mustCheckHash
+
 pMustCheckProposalHash :: Parser (MustCheckHash ProposalUrl)
 pMustCheckProposalHash = pMustCheckHash "anchor-data" "proposal" "--anchor-data-hash" "--anchor-url"
 
 pMustCheckConstitutionHash :: Parser (MustCheckHash ConstitutionUrl)
 pMustCheckConstitutionHash = pMustCheckHash "constitution-hash" "constitution" "--constitution-hash" "--constitution-url"
 
+pMustCheckMetadataHash :: Parser (MustCheckHash DRepMetadataUrl)
+pMustCheckMetadataHash = pMustCheckHash "drep-metadata-hash" "DRep metadata" "--drep-metadata-hash" "--drep-metadata-url"
+
 pPreviousGovernanceAction :: Parser (Maybe (TxId, Word16))
 pPreviousGovernanceAction =
   optional $

cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/DRep.hs

@@ -111,15 +111,18 @@ pRegistrationCertificateCmd era = do
       GovernanceDRepRegistrationCertificateCmdArgs w
         <$> pDRepHashSource
         <*> pKeyRegistDeposit
-        <*> pDRepMetadata
+        <*> optional
+          ( pPotentiallyCheckedAnchorData
+              pMustCheckMetadataHash
+              pDRepMetadata
+          )
         <*> pOutputFile
 
-pDRepMetadata :: Parser (Maybe (L.Anchor L.StandardCrypto))
+pDRepMetadata :: Parser (L.Anchor L.StandardCrypto)
 pDRepMetadata =
-  optional $
-    L.Anchor
-      <$> fmap unAnchorUrl pDrepMetadataUrl
-      <*> pDrepMetadataHash
+  L.Anchor
+    <$> fmap unAnchorUrl pDrepMetadataUrl
+    <*> pDrepMetadataHash
 
 pDrepMetadataUrl :: Parser AnchorUrl
 pDrepMetadataUrl =
@@ -165,7 +168,11 @@ pUpdateCertificateCmd era = do
           conwayEraOnwardsConstraints w $
             GovernanceDRepUpdateCertificateCmdArgs w
               <$> pDRepHashSource
-              <*> pDRepMetadata
+              <*> optional
+                ( pPotentiallyCheckedAnchorData
+                    pMustCheckMetadataHash
+                    pDRepMetadata
+                )
               <*> pOutputFile
       )
     $ Opt.progDesc "Create a DRep update certificate."

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

@@ -530,5 +530,5 @@ carryHashChecks checkHash anchor checkType =
       let hash = L.hashAnchorData anchorData
       when (hash /= L.anchorDataHash anchor) $
         left $
-          GovernanceActionsProposalMismatchedHashError checkType (L.anchorDataHash anchor) hash
+          GovernanceActionsMismatchedHashError checkType (L.anchorDataHash anchor) hash
     TrustHash -> pure ()

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

@@ -16,16 +16,19 @@ module Cardano.CLI.EraBased.Run.Governance.DRep
 where
 
 import           Cardano.Api
+import qualified Cardano.Api.Ledger as L
 
 import qualified Cardano.CLI.EraBased.Commands.Governance.DRep as Cmd
 import qualified Cardano.CLI.EraBased.Run.Key as Key
+import           Cardano.CLI.Run.Hash (getByteStringFromURL, httpsAndIpfsSchemas)
 import           Cardano.CLI.Types.Common
 import           Cardano.CLI.Types.Errors.CmdError
 import           Cardano.CLI.Types.Errors.GovernanceCmdError
+import           Cardano.CLI.Types.Errors.HashCmdError (FetchURLError)
 import           Cardano.CLI.Types.Errors.RegistrationError
 import           Cardano.CLI.Types.Key
 
-import           Control.Monad (void)
+import           Control.Monad (void, when)
 import           Data.Function
 import qualified Data.Text.Encoding as Text
 
@@ -103,13 +106,21 @@ runGovernanceDRepRegistrationCertificateCmd
     { eon = w
     , drepHashSource
     , deposit
-    , mAnchor
+    , mPotentiallyCheckedAnchor
     , outFile
     } =
     conwayEraOnwardsConstraints w $ do
       drepCred <- modifyError RegistrationReadError $ readDRepCredential drepHashSource
+
+      mapM_
+        (carryHashChecks RegistrationFetchURLError RegistrationMismatchedDRepMetadataHashError)
+        mPotentiallyCheckedAnchor
+
       let req = DRepRegistrationRequirements w drepCred deposit
-          registrationCert = makeDrepRegistrationCertificate req mAnchor
+          registrationCert =
+            makeDrepRegistrationCertificate
+              req
+              (pcaAnchor <$> mPotentiallyCheckedAnchor)
           description = Just @TextEnvelopeDescr "DRep Key Registration Certificate"
 
       firstExceptT RegistrationWriteFileError
@@ -146,12 +157,18 @@ runGovernanceDRepUpdateCertificateCmd
   Cmd.GovernanceDRepUpdateCertificateCmdArgs
     { eon = w
     , drepHashSource
-    , mAnchor
+    , mPotentiallyCheckedAnchor
     , outFile
     } =
     conwayEraOnwardsConstraints w $ do
+      mapM_
+        (carryHashChecks GovernanceCmdFetchURLError GovernanceCmdMismatchedDRepMetadataHashError)
+        mPotentiallyCheckedAnchor
       drepCredential <- modifyError GovernanceCmdKeyReadError $ readDRepCredential drepHashSource
-      let updateCertificate = makeDrepUpdateCertificate (DRepUpdateRequirements w drepCredential) mAnchor
+      let updateCertificate =
+            makeDrepUpdateCertificate
+              (DRepUpdateRequirements w drepCredential)
+              (pcaAnchor <$> mPotentiallyCheckedAnchor)
       firstExceptT GovernanceCmdTextEnvWriteError . newExceptT $
         writeFileTextEnvelope outFile (Just "DRep Update Certificate") updateCertificate
 
@@ -171,3 +188,28 @@ runGovernanceDRepMetadataHashCmd
       . writeByteStringOutput mOutFile
       . serialiseToRawBytesHex
       $ metadataHash
+
+-- | Check the hash of the anchor data against the hash in the anchor if
+-- checkHash is set to CheckHash.
+carryHashChecks
+  :: (FetchURLError -> error)
+  -- ^ Function that takes a FetchURLError and returns the error type of the caller
+  -> (L.SafeHash L.StandardCrypto L.AnchorData -> L.SafeHash L.StandardCrypto L.AnchorData -> error)
+  -- ^ Function that takes the expected and actual hashes and returns the mismatch hash error type of the caller
+  -> PotentiallyCheckedAnchor DRepMetadataUrl (L.Anchor L.StandardCrypto)
+  -- ^ The information about anchor data and whether to check the hash (see 'PotentiallyCheckedAnchor')
+  -> ExceptT error IO ()
+carryHashChecks errorAdaptor hashMismatchError potentiallyCheckedAnchor =
+  let anchor = pcaAnchor potentiallyCheckedAnchor
+   in case pcaMustCheck potentiallyCheckedAnchor of
+        CheckHash -> do
+          anchorData <-
+            L.AnchorData
+              <$> withExceptT
+                errorAdaptor
+                (getByteStringFromURL httpsAndIpfsSchemas $ L.anchorUrl anchor)
+          let hash = L.hashAnchorData anchorData
+          when (hash /= L.anchorDataHash anchor) $
+            left $
+              hashMismatchError (L.anchorDataHash anchor) hash
+        TrustHash -> pure ()

cardano-cli/src/Cardano/CLI/Types/Common.hs

@@ -87,6 +87,8 @@ module Cardano.CLI.Types.Common
   , WitnessFile (..)
   , WitnessSigningData (..)
   , DRepMetadataFile
+  , DRepMetadataUrl
+  , PotentiallyCheckedAnchor (..)
   )
 where
 
@@ -137,6 +139,10 @@ data ProposalBinary
 -- | Tag for tracking proposals submitted as 'Text.Text'
 data ProposalText
 
+-- | Tag for differentiating between DRep metadata sources and
+-- sources for other types of anchor data
+data DRepMetadataUrl
+
 newtype VoteUrl = VoteUrl
   { unVoteUrl :: L.Url
   }
@@ -645,3 +651,12 @@ data MustCheckHash a
   = CheckHash
   | TrustHash
   deriving (Eq, Show)
+
+data PotentiallyCheckedAnchor anchorType anchor
+  = PotentiallyCheckedAnchor
+  { pcaAnchor :: anchor
+  -- ^ The anchor data whose hash is to be checked
+  , pcaMustCheck :: MustCheckHash anchorType
+  -- ^ Whether to check the hash or not (CheckHash for checking or TrustHash for not checking)
+  }
+  deriving (Eq, Show)

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

@@ -24,7 +24,7 @@ data GovernanceActionsError
   | GovernanceActionsCmdReadTextEnvelopeFileError (FileError TextEnvelopeError)
   | GovernanceActionsCmdWriteFileError (FileError ())
   | GovernanceActionsValueUpdateProtocolParametersNotFound AnyShelleyBasedEra
-  | GovernanceActionsProposalMismatchedHashError
+  | GovernanceActionsMismatchedHashError
       AnchorDataTypeCheck
       -- ^ Type of anchor data that we were checking
       !(L.SafeHash L.StandardCrypto L.AnchorData)
@@ -56,7 +56,7 @@ instance Error GovernanceActionsError where
       "Protocol parameters update value for" <+> pretty expectedShelleyEra <+> "was not found."
     GovernanceActionsReadStakeCredErrror e ->
       prettyError e
-    GovernanceActionsProposalMismatchedHashError adt expectedHash actualHash ->
+    GovernanceActionsMismatchedHashError adt expectedHash actualHash ->
       "Hashes do not match while checking"
         <+> pretty (anchorDataTypeCheckName adt)
         <+> "hashes!"

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

@@ -5,12 +5,15 @@
 module Cardano.CLI.Types.Errors.GovernanceCmdError where
 
 import           Cardano.Api
+import qualified Cardano.Api.Ledger as L
 import           Cardano.Api.Shelley
 
 import           Cardano.Binary (DecoderError)
 import           Cardano.CLI.Read
+import           Cardano.CLI.Types.Errors.HashCmdError (FetchURLError)
 import           Cardano.CLI.Types.Errors.StakeAddressCmdError
 
+import           Control.Exception (displayException)
 import qualified Data.List as List
 import           Data.Text (Text)
 import qualified Data.Text.Lazy.Builder as TL
@@ -53,6 +56,10 @@ data GovernanceCmdError
   | -- Legacy - remove me after cardano-cli transitions to new era based structure
     GovernanceCmdMIRCertNotSupportedInConway
   | GovernanceCmdGenesisDelegationNotSupportedInConway
+  | GovernanceCmdMismatchedDRepMetadataHashError
+      !(L.SafeHash L.StandardCrypto L.AnchorData)
+      !(L.SafeHash L.StandardCrypto L.AnchorData)
+  | GovernanceCmdFetchURLError !FetchURLError
   deriving Show
 
 instance Error GovernanceCmdError where
@@ -114,5 +121,13 @@ instance Error GovernanceCmdError where
       "MIR certificates are not supported in Conway era onwards."
     GovernanceCmdGenesisDelegationNotSupportedInConway ->
       "Genesis delegation is not supported in Conway era onwards."
+    GovernanceCmdMismatchedDRepMetadataHashError expectedHash actualHash ->
+      "DRep metadata Hashes do not match!"
+        <> "\nExpected:"
+          <+> pretty (show (L.extractHash expectedHash))
+        <> "\n  Actual:"
+          <+> pretty (show (L.extractHash actualHash))
+    GovernanceCmdFetchURLError fetchErr ->
+      "Error while fetching proposal: " <> pretty (displayException fetchErr)
    where
     renderDecoderError = pretty . TL.toLazyText . B.build

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

@@ -6,15 +6,23 @@ module Cardano.CLI.Types.Errors.RegistrationError
 where
 
 import           Cardano.Api
+import qualified Cardano.Api.Ledger as L
 
+import           Cardano.CLI.Types.Errors.HashCmdError (FetchURLError)
 import           Cardano.CLI.Types.Errors.StakeAddressRegistrationError
 import           Cardano.CLI.Types.Errors.StakeCredentialError
 
+import           Control.Exception (displayException)
+
 data RegistrationError
   = RegistrationReadError !(FileError InputDecodeError)
   | RegistrationWriteFileError !(FileError ())
   | RegistrationStakeCredentialError !StakeCredentialError
   | RegistrationStakeError !StakeAddressRegistrationError
+  | RegistrationMismatchedDRepMetadataHashError
+      !(L.SafeHash L.StandardCrypto L.AnchorData)
+      !(L.SafeHash L.StandardCrypto L.AnchorData)
+  | RegistrationFetchURLError !FetchURLError
   deriving Show
 
 instance Error RegistrationError where
@@ -27,3 +35,11 @@ instance Error RegistrationError where
       "Cannot read stake credential: " <> prettyError e
     RegistrationStakeError e ->
       "Stake address registation error: " <> prettyError e
+    RegistrationMismatchedDRepMetadataHashError expectedHash actualHash ->
+      "DRep metadata Hashes do not match!"
+        <> "\nExpected:"
+          <+> pretty (show (L.extractHash expectedHash))
+        <> "\n  Actual:"
+          <+> pretty (show (L.extractHash actualHash))
+    RegistrationFetchURLError fetchErr ->
+      "Error while fetching proposal: " <> pretty (displayException fetchErr)