Merge pull request #895 from IntersectMBO/add-hash-validation

Add hash validation and support for HTTP(S) and IPFS to command `hash anchor-data`

.gitattributes

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

cardano-cli/cardano-cli.cabal

@@ -235,13 +235,18 @@ library
     cryptonite,
     deepseq,
     directory,
+    exceptions,
     filepath,
     formatting,
+    http-client,
+    http-client-tls,
+    http-types,
     io-classes,
     iproute,
     microlens,
     mtl,
     network,
+    network-uri,
     optparse-applicative-fork,
     ouroboros-consensus ^>=0.20,
     ouroboros-consensus-cardano ^>=0.19,
@@ -321,17 +326,25 @@ test-suite cardano-cli-test
     cardano-ledger-alonzo,
     cardano-slotting,
     containers,
+    directory,
     exceptions,
     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:
@@ -340,6 +353,7 @@ test-suite cardano-cli-test
     Test.Cli.FilePermissions
     Test.Cli.Governance.DRep
     Test.Cli.Governance.Hash
+    Test.Cli.Hash
     Test.Cli.ITN
     Test.Cli.Json
     Test.Cli.MonadWarning

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

@@ -4,6 +4,7 @@
 
 module Cardano.CLI.Commands.Hash
   ( HashCmds (..)
+  , HashGoal (..)
   , HashAnchorDataCmdArgs (..)
   , HashScriptCmdArgs (..)
   , AnchorDataHashSource (..)
@@ -12,6 +13,7 @@ module Cardano.CLI.Commands.Hash
 where
 
 import           Cardano.Api
+import qualified Cardano.Api.Ledger as L
 
 import           Cardano.CLI.Types.Common
 
@@ -21,18 +23,27 @@ data HashCmds
   = HashAnchorDataCmd !HashAnchorDataCmdArgs
   | HashScriptCmd !HashScriptCmdArgs
 
+data HashGoal
+  = -- | The hash is written to stdout
+    HashToStdout
+  | -- | The hash to check against
+    CheckHash !(L.SafeHash L.StandardCrypto L.AnchorData)
+  | -- | The output file to which the hash is written
+    HashToFile !(File () Out)
+  deriving Show
+
 data HashAnchorDataCmdArgs
   = HashAnchorDataCmdArgs
   { toHash :: !AnchorDataHashSource
-  , mOutFile :: !(Maybe (File () Out))
-  -- ^ The output file to which the hash is written
+  , hashGoal :: !HashGoal
   }
   deriving Show
 
 data AnchorDataHashSource
   = AnchorDataHashSourceBinaryFile (File ProposalBinary In)
   | AnchorDataHashSourceTextFile (File ProposalText In)
   | AnchorDataHashSourceText Text
+  | AnchorDataHashSourceURL L.Url
   deriving Show
 
 data HashScriptCmdArgs

cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs

@@ -3618,6 +3618,19 @@ pAnchorUrl =
   ProposalUrl
     <$> pUrl "anchor-url" "Anchor URL"
 
+pExpectedHash :: Parser (L.SafeHash L.StandardCrypto L.AnchorData)
+pExpectedHash =
+  Opt.option readSafeHash $
+    mconcat
+      [ Opt.long "expected-hash"
+      , Opt.metavar "HASH"
+      , Opt.help $
+          mconcat
+            [ "Expected hash for the anchor data for verification purposes. "
+            , "If provided, the hash of the anchor data will be compared to this value."
+            ]
+      ]
+
 pAnchorDataHash :: Parser (L.SafeHash L.StandardCrypto L.AnchorData)
 pAnchorDataHash =
   Opt.option readSafeHash $

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

@@ -32,11 +32,19 @@ pHashAnchorDataCmd = do
           Cmd.HashAnchorDataCmd
           ( Cmd.HashAnchorDataCmdArgs
               <$> pAnchorDataHashSource
-              <*> optional pOutputFile
+              <*> pHashGoal
           )
       )
     $ Opt.progDesc "Compute the hash of some anchor data (to then pass it to other commands)."
 
