{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TupleSections #-}

module Cardano.CLI.EraBased.Script.Certificate.Read
  ( readCertificateScriptWitness
  , readCertificateScriptWitnesses
  )
where

import Cardano.Api
import Cardano.Api.Shelley

import Cardano.CLI.EraBased.Script.Certificate.Type
import Cardano.CLI.EraBased.Script.Read.Common
import Cardano.CLI.EraBased.Script.Type
import Cardano.CLI.Type.Common (CertificateFile)

import Control.Monad

readCertificateScriptWitnesses
  :: MonadIOTransError (FileError CliScriptWitnessError) t m
  => ShelleyBasedEra era
  -> [(CertificateFile, Maybe CliCertificateScriptRequirements)]
  -> t m [(CertificateFile, Maybe (CertificateScriptWitness era))]
readCertificateScriptWitnesses :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) era.
MonadIOTransError (FileError CliScriptWitnessError) t m =>
ShelleyBasedEra era
-> [(CertificateFile, Maybe CliCertificateScriptRequirements)]
-> t m [(CertificateFile, Maybe (CertificateScriptWitness era))]
readCertificateScriptWitnesses ShelleyBasedEra era
sbe =
  ((CertificateFile, Maybe CliCertificateScriptRequirements)
 -> t m (CertificateFile, Maybe (CertificateScriptWitness era)))
