-- | This module provides a function to ensure that each redeemer used in a
-- skeleton is attached a reference input with the right reference script when
-- it exists in the index.
module Cooked.MockChain.AutoReferenceScripts (toTxSkelWithReferenceScripts) where

import Control.Monad
import Cooked.MockChain.BlockChain
import Cooked.MockChain.UtxoSearch
import Cooked.Skeleton
import Data.List (find)
import Data.Map qualified as Map
import Optics.Core
import Plutus.Script.Utils.Scripts qualified as Script
import PlutusLedgerApi.V3 qualified as Api

-- | Attempts to find in the index a utxo containing a reference script with the
-- given script hash, and attaches it to a redeemer when it does not yet have a
-- reference input and when it is allowed, in which case an event is logged.
updateRedeemer :: (MonadBlockChain m, Script.ToScriptHash s) => s -> [Api.TxOutRef] -> TxSkelRedeemer -> m TxSkelRedeemer
updateRedeemer :: forall (m :: * -> *) s.
(MonadBlockChain m, ToScriptHash s) =>
s -> [TxOutRef] -> TxSkelRedeemer -> m TxSkelRedeemer
updateRedeemer s
script [TxOutRef]
inputs txSkelRed :: TxSkelRedeemer
txSkelRed@(TxSkelRedeemer redeemer
_ Maybe TxOutRef
Nothing Bool
True) = do
  [(TxOutRef, TxSkelOut)]
oRefsInInputs <- UtxoSearch m TxSkelOut -> m [(TxOutRef, TxSkelOut)]
forall (m :: * -> *) a.
Monad m =>
UtxoSearch m a -> m [(TxOutRef, a)]
runUtxoSearch (s -> UtxoSearch m TxSkelOut
forall (m :: * -> *) s.
(MonadBlockChain m, ToScriptHash s) =>
s -> UtxoSearch m TxSkelOut
referenceScriptOutputsSearch s
script)
  m TxSkelRedeemer
-> (TxOutRef -> m TxSkelRedeemer)
-> Maybe TxOutRef
-> m TxSkelRedeemer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    -- We leave the redeemer unchanged if no reference input was found
    (TxSkelRedeemer -> m TxSkelRedeemer
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return TxSkelRedeemer
txSkelRed)
    -- If a reference input is found, we assign it and log the event
    ( \TxOutRef
oRef -> do
        MockChainLogEntry -> m ()
forall (m :: * -> *).
MonadBlockChainBalancing m =>
MockChainLogEntry -> m ()
logEvent (MockChainLogEntry -> m ()) -> MockChainLogEntry -> m ()
forall a b. (a -> b) -> a -> b
$ TxSkelRedeemer -> TxOutRef -> ScriptHash -> MockChainLogEntry
MCLogAddedReferenceScript TxSkelRedeemer
txSkelRed TxOutRef
oRef (s -> ScriptHash
forall a. ToScriptHash a => a -> ScriptHash
Script.toScriptHash s
script)
        TxSkelRedeemer -> m TxSkelRedeemer
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TxSkelRedeemer -> m TxSkelRedeemer)
-> TxSkelRedeemer -> m TxSkelRedeemer
forall a b. (a -> b) -> a -> b
$ TxSkelRedeemer
txSkelRed TxSkelRedeemer -> TxOutRef -> TxSkelRedeemer
`withReferenceInput` TxOutRef
oRef
    )
    (Maybe TxOutRef -> m TxSkelRedeemer)
-> Maybe TxOutRef -> m TxSkelRedeemer
forall a b. (a -> b) -> a -> b
$ case [(TxOutRef, TxSkelOut)]
oRefsInInputs of
      [] -> Maybe TxOutRef
forall a. Maybe a
Nothing
      -- If possible, we use a reference input appearing in regular inputs
      [(TxOutRef, TxSkelOut)]
l | Just (TxOutRef
oRefM', TxSkelOut
_) <- ((TxOutRef, TxSkelOut) -> Bool)
-> [(TxOutRef, TxSkelOut)] -> Maybe (TxOutRef, TxSkelOut)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(TxOutRef
r, TxSkelOut
_) -> TxOutRef
r TxOutRef -> [TxOutRef] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TxOutRef]
inputs) [(TxOutRef, TxSkelOut)]
l -> TxOutRef -> Maybe TxOutRef
forall a. a -> Maybe a
Just TxOutRef
oRefM'
      -- If none exist, we use the first one we find elsewhere
      ((TxOutRef
oRefM', TxSkelOut
_) : [(TxOutRef, TxSkelOut)]
_) -> TxOutRef -> Maybe TxOutRef
forall a. a -> Maybe a
Just TxOutRef
oRefM'
updateRedeemer s
_ [TxOutRef]
_ TxSkelRedeemer
redeemer = TxSkelRedeemer -> m TxSkelRedeemer
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return TxSkelRedeemer
redeemer

