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

module Cardano.CLI.EraIndependent.Hash.Run
  ( runHashCmds
  )
where

import Cardano.Api
import Cardano.Api.Ledger qualified as L

import Cardano.CLI.Compatible.Exception
import Cardano.CLI.EraIndependent.Hash.Command qualified as Cmd
import Cardano.CLI.EraIndependent.Hash.Internal.Common
import Cardano.CLI.Read
import Cardano.CLI.Type.Common
  ( GenesisFile (..)
  )
import Cardano.CLI.Type.Error.HashCmdError
import Cardano.Crypto.Hash (hashToTextAsHex)
import Cardano.Crypto.Hash qualified as Crypto
import Cardano.Ledger.Hashes qualified as L

import RIO

import Data.ByteString.Char8 qualified as BS8
import Data.Text.Encoding qualified as Text
import Data.Text.IO qualified as Text

runHashCmds
  :: ()
  => Cmd.HashCmds
  -> CIO e ()
runHashCmds :: forall e. HashCmds -> CIO e ()
runHashCmds = \case
  Cmd.HashAnchorDataCmd HashAnchorDataCmdArgs
args -> HashAnchorDataCmdArgs -> CIO e ()
forall e. HashAnchorDataCmdArgs -> CIO e ()
runHashAnchorDataCmd HashAnchorDataCmdArgs
args
  Cmd.HashScriptCmd HashScriptCmdArgs
args ->
    HashScriptCmdArgs -> CIO e ()
forall e. HashScriptCmdArgs -> CIO e ()
runHashScriptCmd HashScriptCmdArgs
args
  Cmd.HashGenesisFile GenesisFile
args -> GenesisFile -> CIO e ()
forall e. GenesisFile -> CIO e ()
runHashGenesisFile GenesisFile
args

runHashAnchorDataCmd
  :: ()
  => Cmd.HashAnchorDataCmdArgs
  -> CIO e ()
runHashAnchorDataCmd :: forall e. HashAnchorDataCmdArgs -> CIO e ()
runHashAnchorDataCmd Cmd.HashAnchorDataCmdArgs{AnchorDataHashSource
toHash :: AnchorDataHashSource
toHash :: HashAnchorDataCmdArgs -> AnchorDataHashSource
toHash, HashGoal (SafeHash AnchorData)
hashGoal :: HashGoal (SafeHash AnchorData)
hashGoal :: HashAnchorDataCmdArgs -> HashGoal (SafeHash AnchorData)
hashGoal} = do
  AnchorData
anchorData <-
    ByteString -> AnchorData
L.AnchorData (ByteString -> AnchorData) -> RIO e ByteString -> RIO e 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 :: FilePath
path = File ProposalBinary 'In -> FilePath
forall content (direction :: FileDirection).
File content direction -> FilePath
unFile File ProposalBinary 'In
fp
        FilePath -> RIO e ByteString
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
FilePath -> m ByteString
readFileCli FilePath
path
      Cmd.AnchorDataHashSourceTextFile File ProposalText 'In
fp -> do
        let path :: FilePath
path = File ProposalText 'In -> FilePath
forall content (direction :: FileDirection).
File content direction -> FilePath
unFile File ProposalText 'In
fp
        FilePath -> RIO e ByteString
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
FilePath -> m ByteString
readFileCli FilePath
path
      Cmd.AnchorDataHashSourceText Text
text -> ByteString -> RIO e ByteString
forall a. a -> RIO e a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> RIO e ByteString) -> ByteString -> RIO e ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
Text.encodeUtf8 Text
text
      Cmd.AnchorDataHashSourceURL Url
urlText ->
        ExceptT HashCmdError IO ByteString -> RIO e ByteString
forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
ExceptT e IO a -> m a
fromExceptTCli (ExceptT HashCmdError IO ByteString -> RIO e ByteString)
-> ExceptT HashCmdError IO ByteString -> RIO e ByteString
forall a b. (a -> b) -> a -> b
$
          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 AnchorData
hash = AnchorData -> SafeHash AnchorData
forall x i. HashAnnotated x i => x -> SafeHash i
L.hashAnnotated AnchorData
anchorData
  case HashGoal (SafeHash AnchorData)
hashGoal of
    Cmd.CheckHash SafeHash AnchorData
expectedHash
      | SafeHash AnchorData
hash SafeHash AnchorData -> SafeHash AnchorData -> Bool
forall a. Eq a => a -> a -> Bool
/= SafeHash AnchorData
expectedHash ->
          HashCmdError -> RIO e ()
