Merge branch 'main' into cl/helptext

.gitattributes

@@ -1 +1,2 @@
+cardano-cli/test/cardano-cli-golden/files/input/example_anchor_data.txt -text
 cardano-cli/test/cardano-cli-test/files/input/example_anchor_data.txt -text

cardano-cli/cardano-cli.cabal

@@ -289,6 +289,7 @@ library cardano-cli-test-lib
   hs-source-dirs: test/cardano-cli-test-lib
   exposed-modules:
     Test.Cardano.CLI.Aeson
+    Test.Cardano.CLI.Hash
     Test.Cardano.CLI.Util
 
   build-depends:
@@ -303,12 +304,17 @@ library cardano-cli-test-lib
     filepath,
     hedgehog,
     hedgehog-extras ^>=0.6.1.0,
+    http-types,
     lifted-base,
     monad-control,
+    network,
     process,
     text,
     transformers-base,
+    utf8-string,
     vector,
+    wai,
+    warp,
 
 test-suite cardano-cli-test
   import: project-config
@@ -331,24 +337,18 @@ test-suite cardano-cli-test
     filepath,
     hedgehog,
     hedgehog-extras ^>=0.6.1.0,
-    http-types,
-    lifted-base,
-    monad-control,
-    network,
     parsec,
     regex-tdfa,
     tasty,
     tasty-hedgehog,
     text,
     time,
     transformers,
-    utf8-string,
-    wai,
-    warp,
 
   build-tool-depends: tasty-discover:tasty-discover
   other-modules:
     Test.Cli.AddCostModels
+    Test.Cli.CreateCardano
     Test.Cli.CreateTestnetData
     Test.Cli.FilePermissions
     Test.Cli.Governance.DRep
@@ -398,10 +398,12 @@ test-suite cardano-cli-golden
     cborg,
     containers,
     directory,
+    exceptions,
     extra,
     filepath,
     hedgehog ^>=1.4,
     hedgehog-extras ^>=0.6.1.0,
+    monad-control,
     regex-compat,
     regex-tdfa,
     tasty,

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

@@ -84,6 +84,7 @@ data GovernanceActionInfoCmdArgs era
   , returnStakeAddress :: !StakeIdentifier
   , proposalUrl :: !ProposalUrl
   , proposalHash :: !(L.SafeHash L.StandardCrypto L.AnchorData)
+  , checkProposalHash :: !(MustCheckHash ProposalUrl)
   , outFile :: !(File () Out)
   }
   deriving Show

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

@@ -74,9 +74,26 @@ pGovernanceActionNewInfoCmd era = do
             <*> pStakeIdentifier (Just "deposit-return")
             <*> pAnchorUrl
             <*> pAnchorDataHash
+            <*> pMustCheckProposalHash
             <*> pFileOutDirection "out-file" "Path to action file to be used later on with build or build-raw "
       )
     $ Opt.progDesc "Create an info action."
+ where
+  pMustCheckProposalHash :: Parser (MustCheckHash ProposalUrl)
+  pMustCheckProposalHash =
+    asum
+      [ Opt.flag' CheckHash $
+          mconcat
+            [ Opt.long "check-anchor-data"
+            , Opt.help
+                "Check the proposal hash (from --anchor-data-hash) by downloading anchor data (from --anchor-url)."
+            ]
+      , Opt.flag' TrustHash $
+          mconcat
+            [ Opt.long "trust-anchor-data"
+            , Opt.help "Do not check the proposal hash (from --anchor-data-hash) and trust it is correct."
+            ]
+      ]
 
 pGovernanceActionNewConstitutionCmd
   :: CardanoEra era

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

@@ -21,8 +21,10 @@ import           Cardano.CLI.EraBased.Commands.Governance.Actions
 import qualified Cardano.CLI.EraBased.Commands.Governance.Actions as Cmd
 import           Cardano.CLI.Json.Friendly
 import           Cardano.CLI.Read
+import           Cardano.CLI.Run.Hash (getByteStringFromURL, httpsAndIpfsSchemas)
 import           Cardano.CLI.Types.Common
 import           Cardano.CLI.Types.Errors.GovernanceActionsError
+import           Cardano.CLI.Types.Errors.HashCmdError (FetchURLError)
 import           Cardano.CLI.Types.Key
 
 import           Control.Monad
@@ -86,6 +88,7 @@ runGovernanceActionInfoCmd
     , Cmd.returnStakeAddress
     , Cmd.proposalUrl
     , Cmd.proposalHash
+    , Cmd.checkProposalHash
     , Cmd.outFile
     } = do
     depositStakeCredential <-
@@ -98,13 +101,30 @@ runGovernanceActionInfoCmd
             , L.anchorDataHash = proposalHash
             }
 