+pHashGoal :: Parser Cmd.HashGoal
+pHashGoal =
+  asum
+    [ Cmd.CheckHash <$> pExpectedHash
+    , Cmd.HashToFile <$> pOutputFile
+    ]
+    <|> pure Cmd.HashToStdout
+
 pAnchorDataHashSource :: Parser Cmd.AnchorDataHashSource
 pAnchorDataHashSource =
   asum
@@ -52,6 +60,8 @@ pAnchorDataHashSource =
         <$> pFileInDirection "file-binary" "Binary file to hash"
     , Cmd.AnchorDataHashSourceTextFile
         <$> pFileInDirection "file-text" "Text file to hash"
+    , Cmd.AnchorDataHashSourceURL
+        <$> pUrl "url" "A URL to the file to hash (HTTP(S) and IPFS only)"
     ]
 
 pHashScriptCmd :: Parser Cmd.HashCmds

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

@@ -14,15 +14,30 @@ where
 import           Cardano.Api
 import qualified Cardano.Api.Ledger as L
 
+import           Cardano.CLI.Commands.Hash (HashGoal (..))
 import qualified Cardano.CLI.Commands.Hash as Cmd
 import           Cardano.CLI.Read
 import           Cardano.CLI.Types.Errors.HashCmdError
 import           Cardano.Crypto.Hash (hashToTextAsHex)
 
+import           Control.Exception (throw)
+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           Data.Char (toLower)
 import           Data.Function
+import           Data.List (intercalate)
+import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import qualified Data.Text.IO as Text
+import           Network.HTTP.Client (Response (..), httpLbs, newManager, requestFromURI)
+import           Network.HTTP.Client.TLS (tlsManagerSettings)
+import           Network.HTTP.Types (Status (statusCode), statusMessage)
+import           Network.URI (URI (..), URIAuth (..), parseAbsoluteURI, pathSegments)
+import qualified System.Environment as IO
+import           System.FilePath ((</>))
+import           System.FilePath.Posix (isDrive)
 
 runHashCmds
   :: ()
@@ -36,30 +51,98 @@ runHashAnchorDataCmd
   :: ()
   => Cmd.HashAnchorDataCmdArgs
   -> ExceptT HashCmdError IO ()
-runHashAnchorDataCmd Cmd.HashAnchorDataCmdArgs{toHash, mOutFile} =
-  case toHash of
-    Cmd.AnchorDataHashSourceBinaryFile fp -> do
-      let path = unFile fp
-      bytes <- handleIOExceptT (HashReadFileError path) $ BS.readFile path
-      let hash = L.hashAnchorData $ L.AnchorData bytes
-      writeHash hash
-    Cmd.AnchorDataHashSourceTextFile fp -> do
-      let path = unFile fp
-      text <- handleIOExceptT (HashReadFileError path) $ Text.readFile path
-      let hash = L.hashAnchorData $ L.AnchorData $ Text.encodeUtf8 text
-      writeHash hash
-    Cmd.AnchorDataHashSourceText text -> do
-      let hash = L.hashAnchorData $ L.AnchorData $ Text.encodeUtf8 text
-      writeHash hash
+runHashAnchorDataCmd Cmd.HashAnchorDataCmdArgs{toHash, hashGoal} = do
+  anchorData <-
+    L.AnchorData <$> case toHash of
+      Cmd.AnchorDataHashSourceBinaryFile fp -> do
+        let path = unFile fp
+        handleIOExceptT (HashReadFileError path) $ BS.readFile path
+      Cmd.AnchorDataHashSourceTextFile fp -> do
+        let path = unFile fp
+        text <- handleIOExceptT (HashReadFileError path) $ Text.readFile path
+        return $ Text.encodeUtf8 text
+      Cmd.AnchorDataHashSourceText text -> return $ Text.encodeUtf8 text
+      Cmd.AnchorDataHashSourceURL urlText ->
+        getByteStringFromURL urlText
+  let hash = L.hashAnchorData anchorData
+  case hashGoal of
+    CheckHash expectedHash
+      | hash /= expectedHash ->
+          left $ HashMismatchedHashError expectedHash hash
+      | otherwise -> do
+          liftIO $ putStrLn "Hashes match!"
+    HashToFile outFile -> writeHash (Just outFile) hash
+    HashToStdout -> writeHash Nothing hash
  where
