-- | This module exposes functions to automatically attach reference inputs
-- carrying reference scripts to the redeemers of a 'Cooked.Skeleton.TxSkel',
-- based on the current state of the blockchain.
module Cooked.MockChain.Automation.AutoFilling.ReferenceScripts
  ( updateRedeemedScript,
    autoFillReferenceScripts,
  )
where

import Control.Monad
import Cooked.MockChain.Effect.Log
import Cooked.MockChain.Effect.Read
import Cooked.MockChain.UtxoSearch
import Cooked.Skeleton
import Cooked.Tweak.Common
import Cooked.Tweak.Query
import Cooked.Tweak.Update
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
import Polysemy

-- * Auto filling reference scripts

-- | 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.
updateRedeemedScript ::
  (Members '[MockChainLog, MockChainRead] effs) =>
  [Api.TxOutRef] ->
  User IsScript Redemption ->
  Sem effs (User IsScript Redemption)
updateRedeemedScript :: forall (effs :: EffectRow).
Members '[MockChainLog, MockChainRead] effs =>
[TxOutRef]
-> User 'IsScript 'Redemption
-> Sem effs (User 'IsScript 'Redemption)
updateRedeemedScript
  [TxOutRef]
inputs
  rs :: User 'IsScript 'Redemption
rs@( UserRedeemedScript
         (script -> VScript
forall script. ToVScript script => script -> VScript
toVScript -> VScript
vScript)
         txSkelRed :: TxSkelRedeemer
txSkelRed@(TxSkelRedeemer {txSkelRedeemerAutoFill :: TxSkelRedeemer -> Bool
txSkelRedeemerAutoFill = Bool
True})
       ) = do
    [TxOutRef]
oRefsInInputs <- Sem effs (UtxoSearchResult '[]) -> Sem effs [TxOutRef]
forall (effs :: EffectRow) (elems :: [*]).
Sem effs (UtxoSearchResult elems) -> Sem effs [TxOutRef]
getTxOutRefs (Sem effs (UtxoSearchResult '[]) -> Sem effs [TxOutRef])
-> Sem effs (UtxoSearchResult '[]) -> Sem effs [TxOutRef]
forall a b. (a -> b) -> a -> b
$ (Sem effs (UtxoSearchResult '[])
 -> Sem effs (UtxoSearchResult '[]))
-> Sem effs (UtxoSearchResult '[])
forall (effs :: EffectRow) (els :: [*]).
Member MockChainRead effs =>
(UtxoSearch effs '[] -> UtxoSearch effs els) -> UtxoSearch effs els
allUtxosSearch ((Sem effs (UtxoSearchResult '[])
  -> Sem effs (UtxoSearchResult '[]))
 -> Sem effs (UtxoSearchResult '[]))
-> (Sem effs (UtxoSearchResult '[])
    -> Sem effs (UtxoSearchResult '[]))
-> Sem effs (UtxoSearchResult '[])
forall a b. (a -> b) -> a -> b
$ VScript
-> Sem effs (UtxoSearchResult '[])
-> Sem effs (UtxoSearchResult '[])
forall s (effs :: EffectRow) (els :: [*]).
ToScriptHash s =>
s -> UtxoSearch effs els -> UtxoSearch effs els
ensureProperReferenceScript VScript
vScript
    Sem effs (User 'IsScript 'Redemption)
-> (TxOutRef -> Sem effs (User 'IsScript 'Redemption))
-> Maybe TxOutRef
-> Sem effs (User 'IsScript 'Redemption)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      -- We leave the redeemer unchanged if no reference input was found
      (User 'IsScript 'Redemption -> Sem effs (User 'IsScript 'Redemption)
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return User 'IsScript 'Redemption
rs)
      -- If a reference input is found, we assign it and log the event
      ( \TxOutRef
oRef -> do
          MockChainLogEntry -> Sem effs ()
forall (effs :: EffectRow).
Member MockChainLog effs =>
MockChainLogEntry -> Sem effs ()
logEvent (MockChainLogEntry -> Sem effs ())
-> MockChainLogEntry -> Sem effs ()
forall a b. (a -> b) -> a -> b
$ TxSkelRedeemer -> TxOutRef -> ScriptHash -> MockChainLogEntry
MCLogAddedReferenceScript TxSkelRedeemer
txSkelRed TxOutRef
oRef (VScript -> ScriptHash
forall a. ToScriptHash a => a -> ScriptHash
Script.toScriptHash VScript
vScript)
          User 'IsScript 'Redemption -> Sem effs (User 'IsScript 'Redemption)
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (User 'IsScript 'Redemption
 -> Sem effs (User 'IsScript 'Redemption))
-> User 'IsScript 'Redemption
-> Sem effs (User 'IsScript 'Redemption)
forall a b. (a -> b) -> a -> b
$ Optic
  An_AffineTraversal
  '[]
  (User 'IsScript 'Redemption)
  (User 'IsScript 'Redemption)
  TxSkelRedeemer
  TxSkelRedeemer
-> (TxSkelRedeemer -> TxSkelRedeemer)
-> User 'IsScript 'Redemption
-> User 'IsScript 'Redemption
forall k (is :: [*]) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic
  An_AffineTraversal
  '[]
  (User 'IsScript 'Redemption)
  (User 'IsScript 'Redemption)
  TxSkelRedeemer
  TxSkelRedeemer
forall (kind :: UserKind) (mode :: UserMode).
AffineTraversal' (User kind mode) TxSkelRedeemer
userRedeemerAT (TxOutRef -> TxSkelRedeemer -> TxSkelRedeemer
fillReferenceInput TxOutRef
oRef) User 'IsScript 'Redemption
rs
      )
      (Maybe TxOutRef -> Sem effs (User 'IsScript 'Redemption))
-> Maybe TxOutRef -> Sem effs (User 'IsScript 'Redemption)
forall a b. (a -> b) -> a -> b
$ case [TxOutRef]
oRefsInInputs of
        [] -> Maybe TxOutRef
forall a. Maybe a
Nothing
        -- If possible, we use a reference input appearing in regular inputs
        [TxOutRef]
l | Just TxOutRef
oRefM' <- (TxOutRef -> Bool) -> [TxOutRef] -> Maybe TxOutRef
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (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]
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' : [TxOutRef]
_) -> TxOutRef -> Maybe TxOutRef
forall a. a -> Maybe a
Just TxOutRef
oRefM'
updateRedeemedScript [TxOutRef]
_ User 'IsScript 'Redemption
rs = User 'IsScript 'Redemption -> Sem effs (User 'IsScript 'Redemption)
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return User 'IsScript 'Redemption
rs

-- | 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. Logs an event whenever such an
-- addition occurs.
autoFillReferenceScripts ::
  (Members '[Tweak, MockChainRead, MockChainLog] effs) =>
  Sem effs ()
autoFillReferenceScripts :: forall (effs :: EffectRow).
Members '[Tweak, MockChainRead, MockChainLog] effs =>
Sem effs ()
autoFillReferenceScripts = do
  [TxOutRef]
inputsKeys <- Optic' A_Getter '[] TxSkel [TxOutRef] -> Sem effs [TxOutRef]
forall (effs :: EffectRow) k (is :: [*]) a.
(Member Tweak effs, Is k A_Getter) =>
Optic' k is TxSkel a -> Sem effs a
viewTweak (Optic' A_Getter '[] TxSkel [TxOutRef] -> Sem effs [TxOutRef])
-> Optic' A_Getter '[] TxSkel [TxOutRef] -> Sem effs [TxOutRef]
forall a b. (a -> b) -> a -> b
$ Lens' TxSkel (Map TxOutRef TxSkelRedeemer)
txSkelInputsL Lens' TxSkel (Map TxOutRef TxSkelRedeemer)
-> Optic
     A_Getter
     '[]
     (Map TxOutRef TxSkelRedeemer)
     (Map TxOutRef TxSkelRedeemer)
     [TxOutRef]
     [TxOutRef]
-> Optic' A_Getter '[] TxSkel [TxOutRef]
forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% (Map TxOutRef TxSkelRedeemer -> [TxOutRef])
-> Optic
     A_Getter
     '[]
     (Map TxOutRef TxSkelRedeemer)
     (Map TxOutRef TxSkelRedeemer)
     [TxOutRef]
     [TxOutRef]
forall s a. (s -> a) -> Getter s a
to Map TxOutRef TxSkelRedeemer -> [TxOutRef]
forall k a. Map k a -> [k]
Map.keys
  -- Updating spending redeemers, whose validators are fetched from the index
  -- based on the inputs' references, and thus require a dedicated treatment.
  [(TxOutRef, TxSkelRedeemer)]
inputsList <- Optic' A_Getter '[] TxSkel [(TxOutRef, TxSkelRedeemer)]
-> Sem effs [(TxOutRef, TxSkelRedeemer)]
forall (effs :: EffectRow) k (is :: [*]) a.
(Member Tweak effs, Is k A_Getter) =>
Optic' k is TxSkel a -> Sem effs a
viewTweak (Optic' A_Getter '[] TxSkel [(TxOutRef, TxSkelRedeemer)]
 -> Sem effs [(TxOutRef, TxSkelRedeemer)])
-> Optic' A_Getter '[] TxSkel [(TxOutRef, TxSkelRedeemer)]
-> Sem effs [(TxOutRef, TxSkelRedeemer)]
forall a b. (a -> b) -> a -> b
$ Lens' TxSkel (Map TxOutRef TxSkelRedeemer)
txSkelInputsL Lens' TxSkel (Map TxOutRef TxSkelRedeemer)
-> Optic
     A_Getter
     '[]
     (Map TxOutRef TxSkelRedeemer)
     (Map TxOutRef TxSkelRedeemer)
     [(TxOutRef, TxSkelRedeemer)]
     [(TxOutRef, TxSkelRedeemer)]
-> Optic' A_Getter '[] TxSkel [(TxOutRef, TxSkelRedeemer)]
forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% (Map TxOutRef TxSkelRedeemer -> [(TxOutRef, TxSkelRedeemer)])
-> Optic
     A_Getter
     '[]
     (Map TxOutRef TxSkelRedeemer)
     (Map TxOutRef TxSkelRedeemer)
     [(TxOutRef, TxSkelRedeemer)]
     [(TxOutRef, TxSkelRedeemer)]
forall s a. (s -> a) -> Getter s a
to Map TxOutRef TxSkelRedeemer -> [(TxOutRef, TxSkelRedeemer)]
forall k a. Map k a -> [(k, a)]
Map.toList
  [(TxOutRef, TxSkelRedeemer)]
newInputs <- [(TxOutRef, TxSkelRedeemer)]
-> ((TxOutRef, TxSkelRedeemer)
    -> Sem effs (TxOutRef, TxSkelRedeemer))
-> Sem effs [(TxOutRef, TxSkelRedeemer)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(TxOutRef, TxSkelRedeemer)]
inputsList (((TxOutRef, TxSkelRedeemer)
  -> Sem effs (TxOutRef, TxSkelRedeemer))
 -> Sem effs [(TxOutRef, TxSkelRedeemer)])
-> ((TxOutRef, TxSkelRedeemer)
    -> Sem effs (TxOutRef, TxSkelRedeemer))
-> Sem effs [(TxOutRef, TxSkelRedeemer)]
forall a b. (a -> b) -> a -> b
$ \(TxOutRef
oRef, TxSkelRedeemer
red) ->
    (TxOutRef
oRef,) (TxSkelRedeemer -> (TxOutRef, TxSkelRedeemer))
-> Sem effs TxSkelRedeemer -> Sem effs (TxOutRef, TxSkelRedeemer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      Maybe VScript
validatorM <- Optic' An_AffineTraversal '[] TxSkelOut VScript
-> TxOutRef -> Sem effs (Maybe VScript)
forall (effs :: EffectRow) af (is :: [*]) c.
(Member MockChainRead effs, Is af An_AffineFold) =>
Optic' af is TxSkelOut c -> TxOutRef -> Sem effs (Maybe c)
previewByRef (Lens' TxSkelOut (User 'IsEither 'Allocation)
txSkelOutOwnerL Lens' TxSkelOut (User 'IsEither 'Allocation)
-> Optic
     An_AffineTraversal
     '[]
     (User 'IsEither 'Allocation)
     (User 'IsEither 'Allocation)
     VScript
     VScript
-> Optic' An_AffineTraversal '[] TxSkelOut VScript
forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  An_AffineTraversal
  '[]
  (User 'IsEither 'Allocation)
  (User 'IsEither 'Allocation)
  VScript
  VScript
forall (kind :: UserKind) (mode :: UserMode).
AffineTraversal' (User kind mode) VScript
userVScriptAT) TxOutRef
oRef
      case Maybe VScript
validatorM of
        Maybe VScript
Nothing -> TxSkelRedeemer -> Sem effs TxSkelRedeemer
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return TxSkelRedeemer
red
        Just VScript
val -> Optic' A_Lens '[] (User 'IsScript 'Redemption) TxSkelRedeemer
-> User 'IsScript 'Redemption -> TxSkelRedeemer
forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] (User 'IsScript 'Redemption) TxSkelRedeemer
userRedeemerL (User 'IsScript 'Redemption -> TxSkelRedeemer)
-> Sem effs (User 'IsScript 'Redemption) -> Sem effs TxSkelRedeemer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxOutRef]
-> User 'IsScript 'Redemption
-> Sem effs (User 'IsScript 'Redemption)
forall (effs :: EffectRow).
Members '[MockChainLog, MockChainRead] effs =>
[TxOutRef]
-> User 'IsScript 'Redemption
-> Sem effs (User 'IsScript 'Redemption)
updateRedeemedScript [TxOutRef]
inputsKeys (VScript -> TxSkelRedeemer -> User 'IsScript 'Redemption
forall script (a :: UserKind).
(a ∈ '[ 'IsScript, 'IsEither], ToVScript script,
 Typeable script) =>
script -> TxSkelRedeemer -> User a 'Redemption
UserRedeemedScript VScript
val TxSkelRedeemer
red)
  Lens' TxSkel (Map TxOutRef TxSkelRedeemer)
-> Map TxOutRef TxSkelRedeemer -> Sem effs ()
forall (effs :: EffectRow) k (is :: [*]) a.
(Member Tweak effs, Is k A_Setter) =>
Optic' k is TxSkel a -> a -> Sem effs ()
setTweak Lens' TxSkel (Map TxOutRef TxSkelRedeemer)
txSkelInputsL (Map TxOutRef TxSkelRedeemer -> Sem effs ())
-> Map TxOutRef TxSkelRedeemer -> Sem effs ()
forall a b. (a -> b) -> a -> b
$ [(TxOutRef, TxSkelRedeemer)] -> Map TxOutRef TxSkelRedeemer
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TxOutRef, TxSkelRedeemer)]
newInputs
  -- Updating minting, proposing, withdrawing and certifying redeemers, whose
  -- scripts are directly stored in the skeleton, in one go.
  Optic' A_Traversal '[] TxSkel (User 'IsScript 'Redemption)
-> (User 'IsScript 'Redemption
    -> Sem effs (User 'IsScript 'Redemption))
-> Sem effs ()
forall (effs :: EffectRow) k (is :: [*]) a.
(Member Tweak effs, Is k A_Traversal) =>
Optic' k is TxSkel a -> (a -> Sem effs a) -> Sem effs ()
traverseTweak Optic' A_Traversal '[] TxSkel (User 'IsScript 'Redemption)
txSkelRedeemedScriptsT ([TxOutRef]
-> User 'IsScript 'Redemption
-> Sem effs (User 'IsScript 'Redemption)
forall (effs :: EffectRow).
Members '[MockChainLog, MockChainRead] effs =>
[TxOutRef]
-> User 'IsScript 'Redemption
-> Sem effs (User 'IsScript 'Redemption)
updateRedeemedScript [TxOutRef]
inputsKeys)