-> [(CertificateFile, Maybe CliCertificateScriptRequirements)]
-> t m [(CertificateFile, Maybe (CertificateScriptWitness era))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
    ( \(CertificateFile
certFile, Maybe CliCertificateScriptRequirements
mSWit) -> do
        (CertificateFile
certFile,) (Maybe (CertificateScriptWitness era)
 -> (CertificateFile, Maybe (CertificateScriptWitness era)))
-> t m (Maybe (CertificateScriptWitness era))
-> t m (CertificateFile, Maybe (CertificateScriptWitness era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CliCertificateScriptRequirements
-> (CliCertificateScriptRequirements
    -> t m (CertificateScriptWitness era))
-> t m (Maybe (CertificateScriptWitness era))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe CliCertificateScriptRequirements
mSWit (ShelleyBasedEra era
-> CliCertificateScriptRequirements
-> t m (CertificateScriptWitness era)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) era.
MonadIOTransError (FileError CliScriptWitnessError) t m =>
ShelleyBasedEra era
-> CliCertificateScriptRequirements
-> t m (CertificateScriptWitness era)
readCertificateScriptWitness ShelleyBasedEra era
sbe)
    )

readCertificateScriptWitness
  :: MonadIOTransError (FileError CliScriptWitnessError) t m
  => ShelleyBasedEra era -> CliCertificateScriptRequirements -> t m (CertificateScriptWitness era)
readCertificateScriptWitness :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) era.
MonadIOTransError (FileError CliScriptWitnessError) t m =>
ShelleyBasedEra era
-> CliCertificateScriptRequirements
-> t m (CertificateScriptWitness era)
readCertificateScriptWitness ShelleyBasedEra era
sbe CliCertificateScriptRequirements
certScriptReq =
  case CliCertificateScriptRequirements
certScriptReq of
    OnDiskSimpleScript File ScriptInAnyLang 'In
scriptFp -> do
      let sFp :: FilePath
sFp = File ScriptInAnyLang 'In -> FilePath
forall content (direction :: FileDirection).
File content direction -> FilePath
unFile File ScriptInAnyLang 'In
scriptFp
      Script SimpleScript'
s <-
        (FileError ScriptDecodeError -> FileError CliScriptWitnessError)
-> ExceptT (FileError ScriptDecodeError) m (Script SimpleScript')
-> t m (Script SimpleScript')
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError ((ScriptDecodeError -> CliScriptWitnessError)
-> FileError ScriptDecodeError -> FileError CliScriptWitnessError
forall a b. (a -> b) -> FileError a -> FileError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScriptDecodeError -> CliScriptWitnessError
SimpleScriptWitnessDecodeError) (ExceptT (FileError ScriptDecodeError) m (Script SimpleScript')
 -> t m (Script SimpleScript'))
-> ExceptT (FileError ScriptDecodeError) m (Script SimpleScript')
-> t m (Script SimpleScript')
forall a b. (a -> b) -> a -> b
$
          FilePath
-> ExceptT (FileError ScriptDecodeError) m (Script SimpleScript')
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
MonadIOTransError (FileError ScriptDecodeError) t m =>
FilePath -> t m (Script SimpleScript')
readFileSimpleScript FilePath
sFp
      case Script SimpleScript'
s of
        SimpleScript SimpleScript
ss -> do
          CertificateScriptWitness era -> t m (CertificateScriptWitness era)
forall a. a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CertificateScriptWitness era
 -> t m (CertificateScriptWitness era))
-> CertificateScriptWitness era
-> t m (CertificateScriptWitness era)
forall a b. (a -> b) -> a -> b
$
            ScriptWitness WitCtxStake era -> CertificateScriptWitness era
forall era.
ScriptWitness WitCtxStake era -> CertificateScriptWitness era
CertificateScriptWitness (ScriptWitness WitCtxStake era -> CertificateScriptWitness era)
-> ScriptWitness WitCtxStake era -> CertificateScriptWitness era
forall a b. (a -> b) -> a -> b
$
              ScriptLanguageInEra SimpleScript' era
-> SimpleScriptOrReferenceInput SimpleScript'
-> ScriptWitness WitCtxStake era
forall era witctx.
ScriptLanguageInEra SimpleScript' era
-> SimpleScriptOrReferenceInput SimpleScript'
-> ScriptWitness witctx era
SimpleScriptWitness (ShelleyBasedEra era -> ScriptLanguageInEra SimpleScript' era
forall era.
ShelleyBasedEra era -> ScriptLanguageInEra SimpleScript' era
sbeToSimpleScriptLanguageInEra ShelleyBasedEra era
sbe) (SimpleScriptOrReferenceInput SimpleScript'
 -> ScriptWitness WitCtxStake era)
-> SimpleScriptOrReferenceInput SimpleScript'
-> ScriptWitness WitCtxStake era
forall a b. (a -> b) -> a -> b
$
                SimpleScript -> SimpleScriptOrReferenceInput SimpleScript'
forall lang. SimpleScript -> SimpleScriptOrReferenceInput lang
SScript SimpleScript
ss
    OnDiskPlutusScript (OnDiskPlutusScriptCliArgs File ScriptInAnyLang 'In
scriptFp ScriptDataOrFile
redeemerFile ExecutionUnits
execUnits) -> do
      let plutusScriptFp :: FilePath
plutusScriptFp = File ScriptInAnyLang 'In -> FilePath
forall content (direction :: FileDirection).
File content direction -> FilePath
unFile File ScriptInAnyLang 'In
scriptFp
      AnyPlutusScript
plutusScript <-
        (FileError PlutusScriptDecodeError
 -> FileError CliScriptWitnessError)
-> ExceptT (FileError PlutusScriptDecodeError) m AnyPlutusScript
-> t m AnyPlutusScript
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError ((PlutusScriptDecodeError -> CliScriptWitnessError)
-> FileError PlutusScriptDecodeError
-> FileError CliScriptWitnessError
forall a b. (a -> b) -> FileError a -> FileError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PlutusScriptDecodeError -> CliScriptWitnessError
PlutusScriptWitnessDecodeError) (ExceptT (FileError PlutusScriptDecodeError) m AnyPlutusScript
 -> t m AnyPlutusScript)
-> ExceptT (FileError PlutusScriptDecodeError) m AnyPlutusScript
-> t m AnyPlutusScript
forall a b. (a -> b) -> a -> b
$
          FilePath
-> ExceptT (FileError PlutusScriptDecodeError) m AnyPlutusScript
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
MonadIOTransError (FileError PlutusScriptDecodeError) t m =>
FilePath -> t m AnyPlutusScript
readFilePlutusScript FilePath
plutusScriptFp
      HashableScriptData
redeemer <-
        (ScriptDataError -> FileError CliScriptWitnessError)
-> ExceptT ScriptDataError m HashableScriptData
-> t m HashableScriptData
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError (FilePath
-> CliScriptWitnessError -> FileError CliScriptWitnessError
forall e. FilePath -> e -> FileError e
FileError FilePath
plutusScriptFp (CliScriptWitnessError -> FileError CliScriptWitnessError)
-> (ScriptDataError -> CliScriptWitnessError)
-> ScriptDataError
-> FileError CliScriptWitnessError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptDataError -> CliScriptWitnessError
PlutusScriptWitnessRedeemerError) (ExceptT ScriptDataError m HashableScriptData
 -> t m HashableScriptData)
-> ExceptT ScriptDataError m HashableScriptData
-> t m HashableScriptData
forall a b. (a -> b) -> a -> b
$
          ScriptDataOrFile -> ExceptT ScriptDataError m HashableScriptData
forall (m :: * -> *).
MonadIO m =>
ScriptDataOrFile -> ExceptT ScriptDataError m HashableScriptData
readScriptDataOrFile ScriptDataOrFile
redeemerFile
      case AnyPlutusScript
plutusScript of
        AnyPlutusScript PlutusScriptVersion lang
lang PlutusScript lang
script -> do
          let pScript :: PlutusScriptOrReferenceInput lang
pScript = PlutusScript lang -> PlutusScriptOrReferenceInput lang
forall lang. PlutusScript lang -> PlutusScriptOrReferenceInput lang
PScript PlutusScript lang
script
          ScriptLanguageInEra lang era
sLangSupported <-
            (CliScriptWitnessError -> FileError CliScriptWitnessError)
-> ExceptT CliScriptWitnessError m (ScriptLanguageInEra lang era)
-> t m (ScriptLanguageInEra lang era)
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError (FilePath
-> CliScriptWitnessError -> FileError CliScriptWitnessError
forall e. FilePath -> e -> FileError e
FileError FilePath
plutusScriptFp)
              (ExceptT CliScriptWitnessError m (ScriptLanguageInEra lang era)
 -> t m (ScriptLanguageInEra lang era))
-> ExceptT CliScriptWitnessError m (ScriptLanguageInEra lang era)
-> t m (ScriptLanguageInEra lang era)
forall a b. (a -> b) -> a -> b
$ CliScriptWitnessError
-> Maybe (ScriptLanguageInEra lang era)
-> ExceptT CliScriptWitnessError m (ScriptLanguageInEra lang era)
forall (m :: * -> *) x a. Monad m => x -> Maybe a -> ExceptT x m a
hoistMaybe
                ( AnyPlutusScriptVersion
-> AnyShelleyBasedEra -> CliScriptWitnessError
PlutusScriptWitnessLanguageNotSupportedInEra
                    (PlutusScriptVersion lang -> AnyPlutusScriptVersion
forall lang.
IsPlutusScriptLanguage lang =>
PlutusScriptVersion lang -> AnyPlutusScriptVersion
AnyPlutusScriptVersion PlutusScriptVersion lang
lang)
                    (ShelleyBasedEra era
-> (ShelleyBasedEraConstraints era => AnyShelleyBasedEra)
-> AnyShelleyBasedEra
forall era a.
ShelleyBasedEra era -> (ShelleyBasedEraConstraints era => a) -> a
shelleyBasedEraConstraints ShelleyBasedEra era
sbe ((ShelleyBasedEraConstraints era => AnyShelleyBasedEra)
 -> AnyShelleyBasedEra)
-> (ShelleyBasedEraConstraints era => AnyShelleyBasedEra)
-> AnyShelleyBasedEra
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era -> AnyShelleyBasedEra
forall era.
Typeable era =>
ShelleyBasedEra era -> AnyShelleyBasedEra
AnyShelleyBasedEra ShelleyBasedEra era
sbe)
                )
              (Maybe (ScriptLanguageInEra lang era)
 -> ExceptT CliScriptWitnessError m (ScriptLanguageInEra lang era))
-> Maybe (ScriptLanguageInEra lang era)
-> ExceptT CliScriptWitnessError m (ScriptLanguageInEra lang era)
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era
-> ScriptLanguage lang -> Maybe (ScriptLanguageInEra lang era)
forall era lang.
ShelleyBasedEra era
-> ScriptLanguage lang -> Maybe (ScriptLanguageInEra lang era)
scriptLanguageSupportedInEra ShelleyBasedEra era
sbe
              (ScriptLanguage lang -> Maybe (ScriptLanguageInEra lang era))
-> ScriptLanguage lang -> Maybe (ScriptLanguageInEra lang era)
forall a b. (a -> b) -> a -> b
$ PlutusScriptVersion lang -> ScriptLanguage lang
forall lang.
IsPlutusScriptLanguage lang =>
PlutusScriptVersion lang -> ScriptLanguage lang
PlutusScriptLanguage PlutusScriptVersion lang
lang
          CertificateScriptWitness era -> t m (CertificateScriptWitness era)
forall a. a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CertificateScriptWitness era
 -> t m (CertificateScriptWitness era))
-> CertificateScriptWitness era
-> t m (CertificateScriptWitness era)
forall a b. (a -> b) -> a -> b
$
            ScriptWitness WitCtxStake era -> CertificateScriptWitness era
forall era.
ScriptWitness WitCtxStake era -> CertificateScriptWitness era
CertificateScriptWitness (ScriptWitness WitCtxStake era -> CertificateScriptWitness era)
-> ScriptWitness WitCtxStake era -> CertificateScriptWitness era
forall a b. (a -> b) -> a -> b
$
              ScriptLanguageInEra lang era
-> PlutusScriptVersion lang
-> PlutusScriptOrReferenceInput lang
-> ScriptDatum WitCtxStake
-> HashableScriptData
-> ExecutionUnits
-> ScriptWitness WitCtxStake era
forall lang era witctx.
IsPlutusScriptLanguage lang =>
ScriptLanguageInEra lang era
-> PlutusScriptVersion lang
-> PlutusScriptOrReferenceInput lang
-> ScriptDatum witctx
-> HashableScriptData
-> ExecutionUnits
-> ScriptWitness witctx era
PlutusScriptWitness
                ScriptLanguageInEra lang era
sLangSupported
                PlutusScriptVersion lang
lang
                PlutusScriptOrReferenceInput lang
pScript
                ScriptDatum WitCtxStake
NoScriptDatumForStake
                HashableScriptData
redeemer
                ExecutionUnits
execUnits
    OnDiskPlutusRefScript (PlutusRefScriptCliArgs TxIn
refTxIn AnyPlutusScriptVersion
anyPlutusScriptVersion ScriptDataOrFile
redeemerFile ExecutionUnits
execUnits) -> do
      case AnyPlutusScriptVersion
anyPlutusScriptVersion of
        AnyPlutusScriptVersion PlutusScriptVersion lang
lang -> do
          let pScript :: PlutusScriptOrReferenceInput lang
pScript = TxIn -> PlutusScriptOrReferenceInput lang
forall lang. TxIn -> PlutusScriptOrReferenceInput lang
PReferenceScript TxIn
refTxIn
          HashableScriptData
redeemer <-
            -- TODO: Implement a new error type to capture this. FileError is not representative of cases
            -- where we do not have access to the script.
            (ScriptDataError -> FileError CliScriptWitnessError)
-> ExceptT ScriptDataError m HashableScriptData
-> t m HashableScriptData
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError
              ( FilePath
-> CliScriptWitnessError -> FileError CliScriptWitnessError
forall e. FilePath -> e -> FileError e
FileError FilePath
"Reference script filepath not available"
                  (CliScriptWitnessError -> FileError CliScriptWitnessError)
-> (ScriptDataError -> CliScriptWitnessError)
-> ScriptDataError
-> FileError CliScriptWitnessError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptDataError -> CliScriptWitnessError
PlutusScriptWitnessRedeemerError
              )
              (ExceptT ScriptDataError m HashableScriptData
 -> t m HashableScriptData)
-> ExceptT ScriptDataError m HashableScriptData
-> t m HashableScriptData
forall a b. (a -> b) -> a -> b
$ ScriptDataOrFile -> ExceptT ScriptDataError m HashableScriptData
forall (m :: * -> *).
MonadIO m =>
ScriptDataOrFile -> ExceptT ScriptDataError m HashableScriptData
readScriptDataOrFile ScriptDataOrFile
redeemerFile
          ScriptLanguageInEra lang era
sLangSupported <-
            -- TODO: Implement a new error type to capture this. FileError is not representative of cases
            -- where we do not have access to the script.
            (CliScriptWitnessError -> FileError CliScriptWitnessError)
-> ExceptT CliScriptWitnessError m (ScriptLanguageInEra lang era)
-> t m (ScriptLanguageInEra lang era)
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError (FilePath
-> CliScriptWitnessError -> FileError CliScriptWitnessError
forall e. FilePath -> e -> FileError e
FileError FilePath
"Reference script filepath not available")
              (ExceptT CliScriptWitnessError m (ScriptLanguageInEra lang era)
 -> t m (ScriptLanguageInEra lang era))
-> ExceptT CliScriptWitnessError m (ScriptLanguageInEra lang era)
-> t m (ScriptLanguageInEra lang era)
forall a b. (a -> b) -> a -> b
$ CliScriptWitnessError
-> Maybe (ScriptLanguageInEra lang era)
-> ExceptT CliScriptWitnessError m (ScriptLanguageInEra lang era)
forall (m :: * -> *) x a. Monad m => x -> Maybe a -> ExceptT x m a
hoistMaybe
                ( AnyPlutusScriptVersion
-> AnyShelleyBasedEra -> CliScriptWitnessError
PlutusScriptWitnessLanguageNotSupportedInEra
                    (PlutusScriptVersion lang -> AnyPlutusScriptVersion
forall lang.
IsPlutusScriptLanguage lang =>
PlutusScriptVersion lang -> AnyPlutusScriptVersion
AnyPlutusScriptVersion PlutusScriptVersion lang
lang)
                    (ShelleyBasedEra era
-> (ShelleyBasedEraConstraints era => AnyShelleyBasedEra)
-> AnyShelleyBasedEra
forall era a.
ShelleyBasedEra era -> (ShelleyBasedEraConstraints era => a) -> a
shelleyBasedEraConstraints ShelleyBasedEra era
sbe ((ShelleyBasedEraConstraints era => AnyShelleyBasedEra)
 -> AnyShelleyBasedEra)
-> (ShelleyBasedEraConstraints era => AnyShelleyBasedEra)
-> AnyShelleyBasedEra
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era -> AnyShelleyBasedEra
forall era.
Typeable era =>
ShelleyBasedEra era -> AnyShelleyBasedEra
AnyShelleyBasedEra ShelleyBasedEra era
sbe)
                )
              (Maybe (ScriptLanguageInEra lang era)
 -> ExceptT CliScriptWitnessError m (ScriptLanguageInEra lang era))
-> Maybe (ScriptLanguageInEra lang era)
-> ExceptT CliScriptWitnessError m (ScriptLanguageInEra lang era)
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era
-> ScriptLanguage lang -> Maybe (ScriptLanguageInEra lang era)
forall era lang.
ShelleyBasedEra era
-> ScriptLanguage lang -> Maybe (ScriptLanguageInEra lang era)
scriptLanguageSupportedInEra ShelleyBasedEra era
sbe
              (ScriptLanguage lang -> Maybe (ScriptLanguageInEra lang era))
-> ScriptLanguage lang -> Maybe (ScriptLanguageInEra lang era)
forall a b. (a -> b) -> a -> b
$ PlutusScriptVersion lang -> ScriptLanguage lang
forall lang.
IsPlutusScriptLanguage lang =>
PlutusScriptVersion lang -> ScriptLanguage lang
PlutusScriptLanguage PlutusScriptVersion lang
lang

          CertificateScriptWitness era -> t m (CertificateScriptWitness era)
forall a. a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CertificateScriptWitness era
 -> t m (CertificateScriptWitness era))
-> CertificateScriptWitness era
-> t m (CertificateScriptWitness era)
forall a b. (a -> b) -> a -> b
$
            ScriptWitness WitCtxStake era -> CertificateScriptWitness era
forall era.
ScriptWitness WitCtxStake era -> CertificateScriptWitness era
CertificateScriptWitness (ScriptWitness WitCtxStake era -> CertificateScriptWitness era)
-> ScriptWitness WitCtxStake era -> CertificateScriptWitness era
forall a b. (a -> b) -> a -> b
$
              ScriptLanguageInEra lang era
-> PlutusScriptVersion lang
-> PlutusScriptOrReferenceInput lang
-> ScriptDatum WitCtxStake
-> HashableScriptData
-> ExecutionUnits
-> ScriptWitness WitCtxStake era
forall lang era witctx.
IsPlutusScriptLanguage lang =>
ScriptLanguageInEra lang era
-> PlutusScriptVersion lang
-> PlutusScriptOrReferenceInput lang
-> ScriptDatum witctx
-> HashableScriptData
-> ExecutionUnits
-> ScriptWitness witctx era
PlutusScriptWitness
                ScriptLanguageInEra lang era
sLangSupported
                PlutusScriptVersion lang
lang
                PlutusScriptOrReferenceInput lang
pScript
                ScriptDatum WitCtxStake
NoScriptDatumForStake
                HashableScriptData
redeemer
                ExecutionUnits
execUnits