-- | Goes through the various parts of the skeleton where a redeemer can appear,
-- and attempts to attach a reference input to each of them, whenever it is
-- allowed and one has not already been set.
toTxSkelWithReferenceScripts :: (MonadBlockChain m) => TxSkel -> m TxSkel
toTxSkelWithReferenceScripts :: forall (m :: * -> *). MonadBlockChain m => TxSkel -> m TxSkel
toTxSkelWithReferenceScripts txSkel :: TxSkel
txSkel@TxSkel {[Wallet]
[TxSkelProposal]
[TxSkelOut]
Set TxOutRef
Set TxLabel
TxSkelWithdrawals
Map TxOutRef TxSkelRedeemer
TxSkelMints
SlotRange
TxOpts
txSkelLabel :: Set TxLabel
txSkelOpts :: TxOpts
txSkelMints :: TxSkelMints
txSkelSigners :: [Wallet]
txSkelValidityRange :: SlotRange
txSkelIns :: Map TxOutRef TxSkelRedeemer
txSkelInsReference :: Set TxOutRef
txSkelOuts :: [TxSkelOut]
txSkelProposals :: [TxSkelProposal]
txSkelWithdrawals :: TxSkelWithdrawals
txSkelLabel :: TxSkel -> Set TxLabel
txSkelOpts :: TxSkel -> TxOpts
txSkelMints :: TxSkel -> TxSkelMints
txSkelSigners :: TxSkel -> [Wallet]
txSkelValidityRange :: TxSkel -> SlotRange
txSkelIns :: TxSkel -> Map TxOutRef TxSkelRedeemer
txSkelInsReference :: TxSkel -> Set TxOutRef
txSkelOuts :: TxSkel -> [TxSkelOut]
txSkelProposals :: TxSkel -> [TxSkelProposal]
txSkelWithdrawals :: TxSkel -> TxSkelWithdrawals
..} = do
  let inputs :: [TxOutRef]
inputs = Map TxOutRef TxSkelRedeemer -> [TxOutRef]
forall k a. Map k a -> [k]
Map.keys Map TxOutRef TxSkelRedeemer
txSkelIns
  [Mint]
newMints <- [Mint] -> (Mint -> m Mint) -> m [Mint]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (TxSkelMints -> [Mint]
txSkelMintsToList TxSkelMints
txSkelMints) ((Mint -> m Mint) -> m [Mint]) -> (Mint -> m Mint) -> m [Mint]
forall a b. (a -> b) -> a -> b
$ \(Mint a
mPol TxSkelRedeemer
red [(TokenName, Integer)]
tks) ->
    (\TxSkelRedeemer
x -> a -> TxSkelRedeemer -> [(TokenName, Integer)] -> Mint
forall a.
ToVersioned MintingPolicy a =>
a -> TxSkelRedeemer -> [(TokenName, Integer)] -> Mint
Mint a
mPol TxSkelRedeemer
x [(TokenName, Integer)]
tks) (TxSkelRedeemer -> Mint) -> m TxSkelRedeemer -> m Mint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Versioned MintingPolicy
-> [TxOutRef] -> TxSkelRedeemer -> m TxSkelRedeemer
forall (m :: * -> *) s.
(MonadBlockChain m, ToScriptHash s) =>
s -> [TxOutRef] -> TxSkelRedeemer -> m TxSkelRedeemer
updateRedeemer (forall s a. ToVersioned s a => a -> Versioned s
Script.toVersioned @Script.MintingPolicy a
mPol) [TxOutRef]
inputs TxSkelRedeemer
red
  [(TxOutRef, TxSkelRedeemer)]
newInputs <- [(TxOutRef, TxSkelRedeemer)]
-> ((TxOutRef, TxSkelRedeemer) -> m (TxOutRef, TxSkelRedeemer))
-> m [(TxOutRef, TxSkelRedeemer)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map TxOutRef TxSkelRedeemer -> [(TxOutRef, TxSkelRedeemer)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxOutRef TxSkelRedeemer
txSkelIns) (((TxOutRef, TxSkelRedeemer) -> m (TxOutRef, TxSkelRedeemer))
 -> m [(TxOutRef, TxSkelRedeemer)])
-> ((TxOutRef, TxSkelRedeemer) -> m (TxOutRef, TxSkelRedeemer))
-> m [(TxOutRef, TxSkelRedeemer)]
forall a b. (a -> b) -> a -> b
$ \(TxOutRef
oRef, TxSkelRedeemer
red) -> do
    Maybe (Versioned Validator)
validatorM <- TxSkelOut -> Maybe (Versioned Validator)
txSkelOutValidator (TxSkelOut -> Maybe (Versioned Validator))
-> m TxSkelOut -> m (Maybe (Versioned Validator))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxOutRef -> m TxSkelOut
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m TxSkelOut
unsafeTxOutByRef TxOutRef
oRef
    case Maybe (Versioned Validator)
validatorM of
      Maybe (Versioned Validator)
Nothing -> (TxOutRef, TxSkelRedeemer) -> m (TxOutRef, TxSkelRedeemer)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TxOutRef
oRef, TxSkelRedeemer
red)
      Just Versioned Validator