+    case checkProposalHash of
+      CheckHash -> do
+        anchorData <-
+          L.AnchorData
+            <$> fetchURLErrorToGovernanceActionError
+              ProposalCheck
+              (getByteStringFromURL httpsAndIpfsSchemas $ L.anchorUrl proposalAnchor)
+        let hash = L.hashAnchorData anchorData
+        when (hash /= L.anchorDataHash proposalAnchor) $
+          left $
+            GovernanceActionsProposalMismatchedHashError ProposalCheck proposalHash hash
+      TrustHash -> pure ()
+
     let sbe = conwayEraOnwardsToShelleyBasedEra eon
         govAction = InfoAct
         proposalProcedure = createProposalProcedure sbe networkId deposit depositStakeCredential govAction proposalAnchor
 
     firstExceptT GovernanceActionsCmdWriteFileError . newExceptT $
       conwayEraOnwardsConstraints eon $
         writeFileTextEnvelope outFile (Just "Info proposal") proposalProcedure
+   where
+    fetchURLErrorToGovernanceActionError
+      :: AnchorDataTypeCheck -> ExceptT FetchURLError IO a -> ExceptT GovernanceActionsError IO a
+    fetchURLErrorToGovernanceActionError adt = withExceptT (GovernanceActionsProposalFetchURLError adt)
 
 -- TODO: Conway era - update with new ledger types from cardano-ledger-conway-1.7.0.0
 runGovernanceActionCreateNoConfidenceCmd

cardano-cli/src/Cardano/CLI/Run/Hash.hs

@@ -8,6 +8,10 @@
 
 module Cardano.CLI.Run.Hash
   ( runHashCmds
+  , getByteStringFromURL
+  , SupportedSchemas (..)
+  , allSchemas
+  , httpsAndIpfsSchemas
   )
 where
 
@@ -25,6 +29,7 @@ import           Control.Monad.Catch (Exception, Handler (Handler))
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as BS8
 import qualified Data.ByteString.Lazy as BSL
+import qualified Data.ByteString.Lazy.Char8 as BSL8
 import           Data.Char (toLower)
 import           Data.Function
 import           Data.List (intercalate)
@@ -63,7 +68,7 @@ runHashAnchorDataCmd Cmd.HashAnchorDataCmdArgs{toHash, hashGoal} = do
         return $ Text.encodeUtf8 text
       Cmd.AnchorDataHashSourceText text -> return $ Text.encodeUtf8 text
       Cmd.AnchorDataHashSourceURL urlText ->
-        getByteStringFromURL urlText
+        fetchURLToHashCmdError $ getByteStringFromURL allSchemas urlText
   let hash = L.hashAnchorData anchorData
   case hashGoal of
     CheckHash expectedHash
@@ -82,66 +87,84 @@ runHashAnchorDataCmd Cmd.HashAnchorDataCmdArgs{toHash, hashGoal} = do
    where
     text = hashToTextAsHex . L.extractHash $ hash
 
-  getByteStringFromURL :: L.Url -> ExceptT HashCmdError IO BS.ByteString
-  getByteStringFromURL urlText = do
-    let urlString = Text.unpack $ L.urlToText urlText
-    uri <- hoistMaybe (HashInvalidURLError urlString) $ parseAbsoluteURI urlString
-    case map toLower $ uriScheme uri of
-      "file:" ->
-        let path = uriPathToFilePath (pathSegments uri)
-         in handleIOExceptT (HashReadFileError path) $ BS.readFile path
-      "http:" -> getFileFromHttp uri
-      "https:" -> getFileFromHttp uri
-      "ipfs:" -> do
-        httpUri <- convertToHttp uri
-        getFileFromHttp httpUri
-      unsupportedScheme -> left $ HashUnsupportedURLSchemeError unsupportedScheme
-   where
-    uriPathToFilePath :: [String] -> FilePath
-    uriPathToFilePath allPath@(letter : path) =
-      if isDrive letter
-        then foldl (</>) letter path
-        else foldl (</>) "/" allPath
-    uriPathToFilePath [] = "/"
+  fetchURLToHashCmdError
+    :: ExceptT FetchURLError IO BS8.ByteString -> ExceptT HashCmdError IO BS8.ByteString
+  fetchURLToHashCmdError = withExceptT HashFetchURLError
+
+data SupportedSchemas = FileSchema | HttpSchema | HttpsSchema | IpfsSchema
+  deriving (Show, Eq)
 
-    getFileFromHttp :: URI -> ExceptT HashCmdError IO BS.ByteString
-    getFileFromHttp uri = handlesExceptT handlers $ liftIO $ do
-      request <- requestFromURI uri
-      manager <- newManager tlsManagerSettings
-      response <- httpLbs request manager
-      let status = responseStatus response
-      if statusCode status /= 200
-        then throw $ BadStatusCodeHRE (statusCode status) (BS8.unpack $ statusMessage status)
-        else return $ BS.concat . BSL.toChunks $ responseBody response
+allSchemas :: [SupportedSchemas]
+allSchemas = [FileSchema, HttpSchema, HttpsSchema, IpfsSchema]
 
