-- | This module exposes the generation of key and script witnesses
module Cooked.MockChain.GenerateTx.Witness
  ( toScriptWitness,
    toKeyWitness,
  )
where

import Cardano.Api qualified as Cardano
import Cooked.MockChain.Error
import Cooked.MockChain.Read
import Cooked.Skeleton
import Ledger.Address qualified as Ledger
import Ledger.Tx.CardanoAPI qualified as Ledger
import Optics.Core
import Plutus.Script.Utils.Scripts qualified as Script
import PlutusLedgerApi.V3 qualified as Api
import Polysemy
import Polysemy.Error

-- | Translates a script and a reference script utxo into either a plutus script
-- or a reference input containing the right script
toPlutusScriptOrReferenceInput ::
  (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError] effs) =>
  VScript ->
  Maybe Api.TxOutRef ->
  Sem effs (Cardano.PlutusScriptOrReferenceInput lang)
toPlutusScriptOrReferenceInput :: forall (effs :: EffectRow) lang.
Members
  '[MockChainRead, Error MockChainError, Error ToCardanoError]
  effs =>
VScript
-> Maybe TxOutRef -> Sem effs (PlutusScriptOrReferenceInput lang)
toPlutusScriptOrReferenceInput (Script.Versioned (Script.Script SerialisedScript
script) Language
_) Maybe TxOutRef
Nothing =
  PlutusScriptOrReferenceInput lang
-> Sem effs (PlutusScriptOrReferenceInput lang)
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (PlutusScriptOrReferenceInput lang
 -> Sem effs (PlutusScriptOrReferenceInput lang))
-> PlutusScriptOrReferenceInput lang
-> Sem effs (PlutusScriptOrReferenceInput lang)
forall a b. (a -> b) -> a -> b
$ PlutusScript lang -> PlutusScriptOrReferenceInput lang
forall lang. PlutusScript lang -> PlutusScriptOrReferenceInput lang
Cardano.PScript (PlutusScript lang -> PlutusScriptOrReferenceInput lang)
-> PlutusScript lang -> PlutusScriptOrReferenceInput lang
forall a b. (a -> b) -> a -> b
$ SerialisedScript -> PlutusScript lang
forall lang. SerialisedScript -> PlutusScript lang
Cardano.PlutusScriptSerialised SerialisedScript
script
toPlutusScriptOrReferenceInput (VScript -> ScriptHash
forall a. ToScriptHash a => a -> ScriptHash
Script.toScriptHash -> ScriptHash
scriptHash) (Just TxOutRef
scriptOutRef) = do
  (Optic' An_AffineFold NoIx TxSkelOut ScriptHash
-> TxSkelOut -> Maybe ScriptHash
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview Optic' An_AffineFold NoIx TxSkelOut ScriptHash
txSkelOutReferenceScriptHashAF -> Maybe ScriptHash
mScriptHash) <- TxOutRef -> Sem effs TxSkelOut
forall (effs :: EffectRow).
Member MockChainRead effs =>
TxOutRef -> Sem effs TxSkelOut
txSkelOutByRef TxOutRef
scriptOutRef
  case Maybe ScriptHash
mScriptHash of
    Just ScriptHash
scriptHash'
      | ScriptHash
scriptHash ScriptHash -> ScriptHash -> Bool
forall a. Eq a => a -> a -> Bool
== ScriptHash
scriptHash' -> do
          TxIn
s <- Either ToCardanoError TxIn -> Sem effs TxIn
forall e (r :: EffectRow) a.
Member (Error e) r =>
Either e a -> Sem r a
fromEither (Either ToCardanoError TxIn -> Sem effs TxIn)
-> Either ToCardanoError TxIn -> Sem effs TxIn
forall a b. (a -> b) -> a -> b
$ TxOutRef -> Either ToCardanoError TxIn
Ledger.toCardanoTxIn TxOutRef
scriptOutRef
          PlutusScriptOrReferenceInput lang
-> Sem effs (PlutusScriptOrReferenceInput lang)
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (PlutusScriptOrReferenceInput lang
 -> Sem effs (PlutusScriptOrReferenceInput lang))
-> PlutusScriptOrReferenceInput lang
-> Sem effs (PlutusScriptOrReferenceInput lang)
forall a b. (a -> b) -> a -> b
$ TxIn -> PlutusScriptOrReferenceInput lang
forall lang. TxIn -> PlutusScriptOrReferenceInput lang
Cardano.PReferenceScript TxIn
s
    Maybe ScriptHash
_ -> MockChainError -> Sem effs (PlutusScriptOrReferenceInput lang)
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (MockChainError -> Sem effs (PlutusScriptOrReferenceInput lang))
-> MockChainError -> Sem effs (PlutusScriptOrReferenceInput lang)
forall a b. (a -> b) -> a -> b
$ TxOutRef -> ScriptHash -> Maybe ScriptHash -> MockChainError
MCEWrongReferenceScriptError TxOutRef
scriptOutRef ScriptHash
scriptHash Maybe ScriptHash
mScriptHash

