Merge pull request #979 from IntersectMBO/allow-http-anchor-data-but-…

…warn

Allow and add warning for HTTP anchor-data

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

@@ -22,7 +22,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)
@@ -534,7 +534,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,10 @@ carryHashChecks potentiallyCheckedAnchor =
       metadataBytes <-
         withExceptT
           StakePoolCmdFetchURLError
-          (getByteStringFromURL httpsAndIpfsSchemas urlText)
+          ( getByteStringFromURL
+              httpsAndIpfsSchemes
+              urlText
+          )
 
       let expectedHash = stakePoolMetadataHash anchor
 

cardano-cli/src/Cardano/CLI/Parser.hs

@@ -14,6 +14,7 @@ module Cardano.CLI.Parser
   , readURIOfMaxLength
   , subParser
   , eDNSName
+  , stringToAnchorScheme
   )
 where
 
@@ -24,6 +25,7 @@ import           Cardano.CLI.Types.Common
 import qualified Data.Attoparsec.ByteString.Char8 as Atto
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as BSC
+import           Data.Char (toLower)
 import           Data.Foldable
 import           Data.Ratio ((%))
 import           Data.Text (Text)
@@ -125,6 +127,21 @@ subParser :: String -> Opt.ParserInfo a -> Opt.Parser a
 subParser availableCommand pInfo =
   Opt.hsubparser $ Opt.command availableCommand pInfo <> Opt.metavar availableCommand
 
+-- | Converts a string to an 'AnchorScheme' if it is a valid scheme and is in the
+-- 'SupportedScheme' list, otherwise it returns 'Left'.
+stringToAnchorScheme :: SupportedSchemes -> String -> Either String AnchorScheme
+stringToAnchorScheme supportedSchemes schemaString = do
+  case convertToAnchorScheme $ map toLower schemaString of
+    Just scheme | scheme `elem` supportedSchemes -> pure scheme
+    _ -> Left $ "Unsupported URL scheme: " <> schemaString
+ where
+  convertToAnchorScheme :: String -> Maybe AnchorScheme
+  convertToAnchorScheme "file:" = Just FileScheme
+  convertToAnchorScheme "http:" = Just HttpScheme
+  convertToAnchorScheme "https:" = Just HttpsScheme
+  convertToAnchorScheme "ipfs:" = Just IpfsScheme
+  convertToAnchorScheme _ = Nothing
+
 eDNSName :: String -> Either String ByteString
 eDNSName str =
   -- We're using 'Shelley.textToDns' to validate the string.

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

@@ -9,21 +9,23 @@
 module Cardano.CLI.Run.Hash
   ( runHashCmds
   , getByteStringFromURL
-  , SupportedSchemas (..)
-  , allSchemas
-  , httpsAndIpfsSchemas
   , carryHashChecks
+  , allSchemes
+  , httpsAndIpfsSchemes
   )
 where
 
 import           Cardano.Api
 import qualified Cardano.Api.Ledger as L
 
 import qualified Cardano.CLI.Commands.Hash as Cmd
+import           Cardano.CLI.Parser (stringToAnchorScheme)
 import           Cardano.CLI.Read
-import           Cardano.CLI.Types.Common (MustCheckHash (..), PotentiallyCheckedAnchor (..))
+import           Cardano.CLI.Types.Common (AnchorScheme (..), MustCheckHash (..),
+                   PotentiallyCheckedAnchor (..), SupportedSchemes)
 import           Cardano.CLI.Types.Errors.HashCmdError
 import           Cardano.Crypto.Hash (hashToTextAsHex)
+import           Cardano.Prelude (first)
 
 import           Control.Exception (throw)
 import           Control.Monad (when)
@@ -32,7 +34,6 @@ 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)
 import           Data.Text (Text)
@@ -71,7 +72,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 +95,42 @@ 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]
-
-httpsAndIpfsSchemas :: [SupportedSchemas]
-httpsAndIpfsSchemas = [HttpsSchema, IpfsSchema]
-
-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
+  ]
+
+-- | 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 <-
+    hoistEither $
+      first FetchURLUnsupportedURLSchemeError $
+        stringToAnchorScheme supportedSchemes 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) =
@@ -196,7 +209,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/Common.hs

@@ -9,6 +9,7 @@
 module Cardano.CLI.Types.Common
   ( AllOrOnly (..)
   , AddressKeyType (..)
+  , AnchorScheme (..)
   , AnyPlutusScriptVersion (..)
   , BalanceTxExecUnits (..)
   , BlockId (..)
@@ -65,6 +66,7 @@ module Cardano.CLI.Types.Common
   , SomeKeyFile (..)
   , StakeDelegators (..)
   , StakePoolMetadataFile
+  , SupportedSchemes
   , TransferDirection (..)
   , TxBodyFile
   , TxBuildOutputOptions (..)
@@ -136,6 +138,13 @@ newtype ProposalUrl = ProposalUrl
   }
   deriving (Eq, Show)
 
+-- | Specifies the schemes that are allowed to fetch anchor data.
+type SupportedSchemes = [AnchorScheme]
+
+-- | The different schemes that can be used to fetch anchor data.
+data AnchorScheme = FileScheme | HttpScheme | HttpsScheme | IpfsScheme
+  deriving (Show, Eq)
+
 -- | Tag for tracking proposals submitted as 'Bytestring'
 data ProposalBinary
 

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