{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.CLI.EraBased.Script.Read.Common
  ( -- * Plutus Script Related
    readScriptDataOrFile

    -- * Simple Script Related
  , readFileSimpleScript
  )
where

import Cardano.Api as Api
import Cardano.Api.Experimental (obtainCommonConstraints)
import Cardano.Api.Experimental qualified as Exp

import Cardano.CLI.Compatible.Exception
import Cardano.CLI.Read (readFileCli)
import Cardano.CLI.Type.Common
import Cardano.CLI.Type.Error.ScriptDataError
import Cardano.Ledger.Core qualified as L

import Prelude

import Data.Aeson qualified as Aeson
import Data.Bifunctor
import Data.ByteString qualified as BS
import Data.ByteString.Lazy.Char8 qualified as LBS

-- TODO: Update to handle hex script bytes directly as well!
readFileSimpleScript
  :: forall era e
   . FilePath
  -> Exp.Era era
  -> CIO e (Exp.SimpleScript (Exp.LedgerEra era))
readFileSimpleScript :: forall era e.
FilePath -> Era era -> CIO e (SimpleScript (LedgerEra era))
readFileSimpleScript FilePath
file Era era
era = do
  ByteString
bs <- FilePath -> RIO e ByteString
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
FilePath -> m ByteString
readFileCli FilePath
file
  case ByteString -> Either JsonDecodeError TextEnvelope
forall a. FromJSON a => ByteString -> Either JsonDecodeError a
deserialiseFromJSON ByteString
bs of
    Left JsonDecodeError
_ -> do
      -- In addition to the TextEnvelope format, we also try to
      -- deserialize the JSON representation of SimpleScripts..
      SimpleScript
script :: SimpleScript <- Either FilePath SimpleScript -> RIO e SimpleScript
forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
Either e a -> m a
fromEitherCli (Either FilePath SimpleScript -> RIO e SimpleScript)
-> Either FilePath SimpleScript -> RIO e SimpleScript
forall a b. (a -> b) -> a -> b
$ ByteString -> Either FilePath SimpleScript
forall a. FromJSON a => ByteString -> Either FilePath a
Aeson.eitherDecodeStrict' ByteString
bs
      let NativeScript (LedgerEra era)
s :: L.NativeScript (Exp.LedgerEra era) = Era era
-> (EraCommonConstraints era => NativeScript (LedgerEra era))
-> NativeScript (LedgerEra era)
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
era ((EraCommonConstraints era => NativeScript (LedgerEra era))
 -> NativeScript (LedgerEra era))
-> (EraCommonConstraints era => NativeScript (LedgerEra era))
-> NativeScript (LedgerEra era)
forall a b. (a -> b) -> a -> b
$ SimpleScript -> NativeScript (LedgerEra era)
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
SimpleScript -> NativeScript era
toAllegraTimelock SimpleScript
script
      SimpleScript (LedgerEra era)
-> RIO e (SimpleScript (LedgerEra era))
forall a. a -> RIO e a
forall (m :: * -> *) a. Monad m => a -> m a
return (SimpleScript (LedgerEra era)
 -> RIO e (SimpleScript (LedgerEra era)))
-> SimpleScript (LedgerEra era)
-> RIO e (SimpleScript (LedgerEra era))
forall a b. (a -> b) -> a -> b
$ Era era
-> (EraCommonConstraints era => SimpleScript (LedgerEra era))
-> SimpleScript (LedgerEra era)
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints (Era era
era :: Exp.Era era) ((EraCommonConstraints era => SimpleScript (LedgerEra era))
 -> SimpleScript (LedgerEra era))
-> (EraCommonConstraints era => SimpleScript (LedgerEra era))
-> SimpleScript (LedgerEra era)
forall a b. (a -> b) -> a -> b
$ NativeScript (LedgerEra era) -> SimpleScript (LedgerEra era)
forall era. EraScript era => NativeScript era -> SimpleScript era
Exp.SimpleScript NativeScript (LedgerEra era)
s
    Right TextEnvelope
te -> do
      let scriptBs :: ByteString
scriptBs = TextEnvelope -> ByteString
teRawCBOR TextEnvelope
te
      Era era
-> (EraCommonConstraints era =>
    RIO e (SimpleScript (LedgerEra era)))
-> RIO e (SimpleScript (LedgerEra era))
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
era ((EraCommonConstraints era => RIO e (SimpleScript (LedgerEra era)))
 -> RIO e (SimpleScript (LedgerEra era)))
-> (EraCommonConstraints era =>
    RIO e (SimpleScript (LedgerEra era)))
-> RIO e (SimpleScript (LedgerEra era))
forall a b. (a -> b) -> a -> b
$
        Either DecoderError (SimpleScript (LedgerEra era))
-> RIO e (SimpleScript (LedgerEra era))
forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
Either e a -> m a
fromEitherCli (Either DecoderError (SimpleScript (LedgerEra era))
 -> RIO e (SimpleScript (LedgerEra era)))
-> Either DecoderError (SimpleScript (LedgerEra era))
-> RIO e (SimpleScript (LedgerEra era))
forall a b. (a -> b) -> a -> b
$
          ByteString -> Either DecoderError (SimpleScript (LedgerEra era))
forall era.
EraScript era =>
ByteString -> Either DecoderError (SimpleScript era)
Exp.deserialiseSimpleScript ByteString
scriptBs

readScriptDataOrFile
  :: MonadIO m
  => ScriptDataOrFile
  -> ExceptT ScriptDataError m HashableScriptData
readScriptDataOrFile :: forall (m :: * -> *).
MonadIO m =>
ScriptDataOrFile -> ExceptT ScriptDataError m HashableScriptData
readScriptDataOrFile (ScriptDataValue HashableScriptData
d) = HashableScriptData -> ExceptT ScriptDataError m HashableScriptData
forall a. a -> ExceptT ScriptDataError m a
forall (m :: * -> *) a. Monad m => a -> m a
return HashableScriptData
d
readScriptDataOrFile (ScriptDataJsonFile FilePath
fp) = do
  ByteString
sDataBs <- (IOException -> ScriptDataError)
-> IO ByteString -> ExceptT ScriptDataError m ByteString
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FileError () -> ScriptDataError
ScriptDataErrorFile (FileError () -> ScriptDataError)
-> (IOException -> FileError ()) -> IOException -> ScriptDataError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IOException -> FileError ()
forall e. FilePath -> IOException -> FileError e
FileIOError FilePath
fp) (IO ByteString -> ExceptT ScriptDataError m ByteString)
-> IO ByteString -> ExceptT ScriptDataError m ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
LBS.readFile FilePath
fp
  Value
