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 Cooked.Conversion
import Cooked.MockChain.BlockChain
import Cooked.MockChain.GenerateTx.Common
import Cooked.Output
import Cooked.Skeleton
import Ledger.Tx.CardanoAPI qualified as Ledger
import Optics.Core
import Plutus.Script.Utils.Scripts qualified as Script
import PlutusLedgerApi.V3 qualified as Api

-- | Translates a given credential to a reward account.
toRewardAccount :: (MonadBlockChainBalancing m) => Api.Credential -> m (Cardano.RewardAccount Crypto.StandardCrypto)
toRewardAccount :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
Credential -> m (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)
-> m (Credential 'Staking StandardCrypto)
-> m (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 -> m ScriptHash
forall (m :: * -> *) a.
MonadError MockChainError m =>
String -> Either ToCardanoError a -> m a
throwOnToCardanoError
          String
"toRewardAccount: Unable to convert script hash."
          (ScriptHash -> Either ToCardanoError ScriptHash
Ledger.toCardanoScriptHash ScriptHash
scriptHash)
      Credential 'Staking StandardCrypto
-> m (Credential 'Staking StandardCrypto)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Credential 'Staking StandardCrypto
 -> m (Credential 'Staking StandardCrypto))
-> Credential 'Staking StandardCrypto
-> m (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) -> m (Hash StakeKey)
forall (m :: * -> *) a.
MonadError MockChainError m =>
String -> Either ToCardanoError a -> m a
throwOnToCardanoError
          String
"toRewardAccount: Unable to convert private key hash."
          (PubKeyHash -> Either ToCardanoError (Hash StakeKey)
Ledger.toCardanoStakeKeyHash PubKeyHash
pubkeyHash)
      Credential 'Staking StandardCrypto
-> m (Credential 'Staking StandardCrypto)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Credential 'Staking StandardCrypto
 -> m (Credential 'Staking StandardCrypto))
-> Credential 'Staking StandardCrypto
-> m (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 :: (MonadBlockChainBalancing m) => Script.Versioned Script.Script -> Maybe Api.TxOutRef -> m (Cardano.PlutusScriptOrReferenceInput lang)
toPlutusScriptOrReferenceInput :: forall (m :: * -> *) lang.
MonadBlockChainBalancing m =>
Versioned Script
-> Maybe TxOutRef -> m (PlutusScriptOrReferenceInput lang)
toPlutusScriptOrReferenceInput (Script.Versioned (Script.Script SerialisedScript
script) Language
_) Maybe TxOutRef
Nothing = PlutusScriptOrReferenceInput lang
-> m (PlutusScriptOrReferenceInput lang)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PlutusScriptOrReferenceInput lang
 -> m (PlutusScriptOrReferenceInput lang))
-> PlutusScriptOrReferenceInput lang
-> m (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 -> ScriptHash
forall a. ToScriptHash a => a -> ScriptHash
toScriptHash -> ScriptHash
scriptHash) (Just TxOutRef
scriptOutRef) = do
  ((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) -> Maybe ScriptHash
mScriptHash) <-
    String -> Maybe TxOut -> m TxOut
forall (m :: * -> *) a.
MonadError MockChainError m =>
String -> Maybe a -> m a
throwOnMaybe String
"toPlutusScriptOrReferenceInput: Can't resolve reference script utxo." (Maybe TxOut -> m TxOut) -> m (Maybe TxOut) -> m TxOut
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TxOutRef -> m (Maybe TxOut)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m (Maybe TxOut)
txOutByRef TxOutRef
scriptOutRef
  case Maybe ScriptHash
mScriptHash of
    Maybe ScriptHash
Nothing -> String -> m (PlutusScriptOrReferenceInput lang)
forall (m :: * -> *) a.
MonadError MockChainError m =>
String -> m a
throwOnString String
"toPlutusScriptOrReferenceInput: No reference script found in utxo."
    Just ScriptHash
scriptHash' | ScriptHash
scriptHash ScriptHash -> ScriptHash -> Bool
forall a. Eq a => a -> a -> Bool
/= ScriptHash
scriptHash' -> String -> m (PlutusScriptOrReferenceInput lang)
forall (m :: * -> *) a.
MonadError MockChainError m =>
String -> m a
throwOnString String
"toPlutusScriptOrReferenceInput: Wrong reference script hash."
    Just ScriptHash
_ -> do
      TxIn
scriptTxIn <-
        String -> Either ToCardanoError TxIn -> m TxIn
forall (m :: * -> *) a.
MonadError MockChainError m =>
String -> Either ToCardanoError a -> m a
throwOnToCardanoError
          String
"toPlutusScriptOrReferenceInput: Unable to translate reference script utxo."
          (TxOutRef -> Either ToCardanoError TxIn
Ledger.toCardanoTxIn TxOutRef
scriptOutRef)
      TxIn -> Maybe ScriptHash -> PlutusScriptOrReferenceInput lang
forall lang.
TxIn -> Maybe ScriptHash -> PlutusScriptOrReferenceInput lang
Cardano.PReferenceScript TxIn
scriptTxIn (Maybe ScriptHash -> PlutusScriptOrReferenceInput lang)
-> (ScriptHash -> Maybe ScriptHash)
-> ScriptHash
-> PlutusScriptOrReferenceInput lang
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptHash -> Maybe ScriptHash
forall a. a -> Maybe a
Just
        (ScriptHash -> PlutusScriptOrReferenceInput lang)
-> m ScriptHash -> m (PlutusScriptOrReferenceInput lang)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Either ToCardanoError ScriptHash -> m ScriptHash
forall (m :: * -> *) a.
MonadError MockChainError m =>
String -> Either ToCardanoError a -> m a
throwOnToCardanoError
          String
"toPlutusScriptOrReferenceInput: Unable to translate script hash of reference script."
          (ScriptHash -> Either ToCardanoError ScriptHash
Ledger.toCardanoScriptHash ScriptHash
scriptHash)

-- | Translates a script with its associated redeemer and datum to a script
-- witness.
toScriptWitness :: (MonadBlockChainBalancing m, ToVersionedScript a) => a -> TxSkelRedeemer -> Cardano.ScriptDatum b -> m (Cardano.ScriptWitness b Cardano.ConwayEra)
toScriptWitness :: forall (m :: * -> *) a b.
(MonadBlockChainBalancing m, ToVersionedScript a) =>
a
-> TxSkelRedeemer -> ScriptDatum b -> m (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)
-> m (PlutusScriptOrReferenceInput PlutusScriptV1)
-> m (ScriptWitness b ConwayEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Versioned Script
-> Maybe TxOutRef
-> m (PlutusScriptOrReferenceInput PlutusScriptV1)
forall (m :: * -> *) lang.
MonadBlockChainBalancing m =>
Versioned Script
-> Maybe TxOutRef -> m (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)
-> m (PlutusScriptOrReferenceInput PlutusScriptV2)
-> m (ScriptWitness b ConwayEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Versioned Script
-> Maybe TxOutRef
-> m (PlutusScriptOrReferenceInput PlutusScriptV2)
forall (m :: * -> *) lang.
MonadBlockChainBalancing m =>
Versioned Script
-> Maybe TxOutRef -> m (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)
-> m (PlutusScriptOrReferenceInput PlutusScriptV3)
-> m (ScriptWitness b ConwayEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Versioned Script
-> Maybe TxOutRef
-> m (PlutusScriptOrReferenceInput PlutusScriptV3)
forall (m :: * -> *) lang.
MonadBlockChainBalancing m =>
Versioned Script
-> Maybe TxOutRef -> m (PlutusScriptOrReferenceInput lang)
toPlutusScriptOrReferenceInput Versioned Script
script Maybe TxOutRef
txSkelReferenceInput