module Cooked.MockChain.GenerateTx.Witness
  ( toRewardAccount,
    toScriptWitness,
  )
where

import Cardano.Api.Shelley qualified as Cardano hiding (Testnet)
import Cardano.Ledger.Address qualified as Cardano
import Cardano.Ledger.BaseTypes qualified as Cardano
import Cardano.Ledger.Credential qualified as Cardano
import Cardano.Ledger.Crypto qualified as Crypto
import Control.Monad
import Control.Monad.Reader
import Cooked.Conversion
import Cooked.MockChain.GenerateTx.Common
import Cooked.Output
import Cooked.Skeleton
import Data.Map (Map)
import Data.Map qualified as Map
import Ledger.Tx.CardanoAPI qualified as Ledger
import Optics.Core
import Plutus.Script.Utils.Scripts qualified as Script
import PlutusLedgerApi.V3 qualified as Api

type WitnessGen a = TxGen (Map Api.TxOutRef Api.TxOut) a

-- | Translates a given credential to a reward account.
toRewardAccount :: Api.Credential -> WitnessGen (Cardano.RewardAccount Crypto.StandardCrypto)
toRewardAccount :: Credential -> WitnessGen (RewardAccount StandardCrypto)
toRewardAccount Credential
cred =
  Network
-> Credential 'Staking StandardCrypto
-> RewardAccount StandardCrypto
forall c. Network -> Credential 'Staking c -> RewardAccount c
Cardano.RewardAccount Network
Cardano.Testnet (Credential 'Staking StandardCrypto
 -> RewardAccount StandardCrypto)