-- | Translates a script with its associated redeemer and datum to a script
-- witness. Note on the usage of 'Ledger.zeroExecutionUnits': at this stage of
-- the transaction create, we cannot know the execution units used by the
-- script. They will be filled out later on once the full body has been
-- generated. So, for now, we temporarily leave them to 0.
toScriptWitness ::
  ( Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError] effs,
    ToVScript a
  ) =>
  a ->
  TxSkelRedeemer ->
  Cardano.ScriptDatum b ->
  Sem effs (Cardano.ScriptWitness b Cardano.ConwayEra)
toScriptWitness :: forall (effs :: EffectRow) a b.
(Members
   '[MockChainRead, Error MockChainError, Error ToCardanoError] effs,
 ToVScript a) =>
a
-> TxSkelRedeemer
-> ScriptDatum b
-> Sem effs (ScriptWitness b ConwayEra)
toScriptWitness (a -> VScript
forall script. ToVScript script => script -> VScript
toVScript -> script :: VScript
script@(Script.Versioned Script
_ Language
version)) (TxSkelRedeemer {redeemer
Bool
Maybe TxOutRef
txSkelRedeemerContent :: redeemer
txSkelRedeemerReferenceInput :: Maybe TxOutRef
txSkelRedeemerAutoFill :: Bool
txSkelRedeemerContent :: ()
txSkelRedeemerReferenceInput :: TxSkelRedeemer -> Maybe TxOutRef
txSkelRedeemerAutoFill :: TxSkelRedeemer -> Bool
..}) ScriptDatum b
datum = do
  let scriptData :: HashableScriptData
scriptData = BuiltinData -> HashableScriptData
Ledger.toCardanoScriptData (BuiltinData -> HashableScriptData)
-> BuiltinData -> HashableScriptData
forall a b. (a -> b) -> a -> b
$ redeemer -> BuiltinData
forall a. ToData a => a -> BuiltinData
Api.toBuiltinData redeemer
txSkelRedeemerContent
  case Language
version of
    Language
Script.PlutusV1 ->
      (\PlutusScriptOrReferenceInput PlutusScriptV1
x -> ScriptLanguageInEra PlutusScriptV1 ConwayEra
-> PlutusScriptVersion PlutusScriptV1
-> PlutusScriptOrReferenceInput PlutusScriptV1
-> ScriptDatum b
-> HashableScriptData
-> ExecutionUnits
-> ScriptWitness b ConwayEra
forall lang era witctx.
IsPlutusScriptLanguage lang =>
ScriptLanguageInEra lang era
-> PlutusScriptVersion lang
-> PlutusScriptOrReferenceInput lang
-> ScriptDatum witctx
-> HashableScriptData
-> ExecutionUnits
-> ScriptWitness witctx era
Cardano.PlutusScriptWitness ScriptLanguageInEra PlutusScriptV1 ConwayEra
Cardano.PlutusScriptV1InConway PlutusScriptVersion PlutusScriptV1
Cardano.PlutusScriptV1 PlutusScriptOrReferenceInput PlutusScriptV1
x ScriptDatum b
datum HashableScriptData
scriptData ExecutionUnits
Ledger.zeroExecutionUnits)
        (PlutusScriptOrReferenceInput PlutusScriptV1
 -> ScriptWitness b ConwayEra)