scriptHash -> (TxOutRef
oRef,) (TxSkelRedeemer -> (TxOutRef, TxSkelRedeemer))
-> m TxSkelRedeemer -> m (TxOutRef, TxSkelRedeemer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Versioned Validator
-> [TxOutRef] -> TxSkelRedeemer -> m TxSkelRedeemer
forall (m :: * -> *) s.
(MonadBlockChain m, ToScriptHash s) =>
s -> [TxOutRef] -> TxSkelRedeemer -> m TxSkelRedeemer
updateRedeemer Versioned Validator
scriptHash [TxOutRef]
inputs TxSkelRedeemer
red
  [TxSkelProposal]
newProposals <- [TxSkelProposal]
-> (TxSkelProposal -> m TxSkelProposal) -> m [TxSkelProposal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TxSkelProposal]
txSkelProposals ((TxSkelProposal -> m TxSkelProposal) -> m [TxSkelProposal])
-> (TxSkelProposal -> m TxSkelProposal) -> m [TxSkelProposal]
forall a b. (a -> b) -> a -> b
$ \TxSkelProposal
prop ->
    case TxSkelProposal
prop TxSkelProposal
-> Optic'
     A_Lens
     NoIx
     TxSkelProposal
     (Maybe (Versioned Script, TxSkelRedeemer))
-> Maybe (Versioned Script, TxSkelRedeemer)
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic'
  A_Lens
  NoIx
  TxSkelProposal
  (Maybe (Versioned Script, TxSkelRedeemer))
txSkelProposalWitnessL of
      Maybe (Versioned Script, TxSkelRedeemer)
Nothing -> TxSkelProposal -> m TxSkelProposal
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return TxSkelProposal
prop
      Just (Versioned Script
script, TxSkelRedeemer
red) -> (Maybe (Versioned Script, TxSkelRedeemer)
 -> TxSkelProposal -> TxSkelProposal)
-> TxSkelProposal
-> Maybe (Versioned Script, TxSkelRedeemer)
-> TxSkelProposal
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Optic'
  A_Lens
  NoIx
  TxSkelProposal
  (Maybe (Versioned Script, TxSkelRedeemer))
-> Maybe (Versioned Script, TxSkelRedeemer)
-> TxSkelProposal
-> TxSkelProposal
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Optic'
  A_Lens
  NoIx
  TxSkelProposal
  (Maybe (Versioned Script, TxSkelRedeemer))
txSkelProposalWitnessL) TxSkelProposal
prop (Maybe (Versioned Script, TxSkelRedeemer) -> TxSkelProposal)
-> (TxSkelRedeemer -> Maybe (Versioned Script, TxSkelRedeemer))
-> TxSkelRedeemer
-> TxSkelProposal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Versioned Script, TxSkelRedeemer)
-> Maybe (Versioned Script, TxSkelRedeemer)
forall a. a -> Maybe a
Just ((Versioned Script, TxSkelRedeemer)
 -> Maybe (Versioned Script, TxSkelRedeemer))
-> (TxSkelRedeemer -> (Versioned Script, TxSkelRedeemer))
-> TxSkelRedeemer
-> Maybe (Versioned Script, TxSkelRedeemer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Versioned Script
script,) (TxSkelRedeemer -> TxSkelProposal)
-> m TxSkelRedeemer -> m TxSkelProposal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Versioned Script
-> [TxOutRef] -> TxSkelRedeemer -> m TxSkelRedeemer
forall (m :: * -> *) s.
(MonadBlockChain m, ToScriptHash s) =>
s -> [TxOutRef] -> TxSkelRedeemer -> m TxSkelRedeemer
updateRedeemer Versioned Script
script [TxOutRef]
inputs TxSkelRedeemer
red
  [(Either (Versioned Script) PubKeyHash,
  (TxSkelRedeemer, Lovelace))]
newWithdrawals <- [(Either (Versioned Script) PubKeyHash,
  (TxSkelRedeemer, Lovelace))]
-> ((Either (Versioned Script) PubKeyHash,
     (TxSkelRedeemer, Lovelace))
    -> m (Either (Versioned Script) PubKeyHash,
          (TxSkelRedeemer, Lovelace)))