-> ReaderT
     (Map TxOutRef TxOut)
     (Either GenerateTxError)
     (Credential 'Staking StandardCrypto)
-> WitnessGen (RewardAccount StandardCrypto)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Credential
cred of
    Api.ScriptCredential ScriptHash
scriptHash -> do
      Cardano.ScriptHash ScriptHash StandardCrypto
cHash <-
        String
-> Either ToCardanoError ScriptHash
-> TxGen (Map TxOutRef TxOut) ScriptHash
forall a context.
String -> Either ToCardanoError a -> TxGen context a
throwOnToCardanoError
          String
"toRewardAccount: Unable to convert script hash."
          (ScriptHash -> Either ToCardanoError ScriptHash
Ledger.toCardanoScriptHash ScriptHash
scriptHash)
      Credential 'Staking StandardCrypto
-> ReaderT
     (Map TxOutRef TxOut)
     (Either GenerateTxError)
     (Credential 'Staking StandardCrypto)
forall a.
a -> ReaderT (Map TxOutRef TxOut) (Either GenerateTxError) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Credential 'Staking StandardCrypto
 -> ReaderT
      (Map TxOutRef TxOut)
      (Either GenerateTxError)
      (Credential 'Staking StandardCrypto))
-> Credential 'Staking StandardCrypto
-> ReaderT
     (Map TxOutRef TxOut)
     (Either GenerateTxError)
     (Credential 'Staking StandardCrypto)
forall a b. (a -> b) -> a -> b
$ ScriptHash StandardCrypto -> Credential 'Staking StandardCrypto
forall (kr :: KeyRole) c. ScriptHash c -> Credential kr c
Cardano.ScriptHashObj ScriptHash StandardCrypto
cHash
    Api.PubKeyCredential PubKeyHash
pubkeyHash -> do
      Cardano.StakeKeyHash KeyHash 'Staking StandardCrypto
pkHash <-
        String
-> Either ToCardanoError (Hash StakeKey)
-> TxGen (Map TxOutRef TxOut) (Hash StakeKey)
forall a context.
String -> Either ToCardanoError a -> TxGen context a
throwOnToCardanoError
          String
"toRewardAccount: Unable to convert private key hash."
          (PubKeyHash -> Either ToCardanoError (Hash StakeKey)
Ledger.toCardanoStakeKeyHash PubKeyHash
pubkeyHash)
      Credential 'Staking StandardCrypto
-> ReaderT
     (Map TxOutRef TxOut)
     (Either GenerateTxError)
     (Credential 'Staking StandardCrypto)
forall a.
a -> ReaderT (Map TxOutRef TxOut) (Either GenerateTxError) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Credential 'Staking StandardCrypto
 -> ReaderT
      (Map TxOutRef TxOut)
      (Either GenerateTxError)
      (Credential 'Staking StandardCrypto))
-> Credential 'Staking StandardCrypto
-> ReaderT
     (Map TxOutRef TxOut)
     (Either GenerateTxError)
     (Credential 'Staking StandardCrypto)
forall a b. (a -> b) -> a -> b
$ KeyHash 'Staking StandardCrypto
-> Credential 'Staking StandardCrypto
forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
Cardano.KeyHashObj KeyHash 'Staking StandardCrypto
pkHash

-- | Translates a script and a reference script utxo into either a plutus script
-- or a reference input containing the right script
toPlutusScriptOrReferenceInput :: Script.Versioned Script.Script -> Maybe Api.TxOutRef -> WitnessGen (Cardano.PlutusScriptOrReferenceInput lang)
toPlutusScriptOrReferenceInput :: forall lang.
Versioned Script
-> Maybe TxOutRef -> WitnessGen (PlutusScriptOrReferenceInput lang)
toPlutusScriptOrReferenceInput (Script.Versioned (Script.Script SerialisedScript
script) Language
_) Maybe TxOutRef
Nothing = PlutusScriptOrReferenceInput lang
-> ReaderT
     (Map TxOutRef TxOut)
     (Either GenerateTxError)
     (PlutusScriptOrReferenceInput lang)
forall a.
a -> ReaderT (Map TxOutRef TxOut) (Either GenerateTxError) a
forall (m :: * -> *) a. Monad m => a -> m a
return (PlutusScriptOrReferenceInput lang
 -> ReaderT
      (Map TxOutRef TxOut)
      (Either GenerateTxError)
      (PlutusScriptOrReferenceInput lang))
-> PlutusScriptOrReferenceInput lang
-> ReaderT
     (Map TxOutRef TxOut)
     (Either GenerateTxError)
     (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 Versioned Script
script (Just TxOutRef
scriptOutRef) = do
  Map TxOutRef ScriptHash
referenceScriptsMap <- (Map TxOutRef TxOut -> Map TxOutRef ScriptHash)
-> ReaderT
     (Map TxOutRef TxOut)
     (Either GenerateTxError)
     (Map TxOutRef ScriptHash)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Map TxOutRef TxOut -> Map TxOutRef ScriptHash)
 -> ReaderT
      (Map TxOutRef TxOut)
      (Either GenerateTxError)
      (Map TxOutRef ScriptHash))
-> (Map TxOutRef TxOut -> Map TxOutRef ScriptHash)
-> ReaderT
     (Map TxOutRef TxOut)
     (Either GenerateTxError)
     (Map TxOutRef ScriptHash)
forall a b. (a -> b) -> a -> b
$ (TxOut -> Maybe ScriptHash)
-> Map TxOutRef TxOut -> Map TxOutRef ScriptHash
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe (TxOut
-> Optic' A_Lens NoIx TxOut (Maybe ScriptHash) -> Maybe ScriptHash
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx TxOut (Maybe ScriptHash)
Lens' TxOut (Maybe (ReferenceScriptType TxOut))
forall o.
IsAbstractOutput o =>
Lens' o (Maybe (ReferenceScriptType o))
outputReferenceScriptL)
  ScriptHash
refScriptHash <-
    String
-> TxOutRef
-> Map TxOutRef ScriptHash
-> TxGen (Map TxOutRef TxOut) ScriptHash
forall k a context.
Ord k =>
String -> k -> Map k a -> TxGen context a
throwOnLookup
      String
"toPlutusScriptOrReferenceInput: Can't resolve reference script utxo."
      TxOutRef
scriptOutRef
      Map TxOutRef ScriptHash
referenceScriptsMap
  Bool
-> ReaderT (Map TxOutRef TxOut) (Either GenerateTxError) ()
-> ReaderT (Map TxOutRef TxOut) (Either GenerateTxError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ScriptHash
refScriptHash ScriptHash -> ScriptHash -> Bool
forall a. Eq a => a -> a -> Bool
/= Versioned Script -> ScriptHash
forall a. ToScriptHash a => a -> ScriptHash
toScriptHash Versioned Script
script) (ReaderT (Map TxOutRef TxOut) (Either GenerateTxError) ()
 -> ReaderT (Map TxOutRef TxOut) (Either GenerateTxError) ())
-> ReaderT (Map TxOutRef TxOut) (Either GenerateTxError) ()
-> ReaderT (Map TxOutRef TxOut) (Either GenerateTxError) ()
forall a b. (a -> b) -> a -> b
$
    String -> ReaderT (Map TxOutRef TxOut) (Either GenerateTxError) ()
forall context a. String -> TxGen context a
throwOnString String
"toPlutusScriptOrReferenceInput: Wrong reference script hash."
  TxIn
scriptTxIn <-
    String
-> Either ToCardanoError TxIn -> TxGen (Map TxOutRef TxOut) TxIn
forall a context.
String -> Either ToCardanoError a -> TxGen context a
throwOnToCardanoError
      String
"toPlutusScriptOrReferenceInput: Unable to translate reference script utxo."
      (TxOutRef -> Either ToCardanoError TxIn
Ledger.toCardanoTxIn TxOutRef
scriptOutRef)
  ScriptHash
scriptHash <-
    String
-> Either ToCardanoError ScriptHash
-> TxGen (Map TxOutRef TxOut) ScriptHash
forall a context.
String -> Either ToCardanoError a -> TxGen context a
throwOnToCardanoError
      String
"toPlutusScriptOrReferenceInput: Unable to translate script hash of reference script."
      (ScriptHash -> Either ToCardanoError ScriptHash
Ledger.toCardanoScriptHash ScriptHash
refScriptHash)
  PlutusScriptOrReferenceInput lang
-> ReaderT
     (Map TxOutRef TxOut)
     (Either GenerateTxError)
     (PlutusScriptOrReferenceInput lang)
forall a.
a -> ReaderT (Map TxOutRef TxOut) (Either GenerateTxError) a
forall (m :: * -> *) a. Monad m => a -> m a
return (PlutusScriptOrReferenceInput lang
 -> ReaderT
      (Map TxOutRef TxOut)
      (Either GenerateTxError)
      (PlutusScriptOrReferenceInput lang))
-> PlutusScriptOrReferenceInput lang
-> ReaderT
     (Map TxOutRef TxOut)
     (Either GenerateTxError)
     (PlutusScriptOrReferenceInput lang)
forall a b. (a -> b) -> a -> b
$ TxIn -> Maybe ScriptHash -> PlutusScriptOrReferenceInput lang
forall lang.
TxIn -> Maybe ScriptHash -> PlutusScriptOrReferenceInput lang
Cardano.PReferenceScript TxIn
scriptTxIn (ScriptHash -> Maybe ScriptHash
forall a. a -> Maybe a
Just ScriptHash
scriptHash)

-- | Translates a script with its associated redeemer and datum to a script
-- witness.
toScriptWitness :: (ToVersionedScript a) => a -> TxSkelRedeemer -> Cardano.ScriptDatum b -> WitnessGen (Cardano.ScriptWitness b Cardano.ConwayEra)
toScriptWitness :: forall a b.
ToVersionedScript a =>
a
-> TxSkelRedeemer
-> ScriptDatum b
-> WitnessGen (ScriptWitness b ConwayEra)
toScriptWitness (a -> Versioned Script
forall a. ToVersionedScript a => a -> Versioned Script
toVersionedScript -> script :: Versioned Script
script@(Script.Versioned Script
_ Language
version)) (TxSkelRedeemer {Maybe TxOutRef
Redeemer
txSkelRedeemer :: Redeemer
txSkelReferenceInput :: Maybe TxOutRef
txSkelRedeemer :: TxSkelRedeemer -> Redeemer
txSkelReferenceInput :: TxSkelRedeemer -> Maybe TxOutRef
..}) ScriptDatum b
datum =
  let scriptData :: HashableScriptData
scriptData = case Redeemer
txSkelRedeemer of
        Redeemer
EmptyRedeemer -> BuiltinData -> HashableScriptData
Ledger.toCardanoScriptData (BuiltinData -> HashableScriptData)
-> BuiltinData -> HashableScriptData
forall a b. (a -> b) -> a -> b
$ () -> BuiltinData
forall a. ToData a => a -> BuiltinData
Api.toBuiltinData ()
        SomeRedeemer redeemer
s -> 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
s
   in 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.
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)
-> ReaderT
     (Map TxOutRef TxOut)
     (Either GenerateTxError)
     (PlutusScriptOrReferenceInput PlutusScriptV1)
-> WitnessGen (ScriptWitness b ConwayEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Versioned Script
-> Maybe TxOutRef
-> ReaderT
     (Map TxOutRef TxOut)
     (Either GenerateTxError)
     (PlutusScriptOrReferenceInput PlutusScriptV1)
forall lang.
Versioned Script
-> Maybe TxOutRef -> WitnessGen (PlutusScriptOrReferenceInput lang)
toPlutusScriptOrReferenceInput Versioned Script
script Maybe TxOutRef
txSkelReferenceInput
        Language
Script.PlutusV2 ->
          (\PlutusScriptOrReferenceInput PlutusScriptV2
x -> ScriptLanguageInEra PlutusScriptV2 ConwayEra
-> PlutusScriptVersion PlutusScriptV2
-> PlutusScriptOrReferenceInput PlutusScriptV2
-> ScriptDatum b
-> HashableScriptData
-> ExecutionUnits
-> ScriptWitness b ConwayEra
forall lang era witctx.
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)
-> ReaderT
     (Map TxOutRef TxOut)
     (Either GenerateTxError)
     (PlutusScriptOrReferenceInput PlutusScriptV2)
-> WitnessGen (ScriptWitness b ConwayEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Versioned Script
-> Maybe TxOutRef
-> ReaderT
     (Map TxOutRef TxOut)
     (Either GenerateTxError)
     (PlutusScriptOrReferenceInput PlutusScriptV2)
forall lang.
Versioned Script
-> Maybe TxOutRef -> WitnessGen (PlutusScriptOrReferenceInput lang)
toPlutusScriptOrReferenceInput Versioned Script
script Maybe TxOutRef
txSkelReferenceInput
        Language
Script.PlutusV3 ->
          (\PlutusScriptOrReferenceInput PlutusScriptV3
x -> ScriptLanguageInEra PlutusScriptV3 ConwayEra
-> PlutusScriptVersion PlutusScriptV3
-> PlutusScriptOrReferenceInput PlutusScriptV3
-> ScriptDatum b
-> HashableScriptData
-> ExecutionUnits
-> ScriptWitness b ConwayEra
forall lang era witctx.
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)
-> ReaderT
     (Map TxOutRef TxOut)
     (Either GenerateTxError)
     (PlutusScriptOrReferenceInput PlutusScriptV3)
-> WitnessGen (ScriptWitness b ConwayEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Versioned Script
-> Maybe TxOutRef
-> ReaderT
     (Map TxOutRef TxOut)
     (Either GenerateTxError)
     (PlutusScriptOrReferenceInput PlutusScriptV3)
forall lang.
Versioned Script
-> Maybe TxOutRef -> WitnessGen (PlutusScriptOrReferenceInput lang)
toPlutusScriptOrReferenceInput Versioned Script
script Maybe TxOutRef
txSkelReferenceInput