-    handlers :: [Handler IO HashCmdError]
-    handlers =
-      [ mkHandler id
-      , mkHandler HttpExceptionHRE
-      , mkHandler IOExceptionHRE
-      ]
-     where
-      mkHandler :: (Monad m, Exception e) => (e -> HttpRequestError) -> Handler m HashCmdError
-      mkHandler x = Handler $ return . HashGetFileFromHttpError . x
+httpsAndIpfsSchemas :: [SupportedSchemas]
+httpsAndIpfsSchemas = [HttpsSchema, IpfsSchema]
+
+getByteStringFromURL :: [SupportedSchemas] -> L.Url -> ExceptT FetchURLError IO BS.ByteString
+getByteStringFromURL supportedSchemas urlText = do
+  let urlString = Text.unpack $ L.urlToText urlText
+  uri <- hoistMaybe (FetchURLInvalidURLError urlString) $ parseAbsoluteURI urlString
+  case map toLower $ uriScheme uri of
+    "file:"
+      | FileSchema `elem` supportedSchemas ->
+          let path = uriPathToFilePath (pathSegments uri)
+           in handleIOExceptT (FetchURLReadFileError path) $ BS.readFile path
+    "http:" | HttpSchema `elem` supportedSchemas -> getFileFromHttp uri
+    "https:" | HttpsSchema `elem` supportedSchemas -> getFileFromHttp uri
+    "ipfs:" | IpfsSchema `elem` supportedSchemas -> do
+      httpUri <- convertToHttp uri
+      getFileFromHttp httpUri
+    unsupportedScheme -> left $ FetchURLUnsupportedURLSchemeError unsupportedScheme
+ where
+  uriPathToFilePath :: [String] -> FilePath
+  uriPathToFilePath allPath@(letter : path) =
+    if isDrive letter
+      then foldl (</>) letter path
+      else foldl (</>) "/" allPath
+  uriPathToFilePath [] = "/"
+
+  getFileFromHttp :: URI -> ExceptT FetchURLError IO BS.ByteString
+  getFileFromHttp uri = handlesExceptT handlers $ liftIO $ do
+    request <- requestFromURI uri
+    manager <- newManager tlsManagerSettings
+    response <- httpLbs request manager
+    let status = responseStatus response
+    if statusCode status /= 200
+      then
+        throw $
+          BadStatusCodeHRE
+            (statusCode status)
+            (BS8.unpack (statusMessage status) ++ ": " ++ BSL8.unpack (responseBody response))
+      else return $ BS.concat . BSL.toChunks $ responseBody response
+
+  handlers :: [Handler IO FetchURLError]
+  handlers =
+    [ mkHandler id
+    , mkHandler HttpExceptionHRE
+    , mkHandler IOExceptionHRE
+    ]
+   where
+    mkHandler :: (Monad m, Exception e) => (e -> HttpRequestError) -> Handler m FetchURLError
+    mkHandler x = Handler $ return . FetchURLGetFileFromHttpError . x
 
-convertToHttp :: URI -> ExceptT HashCmdError IO URI
-convertToHttp ipfsUri = do
-  mIpfsGatewayUriString <- handleIOExceptT HashReadEnvVarError $ IO.lookupEnv "IPFS_GATEWAY_URI"
-  ipfsGatewayUriString <- hoistMaybe HashIpfsGatewayNotSetError mIpfsGatewayUriString
-  ipfsGatewayUri <-
-    hoistMaybe (HashInvalidURLError ipfsGatewayUriString) $ parseAbsoluteURI ipfsGatewayUriString
-  return $
-    ipfsGatewayUri
-      { uriPath =
-          '/'
-            : intercalate
-              "/"
-              ( pathSegments ipfsGatewayUri
-                  ++ ["ipfs"]
-                  ++ maybe [] (\ipfsAuthority -> [uriRegName ipfsAuthority]) (uriAuthority ipfsUri)
-                  ++ pathSegments ipfsUri
-              )
-      }
+  convertToHttp :: URI -> ExceptT FetchURLError IO URI
+  convertToHttp ipfsUri = do
+    mIpfsGatewayUriString <- handleIOExceptT FetchURLReadEnvVarError $ IO.lookupEnv "IPFS_GATEWAY_URI"
+    ipfsGatewayUriString <- hoistMaybe FetchURLIpfsGatewayNotSetError mIpfsGatewayUriString
+    ipfsGatewayUri <-
+      hoistMaybe (FetchURLInvalidURLError ipfsGatewayUriString) $ parseAbsoluteURI ipfsGatewayUriString
+    return $
+      ipfsGatewayUri
+        { uriPath =
+            '/'
+              : intercalate
+                "/"
+                ( pathSegments ipfsGatewayUri
+                    ++ ["ipfs"]
+                    ++ maybe [] (\ipfsAuthority -> [uriRegName ipfsAuthority]) (uriAuthority ipfsUri)
+                    ++ pathSegments ipfsUri
+                )
+        }
 
 runHashScriptCmd
   :: ()

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

@@ -31,6 +31,7 @@ module Cardano.CLI.Types.Common
   , InputTxBodyOrTxFile (..)
   , KeyOutputFormat (..)
   , MetadataFile (..)
+  , MustCheckHash (..)
   , OpCertCounter
   , OpCertCounterFile
   , OpCertEndingKesPeriod (..)
@@ -639,3 +640,8 @@ data ParserFileDirection
   = Input
   | Output
   deriving (Eq, Show)
+
+data MustCheckHash a
+  = CheckHash
+  | TrustHash
+  deriving (Eq, Show)