sDataValue <- Either ScriptDataError Value -> ExceptT ScriptDataError m Value
forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither (Either ScriptDataError Value -> ExceptT ScriptDataError m Value)
-> (Either FilePath Value -> Either ScriptDataError Value)
-> Either FilePath Value
-> ExceptT ScriptDataError m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> ScriptDataError)
-> Either FilePath Value -> Either ScriptDataError Value
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 (FilePath -> FilePath -> ScriptDataError
ScriptDataErrorJsonParse FilePath
fp) (Either FilePath Value -> ExceptT ScriptDataError m Value)
-> Either FilePath Value -> ExceptT ScriptDataError m Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Either FilePath Value
forall a. FromJSON a => ByteString -> Either FilePath a
Aeson.eitherDecode ByteString
sDataBs
  Either ScriptDataError HashableScriptData
-> ExceptT ScriptDataError m HashableScriptData
forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither
    (Either ScriptDataError HashableScriptData
 -> ExceptT ScriptDataError m HashableScriptData)
-> (Either ScriptDataJsonBytesError HashableScriptData
    -> Either ScriptDataError HashableScriptData)
-> Either ScriptDataJsonBytesError HashableScriptData
-> ExceptT ScriptDataError m HashableScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScriptDataJsonBytesError -> ScriptDataError)
-> Either ScriptDataJsonBytesError HashableScriptData
-> Either ScriptDataError HashableScriptData
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 ScriptDataJsonBytesError -> ScriptDataError
ScriptDataErrorJsonBytes
    (Either ScriptDataJsonBytesError HashableScriptData
 -> ExceptT ScriptDataError m HashableScriptData)
