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

module Cardano.CLI.Compatible.Transaction.ScriptWitness
  ( readCertificateScriptWitness
  , readCertificateScriptWitnesses
  )
where

import Cardano.Api
  ( AnyPlutusScriptVersion (..)
  , AnyShelleyBasedEra (..)
  , File (..)
  , PlutusScriptOrReferenceInput (..)
  , Script (..)
  , ScriptDatum (..)
  , ScriptLanguage (..)
  , ScriptWitness (..)
  , ShelleyBasedEra
  , SimpleScriptOrReferenceInput (..)
  , sbeToSimpleScriptLanguageInEra
  , scriptLanguageSupportedInEra
  , shelleyBasedEraConstraints
  )
import Cardano.Api.Experimental qualified as Exp

import Cardano.CLI.Compatible.Exception
import Cardano.CLI.EraBased.Script.Certificate.Type
import Cardano.CLI.EraBased.Script.Read.Common
import Cardano.CLI.EraBased.Script.Type
import Cardano.CLI.EraBased.Script.Type qualified as Exp
import Cardano.CLI.Read
import Cardano.CLI.Type.Common (CertificateFile)

import Control.Monad

readCertificateScriptWitnesses
  :: ShelleyBasedEra era
  -> [(CertificateFile, Maybe (ScriptRequirements Exp.CertItem))]
  -> CIO e [(CertificateFile, Maybe (CertificateScriptWitness era))]
