Allow and add warning in comment for HTTP anchor-data

cardano-cli/cardano-cli.cabal

@@ -220,6 +220,7 @@ library
     cryptonite,
     deepseq,
     directory,
+    errors,
     exceptions,
     filepath,
     formatting,

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

@@ -21,7 +21,7 @@ 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.Run.Hash (getByteStringFromURL, httpsAndIpfsSchemes)
 import           Cardano.CLI.Types.Common
 import           Cardano.CLI.Types.Errors.GovernanceActionsError
 import           Cardano.CLI.Types.Errors.HashCmdError (FetchURLError)
@@ -526,7 +526,7 @@ carryHashChecks checkHash anchor checkType =
         L.AnchorData
           <$> fetchURLErrorToGovernanceActionError
             checkType
-            (getByteStringFromURL httpsAndIpfsSchemas $ L.urlToText $ L.anchorUrl anchor)
+            (getByteStringFromURL httpsAndIpfsSchemes $ L.urlToText $ L.anchorUrl anchor)
       let hash = L.hashAnchorData anchorData
       when (hash /= L.anchorDataHash anchor) $
         left $

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

@@ -20,7 +20,7 @@ import qualified Cardano.Api.Ledger as L
 
 import qualified Cardano.CLI.Commands.Hash as Cmd
 import qualified Cardano.CLI.EraBased.Commands.Governance.DRep as Cmd
-import           Cardano.CLI.Run.Hash (allSchemas, carryHashChecks, getByteStringFromURL)
+import           Cardano.CLI.Run.Hash (allSchemes, carryHashChecks, getByteStringFromURL)
 import qualified Cardano.CLI.Run.Key as Key
 import           Cardano.CLI.Types.Common
 import           Cardano.CLI.Types.Errors.CmdError
@@ -187,7 +187,7 @@ runGovernanceDRepMetadataHashCmd
       Cmd.DrepMetadataFileIn metadataFile ->
         firstExceptT ReadFileError . newExceptT $ readByteStringFile metadataFile
       Cmd.DrepMetadataURL urlText ->
-        fetchURLToGovernanceCmdError $ getByteStringFromURL allSchemas $ L.urlToText urlText
+        fetchURLToGovernanceCmdError $ getByteStringFromURL allSchemes $ L.urlToText urlText
     let (_metadata, metadataHash) = hashDRepMetadata metadataBytes
     case hashGoal of
       Cmd.CheckHash expectedHash

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

@@ -20,7 +20,7 @@ import           Cardano.Api.Shelley
 import qualified Cardano.CLI.Commands.Hash as Cmd
 import           Cardano.CLI.EraBased.Commands.StakePool
 import qualified Cardano.CLI.EraBased.Commands.StakePool as Cmd
-import           Cardano.CLI.Run.Hash (allSchemas, getByteStringFromURL, httpsAndIpfsSchemas)
+import           Cardano.CLI.Run.Hash (allSchemes, getByteStringFromURL, httpsAndIpfsSchemes)
 import           Cardano.CLI.Types.Common
 import           Cardano.CLI.Types.Errors.HashCmdError (FetchURLError (..))
 import           Cardano.CLI.Types.Errors.StakePoolCmdError
@@ -235,7 +235,7 @@ runStakePoolMetadataHashCmd
             . newExceptT
             $ readByteStringFile poolMetadataFile
         StakePoolMetadataURL urlText ->
-          fetchURLToStakePoolCmdError $ getByteStringFromURL allSchemas $ L.urlToText urlText
+          fetchURLToStakePoolCmdError $ getByteStringFromURL allSchemes $ L.urlToText urlText
 
     (_metadata, metadataHash) <-
       firstExceptT StakePoolCmdMetadataValidationError
@@ -275,7 +275,7 @@ carryHashChecks potentiallyCheckedAnchor =
       metadataBytes <-
         withExceptT
           StakePoolCmdFetchURLError
-          (getByteStringFromURL httpsAndIpfsSchemas urlText)
+          (getByteStringFromURL httpsAndIpfsSchemes urlText)
 
       let expectedHash = stakePoolMetadataHash anchor
 

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

@@ -9,9 +9,8 @@
 module Cardano.CLI.Run.Hash
   ( runHashCmds
   , getByteStringFromURL
-  , SupportedSchemas (..)
-  , allSchemas
-  , httpsAndIpfsSchemas
+  , allSchemes
+  , httpsAndIpfsSchemes
   , carryHashChecks
   )
 where