-> m [(Either (Versioned Script) PubKeyHash,
       (TxSkelRedeemer, Lovelace))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (TxSkelWithdrawals
-> [(Either (Versioned Script) PubKeyHash,
     (TxSkelRedeemer, Lovelace))]
forall k a. Map k a -> [(k, a)]
Map.toList TxSkelWithdrawals
txSkelWithdrawals) (((Either (Versioned Script) PubKeyHash,
   (TxSkelRedeemer, Lovelace))
  -> m (Either (Versioned Script) PubKeyHash,
        (TxSkelRedeemer, Lovelace)))
 -> m [(Either (Versioned Script) PubKeyHash,
        (TxSkelRedeemer, Lovelace))])
-> ((Either (Versioned Script) PubKeyHash,
     (TxSkelRedeemer, Lovelace))
    -> m (Either (Versioned Script) PubKeyHash,
          (TxSkelRedeemer, Lovelace)))
-> m [(Either (Versioned Script) PubKeyHash,
       (TxSkelRedeemer, Lovelace))]
forall a b. (a -> b) -> a -> b
$ \(Either (Versioned Script) PubKeyHash
wit, (TxSkelRedeemer
red, Lovelace
quantity)) -> case Either (Versioned Script) PubKeyHash
wit of
    Right PubKeyHash
_ -> (Either (Versioned Script) PubKeyHash, (TxSkelRedeemer, Lovelace))
-> m (Either (Versioned Script) PubKeyHash,
      (TxSkelRedeemer, Lovelace))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Versioned Script) PubKeyHash
wit, (TxSkelRedeemer
red, Lovelace
quantity))
    Left Versioned Script
script -> (Versioned Script -> Either (Versioned Script) PubKeyHash
forall a b. a -> Either a b
Left Versioned Script
script,) ((TxSkelRedeemer, Lovelace)
 -> (Either (Versioned Script) PubKeyHash,
     (TxSkelRedeemer, Lovelace)))
-> (TxSkelRedeemer -> (TxSkelRedeemer, Lovelace))
-> TxSkelRedeemer
-> (Either (Versioned Script) PubKeyHash,
    (TxSkelRedeemer, Lovelace))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,Lovelace
quantity) (TxSkelRedeemer
 -> (Either (Versioned Script) PubKeyHash,
     (TxSkelRedeemer, Lovelace)))
-> m TxSkelRedeemer
-> m (Either (Versioned Script) PubKeyHash,
      (TxSkelRedeemer, Lovelace))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Versioned Script
-> [TxOutRef] -> TxSkelRedeemer -> m TxSkelRedeemer
forall (m :: * -> *) s.
(MonadBlockChain m, ToScriptHash s) =>
s -> [TxOutRef] -> TxSkelRedeemer -> m TxSkelRedeemer
updateRedeemer Versioned Script
script [TxOutRef]
inputs TxSkelRedeemer
red
  TxSkel -> m TxSkel
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TxSkel -> m TxSkel) -> TxSkel -> m TxSkel
forall a b. (a -> b) -> a -> b
$
    TxSkel
txSkel
      TxSkel -> (TxSkel -> TxSkel) -> TxSkel
forall a b. a -> (a -> b) -> b
& Lens' TxSkel TxSkelMints
txSkelMintsL
      Lens' TxSkel TxSkelMints -> TxSkelMints -> TxSkel -> TxSkel
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ [Mint] -> TxSkelMints
txSkelMintsFromList [Mint]
newMints
      TxSkel -> (TxSkel -> TxSkel) -> TxSkel
forall a b. a -> (a -> b) -> b
& Lens' TxSkel (Map TxOutRef TxSkelRedeemer)
txSkelInsL
      Lens' TxSkel (Map TxOutRef TxSkelRedeemer)
-> Map TxOutRef TxSkelRedeemer -> TxSkel -> TxSkel
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ [(TxOutRef, TxSkelRedeemer)] -> Map TxOutRef TxSkelRedeemer
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TxOutRef, TxSkelRedeemer)]
newInputs
      TxSkel -> (TxSkel -> TxSkel) -> TxSkel
forall a b. a -> (a -> b) -> b
& Lens' TxSkel [TxSkelProposal]
txSkelProposalsL
      Lens' TxSkel [TxSkelProposal]
-> [TxSkelProposal] -> TxSkel -> TxSkel
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ [TxSkelProposal]
newProposals
      TxSkel -> (TxSkel -> TxSkel) -> TxSkel
forall a b. a -> (a -> b) -> b
& Lens' TxSkel TxSkelWithdrawals
txSkelWithdrawalsL
      Lens' TxSkel TxSkelWithdrawals
-> TxSkelWithdrawals -> TxSkel -> TxSkel
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ [(Either (Versioned Script) PubKeyHash,
  (TxSkelRedeemer, Lovelace))]
-> TxSkelWithdrawals
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Either (Versioned Script) PubKeyHash,
  (TxSkelRedeemer, Lovelace))]
newWithdrawals