-> Either ScriptDataJsonBytesError HashableScriptData
-> ExceptT ScriptDataError m HashableScriptData
forall a b. (a -> b) -> a -> b
$ ScriptDataJsonSchema
-> Value -> Either ScriptDataJsonBytesError HashableScriptData
scriptDataJsonToHashable ScriptDataJsonSchema
ScriptDataJsonDetailedSchema Value
sDataValue
readScriptDataOrFile (ScriptDataCborFile FilePath
fp) = do
  ByteString
origBs <- (IOException -> ScriptDataError)
-> IO ByteString -> ExceptT ScriptDataError m ByteString
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FileError () -> ScriptDataError
ScriptDataErrorFile (FileError () -> ScriptDataError)
-> (IOException -> FileError ()) -> IOException -> ScriptDataError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IOException -> FileError ()
forall e. FilePath -> IOException -> FileError e
FileIOError FilePath
fp) (FilePath -> IO ByteString
BS.readFile FilePath
fp)
  HashableScriptData
hSd <-
    (DecoderError -> ScriptDataError)
-> ExceptT DecoderError m HashableScriptData
-> ExceptT ScriptDataError m HashableScriptData
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT (FilePath -> DecoderError -> ScriptDataError
ScriptDataErrorMetadataDecode FilePath
fp) (ExceptT DecoderError m HashableScriptData
 -> ExceptT ScriptDataError m HashableScriptData)
-> ExceptT DecoderError m HashableScriptData
-> ExceptT ScriptDataError m HashableScriptData
forall a b. (a -> b) -> a -> b
$
      Either DecoderError HashableScriptData
-> ExceptT DecoderError m HashableScriptData
forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither (Either DecoderError HashableScriptData
 -> ExceptT DecoderError m HashableScriptData)
-> Either DecoderError HashableScriptData
-> ExceptT DecoderError m HashableScriptData
forall a b. (a -> b) -> a -> b
$
        AsType HashableScriptData
-> ByteString -> Either DecoderError HashableScriptData
forall a.
SerialiseAsCBOR a =>
AsType a -> ByteString -> Either DecoderError a
deserialiseFromCBOR AsType HashableScriptData
AsHashableScriptData ByteString
origBs
  (ScriptDataRangeError -> ScriptDataError)
-> ExceptT ScriptDataRangeError m ()
-> ExceptT ScriptDataError m ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT (FilePath -> ScriptDataRangeError -> ScriptDataError
ScriptDataErrorValidation FilePath
fp) (ExceptT ScriptDataRangeError m () -> ExceptT ScriptDataError m ())
-> ExceptT ScriptDataRangeError m ()
-> ExceptT ScriptDataError m ()
forall a b. (a -> b) -> a -> b
$
    Either ScriptDataRangeError () -> ExceptT ScriptDataRangeError m ()
forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither (Either ScriptDataRangeError ()
 -> ExceptT ScriptDataRangeError m ())
-> Either ScriptDataRangeError ()
-> ExceptT ScriptDataRangeError m ()
forall a b. (a -> b) -> a -> b
$
      ScriptData -> Either ScriptDataRangeError ()
validateScriptData (ScriptData -> Either ScriptDataRangeError ())
-> ScriptData -> Either ScriptDataRangeError ()
forall a b. (a -> b) -> a -> b
$
        HashableScriptData -> ScriptData
getScriptData HashableScriptData
hSd
  HashableScriptData -> ExceptT ScriptDataError m HashableScriptData
forall a. a -> ExceptT ScriptDataError m a
forall (m :: * -> *) a. Monad m => a -> m a
return HashableScriptData
hSd