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

module Cardano.CLI.EraBased.Script.Withdrawal.Read
  ( readWithdrawalScriptWitness
  )
where

import Cardano.Api
import Cardano.Api.Ledger
import Cardano.Api.Shelley

import Cardano.CLI.EraBased.Script.Read.Common
import Cardano.CLI.EraBased.Script.Type
import Cardano.CLI.EraBased.Script.Withdrawal.Type

readWithdrawalScriptWitness
  :: MonadIOTransError (FileError CliScriptWitnessError) t m
  => ShelleyBasedEra era
  -> (StakeAddress, Coin, Maybe CliWithdrawalScriptRequirements)
  -> t m (StakeAddress, Coin, Maybe (WithdrawalScriptWitness era))
readWithdrawalScriptWitness :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) era.
MonadIOTransError (FileError CliScriptWitnessError) t m =>
ShelleyBasedEra era
-> (StakeAddress, Coin, Maybe CliWithdrawalScriptRequirements)
-> t m (StakeAddress, Coin, Maybe (WithdrawalScriptWitness era))
readWithdrawalScriptWitness ShelleyBasedEra era
_ (StakeAddress
stakeAddr, Coin
withdrawalAmt, Maybe CliWithdrawalScriptRequirements
Nothing) =
  (StakeAddress, Coin, Maybe (WithdrawalScriptWitness era))
-> t m (StakeAddress, Coin, Maybe (WithdrawalScriptWitness era))
forall a. a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return (StakeAddress
stakeAddr, Coin
withdrawalAmt, Maybe (WithdrawalScriptWitness era)
forall a. Maybe a
Nothing)
readWithdrawalScriptWitness ShelleyBasedEra era
sbe (StakeAddress
stakeAddr, Coin
withdrawalAmt, Just CliWithdrawalScriptRequirements
certScriptReq) = do
  case CliWithdrawalScriptRequirements
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
          (StakeAddress, Coin, Maybe (WithdrawalScriptWitness era))
-> t m (StakeAddress, Coin, Maybe (WithdrawalScriptWitness era))
forall a. a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return
            ( StakeAddress
stakeAddr
            , Coin
withdrawalAmt
            , WithdrawalScriptWitness era -> Maybe (WithdrawalScriptWitness era)
forall a. a -> Maybe a
Just (WithdrawalScriptWitness era
 -> Maybe (WithdrawalScriptWitness era))
-> WithdrawalScriptWitness era
-> Maybe (WithdrawalScriptWitness era)
forall a b. (a -> b) -> a -> b
$
                ScriptWitness WitCtxStake era -> WithdrawalScriptWitness era
forall era.
ScriptWitness WitCtxStake era -> WithdrawalScriptWitness era
WithdrawalScriptWitness
                  ( 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
          (StakeAddress, Coin, Maybe (WithdrawalScriptWitness era))
-> t m (StakeAddress, Coin, Maybe (WithdrawalScriptWitness era))
forall a. a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return
            ( StakeAddress
stakeAddr
            , Coin
withdrawalAmt
            , WithdrawalScriptWitness era -> Maybe (WithdrawalScriptWitness era)
forall a. a -> Maybe a
Just (WithdrawalScriptWitness era
 -> Maybe (WithdrawalScriptWitness era))
-> WithdrawalScriptWitness era
-> Maybe (WithdrawalScriptWitness era)
forall a b. (a -> b) -> a -> b
$
                ScriptWitness WitCtxStake era -> WithdrawalScriptWitness era
forall era.
ScriptWitness WitCtxStake era -> WithdrawalScriptWitness era
WithdrawalScriptWitness (ScriptWitness WitCtxStake era -> WithdrawalScriptWitness era)
-> ScriptWitness WitCtxStake era -> WithdrawalScriptWitness 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

          (StakeAddress, Coin, Maybe (WithdrawalScriptWitness era))
-> t m (StakeAddress, Coin, Maybe (WithdrawalScriptWitness era))
forall a. a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return
            ( StakeAddress
stakeAddr
            , Coin
withdrawalAmt
            , WithdrawalScriptWitness era -> Maybe (WithdrawalScriptWitness era)
forall a. a -> Maybe a
Just (WithdrawalScriptWitness era
 -> Maybe (WithdrawalScriptWitness era))
-> WithdrawalScriptWitness era
-> Maybe (WithdrawalScriptWitness era)
forall a b. (a -> b) -> a -> b
$
                ScriptWitness WitCtxStake era -> WithdrawalScriptWitness era
forall era.
ScriptWitness WitCtxStake era -> WithdrawalScriptWitness era
WithdrawalScriptWitness (ScriptWitness WitCtxStake era -> WithdrawalScriptWitness era)
-> ScriptWitness WitCtxStake era -> WithdrawalScriptWitness 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
            )