forall e (m :: * -> *) a.
(HasCallStack, Show e, Typeable e, Error e, MonadIO m) =>
e -> m a
throwCliError (HashCmdError -> RIO e ()) -> HashCmdError -> RIO e ()
forall a b. (a -> b) -> a -> b
$ SafeHash AnchorData -> SafeHash AnchorData -> HashCmdError
HashMismatchedHashError SafeHash AnchorData
expectedHash SafeHash AnchorData
hash
      | Bool
otherwise -> do
          IO () -> RIO e ()
forall a. IO a -> RIO e a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO e ()) -> IO () -> RIO e ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn FilePath
"Hashes match!"
    Cmd.HashToFile File () 'Out
outFile -> Maybe (File () 'Out) -> SafeHash AnchorData -> CIO e ()
forall i e. Maybe (File () 'Out) -> SafeHash i -> CIO e ()
writeHash (File () 'Out -> Maybe (File () 'Out)
forall a. a -> Maybe a
Just File () 'Out
outFile) SafeHash AnchorData
hash
    HashGoal (SafeHash AnchorData)
Cmd.HashToStdout -> Maybe (File () 'Out) -> SafeHash AnchorData -> CIO e ()
forall i e. Maybe (File () 'Out) -> SafeHash i -> CIO e ()
writeHash Maybe (File () 'Out)
forall a. Maybe a
Nothing SafeHash AnchorData
hash
 where
  writeHash :: Maybe (File () Out) -> L.SafeHash i -> CIO e ()
  writeHash :: forall i e. Maybe (File () 'Out) -> SafeHash i -> CIO e ()
writeHash Maybe (File () 'Out)
mOutFile SafeHash i
hash = do
    forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
IO (Either e a) -> m a
fromEitherIOCli @(FileError ()) (IO (Either (FileError ()) ()) -> RIO e ())
-> IO (Either (FileError ()) ()) -> RIO e ()
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 HASH i -> Text
forall h a. Hash h a -> Text
hashToTextAsHex (Hash HASH i -> Text)
-> (SafeHash i -> Hash HASH i) -> SafeHash i -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SafeHash i -> Hash HASH i
forall i. SafeHash i -> Hash HASH i
L.extractHash (SafeHash i -> Text) -> SafeHash i -> Text
forall a b. (a -> b) -> a -> b
$ SafeHash 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 :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT FetchURLError -> HashCmdError
HashFetchURLError

runHashScriptCmd
  :: ()
  => Cmd.HashScriptCmdArgs
  -> CIO e ()
runHashScriptCmd :: forall e. HashScriptCmdArgs -> CIO e ()
runHashScriptCmd Cmd.HashScriptCmdArgs{toHash :: HashScriptCmdArgs -> ScriptFile
Cmd.toHash = File FilePath
toHash, Maybe (File () 'Out)
mOutFile :: Maybe (File () 'Out)
mOutFile :: HashScriptCmdArgs -> Maybe (File () 'Out)
mOutFile} = do
  ScriptInAnyLang ScriptLanguage lang
_ Script lang
script <-
    FilePath -> RIO e ScriptInAnyLang
forall (m :: * -> *). MonadIO m => FilePath -> m ScriptInAnyLang
readFileScriptInAnyLang FilePath
toHash
  forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
IO (Either e a) -> m a
fromEitherIOCli @(FileError ()) (IO (Either (FileError ()) ()) -> RIO e ())
-> IO (Either (FileError ()) ()) -> RIO e ()
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 -> IO (Either (FileError ()) ()))
-> Text -> IO (Either (FileError ()) ())
forall a b. (a -> b) -> a -> b
$
      ScriptHash -> Text
forall a. SerialiseAsRawBytes a => a -> Text
serialiseToRawBytesHexText (ScriptHash -> Text) -> ScriptHash -> Text
forall a b. (a -> b) -> a -> b
$
        Script lang -> ScriptHash
forall lang. Script lang -> ScriptHash
hashScript Script lang
script

runHashGenesisFile :: GenesisFile -> CIO e ()
runHashGenesisFile :: forall e. GenesisFile -> CIO e ()
runHashGenesisFile (GenesisFile FilePath
fpath) = do
  ByteString
content <- FilePath -> RIO e ByteString
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
FilePath -> m ByteString
readFileCli FilePath
fpath
  let gh :: Crypto.Hash Crypto.Blake2b_256 ByteString
      gh :: Hash HASH ByteString
gh = (ByteString -> ByteString) -> ByteString -> Hash HASH ByteString
forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
Crypto.hashWith ByteString -> ByteString
forall a. a -> a
id ByteString
content
  IO () -> RIO e ()
forall a. IO a -> RIO e a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO e ()) -> IO () -> RIO e ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.putStrLn (Hash HASH ByteString -> Text
forall h a. Hash h a -> Text
Crypto.hashToTextAsHex Hash HASH ByteString
gh)