{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.CLI.Run.Hash
  ( runHashCmds
  , getByteStringFromURL
  , 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 (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)
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 qualified Data.ByteString.Lazy.Char8 as BSL8
import           Data.Function
import           Data.List (intercalate)
import           Data.Text (Text)
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
  :: ()
  => Cmd.HashCmds
  -> ExceptT HashCmdError IO ()
runHashCmds :: HashCmds -> ExceptT HashCmdError IO ()
runHashCmds = \case
  Cmd.HashAnchorDataCmd HashAnchorDataCmdArgs
args -> HashAnchorDataCmdArgs -> ExceptT HashCmdError IO ()
runHashAnchorDataCmd HashAnchorDataCmdArgs
args
  Cmd.HashScriptCmd HashScriptCmdArgs
args -> HashScriptCmdArgs -> ExceptT HashCmdError IO ()
runHashScriptCmd HashScriptCmdArgs
args

runHashAnchorDataCmd
  :: ()
  => Cmd.HashAnchorDataCmdArgs
  -> ExceptT HashCmdError IO ()
runHashAnchorDataCmd :: HashAnchorDataCmdArgs -> ExceptT HashCmdError IO ()
runHashAnchorDataCmd Cmd.HashAnchorDataCmdArgs{AnchorDataHashSource
toHash :: AnchorDataHashSource
toHash :: HashAnchorDataCmdArgs -> AnchorDataHashSource
toHash, HashGoal (SafeHash StandardCrypto AnchorData)
hashGoal :: HashGoal (SafeHash StandardCrypto AnchorData)
hashGoal :: HashAnchorDataCmdArgs
-> HashGoal (SafeHash StandardCrypto AnchorData)
hashGoal} = do
  AnchorData
anchorData <-
    ByteString -> AnchorData
L.AnchorData (ByteString -> AnchorData)
-> ExceptT HashCmdError IO ByteString
-> ExceptT HashCmdError IO AnchorData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case AnchorDataHashSource
toHash of
      Cmd.AnchorDataHashSourceBinaryFile File ProposalBinary 'In
fp -> do
        let path :: [Char]
path = File ProposalBinary 'In -> [Char]
forall content (direction :: FileDirection).
File content direction -> [Char]
unFile File ProposalBinary 'In
fp
        (IOException -> HashCmdError)
-> IO ByteString -> ExceptT HashCmdError IO ByteString
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT ([Char] -> IOException -> HashCmdError
HashReadFileError [Char]
path) (IO ByteString -> ExceptT HashCmdError IO ByteString)
-> IO ByteString -> ExceptT HashCmdError IO ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
BS.readFile [Char]
path
      Cmd.AnchorDataHashSourceTextFile File ProposalText 'In
fp -> do
        let path :: [Char]
path = File ProposalText 'In -> [Char]
forall content (direction :: FileDirection).
File content direction -> [Char]
unFile File ProposalText 'In
fp
        Text
text <- (IOException -> HashCmdError)
-> IO Text -> ExceptT HashCmdError IO Text
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT ([Char] -> IOException -> HashCmdError
HashReadFileError [Char]
path) (IO Text -> ExceptT HashCmdError IO Text)
-> IO Text -> ExceptT HashCmdError IO Text
forall a b. (a -> b) -> a -> b
$ [Char] -> IO Text
Text.readFile [Char]
path
        ByteString -> ExceptT HashCmdError IO ByteString
forall a. a -> ExceptT HashCmdError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ExceptT HashCmdError IO ByteString)
-> ByteString -> ExceptT HashCmdError IO ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
Text.encodeUtf8 Text
text
      Cmd.AnchorDataHashSourceText Text
text -> ByteString -> ExceptT HashCmdError IO ByteString
forall a. a -> ExceptT HashCmdError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ExceptT HashCmdError IO ByteString)
-> ByteString -> ExceptT HashCmdError IO ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
Text.encodeUtf8 Text
text
      Cmd.AnchorDataHashSourceURL Url