@@ -25,6 +24,7 @@ import           Cardano.CLI.Types.Common (MustCheckHash (..), PotentiallyChecke
 import           Cardano.CLI.Types.Errors.HashCmdError
 import           Cardano.Crypto.Hash (hashToTextAsHex)
 
+import           Control.Error ((??))
 import           Control.Exception (throw)
 import           Control.Monad (when)
 import           Control.Monad.Catch (Exception, Handler (Handler))
@@ -71,7 +71,7 @@ runHashAnchorDataCmd Cmd.HashAnchorDataCmdArgs{toHash, hashGoal} = do
         return $ Text.encodeUtf8 text
       Cmd.AnchorDataHashSourceText text -> return $ Text.encodeUtf8 text
       Cmd.AnchorDataHashSourceURL urlText ->
-        fetchURLToHashCmdError $ getByteStringFromURL allSchemas $ L.urlToText urlText
+        fetchURLToHashCmdError $ getByteStringFromURL allSchemes $ L.urlToText urlText
   let hash = L.hashAnchorData anchorData
   case hashGoal of
     Cmd.CheckHash expectedHash
@@ -94,30 +94,56 @@ runHashAnchorDataCmd Cmd.HashAnchorDataCmdArgs{toHash, hashGoal} = do
     :: ExceptT FetchURLError IO BS8.ByteString -> ExceptT HashCmdError IO BS8.ByteString
   fetchURLToHashCmdError = withExceptT HashFetchURLError
 
-data SupportedSchemas = FileSchema | HttpSchema | HttpsSchema | IpfsSchema
-  deriving (Show, Eq)
-
-allSchemas :: [SupportedSchemas]
-allSchemas = [FileSchema, HttpSchema, HttpsSchema, IpfsSchema]
+-- | Specifies the schemes that are allowed to fetch anchor data.
+type SupportedSchemes = [AnchorScheme]
 
-httpsAndIpfsSchemas :: [SupportedSchemas]
-httpsAndIpfsSchemas = [HttpsSchema, IpfsSchema]
+-- | The different schemes that can be used to fetch anchor data.
+data AnchorScheme = FileScheme | HttpScheme | HttpsScheme | IpfsScheme
+  deriving (Show, Eq)
 
-getByteStringFromURL :: [SupportedSchemas] -> Text -> ExceptT FetchURLError IO BS.ByteString
-getByteStringFromURL supportedSchemas urlText = do
+-- | All the supported schemes are allowed.
+allSchemes :: SupportedSchemes
+allSchemes = [FileScheme, HttpScheme, HttpsScheme, IpfsScheme]
+
+-- | Only HTTPS and IPFS schemes are allowed. We also allow HTTP for testing purposes
+-- but it is discouraged, because it can lead to security vulnerabilities.
+-- For example: If a user checks the anchor-data through a web browser and through the
+-- `cardano-cli` independently, one of them could easily get spoofed, and the user would
+-- not notice that the anchor-data being verified in the browser is not the same.
+httpsAndIpfsSchemes :: SupportedSchemes
+httpsAndIpfsSchemes =
+  [ HttpScheme -- Insecure, only for testing purposes
+  , HttpsScheme
+  , IpfsScheme
+  ]
+
+-- | Converts a string to an 'AnchorScheme' if it is a valid scheme, otherwise returns 'Nothing'.
+stringToScheme :: String -> Maybe AnchorScheme
+stringToScheme "file:" = Just FileScheme
+stringToScheme "http:" = Just HttpScheme
+stringToScheme "https:" = Just HttpsScheme
+stringToScheme "ipfs:" = Just IpfsScheme
+stringToScheme _ = Nothing
+
+-- | Fetches the content of a URL as a 'ByteString'.
+-- The URL must be an absolute URL. The supported schemes are specified in the 'SupportedSchemes' argument.
+-- If the scheme is not supported, an error is thrown.
+getByteStringFromURL :: SupportedSchemes -> Text -> ExceptT FetchURLError IO BS.ByteString
+getByteStringFromURL supportedSchemes urlText = do
   let urlString = Text.unpack 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
+  uri@URI{uriScheme} <- hoistMaybe (FetchURLInvalidURLError urlString) $ parseAbsoluteURI urlString
+  scheme <-
+    filterMaybe (`elem` supportedSchemes) (stringToScheme $ map toLower uriScheme)
+      ?? FetchURLUnsupportedURLSchemeError uriScheme
+  case scheme of
+    FileScheme ->
+      let path = uriPathToFilePath (pathSegments uri)
+       in handleIOExceptT (FetchURLReadFileError path) $ BS.readFile path
+    HttpScheme -> getFileFromHttp uri
+    HttpsScheme -> getFileFromHttp uri
+    IpfsScheme -> do
       httpUri <- convertToHttp uri
       getFileFromHttp httpUri
-    unsupportedScheme -> left $ FetchURLUnsupportedURLSchemeError unsupportedScheme
  where
   uriPathToFilePath :: [String] -> FilePath
   uriPathToFilePath allPath@(letter : path) =
@@ -140,6 +166,12 @@ getByteStringFromURL supportedSchemas urlText = do
             (BS8.unpack (statusMessage status) ++ ": " ++ BSL8.unpack (responseBody response))
       else return $ BS.concat . BSL.toChunks $ responseBody response
 
+  filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a
+  filterMaybe _ Nothing = Nothing
+  filterMaybe f input@(Just x)
+    | f x = input
+    | otherwise = Nothing
+
   handlers :: [Handler IO FetchURLError]
   handlers =
     [ mkHandler id
@@ -196,7 +228,7 @@ carryHashChecks potentiallyCheckedAnchor =
         L.AnchorData
           <$> withExceptT
             FetchURLError
-            (getByteStringFromURL httpsAndIpfsSchemas $ L.urlToText $ L.anchorUrl anchor)
+            (getByteStringFromURL httpsAndIpfsSchemes $ L.urlToText $ L.anchorUrl anchor)
       let hash = L.hashAnchorData anchorData
       when (hash /= L.anchorDataHash anchor) $
         left $

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

@@ -63,7 +63,7 @@ instance Exception FetchURLError where
   displayException (FetchURLUnsupportedURLSchemeError text) = "Unsupported URL scheme: " <> text
   displayException (FetchURLReadEnvVarError exc) = "Cannot read environment variable: " <> displayException exc
   displayException (FetchURLGetFileFromHttpError err) = displayException err
-  displayException FetchURLIpfsGatewayNotSetError = "IPFS schema requires IPFS_GATEWAY_URI environment variable to be set."
+  displayException FetchURLIpfsGatewayNotSetError = "IPFS scheme requires IPFS_GATEWAY_URI environment variable to be set."
 
 data HttpRequestError
   = BadStatusCodeHRE !Int !String