Address reviews

.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,11 +49,10 @@ data GovernanceDRepRegistrationCertificateCmdArgs era
   { eon :: !(ConwayEraOnwards era)
   , drepHashSource :: !DRepHashSource
   , deposit :: !Lovelace
-  , mPotentiallyCheckedAnchor
+  , mAnchor
       :: !( Maybe
               ( PotentiallyCheckedAnchor
                   DRepMetadataUrl
-                  (L.Anchor (L.EraCrypto (ShelleyLedgerEra era)))
               )
           )
   , outFile :: !(File () Out)
@@ -73,12 +70,10 @@ data GovernanceDRepUpdateCertificateCmdArgs era
   = GovernanceDRepUpdateCertificateCmdArgs
   { eon :: !(ConwayEraOnwards era)
   , drepHashSource :: !DRepHashSource
-  , mPotentiallyCheckedAnchor
-      :: !( Maybe
-              ( PotentiallyCheckedAnchor
-                  DRepMetadataUrl
-                  (L.Anchor (L.EraCrypto (ShelleyLedgerEra era)))
-              )
+  , mAnchor
+      :: Maybe
+          ( PotentiallyCheckedAnchor
+              DRepMetadataUrl
           )
   , outFile :: !(File () Out)
   }

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

@@ -3571,34 +3571,26 @@ 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
+          ( "Check the "
+              ++ dataName'
+              ++ " hash (from "
+              ++ hashParamName'
+              ++ ") by downloading "
+              ++ dataName'
+              ++ " data (from "
+              ++ urlParamName'
+              ++ ")."
+          )
+      ]
 
 pPotentiallyCheckedAnchorData
   :: Parser (MustCheckHash anchorDataType)
-  -> Parser anchorData
-  -> Parser (PotentiallyCheckedAnchor anchorDataType anchorData)
+  -> Parser (L.Anchor L.StandardCrypto)
+  -> Parser (PotentiallyCheckedAnchor anchorDataType)
 pPotentiallyCheckedAnchorData mustCheckHash anchorData =
   PotentiallyCheckedAnchor
     <$> anchorData

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

@@ -24,7 +24,7 @@ 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.HashCmdError (HashCheckError (..))
 import           Cardano.CLI.Types.Errors.RegistrationError
 import           Cardano.CLI.Types.Key
 
@@ -106,21 +106,21 @@ runGovernanceDRepRegistrationCertificateCmd
     { eon = w
     , drepHashSource
     , deposit
-    , mPotentiallyCheckedAnchor
+    , mAnchor
     , outFile
     } =
     conwayEraOnwardsConstraints w $ do
       drepCred <- modifyError RegistrationReadError $ readDRepCredential drepHashSource
 
       mapM_
-        (carryHashChecks RegistrationFetchURLError RegistrationMismatchedDRepMetadataHashError)
-        mPotentiallyCheckedAnchor
+        (withExceptT RegistrationDRepHashCheckError . carryHashChecks)
+        mAnchor
 
       let req = DRepRegistrationRequirements w drepCred deposit
           registrationCert =
             makeDrepRegistrationCertificate
               req
-              (pcaAnchor <$> mPotentiallyCheckedAnchor)
+              (pcaAnchor <$> mAnchor)
           description = Just @TextEnvelopeDescr "DRep Key Registration Certificate"
 
       firstExceptT RegistrationWriteFileError
@@ -157,18 +157,18 @@ runGovernanceDRepUpdateCertificateCmd
   Cmd.GovernanceDRepUpdateCertificateCmdArgs
     { eon = w
     , drepHashSource
-    , mPotentiallyCheckedAnchor
+    , mAnchor
     , outFile
     } =
     conwayEraOnwardsConstraints w $ do
       mapM_
-        (carryHashChecks GovernanceCmdFetchURLError GovernanceCmdMismatchedDRepMetadataHashError)
-        mPotentiallyCheckedAnchor
+        (withExceptT GovernanceDRepHashCheckError . carryHashChecks)
+        mAnchor
       drepCredential <- modifyError GovernanceCmdKeyReadError $ readDRepCredential drepHashSource
       let updateCertificate =
             makeDrepUpdateCertificate
               (DRepUpdateRequirements w drepCredential)
-              (pcaAnchor <$> mPotentiallyCheckedAnchor)
+              (pcaAnchor <$> mAnchor)
       firstExceptT GovernanceCmdTextEnvWriteError . newExceptT $
         writeFileTextEnvelope outFile (Just "DRep Update Certificate") updateCertificate
 
@@ -192,24 +192,21 @@ runGovernanceDRepMetadataHashCmd
 -- | 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)
+  :: PotentiallyCheckedAnchor DRepMetadataUrl
   -- ^ 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 ()
+  -> 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

@@ -93,6 +93,7 @@ module Cardano.CLI.Types.Common
 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
@@ -652,9 +653,9 @@ data MustCheckHash a
   | TrustHash
   deriving (Eq, Show)
 
-data PotentiallyCheckedAnchor anchorType anchor
+data PotentiallyCheckedAnchor anchorType
   = PotentiallyCheckedAnchor
-  { pcaAnchor :: anchor
+  { 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)

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

@@ -5,12 +5,11 @@
 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.HashCmdError (HashCheckError)
 import           Cardano.CLI.Types.Errors.StakeAddressCmdError
 
 import           Control.Exception (displayException)
@@ -56,10 +55,7 @@ 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
+  | GovernanceDRepHashCheckError HashCheckError
   deriving Show
 
 instance Error GovernanceCmdError where
@@ -121,13 +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."
-    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)
+    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

@@ -8,7 +8,7 @@ where
 import           Cardano.Api
 import qualified Cardano.Api.Ledger as L
 
-import           Cardano.CLI.Types.Errors.HashCmdError (FetchURLError)
+import           Cardano.CLI.Types.Errors.HashCmdError (FetchURLError, HashCheckError)
 import           Cardano.CLI.Types.Errors.StakeAddressRegistrationError
 import           Cardano.CLI.Types.Errors.StakeCredentialError
 
@@ -21,8 +21,11 @@ data RegistrationError
   | 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
@@ -43,3 +46,5 @@ instance Error RegistrationError where
           <+> 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)