urlText ->
        ExceptT FetchURLError IO ByteString
-> ExceptT HashCmdError IO ByteString
fetchURLToHashCmdError (ExceptT FetchURLError IO ByteString
 -> ExceptT HashCmdError IO ByteString)
-> ExceptT FetchURLError IO ByteString
-> ExceptT HashCmdError IO ByteString
forall a b. (a -> b) -> a -> b
$ SupportedSchemes -> Text -> ExceptT FetchURLError IO ByteString
getByteStringFromURL SupportedSchemes
allSchemes (Text -> ExceptT FetchURLError IO ByteString)
-> Text -> ExceptT FetchURLError IO ByteString
forall a b. (a -> b) -> a -> b
$ Url -> Text
L.urlToText Url
urlText
  let hash :: SafeHash StandardCrypto AnchorData
hash = AnchorData -> SafeHash StandardCrypto AnchorData
forall c. Crypto c => AnchorData -> SafeHash c AnchorData
L.hashAnchorData AnchorData
anchorData
  case HashGoal (SafeHash StandardCrypto AnchorData)
hashGoal of
    Cmd.CheckHash SafeHash StandardCrypto AnchorData
expectedHash
      | SafeHash StandardCrypto AnchorData
hash SafeHash StandardCrypto AnchorData
-> SafeHash StandardCrypto AnchorData -> Bool
forall a. Eq a => a -> a -> Bool
/= SafeHash StandardCrypto AnchorData
expectedHash ->
          HashCmdError -> ExceptT HashCmdError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (HashCmdError -> ExceptT HashCmdError IO ())
-> HashCmdError -> ExceptT HashCmdError IO ()
forall a b. (a -> b) -> a -> b
$ SafeHash StandardCrypto AnchorData
-> SafeHash StandardCrypto AnchorData -> HashCmdError
HashMismatchedHashError SafeHash StandardCrypto AnchorData
expectedHash SafeHash StandardCrypto AnchorData
hash
      | Bool
otherwise -> do
          IO () -> ExceptT HashCmdError IO ()
forall a. IO a -> ExceptT HashCmdError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT HashCmdError IO ())
-> IO () -> ExceptT HashCmdError IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Hashes match!"
    Cmd.HashToFile File () 'Out