-> Sem effs (PlutusScriptOrReferenceInput PlutusScriptV1)
-> Sem effs (ScriptWitness b ConwayEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VScript
-> Maybe TxOutRef
-> Sem effs (PlutusScriptOrReferenceInput PlutusScriptV1)
forall (effs :: EffectRow) lang.
Members
  '[MockChainRead, Error MockChainError, Error ToCardanoError]
  effs =>
VScript
-> Maybe TxOutRef -> Sem effs (PlutusScriptOrReferenceInput lang)
toPlutusScriptOrReferenceInput VScript
script Maybe TxOutRef
txSkelRedeemerReferenceInput
    Language
Script.PlutusV2 ->
      (\PlutusScriptOrReferenceInput PlutusScriptV2
x -> ScriptLanguageInEra PlutusScriptV2 ConwayEra
-> PlutusScriptVersion PlutusScriptV2
-> PlutusScriptOrReferenceInput PlutusScriptV2
-> ScriptDatum b
-> HashableScriptData
-> ExecutionUnits
-> ScriptWitness b ConwayEra
forall lang era witctx.
IsPlutusScriptLanguage lang =>
ScriptLanguageInEra lang era
-> PlutusScriptVersion lang
-> PlutusScriptOrReferenceInput lang
-> ScriptDatum witctx
-> HashableScriptData
-> ExecutionUnits
-> ScriptWitness witctx era
Cardano.PlutusScriptWitness ScriptLanguageInEra PlutusScriptV2 ConwayEra
Cardano.PlutusScriptV2InConway PlutusScriptVersion PlutusScriptV2
Cardano.PlutusScriptV2 PlutusScriptOrReferenceInput PlutusScriptV2
x ScriptDatum b
datum HashableScriptData
scriptData ExecutionUnits
Ledger.zeroExecutionUnits)
        (PlutusScriptOrReferenceInput PlutusScriptV2
 -> ScriptWitness b ConwayEra)
-> Sem effs (PlutusScriptOrReferenceInput PlutusScriptV2)
-> Sem effs (ScriptWitness b ConwayEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VScript
-> Maybe TxOutRef
-> Sem effs (PlutusScriptOrReferenceInput PlutusScriptV2)
forall (effs :: EffectRow) lang.
Members
  '[MockChainRead, Error MockChainError, Error ToCardanoError]
  effs =>
VScript
-> Maybe TxOutRef -> Sem effs (PlutusScriptOrReferenceInput lang)
toPlutusScriptOrReferenceInput VScript
script Maybe TxOutRef
txSkelRedeemerReferenceInput
    Language
Script.PlutusV3 ->
      (\PlutusScriptOrReferenceInput PlutusScriptV3
x -> ScriptLanguageInEra PlutusScriptV3 ConwayEra
-> PlutusScriptVersion PlutusScriptV3
-> PlutusScriptOrReferenceInput PlutusScriptV3
-> ScriptDatum b
-> HashableScriptData
-> ExecutionUnits
-> ScriptWitness b ConwayEra
forall lang era witctx.
IsPlutusScriptLanguage lang =>
ScriptLanguageInEra lang era
-> PlutusScriptVersion lang
-> PlutusScriptOrReferenceInput lang
-> ScriptDatum witctx
-> HashableScriptData
-> ExecutionUnits
-> ScriptWitness witctx era
Cardano.PlutusScriptWitness ScriptLanguageInEra PlutusScriptV3 ConwayEra
Cardano.PlutusScriptV3InConway PlutusScriptVersion PlutusScriptV3
Cardano.PlutusScriptV3 PlutusScriptOrReferenceInput PlutusScriptV3
x ScriptDatum b
datum HashableScriptData
scriptData ExecutionUnits
Ledger.zeroExecutionUnits)
        (PlutusScriptOrReferenceInput PlutusScriptV3
 -> ScriptWitness b ConwayEra)
-> Sem effs (PlutusScriptOrReferenceInput PlutusScriptV3)
-> Sem effs (ScriptWitness b ConwayEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VScript
-> Maybe TxOutRef
-> Sem effs (PlutusScriptOrReferenceInput PlutusScriptV3)
forall (effs :: EffectRow) lang.
Members
  '[MockChainRead, Error MockChainError, Error ToCardanoError]
  effs =>
VScript
-> Maybe TxOutRef -> Sem effs (PlutusScriptOrReferenceInput lang)
toPlutusScriptOrReferenceInput VScript
script Maybe TxOutRef
txSkelRedeemerReferenceInput

-- | Generates a key witnesses for a given signatory and body, when the
-- signatory contains a private key.
toKeyWitness ::
  Cardano.TxBody Cardano.ConwayEra ->
  TxSkelSignatory ->
  Maybe (Cardano.KeyWitness Cardano.ConwayEra)
toKeyWitness :: TxBody ConwayEra -> TxSkelSignatory -> Maybe (KeyWitness ConwayEra)
toKeyWitness TxBody ConwayEra
txBody =
  (XPrv -> KeyWitness ConwayEra)
-> Maybe XPrv -> Maybe (KeyWitness ConwayEra)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    ( ShelleyBasedEra ConwayEra
-> TxBody ConwayEra
-> ShelleyWitnessSigningKey
-> KeyWitness ConwayEra
forall era.
ShelleyBasedEra era
-> TxBody era -> ShelleyWitnessSigningKey -> KeyWitness era
Cardano.makeShelleyKeyWitness ShelleyBasedEra ConwayEra
Cardano.ShelleyBasedEraConway TxBody ConwayEra
txBody
        (ShelleyWitnessSigningKey -> KeyWitness ConwayEra)
-> (XPrv -> ShelleyWitnessSigningKey)
-> XPrv
-> KeyWitness ConwayEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PaymentPrivateKey -> ShelleyWitnessSigningKey
forall a. ToWitness a => a -> ShelleyWitnessSigningKey
Ledger.toWitness
        (PaymentPrivateKey -> ShelleyWitnessSigningKey)
-> (XPrv -> PaymentPrivateKey) -> XPrv -> ShelleyWitnessSigningKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPrv -> PaymentPrivateKey
Ledger.PaymentPrivateKey
    )
    (Maybe XPrv -> Maybe (KeyWitness ConwayEra))
-> (TxSkelSignatory -> Maybe XPrv)
-> TxSkelSignatory
-> Maybe (KeyWitness ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic' An_AffineTraversal NoIx TxSkelSignatory XPrv
-> TxSkelSignatory -> Maybe XPrv
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview Optic' An_AffineTraversal NoIx TxSkelSignatory XPrv
txSkelSignatoryPrivateKeyAT