Move stringToScheme to Parsers.hs

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

@@ -275,7 +275,10 @@ carryHashChecks potentiallyCheckedAnchor =
       metadataBytes <-
         withExceptT
           StakePoolCmdFetchURLError
-          (getByteStringFromURL httpsAndIpfsSchemes 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,20 +9,23 @@
 module Cardano.CLI.Run.Hash
   ( runHashCmds
   , getByteStringFromURL
+  , carryHashChecks
   , allSchemes
   , httpsAndIpfsSchemes
-  , carryHashChecks
   )
 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)
@@ -31,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)
@@ -93,13 +95,6 @@ runHashAnchorDataCmd Cmd.HashAnchorDataCmdArgs{toHash, hashGoal} = do
     :: ExceptT FetchURLError IO BS8.ByteString -> ExceptT HashCmdError IO BS8.ByteString
   fetchURLToHashCmdError = withExceptT HashFetchURLError
 
--- | 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)
-
 -- | All the supported schemes are allowed.
 allSchemes :: SupportedSchemes
 allSchemes = [FileScheme, HttpScheme, HttpsScheme, IpfsScheme]
@@ -116,14 +111,6 @@ httpsAndIpfsSchemes =
   , 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.
@@ -132,7 +119,9 @@ getByteStringFromURL supportedSchemes urlText = do
   let urlString = Text.unpack urlText
   uri@URI{uriScheme} <- hoistMaybe (FetchURLInvalidURLError urlString) $ parseAbsoluteURI urlString
   scheme <-
-    hoistMaybe (FetchURLUnsupportedURLSchemeError uriScheme) $ filterMaybe (`elem` supportedSchemes) (stringToScheme $ map toLower uriScheme)
+    hoistEither $
+      first FetchURLUnsupportedURLSchemeError $
+        stringToAnchorScheme supportedSchemes uriScheme
   case scheme of
     FileScheme ->
       let path = uriPathToFilePath (pathSegments uri)
@@ -164,12 +153,6 @@ getByteStringFromURL supportedSchemes 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

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

@@ -9,6 +9,7 @@
 module Cardano.CLI.Types.Common
   ( AllOrOnly (..)
   , AddressKeyType (..)
+  , AnchorScheme (..)
   , BalanceTxExecUnits (..)
   , BlockId (..)
   , ByronKeyFormat (..)
@@ -64,6 +65,7 @@ module Cardano.CLI.Types.Common
   , SomeKeyFile (..)
   , StakeDelegators (..)
   , StakePoolMetadataFile
+  , SupportedSchemes
   , TransferDirection (..)
   , TxBodyFile
   , TxBuildOutputOptions (..)
@@ -135,6 +137,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