Merge pull request #916 from IntersectMBO/add-hash-validation3

Add hash checks for `drep registration-certificate` and `drep update-certificate`

.github/workflows/haskell.yml

@@ -32,7 +32,7 @@ jobs:
 
     env:
       # Modify this value to "invalidate" the cabal cache.
-      CABAL_CACHE_VERSION: "2024-07-26"
+      CABAL_CACHE_VERSION: "2024-09-30"
       # these two are msys2 env vars, they have no effect on non-msys2 installs.
       MSYS2_PATH_TYPE: inherit
       MSYSTEM: MINGW64

cardano-cli/cardano-cli.cabal

@@ -321,6 +321,7 @@ test-suite cardano-cli-test
     filepath,
     hedgehog,
     hedgehog-extras ^>=0.6.1.0,
+    monad-control,
     parsec,
     regex-tdfa,
     tasty,

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

@@ -15,8 +15,6 @@ module Cardano.CLI.EraBased.Commands.Governance.DRep
 where
 
 import           Cardano.Api
-import qualified Cardano.Api.Ledger as L
-import           Cardano.Api.Shelley
 
 import           Cardano.CLI.Types.Common
 import           Cardano.CLI.Types.Key
@@ -51,7 +49,12 @@ data GovernanceDRepRegistrationCertificateCmdArgs era
   { eon :: !(ConwayEraOnwards era)
   , drepHashSource :: !DRepHashSource
   , deposit :: !Lovelace
-  , mAnchor :: !(Maybe (L.Anchor (L.EraCrypto (ShelleyLedgerEra era))))
+  , mAnchor
+      :: !( Maybe
+              ( PotentiallyCheckedAnchor
+                  DRepMetadataUrl
+              )
+          )
   , outFile :: !(File () Out)
   }
 
@@ -67,7 +70,11 @@ data GovernanceDRepUpdateCertificateCmdArgs era
   = GovernanceDRepUpdateCertificateCmdArgs
   { eon :: !(ConwayEraOnwards era)
   , drepHashSource :: !DRepHashSource
-  , mAnchor :: !(Maybe (L.Anchor (L.EraCrypto (ShelleyLedgerEra era))))
+  , mAnchor
+      :: Maybe
+          ( PotentiallyCheckedAnchor
+              DRepMetadataUrl
+          )
   , outFile :: !(File () Out)
   }
 

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

@@ -3571,36 +3571,38 @@ pAnchorDataHash =
 
 pMustCheckHash :: String -> String -> String -> String -> Parser (MustCheckHash anchorData)
 pMustCheckHash flagSuffix' dataName' hashParamName' urlParamName' =
-  asum
-    [ Opt.flag' CheckHash $
-        mconcat
-          [ Opt.long ("check-" ++ flagSuffix')
-          , Opt.help
-              ( "Check the "
-                  ++ dataName'
-                  ++ " hash (from "
-                  ++ hashParamName'
-                  ++ ") by downloading "
-                  ++ dataName'
-                  ++ " data (from "
-                  ++ urlParamName'
-                  ++ ")."
-              )
-          ]
-    , Opt.flag' TrustHash $
-        mconcat
-          [ Opt.long ("trust-" ++ flagSuffix')
-          , Opt.help
-              ("Do not check the " ++ dataName' ++ " hash (from " ++ hashParamName' ++ ") and trust it is correct.")
-          ]
-    ]
+  Opt.flag TrustHash CheckHash $
+    mconcat
+      [ Opt.long ("check-" ++ flagSuffix')
+      , Opt.help
+          ( "Verify that the expected "
+              ++ dataName'
+              ++ " hash provided in "
+              ++ hashParamName'
+              ++ " matches the hash of the file downloaded from the URL provided in "
+              ++ urlParamName'
+              ++ " (this parameter will download the file from the URL)"
+          )
+      ]
+
+pPotentiallyCheckedAnchorData
+  :: Parser (MustCheckHash anchorDataType)
+  -> Parser (L.Anchor L.StandardCrypto)
+  -> Parser (PotentiallyCheckedAnchor anchorDataType)
+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 (HashCheckError (..))
 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
 
@@ -108,8 +111,16 @@ runGovernanceDRepRegistrationCertificateCmd
     } =
     conwayEraOnwardsConstraints w $ do
       drepCred <- modifyError RegistrationReadError $ readDRepCredential drepHashSource
+
+      mapM_
+        (withExceptT RegistrationDRepHashCheckError . carryHashChecks)
+        mAnchor
+
       let req = DRepRegistrationRequirements w drepCred deposit
-          registrationCert = makeDrepRegistrationCertificate req mAnchor
+          registrationCert =
+            makeDrepRegistrationCertificate
+              req
+              (pcaAnchor <$> mAnchor)
           description = Just @TextEnvelopeDescr "DRep Key Registration Certificate"
 
       firstExceptT RegistrationWriteFileError
@@ -150,8 +161,14 @@ runGovernanceDRepUpdateCertificateCmd
     , outFile
     } =
     conwayEraOnwardsConstraints w $ do
+      mapM_
+        (withExceptT GovernanceDRepHashCheckError . carryHashChecks)
+        mAnchor
       drepCredential <- modifyError GovernanceCmdKeyReadError $ readDRepCredential drepHashSource
-      let updateCertificate = makeDrepUpdateCertificate (DRepUpdateRequirements w drepCredential) mAnchor
+      let updateCertificate =
+            makeDrepUpdateCertificate
+              (DRepUpdateRequirements w drepCredential)
+              (pcaAnchor <$> mAnchor)
       firstExceptT GovernanceCmdTextEnvWriteError . newExceptT $
         writeFileTextEnvelope outFile (Just "DRep Update Certificate") updateCertificate
 
@@ -171,3 +188,25 @@ 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
+  :: PotentiallyCheckedAnchor DRepMetadataUrl
+  -- ^ The information about anchor data and whether to check the hash (see 'PotentiallyCheckedAnchor')
+  -> ExceptT HashCheckError IO ()
+carryHashChecks potentiallyCheckedAnchor =
+  case pcaMustCheck potentiallyCheckedAnchor of
+    CheckHash -> do
+      anchorData <-
+        L.AnchorData
+          <$> withExceptT
+            FetchURLError
+            (getByteStringFromURL httpsAndIpfsSchemas $ L.anchorUrl anchor)
+      let hash = L.hashAnchorData anchorData
+      when (hash /= L.anchorDataHash anchor) $
+        left $
+          HashMismatchError (L.anchorDataHash anchor) hash
+    TrustHash -> pure ()
+ where
+  anchor = pcaAnchor potentiallyCheckedAnchor

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

@@ -87,10 +87,13 @@ module Cardano.CLI.Types.Common
   , WitnessFile (..)
   , WitnessSigningData (..)
   , DRepMetadataFile
+  , DRepMetadataUrl
+  , PotentiallyCheckedAnchor (..)
   )
 where
 
 import           Cardano.Api hiding (Script)
