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

module Cardano.CLI.EraBased.Script.Vote.Read
  ( readVotingProceduresFiles
  , readVoteScriptWitness
  )
where

import Cardano.Api
import Cardano.Api.Experimental qualified as Exp

import Cardano.CLI.Compatible.Exception
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.EraBased.Script.Vote.Type (VoteScriptWitness (..))
import Cardano.CLI.Read
import Cardano.CLI.Type.Governance

import Control.Monad

readVoteScriptWitness
  :: ConwayEraOnwards era
  -> (VoteFile In, Maybe (ScriptRequirements Exp.VoterItem))
  -> CIO e (VotingProcedures era, Maybe (VoteScriptWitness era))
readVoteScriptWitness :: forall era e.
ConwayEraOnwards era
-> (VoteFile 'In, Maybe (ScriptRequirements 'VoterItem))
-> CIO e (VotingProcedures era, Maybe (VoteScriptWitness era))
readVoteScriptWitness ConwayEraOnwards era
w (VoteFile 'In
voteFp, Maybe (ScriptRequirements 'VoterItem)
Nothing) = do
  VotingProcedures era
votProceds <-
    ConwayEraOnwards era
-> (ConwayEraOnwardsConstraints era =>
    RIO e (VotingProcedures era))
-> RIO e (VotingProcedures era)
forall era a.
ConwayEraOnwards era -> (ConwayEraOnwardsConstraints era => a) -> a
conwayEraOnwardsConstraints ConwayEraOnwards era
w ((ConwayEraOnwardsConstraints era => RIO e (VotingProcedures era))
 -> RIO e (VotingProcedures era))
-> (ConwayEraOnwardsConstraints era =>
    RIO e (VotingProcedures era))
-> RIO e (VotingProcedures era)
forall a b. (a -> b) -> a -> b
$
      IO (Either (FileError TextEnvelopeError) (VotingProcedures era))
-> RIO e (VotingProcedures era)
forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
IO (Either e a) -> m a
fromEitherIOCli (IO (Either (FileError TextEnvelopeError) (VotingProcedures era))
 -> RIO e (VotingProcedures era))
-> IO (Either (FileError TextEnvelopeError) (VotingProcedures era))
-> RIO e (VotingProcedures era)
forall a b. (a -> b) -> a -> b
$
        VoteFile 'In
-> IO (Either (FileError TextEnvelopeError) (VotingProcedures era))
forall a content.
HasTextEnvelope a =>
File content 'In -> IO (Either (FileError TextEnvelopeError) a)
readFileTextEnvelope VoteFile 'In
voteFp
  (VotingProcedures era, Maybe (VoteScriptWitness era))
-> RIO e (VotingProcedures era, Maybe (VoteScriptWitness era))
forall a. a -> RIO e a
forall (m :: * -> *) a. Monad m => a -> m a
return (VotingProcedures era
votProceds, Maybe (VoteScriptWitness era)
forall a. Maybe a
Nothing)
readVoteScriptWitness ConwayEraOnwards era
w (VoteFile 'In
voteFp, Just ScriptRequirements 'VoterItem
certScriptReq) = do
  let sbe :: ShelleyBasedEra era
sbe = ConwayEraOnwards era -> ShelleyBasedEra era
forall era. ConwayEraOnwards era -> ShelleyBasedEra era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert ConwayEraOnwards era
w
  VotingProcedures era
votProceds <-
    ConwayEraOnwards era
-> (ConwayEraOnwardsConstraints era =>
    RIO e (VotingProcedures era))
-> RIO e (VotingProcedures era)
forall era a.
ConwayEraOnwards era -> (ConwayEraOnwardsConstraints era => a) -> a
conwayEraOnwardsConstraints ConwayEraOnwards era
w ((ConwayEraOnwardsConstraints era => RIO e (VotingProcedures era))
 -> RIO e (VotingProcedures era))
-> (ConwayEraOnwardsConstraints era =>
    RIO e (VotingProcedures era))
-> RIO e (VotingProcedures era)
forall a b. (a -> b) -> a -> b
$
      IO (Either (FileError TextEnvelopeError) (VotingProcedures era))
-> RIO e (VotingProcedures era)
forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
IO (Either e a) -> m a
fromEitherIOCli (IO (Either (FileError TextEnvelopeError) (VotingProcedures era))
 -> RIO e (VotingProcedures era))
-> IO (Either (FileError TextEnvelopeError) (VotingProcedures era))
-> RIO e (VotingProcedures era)
forall a b. (a -> b) -> a -> b
$
        VoteFile 'In
-> IO (Either (FileError TextEnvelopeError) (VotingProcedures era))
forall a content.
HasTextEnvelope a =>
File content 'In -> IO (Either (FileError TextEnvelopeError) a)
readFileTextEnvelope VoteFile 'In
voteFp
  case ScriptRequirements 'VoterItem
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
          (VotingProcedures era, Maybe (VoteScriptWitness era))
-> RIO e (VotingProcedures era, Maybe (VoteScriptWitness era))
forall a. a -> RIO e a
forall (m :: * -> *) a. Monad m => a -> m a
return
            ( VotingProcedures era
votProceds
            , VoteScriptWitness era -> Maybe (VoteScriptWitness era)
forall a. a -> Maybe a
Just (VoteScriptWitness era -> Maybe (VoteScriptWitness era))
-> VoteScriptWitness era -> Maybe (VoteScriptWitness era)
forall a b. (a -> b) -> a -> b
$
                ScriptWitness WitCtxStake era -> VoteScriptWitness era
forall era. ScriptWitness WitCtxStake era -> VoteScriptWitness era
VoteScriptWitness
                  ( 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 'VoterItem
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
            (VotingProcedures era, Maybe (VoteScriptWitness era))
-> RIO e (VotingProcedures era, Maybe (VoteScriptWitness era))
forall a. a -> RIO e a
forall (m :: * -> *) a. Monad m => a -> m a
return
              ( VotingProcedures era
votProceds
              , VoteScriptWitness era -> Maybe (VoteScriptWitness era)
forall a. a -> Maybe a
Just (VoteScriptWitness era -> Maybe (VoteScriptWitness era))
-> VoteScriptWitness era -> Maybe (VoteScriptWitness era)
forall a b. (a -> b) -> a -> b
$
                  ScriptWitness WitCtxStake era -> VoteScriptWitness era
forall era. ScriptWitness WitCtxStake era -> VoteScriptWitness era
VoteScriptWitness (ScriptWitness WitCtxStake era -> VoteScriptWitness era)
-> ScriptWitness WitCtxStake era -> VoteScriptWitness 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
              )
    PlutusReferenceScript
      ( PlutusRefScriptCliArgs
          TxIn
refTxIn
          AnyPlutusScriptVersion
anyPlutusScriptVersion
          NoScriptDatum
OptionalDatum 'VoterItem
Exp.NoScriptDatumAllowed
          NoPolicyId
MintPolicyId 'VoterItem
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

            (VotingProcedures era, Maybe (VoteScriptWitness era))
-> RIO e (VotingProcedures era, Maybe (VoteScriptWitness era))
forall a. a -> RIO e a
forall (m :: * -> *) a. Monad m => a -> m a
return
              ( VotingProcedures era
votProceds
              , VoteScriptWitness era -> Maybe (VoteScriptWitness era)
forall a. a -> Maybe a
Just (VoteScriptWitness era -> Maybe (VoteScriptWitness era))
-> VoteScriptWitness era -> Maybe (VoteScriptWitness era)
forall a b. (a -> b) -> a -> b
$
                  ScriptWitness WitCtxStake era -> VoteScriptWitness era
forall era. ScriptWitness WitCtxStake era -> VoteScriptWitness era
VoteScriptWitness (ScriptWitness WitCtxStake era -> VoteScriptWitness era)
-> ScriptWitness WitCtxStake era -> VoteScriptWitness 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 MintPolicyId 'VoterItem
_) ->
      (VotingProcedures era, Maybe (VoteScriptWitness era))
-> RIO e (VotingProcedures era, Maybe (VoteScriptWitness era))
forall a. a -> RIO e a
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( VotingProcedures era
votProceds
        , VoteScriptWitness era -> Maybe (VoteScriptWitness era)
forall a. a -> Maybe a
Just (VoteScriptWitness era -> Maybe (VoteScriptWitness era))
-> VoteScriptWitness era -> Maybe (VoteScriptWitness era)
forall a b. (a -> b) -> a -> b
$
            ScriptWitness WitCtxStake era -> VoteScriptWitness era
forall era. ScriptWitness WitCtxStake era -> VoteScriptWitness era
VoteScriptWitness (ScriptWitness WitCtxStake era -> VoteScriptWitness era)
-> ScriptWitness WitCtxStake era -> VoteScriptWitness 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)
        )

-- Because the 'Voter' type is contained only in the 'VotingProcedures'
-- type, we must read a single vote as 'VotingProcedures'. The cli will
-- not read vote files with multiple votes in them because this will
-- complicate the code further in terms of contructing the redeemer map
-- when it comes to script witnessed votes.
readVotingProceduresFiles
  :: ConwayEraOnwards era
  -> [(VoteFile In, Maybe (ScriptRequirements Exp.VoterItem))]
  -> CIO e [(VotingProcedures era, Maybe (VoteScriptWitness era))]
readVotingProceduresFiles :: forall era e.
ConwayEraOnwards era
-> [(VoteFile 'In, Maybe (ScriptRequirements 'VoterItem))]
-> CIO e [(VotingProcedures era, Maybe (VoteScriptWitness era))]
readVotingProceduresFiles ConwayEraOnwards era
w [(VoteFile 'In, Maybe (ScriptRequirements 'VoterItem))]
files =
  [(VoteFile 'In, Maybe (ScriptRequirements 'VoterItem))]
-> ((VoteFile 'In, Maybe (ScriptRequirements 'VoterItem))
    -> RIO e (VotingProcedures era, Maybe (VoteScriptWitness era)))
-> RIO e [(VotingProcedures era, Maybe (VoteScriptWitness era))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(VoteFile 'In, Maybe (ScriptRequirements 'VoterItem))]
files (ConwayEraOnwards era
-> (VoteFile 'In, Maybe (ScriptRequirements 'VoterItem))
-> CIO e (VotingProcedures era, Maybe (VoteScriptWitness era))
forall era e.
ConwayEraOnwards era
-> (VoteFile 'In, Maybe (ScriptRequirements 'VoterItem))
-> CIO e (VotingProcedures era, Maybe (VoteScriptWitness era))
readVoteScriptWitness ConwayEraOnwards era
w)