outFile -> Maybe (File () 'Out)
-> SafeHash StandardCrypto AnchorData -> ExceptT HashCmdError IO ()
forall i.
Maybe (File () 'Out)
-> SafeHash StandardCrypto i -> ExceptT HashCmdError IO ()
writeHash (File () 'Out -> Maybe (File () 'Out)
forall a. a -> Maybe a
Just File () 'Out
outFile) SafeHash StandardCrypto AnchorData
hash
    HashGoal (SafeHash StandardCrypto AnchorData)
Cmd.HashToStdout -> Maybe (File () 'Out)
-> SafeHash StandardCrypto AnchorData -> ExceptT HashCmdError IO ()
forall i.
Maybe (File () 'Out)
-> SafeHash StandardCrypto i -> ExceptT HashCmdError IO ()
writeHash Maybe (File () 'Out)
forall a. Maybe a
Nothing SafeHash StandardCrypto AnchorData
hash
 where
  writeHash :: Maybe (File () Out) -> L.SafeHash L.StandardCrypto i -> ExceptT HashCmdError IO ()
  writeHash :: forall i.
Maybe (File () 'Out)
-> SafeHash StandardCrypto i -> ExceptT HashCmdError IO ()
writeHash Maybe (File () 'Out)
mOutFile SafeHash StandardCrypto i
hash = do
    (FileError () -> HashCmdError)
-> ExceptT (FileError ()) IO () -> ExceptT HashCmdError IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT FileError () -> HashCmdError
HashWriteFileError (ExceptT (FileError ()) IO () -> ExceptT HashCmdError IO ())
-> ExceptT (FileError ()) IO () -> ExceptT HashCmdError IO ()
forall a b. (a -> b) -> a -> b
$
      IO (Either (FileError ()) ()) -> ExceptT (FileError ()) IO ()
forall (m :: * -> *) x a. m (Either x a) -> ExceptT x m a
newExceptT (IO (Either (FileError ()) ()) -> ExceptT (FileError ()) IO ())
-> IO (Either (FileError ()) ()) -> ExceptT (FileError ()) IO ()
forall a b. (a -> b) -> a -> b
$
        Maybe (File () 'Out) -> Text -> IO (Either (FileError ()) ())
forall (m :: * -> *) content e.
MonadIO m =>
Maybe (File content 'Out) -> Text -> m (Either (FileError e) ())
writeTextOutput Maybe (File () 'Out)
mOutFile Text
text
   where
    text :: Text
text = Hash Blake2b_256 i -> Text
forall h a. Hash h a -> Text
hashToTextAsHex (Hash Blake2b_256 i -> Text)
-> (SafeHash StandardCrypto i -> Hash Blake2b_256 i)
-> SafeHash StandardCrypto i
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SafeHash StandardCrypto i -> Hash Blake2b_256 i
SafeHash StandardCrypto i -> Hash (HASH StandardCrypto) i
forall c i. SafeHash c i -> Hash (HASH c) i
L.extractHash (SafeHash StandardCrypto i -> Text)
-> SafeHash StandardCrypto i -> Text
forall a b. (a -> b) -> a -> b
$ SafeHash StandardCrypto i
hash

  fetchURLToHashCmdError
    :: ExceptT FetchURLError IO BS8.ByteString -> ExceptT HashCmdError IO BS8.ByteString
  fetchURLToHashCmdError :: ExceptT FetchURLError IO ByteString
-> ExceptT HashCmdError IO ByteString
fetchURLToHashCmdError = (FetchURLError -> HashCmdError)
-> ExceptT FetchURLError IO ByteString
-> ExceptT HashCmdError IO ByteString
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
withExceptT FetchURLError -> HashCmdError
HashFetchURLError

-- | All the supported schemes are allowed.
allSchemes :: SupportedSchemes
allSchemes :: SupportedSchemes
allSchemes = [AnchorScheme
FileScheme, AnchorScheme
HttpScheme, AnchorScheme
HttpsScheme, AnchorScheme
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 :: SupportedSchemes
httpsAndIpfsSchemes =
  [ AnchorScheme
HttpScheme -- Insecure, only for testing purposes
  , AnchorScheme
HttpsScheme
  , AnchorScheme
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 -> Text -> ExceptT FetchURLError IO ByteString
getByteStringFromURL SupportedSchemes
supportedSchemes Text
urlText = do
  let urlString :: [Char]
urlString = Text -> [Char]
Text.unpack Text
urlText
  uri :: URI
uri@URI{[Char]
uriScheme :: [Char]
uriScheme :: URI -> [Char]
uriScheme} <- FetchURLError -> Maybe URI -> ExceptT FetchURLError IO URI
forall (m :: * -> *) x a. Monad m => x -> Maybe a -> ExceptT x m a
hoistMaybe ([Char] -> FetchURLError
FetchURLInvalidURLError [Char]
urlString) (Maybe URI -> ExceptT FetchURLError IO URI)
-> Maybe URI -> ExceptT FetchURLError IO URI
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe URI
parseAbsoluteURI [Char]
urlString
  AnchorScheme
scheme <-
    Either FetchURLError AnchorScheme
-> ExceptT FetchURLError IO AnchorScheme
forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither (Either FetchURLError AnchorScheme
 -> ExceptT FetchURLError IO AnchorScheme)
-> Either FetchURLError AnchorScheme
-> ExceptT FetchURLError IO AnchorScheme
forall a b. (a -> b) -> a -> b
$
      ([Char] -> FetchURLError)
-> Either [Char] AnchorScheme -> Either FetchURLError AnchorScheme
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [Char] -> FetchURLError
FetchURLUnsupportedURLSchemeError (Either [Char] AnchorScheme -> Either FetchURLError AnchorScheme)
-> Either [Char] AnchorScheme -> Either FetchURLError AnchorScheme
forall a b. (a -> b) -> a -> b
$
        SupportedSchemes -> [Char] -> Either [Char] AnchorScheme
stringToAnchorScheme SupportedSchemes
supportedSchemes [Char]
uriScheme
  case AnchorScheme
scheme of
    AnchorScheme
FileScheme ->
      let path :: [Char]
path = [[Char]] -> [Char]
uriPathToFilePath (URI -> [[Char]]
pathSegments URI
uri)
       in (IOException -> FetchURLError)
-> IO ByteString -> ExceptT FetchURLError IO ByteString
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT ([Char] -> IOException -> FetchURLError
FetchURLReadFileError [Char]
path) (IO ByteString -> ExceptT FetchURLError IO ByteString)
-> IO ByteString -> ExceptT FetchURLError IO ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
BS.readFile [Char]
path
    AnchorScheme
HttpScheme -> URI -> ExceptT FetchURLError IO ByteString
getFileFromHttp URI
uri
    AnchorScheme
HttpsScheme -> URI -> ExceptT FetchURLError IO ByteString
getFileFromHttp URI
uri
    AnchorScheme
IpfsScheme -> do
      URI
httpUri <- URI -> ExceptT FetchURLError IO URI
convertToHttp URI
uri
      URI -> ExceptT FetchURLError IO ByteString
getFileFromHttp URI
httpUri
 where
  uriPathToFilePath :: [String] -> FilePath
  uriPathToFilePath :: [[Char]] -> [Char]
uriPathToFilePath allPath :: [[Char]]
allPath@([Char]
letter : [[Char]]
path) =
    if [Char] -> Bool
isDrive [Char]
letter
      then ([Char] -> [Char] -> [Char]) -> [Char] -> [[Char]] -> [Char]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Char] -> [Char] -> [Char]
(</>) [Char]
letter [[Char]]
path
      else ([Char] -> [Char] -> [Char]) -> [Char] -> [[Char]] -> [Char]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Char] -> [Char] -> [Char]
(</>) [Char]
"/" [[Char]]
allPath
  uriPathToFilePath [] = [Char]
"/"

  getFileFromHttp :: URI -> ExceptT FetchURLError IO BS.ByteString
  getFileFromHttp :: URI -> ExceptT FetchURLError IO ByteString
getFileFromHttp URI
uri = [Handler IO FetchURLError]
-> IO ByteString -> ExceptT FetchURLError IO ByteString
forall (f :: * -> *) (m :: * -> *) x a.
(Foldable f, MonadCatch m) =>
f (Handler m x) -> m a -> ExceptT x m a
handlesExceptT [Handler IO FetchURLError]
handlers (IO ByteString -> ExceptT FetchURLError IO ByteString)
-> IO ByteString -> ExceptT FetchURLError IO ByteString
forall a b. (a -> b) -> a -> b
$ IO ByteString -> IO ByteString
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
    Request
request <- URI -> IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
requestFromURI URI
uri
    Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
    Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
request Manager
manager
    let status :: Status
status = Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
response
    if Status -> Int
statusCode Status
status Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
200
      then
        HttpRequestError -> IO ByteString
forall a e. Exception e => e -> a
throw (HttpRequestError -> IO ByteString)
-> HttpRequestError -> IO ByteString
forall a b. (a -> b) -> a -> b
$
          Int -> [Char] -> HttpRequestError
BadStatusCodeHRE
            (Status -> Int
statusCode Status
status)
            (ByteString -> [Char]
BS8.unpack (Status -> ByteString
statusMessage Status
status) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BSL8.unpack (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
response))
      else ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BSL.toChunks (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
response

  handlers :: [Handler IO FetchURLError]
  handlers :: [Handler IO FetchURLError]
handlers =
    [ (HttpRequestError -> HttpRequestError) -> Handler IO FetchURLError
forall (m :: * -> *) e.
(Monad m, Exception e) =>
(e -> HttpRequestError) -> Handler m FetchURLError
mkHandler HttpRequestError -> HttpRequestError
forall a. a -> a
id
    , (HttpException -> HttpRequestError) -> Handler IO FetchURLError
forall (m :: * -> *) e.
(Monad m, Exception e) =>
(e -> HttpRequestError) -> Handler m FetchURLError
mkHandler HttpException -> HttpRequestError
HttpExceptionHRE
    , (IOException -> HttpRequestError) -> Handler IO FetchURLError
forall (m :: * -> *) e.
(Monad m, Exception e) =>
(e -> HttpRequestError) -> Handler m FetchURLError
mkHandler IOException -> HttpRequestError
IOExceptionHRE
    ]
   where
    mkHandler :: (Monad m, Exception e) => (e -> HttpRequestError) -> Handler m FetchURLError
    mkHandler :: forall (m :: * -> *) e.
(Monad m, Exception e) =>
(e -> HttpRequestError) -> Handler m FetchURLError
mkHandler e -> HttpRequestError
x = (e -> m FetchURLError) -> Handler m FetchURLError
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((e -> m FetchURLError) -> Handler m FetchURLError)
-> (e -> m FetchURLError) -> Handler m FetchURLError
forall a b. (a -> b) -> a -> b
$ FetchURLError -> m FetchURLError
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FetchURLError -> m FetchURLError)
-> (e -> FetchURLError) -> e -> m FetchURLError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpRequestError -> FetchURLError
FetchURLGetFileFromHttpError (HttpRequestError -> FetchURLError)
-> (e -> HttpRequestError) -> e -> FetchURLError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> HttpRequestError
x

  convertToHttp :: URI -> ExceptT FetchURLError IO URI
  convertToHttp :: URI -> ExceptT FetchURLError IO URI
convertToHttp URI
ipfsUri = do
    Maybe [Char]
mIpfsGatewayUriString <- (IOException -> FetchURLError)
-> IO (Maybe [Char]) -> ExceptT FetchURLError IO (Maybe [Char])
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT IOException -> FetchURLError
FetchURLReadEnvVarError (IO (Maybe [Char]) -> ExceptT FetchURLError IO (Maybe [Char]))
-> IO (Maybe [Char]) -> ExceptT FetchURLError IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> IO (Maybe [Char])
IO.lookupEnv [Char]
"IPFS_GATEWAY_URI"
    [Char]
ipfsGatewayUriString <- FetchURLError -> Maybe [Char] -> ExceptT FetchURLError IO [Char]
forall (m :: * -> *) x a. Monad m => x -> Maybe a -> ExceptT x m a
hoistMaybe FetchURLError
FetchURLIpfsGatewayNotSetError Maybe [Char]
mIpfsGatewayUriString
    URI
ipfsGatewayUri <-
      FetchURLError -> Maybe URI -> ExceptT FetchURLError IO URI
forall (m :: * -> *) x a. Monad m => x -> Maybe a -> ExceptT x m a
hoistMaybe ([Char] -> FetchURLError
FetchURLInvalidURLError [Char]
ipfsGatewayUriString) (Maybe URI -> ExceptT FetchURLError IO URI)
-> Maybe URI -> ExceptT FetchURLError IO URI
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe URI
parseAbsoluteURI [Char]
ipfsGatewayUriString
    URI -> ExceptT FetchURLError IO URI
forall a. a -> ExceptT FetchURLError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (URI -> ExceptT FetchURLError IO URI)
-> URI -> ExceptT FetchURLError IO URI
forall a b. (a -> b) -> a -> b
$
      URI
ipfsGatewayUri
        { uriPath =
            '/'
              : intercalate
                "/"
                ( pathSegments ipfsGatewayUri
                    ++ ["ipfs"]
                    ++ maybe [] (\URIAuth
ipfsAuthority -> [URIAuth -> [Char]
uriRegName URIAuth
ipfsAuthority]) (uriAuthority ipfsUri)
                    ++ pathSegments ipfsUri
                )
        }

runHashScriptCmd
  :: ()
  => Cmd.HashScriptCmdArgs
  -> ExceptT HashCmdError IO ()
runHashScriptCmd :: HashScriptCmdArgs -> ExceptT HashCmdError IO ()
runHashScriptCmd Cmd.HashScriptCmdArgs{toHash :: HashScriptCmdArgs -> ScriptFile
Cmd.toHash = File [Char]
toHash, Maybe (File () 'Out)
mOutFile :: Maybe (File () 'Out)
mOutFile :: HashScriptCmdArgs -> Maybe (File () 'Out)
mOutFile} = do
  ScriptInAnyLang ScriptLanguage lang
_ Script lang
script <-
    [Char] -> ExceptT (FileError ScriptDecodeError) IO ScriptInAnyLang
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
MonadIOTransError (FileError ScriptDecodeError) t m =>
[Char] -> t m ScriptInAnyLang
readFileScriptInAnyLang [Char]
toHash
      ExceptT (FileError ScriptDecodeError) IO ScriptInAnyLang
-> (ExceptT (FileError ScriptDecodeError) IO ScriptInAnyLang
    -> ExceptT HashCmdError IO ScriptInAnyLang)
-> ExceptT HashCmdError IO ScriptInAnyLang
forall a b. a -> (a -> b) -> b
& (FileError ScriptDecodeError -> HashCmdError)
-> ExceptT (FileError ScriptDecodeError) IO ScriptInAnyLang
-> ExceptT HashCmdError IO ScriptInAnyLang
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT ([Char] -> FileError ScriptDecodeError -> HashCmdError
HashReadScriptError [Char]
toHash)
  (FileError () -> HashCmdError)
-> ExceptT (FileError ()) IO () -> ExceptT HashCmdError IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT FileError () -> HashCmdError
HashWriteFileError
    (ExceptT (FileError ()) IO () -> ExceptT HashCmdError IO ())
-> (ScriptHash -> ExceptT (FileError ()) IO ())
-> ScriptHash
-> ExceptT HashCmdError IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either (FileError ()) ()) -> ExceptT (FileError ()) IO ()
forall (m :: * -> *) x a. m (Either x a) -> ExceptT x m a
newExceptT
    (IO (Either (FileError ()) ()) -> ExceptT (FileError ()) IO ())
-> (ScriptHash -> IO (Either (FileError ()) ()))
-> ScriptHash
-> ExceptT (FileError ()) IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (File () 'Out) -> Text -> IO (Either (FileError ()) ())
forall (m :: * -> *) content e.
MonadIO m =>
Maybe (File content 'Out) -> Text -> m (Either (FileError e) ())
writeTextOutput Maybe (File () 'Out)
mOutFile
    (Text -> IO (Either (FileError ()) ()))
-> (ScriptHash -> Text)
-> ScriptHash
-> IO (Either (FileError ()) ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptHash -> Text
forall a. SerialiseAsRawBytes a => a -> Text
serialiseToRawBytesHexText
    (ScriptHash -> ExceptT HashCmdError IO ())
-> ScriptHash -> ExceptT HashCmdError IO ()
forall a b. (a -> b) -> a -> b
$ Script lang -> ScriptHash
forall lang. Script lang -> ScriptHash
hashScript Script lang
script

-- | Check the hash of the anchor data against the hash in the anchor if
-- checkHash is set to CheckHash.
carryHashChecks
  :: PotentiallyCheckedAnchor anchorType (L.Anchor L.StandardCrypto)
  -- ^ The information about anchor data and whether to check the hash (see 'PotentiallyCheckedAnchor')
  -> ExceptT HashCheckError IO ()
carryHashChecks :: forall anchorType.
PotentiallyCheckedAnchor anchorType (Anchor StandardCrypto)
-> ExceptT HashCheckError IO ()
carryHashChecks PotentiallyCheckedAnchor anchorType (Anchor StandardCrypto)
potentiallyCheckedAnchor =
  case PotentiallyCheckedAnchor anchorType (Anchor StandardCrypto)
-> MustCheckHash anchorType
forall anchorType anchor.
PotentiallyCheckedAnchor anchorType anchor
-> MustCheckHash anchorType
pcaMustCheck PotentiallyCheckedAnchor anchorType (Anchor StandardCrypto)
potentiallyCheckedAnchor of
    MustCheckHash anchorType
CheckHash -> do
      AnchorData
anchorData <-
        ByteString -> AnchorData
L.AnchorData
          (ByteString -> AnchorData)
-> ExceptT HashCheckError IO ByteString
-> ExceptT HashCheckError IO AnchorData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FetchURLError -> HashCheckError)
-> ExceptT FetchURLError IO ByteString
-> ExceptT HashCheckError IO ByteString
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
withExceptT
            FetchURLError -> HashCheckError
FetchURLError
            (SupportedSchemes -> Text -> ExceptT FetchURLError IO ByteString
getByteStringFromURL SupportedSchemes
httpsAndIpfsSchemes (Text -> ExceptT FetchURLError IO ByteString)
-> Text -> ExceptT FetchURLError IO ByteString
forall a b. (a -> b) -> a -> b
$ Url -> Text
L.urlToText (Url -> Text) -> Url -> Text
forall a b. (a -> b) -> a -> b
$ Anchor StandardCrypto -> Url
forall c. Anchor c -> Url
L.anchorUrl Anchor StandardCrypto
anchor)
      let hash :: SafeHash StandardCrypto AnchorData
hash = AnchorData -> SafeHash StandardCrypto AnchorData
forall c. Crypto c => AnchorData -> SafeHash c AnchorData
L.hashAnchorData AnchorData
anchorData
      Bool
-> ExceptT HashCheckError IO () -> ExceptT HashCheckError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SafeHash StandardCrypto AnchorData
hash SafeHash StandardCrypto AnchorData
-> SafeHash StandardCrypto AnchorData -> Bool
forall a. Eq a => a -> a -> Bool
/= Anchor StandardCrypto -> SafeHash StandardCrypto AnchorData
forall c. Anchor c -> SafeHash c AnchorData
L.anchorDataHash Anchor StandardCrypto
anchor) (ExceptT HashCheckError IO () -> ExceptT HashCheckError IO ())
-> ExceptT HashCheckError IO () -> ExceptT HashCheckError IO ()
forall a b. (a -> b) -> a -> b
$
        HashCheckError -> ExceptT HashCheckError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (HashCheckError -> ExceptT HashCheckError IO ())
-> HashCheckError -> ExceptT HashCheckError IO ()
forall a b. (a -> b) -> a -> b
$
          SafeHash StandardCrypto AnchorData
-> SafeHash StandardCrypto AnchorData -> HashCheckError
HashMismatchError (Anchor StandardCrypto -> SafeHash StandardCrypto AnchorData
forall c. Anchor c -> SafeHash c AnchorData
L.anchorDataHash Anchor StandardCrypto
anchor) SafeHash StandardCrypto AnchorData
hash
    MustCheckHash anchorType
TrustHash -> () -> ExceptT HashCheckError IO ()
forall a. a -> ExceptT HashCheckError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 where
  anchor :: Anchor StandardCrypto
anchor = PotentiallyCheckedAnchor anchorType (Anchor StandardCrypto)
-> Anchor StandardCrypto
forall anchorType anchor.
PotentiallyCheckedAnchor anchorType anchor -> anchor
pcaAnchor PotentiallyCheckedAnchor anchorType (Anchor StandardCrypto)
potentiallyCheckedAnchor