Parametrise getByteStringFromURL for reusability

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

@@ -8,6 +8,7 @@
 
 module Cardano.CLI.Run.Hash
   ( runHashCmds
+  , getByteStringFromURL
   )
 where
 
@@ -63,7 +64,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 urlText
   let hash = L.hashAnchorData anchorData
   case hashGoal of
     CheckHash expectedHash
@@ -82,66 +83,70 @@ 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
+
+getByteStringFromURL :: L.Url -> ExceptT FetchURLError IO BS.ByteString
+getByteStringFromURL urlText = do
+  let urlString = Text.unpack $ L.urlToText urlText
+  uri <- hoistMaybe (FetchURLInvalidURLError urlString) $ parseAbsoluteURI urlString
+  case map toLower $ uriScheme uri of
+    "file:" ->
+      let path = uriPathToFilePath (pathSegments uri)
+       in handleIOExceptT (FetchURLReadFileError path) $ BS.readFile path
+    "http:" -> getFileFromHttp uri
+    "https:" -> getFileFromHttp uri
+    "ipfs:" -> 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 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
+  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)
+      else return $ BS.concat . BSL.toChunks $ responseBody response
 
-    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
+  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/Errors/HashCmdError.hs

@@ -4,6 +4,7 @@
 module Cardano.CLI.Types.Errors.HashCmdError
   ( HashCmdError (..)
   , HttpRequestError (..)
+  , FetchURLError (..)
   )
 where
 
@@ -25,11 +26,7 @@ data HashCmdError
   | HashReadFileError !FilePath !IOException
   | HashWriteFileError !(FileError ())
   | HashReadScriptError !FilePath !(FileError ScriptDecodeError)
-  | HashInvalidURLError !String
-  | HashReadEnvVarError !IOException
-  | HashIpfsGatewayNotSetError
-  | HashUnsupportedURLSchemeError !String
-  | HashGetFileFromHttpError !HttpRequestError
+  | HashFetchURLError !FetchURLError
   deriving Show
 
 instance Error HashCmdError where
@@ -46,11 +43,27 @@ instance Error HashCmdError where
       prettyError fileErr
     HashReadScriptError filepath err ->
       "Cannot read script at " <> pretty filepath <> ": " <> prettyError err
-    HashInvalidURLError text -> "Cannot parse URI: " <> pretty text
-    HashUnsupportedURLSchemeError text -> "Unsupported URL scheme: " <> pretty text
-    HashReadEnvVarError exc -> "Cannot read environment variable: " <> pretty (displayException exc)
-    HashIpfsGatewayNotSetError -> "IPFS schema requires IPFS_GATEWAY_URI environment variable to be set."
-    HashGetFileFromHttpError err -> pretty $ displayException err
+    HashFetchURLError fetchErr ->
+      pretty (displayException fetchErr)
+
+data FetchURLError
+  = FetchURLInvalidURLError !String
+  | FetchURLReadFileError !FilePath !IOException
+  | FetchURLUnsupportedURLSchemeError !String
+  | FetchURLReadEnvVarError !IOException
+  | FetchURLGetFileFromHttpError !HttpRequestError
+  | FetchURLIpfsGatewayNotSetError
+  deriving Show
+
+instance Exception FetchURLError where
+  displayException :: FetchURLError -> String
+  displayException (FetchURLInvalidURLError text) = "Cannot parse URI: " <> text
+  displayException (FetchURLReadFileError filepath exc) =
+    "Cannot read " <> filepath <> ": " <> displayException exc
+  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."
 
 data HttpRequestError
   = BadStatusCodeHRE !Int !String