-  writeHash :: L.SafeHash L.StandardCrypto i -> ExceptT HashCmdError IO ()
-  writeHash hash = do
+  writeHash :: Maybe (File () Out) -> L.SafeHash L.StandardCrypto i -> ExceptT HashCmdError IO ()
+  writeHash mOutFile hash = do
     firstExceptT HashWriteFileError $
       newExceptT $
         writeTextOutput mOutFile text
    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 [] = "/"
+
+    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
+
+    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
+
+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
+              )
+      }
+
 runHashScriptCmd
   :: ()
   => Cmd.HashScriptCmdArgs

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

@@ -1,26 +1,65 @@
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 
 module Cardano.CLI.Types.Errors.HashCmdError
   ( HashCmdError (..)
+  , HttpRequestError (..)
   )
 where
 
 import           Cardano.Api
+import qualified Cardano.Api.Ledger as L
 
 import           Cardano.CLI.Read (ScriptDecodeError)
+import           Cardano.Ledger.SafeHash (extractHash)
 import           Cardano.Prelude (Exception (displayException), IOException)
 
+import           Network.HTTP.Client (HttpException)
+
 data HashCmdError
-  = HashReadFileError !FilePath !IOException
+  = HashMismatchedHashError
+      !(L.SafeHash L.StandardCrypto L.AnchorData)
+      -- ^ Expected hash
+      !(L.SafeHash L.StandardCrypto L.AnchorData)
+      -- ^ Actual hash
+  | HashReadFileError !FilePath !IOException
   | HashWriteFileError !(FileError ())
   | HashReadScriptError !FilePath !(FileError ScriptDecodeError)
+  | HashInvalidURLError !String
+  | HashReadEnvVarError !IOException
+  | HashIpfsGatewayNotSetError
+  | HashUnsupportedURLSchemeError !String
+  | HashGetFileFromHttpError !HttpRequestError
   deriving Show
 
 instance Error HashCmdError where
   prettyError = \case
+    HashMismatchedHashError expectedHash actualHash ->
+      "Hashes do not match! \n"
+        <> "Expected: "
+        <> pretty (show (extractHash expectedHash))
+        <> "\n  Actual: "
+        <> pretty (show (extractHash actualHash))
     HashReadFileError filepath exc ->
       "Cannot read " <> pretty filepath <> ": " <> pretty (displayException exc)
     HashWriteFileError fileErr ->
       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
+
+data HttpRequestError
+  = BadStatusCodeHRE !Int !String
+  | HttpExceptionHRE !HttpException
+  | IOExceptionHRE !IOException
+  deriving Show
+
+instance Exception HttpRequestError where
+  displayException :: HttpRequestError -> String
+  displayException (BadStatusCodeHRE code description) = "Bad status code when downloading anchor data: " <> show code <> " (" <> description <> ")"
+  displayException (HttpExceptionHRE exc) = "HTTP(S) request error when downloading anchor data: " <> displayException exc
+  displayException (IOExceptionHRE exc) = "I/O error when downloading anchor data: " <> displayException exc

cardano-cli/test/cardano-cli-golden/files/golden/help.cli

@@ -12536,8 +12536,11 @@ Usage: cardano-cli hash anchor-data
                                       ( --text TEXT
                                       | --file-binary FILEPATH
                                       | --file-text FILEPATH
+                                      | --url TEXT
                                       )
-                                      [--out-file FILEPATH]
+                                      [ --expected-hash HASH
+                                      | --out-file FILEPATH
+                                      ]
 
   Compute the hash of some anchor data (to then pass it to other commands).