+import           Cardano.Api.Ledger (Anchor)
 import qualified Cardano.Api.Ledger as L
 
 import qualified Cardano.Chain.Slotting as Byron
@@ -137,6 +140,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 +652,12 @@ data MustCheckHash a
   = CheckHash
   | TrustHash
   deriving (Eq, Show)
+
+data PotentiallyCheckedAnchor anchorType
+  = PotentiallyCheckedAnchor
+  { pcaAnchor :: Anchor L.StandardCrypto
+  -- ^ 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

@@ -9,8 +9,10 @@ import           Cardano.Api.Shelley
 
 import           Cardano.Binary (DecoderError)
 import           Cardano.CLI.Read
+import           Cardano.CLI.Types.Errors.HashCmdError (HashCheckError)
 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 +55,7 @@ data GovernanceCmdError
   | -- Legacy - remove me after cardano-cli transitions to new era based structure
     GovernanceCmdMIRCertNotSupportedInConway
   | GovernanceCmdGenesisDelegationNotSupportedInConway
+  | GovernanceDRepHashCheckError HashCheckError
   deriving Show
 
 instance Error GovernanceCmdError where
@@ -114,5 +117,7 @@ instance Error GovernanceCmdError where
       "MIR certificates are not supported in Conway era onwards."
     GovernanceCmdGenesisDelegationNotSupportedInConway ->
       "Genesis delegation is not supported in Conway era onwards."
+    GovernanceDRepHashCheckError hashCheckError ->
+      "Error while checking DRep metadata hash: " <> pretty (displayException hashCheckError)
    where
     renderDecoderError = pretty . TL.toLazyText . B.build

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

@@ -5,6 +5,7 @@ module Cardano.CLI.Types.Errors.HashCmdError
   ( HashCmdError (..)
   , HttpRequestError (..)
   , FetchURLError (..)
+  , HashCheckError (..)
   )
 where
 
@@ -76,3 +77,22 @@ instance Exception HttpRequestError where
   displayException (BadStatusCodeHRE code description) = "Bad status code when downloading anchor data: " <> show code <> " (" <> description <> ")"
   displayException (HttpExceptionHRE exc) = "HTTP(S) request error when downloading anchor data: " <> displayException exc
   displayException (IOExceptionHRE exc) = "I/O error when downloading anchor data: " <> displayException exc
+
+data HashCheckError
+  = HashMismatchError
+      (L.SafeHash L.StandardCrypto L.AnchorData)
+      -- ^ The expected DRep metadata hash.
+      (L.SafeHash L.StandardCrypto L.AnchorData)
+      -- ^ The actual DRep metadata hash.
+  | FetchURLError FetchURLError
+  deriving Show
+
+instance Exception HashCheckError where
+  displayException :: HashCheckError -> String
+  displayException (HashMismatchError expectedHash actualHash) =
+    "Hashes do not match!"
+      <> "\nExpected: "
+      <> show (extractHash expectedHash)
+      <> "\n  Actual: "
+      <> show (extractHash actualHash)
+  displayException (FetchURLError fetchErr) = displayException fetchErr

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

@@ -6,15 +6,26 @@ module Cardano.CLI.Types.Errors.RegistrationError
 where
 
 import           Cardano.Api
+import qualified Cardano.Api.Ledger as L
 
+import           Cardano.CLI.Types.Errors.HashCmdError (FetchURLError, HashCheckError)
 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)
+      -- ^ The expected DRep metadata hash.
+      !(L.SafeHash L.StandardCrypto L.AnchorData)
+      -- ^ The actual DRep metadata hash.
+  | RegistrationFetchURLError !FetchURLError
+  | RegistrationDRepHashCheckError !HashCheckError
   deriving Show
 
 instance Error RegistrationError where
@@ -27,3 +38,13 @@ 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)
+    RegistrationDRepHashCheckError hashCheckError ->
+      "Error while checking DRep metadata hash: " <> pretty (displayException hashCheckError)