readCertificateScriptWitnesses :: forall era e.
ShelleyBasedEra era
-> [(CertificateFile, Maybe (ScriptRequirements 'CertItem))]
-> CIO e [(CertificateFile, Maybe (CertificateScriptWitness era))]
readCertificateScriptWitnesses ShelleyBasedEra era
sbe =
  ((CertificateFile, Maybe (ScriptRequirements 'CertItem))
 -> RIO e (CertificateFile, Maybe (CertificateScriptWitness era)))
-> [(CertificateFile, Maybe (ScriptRequirements 'CertItem))]
-> RIO e [(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 (ScriptRequirements 'CertItem)
mSWit) -> do
        (CertificateFile
certFile,) (Maybe (CertificateScriptWitness era)
 -> (CertificateFile, Maybe (CertificateScriptWitness era)))
-> RIO e (Maybe (CertificateScriptWitness era))
-> RIO e (CertificateFile, Maybe (CertificateScriptWitness era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (ScriptRequirements 'CertItem)
-> (ScriptRequirements 'CertItem
    -> RIO e (CertificateScriptWitness era))
-> RIO e (Maybe (CertificateScriptWitness era))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (ScriptRequirements 'CertItem)
mSWit (ShelleyBasedEra era
-> ScriptRequirements 'CertItem
-> CIO e (CertificateScriptWitness era)
forall era e.
ShelleyBasedEra era
-> ScriptRequirements 'CertItem
-> CIO e (CertificateScriptWitness era)
readCertificateScriptWitness ShelleyBasedEra era
sbe)
    )

readCertificateScriptWitness
  :: ShelleyBasedEra era -> ScriptRequirements Exp.CertItem -> CIO e (CertificateScriptWitness era)
readCertificateScriptWitness :: forall era e.
ShelleyBasedEra era
-> ScriptRequirements 'CertItem
-> CIO e (CertificateScriptWitness era)
readCertificateScriptWitness ShelleyBasedEra era
sbe ScriptRequirements 'CertItem
certScriptReq =
  case ScriptRequirements 'CertItem
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 <-
        FilePath -> CIO e (Script SimpleScript')
forall e. FilePath -> CIO e (Script SimpleScript')
readFileSimpleScript FilePath
sFp
      case Script SimpleScript'
s of
        SimpleScript SimpleScript
ss -> do
          CertificateScriptWitness era
-> RIO e (CertificateScriptWitness era)
forall a. a -> RIO e a
forall (m :: * -> *) a. Monad m => a -> m a
return (CertificateScriptWitness era
 -> RIO e (CertificateScriptWitness era))
-> CertificateScriptWitness era
-> RIO e (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 NoScriptDatum
OptionalDatum 'CertItem
Exp.NoScriptDatumAllowed 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 <-
          FilePath -> CIO e AnyPlutusScript
forall e. FilePath -> CIO e AnyPlutusScript
readFilePlutusScript FilePath
plutusScriptFp
        HashableScriptData
redeemer <-
          ExceptT ScriptDataError IO HashableScriptData
-> RIO e HashableScriptData
forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
ExceptT e IO a -> m a
fromExceptTCli (ExceptT ScriptDataError IO HashableScriptData
 -> RIO e HashableScriptData)
-> ExceptT ScriptDataError IO HashableScriptData
-> RIO e HashableScriptData
forall a b. (a -> b) -> a -> b
$
            ScriptDataOrFile -> ExceptT ScriptDataError IO 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
-> Maybe (ScriptLanguageInEra lang era)
-> CIO e (ScriptLanguageInEra lang era)
forall err a e.
(Show err, Typeable err, Error err) =>
err -> Maybe a -> CIO e a
fromMaybeCli
                ( 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)
 -> CIO e (ScriptLanguageInEra lang era))
-> Maybe (ScriptLanguageInEra lang era)
-> CIO e (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
-> RIO e (CertificateScriptWitness era)
forall a. a -> RIO e a
forall (m :: * -> *) a. Monad m => a -> m a
return (CertificateScriptWitness era
 -> RIO e (CertificateScriptWitness era))
-> CertificateScriptWitness era
-> RIO e (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
    SimpleReferenceScript (SimpleRefScriptArgs TxIn
refTxIn NoPolicyId
MintPolicyId 'CertItem
NoPolicyId) ->
      CertificateScriptWitness era
-> RIO e (CertificateScriptWitness era)
forall a. a -> RIO e a
forall (m :: * -> *) a. Monad m => a -> m a
return (CertificateScriptWitness era
 -> RIO e (CertificateScriptWitness era))
-> CertificateScriptWitness era
-> RIO e (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)
            (TxIn -> SimpleScriptOrReferenceInput SimpleScript'
forall lang. TxIn -> SimpleScriptOrReferenceInput lang
SReferenceScript TxIn
refTxIn)
    PlutusReferenceScript
      ( PlutusRefScriptCliArgs
          TxIn
refTxIn
          AnyPlutusScriptVersion
anyPlutusScriptVersion
          NoScriptDatum
OptionalDatum 'CertItem
Exp.NoScriptDatumAllowed
          NoPolicyId
MintPolicyId 'CertItem
Exp.NoPolicyId
          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 <-
              ExceptT ScriptDataError IO HashableScriptData
-> RIO e HashableScriptData
forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
ExceptT e IO a -> m a
fromExceptTCli (ExceptT ScriptDataError IO HashableScriptData
 -> RIO e HashableScriptData)
-> ExceptT ScriptDataError IO HashableScriptData
-> RIO e HashableScriptData
forall a b. (a -> b) -> a -> b
$
                ScriptDataOrFile -> ExceptT ScriptDataError IO HashableScriptData
forall (m :: * -> *).
MonadIO m =>
ScriptDataOrFile -> ExceptT ScriptDataError m HashableScriptData
readScriptDataOrFile ScriptDataOrFile
redeemerFile
            ScriptLanguageInEra lang era
sLangSupported <-
              CliScriptWitnessError
-> Maybe (ScriptLanguageInEra lang era)
-> CIO e (ScriptLanguageInEra lang era)
forall err a e.
(Show err, Typeable err, Error err) =>
err -> Maybe a -> CIO e a
fromMaybeCli
                ( 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)
 -> CIO e (ScriptLanguageInEra lang era))
-> Maybe (ScriptLanguageInEra lang era)
-> CIO e (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
-> RIO e (CertificateScriptWitness era)
forall a. a -> RIO e a
forall (m :: * -> *) a. Monad m => a -> m a
return (CertificateScriptWitness era
 -> RIO e (CertificateScriptWitness era))
-> CertificateScriptWitness era
-> RIO e (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