-- | This module provides functions to ensure skeleton outputs contain enough
-- ada to satisfy the minimum ada constraint.
module Cooked.MockChain.MinAda
  ( toTxSkelOutWithMinAda,
    toTxSkelWithMinAda,
    getTxSkelOutMinAda,
  )
where

import Cardano.Api qualified as Cardano
import Cardano.Api.Ledger qualified as Cardano
import Cardano.Api.Shelley qualified as Cardano
import Cardano.Ledger.Shelley.Core qualified as Shelley
import Cardano.Node.Emulator qualified as Emulator
import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator
import Control.Monad.Except
import Cooked.MockChain.BlockChain
import Cooked.MockChain.GenerateTx
import Cooked.Skeleton
import Optics.Core
import Plutus.Script.Utils.Ada qualified as Script
import Plutus.Script.Utils.Value qualified as Script

-- | This provides the minimum amount of ada required in a given `TxSkelOut`. As
-- we need to transform our output into a Cardano output to compute this value,
-- this function can fail.
getTxSkelOutMinAda :: Emulator.Params -> TxSkelOut -> Either GenerateTxError Integer
getTxSkelOutMinAda :: Params -> TxSkelOut -> Either GenerateTxError Integer
getTxSkelOutMinAda Emulator.Params {NetworkId
PParams
EpochSize
TransitionConfig
SlotConfig
pSlotConfig :: SlotConfig
pEmulatorPParams :: PParams
pNetworkId :: NetworkId
pEpochSize :: EpochSize
pConfig :: TransitionConfig
pSlotConfig :: Params -> SlotConfig
pEmulatorPParams :: Params -> PParams
pNetworkId :: Params -> NetworkId
pEpochSize :: Params -> EpochSize
pConfig :: Params -> TransitionConfig
..} TxSkelOut
txSkelOut =
  Coin -> Integer
Cardano.unCoin
    (Coin -> Integer)
-> (TxOut CtxTx ConwayEra -> Coin)
-> TxOut CtxTx ConwayEra
-> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PParams -> TxOut EmulatorEra -> Coin
forall era. EraTxOut era => PParams era -> TxOut era -> Coin
Shelley.getMinCoinTxOut PParams
pEmulatorPParams
    (BabbageTxOut EmulatorEra -> Coin)
-> (TxOut CtxTx ConwayEra -> BabbageTxOut EmulatorEra)
-> TxOut CtxTx ConwayEra
-> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyBasedEra ConwayEra
-> TxOut CtxUTxO ConwayEra -> TxOut EmulatorEra
forall era ledgerera.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era -> TxOut CtxUTxO era -> TxOut ledgerera
Cardano.toShelleyTxOut ShelleyBasedEra ConwayEra
Cardano.ShelleyBasedEraConway
    (TxOut CtxUTxO ConwayEra -> BabbageTxOut EmulatorEra)
-> (TxOut CtxTx ConwayEra -> TxOut CtxUTxO ConwayEra)
-> TxOut CtxTx ConwayEra
-> BabbageTxOut EmulatorEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxTx ConwayEra -> TxOut CtxUTxO ConwayEra
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
Cardano.toCtxUTxOTxOut
    (TxOut CtxTx ConwayEra -> Integer)
-> Either GenerateTxError (TxOut CtxTx ConwayEra)
-> Either GenerateTxError Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetworkId
-> TxSkelOut -> Either GenerateTxError (TxOut CtxTx ConwayEra)
generateTxOut NetworkId
pNetworkId TxSkelOut
txSkelOut

-- | This transforms an output into another output which necessarily contains at
-- least the minimal required ada. If the previous quantity of ada was
-- sufficient, it remains unchanged. This requires an iterative process, as
-- adding ada into an output can potentially increase its size and thus make it
-- require more minimal ada (although this remains to be witnessed in practice).
-- This approach was inspired by
-- https://github.com/input-output-hk/plutus-apps/blob/8706e6c7c525b4973a7b6d2ed7c9d0ef9cd4ef46/plutus-ledger/src/Ledger/Index.hs#L124
toTxSkelOutWithMinAda :: Emulator.Params -> TxSkelOut -> Either GenerateTxError TxSkelOut
toTxSkelOutWithMinAda :: Params -> TxSkelOut -> Either GenerateTxError TxSkelOut
toTxSkelOutWithMinAda Params
params TxSkelOut
txSkelOut = do
  let Script.Lovelace Integer
oldAda = TxSkelOut
txSkelOut TxSkelOut -> Optic' A_Lens NoIx TxSkelOut Ada -> Ada
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' TxSkelOut Value
txSkelOutValueL Lens' TxSkelOut Value
-> Optic A_Lens NoIx Value Value Ada Ada
-> Optic' A_Lens NoIx TxSkelOut Ada
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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 A_Lens NoIx Value Value Ada Ada
Script.adaL
  Integer
requiredAda <- Params -> TxSkelOut -> Either GenerateTxError Integer
getTxSkelOutMinAda Params
params TxSkelOut
txSkelOut
  if Integer
oldAda Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
requiredAda
    then Params -> TxSkelOut -> Either GenerateTxError TxSkelOut
toTxSkelOutWithMinAda Params
params (TxSkelOut -> Either GenerateTxError TxSkelOut)
-> TxSkelOut -> Either GenerateTxError TxSkelOut
forall a b. (a -> b) -> a -> b
$ TxSkelOut
txSkelOut TxSkelOut -> (TxSkelOut -> TxSkelOut) -> TxSkelOut
forall a b. a -> (a -> b) -> b
& Lens' TxSkelOut Value
txSkelOutValueL Lens' TxSkelOut Value
-> Optic A_Lens NoIx Value Value Ada Ada
-> Optic' A_Lens NoIx TxSkelOut Ada
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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 A_Lens NoIx Value Value Ada Ada
Script.adaL Optic' A_Lens NoIx TxSkelOut Ada -> Ada -> TxSkelOut -> TxSkelOut
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Integer -> Ada
Script.Lovelace Integer
requiredAda
    else TxSkelOut -> Either GenerateTxError TxSkelOut
forall a. a -> Either GenerateTxError a
forall (m :: * -> *) a. Monad m => a -> m a
return TxSkelOut
txSkelOut

-- | This transforms a skeleton by replacing all its `TxSkelOut` by their
-- updated variants with their minimal amount of required ada. Any error raised
-- in the transformation process is transformed into an `MCEGenerationError`
toTxSkelWithMinAda :: (MonadBlockChainBalancing m) => TxSkel -> m TxSkel
toTxSkelWithMinAda :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> m TxSkel
toTxSkelWithMinAda TxSkel
skel = do
  Params
theParams <- m Params
forall (m :: * -> *). MonadBlockChainBalancing m => m Params
getParams
  case (TxSkelOut -> Either GenerateTxError TxSkelOut)
-> [TxSkelOut] -> Either GenerateTxError [TxSkelOut]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Params -> TxSkelOut -> Either GenerateTxError TxSkelOut
toTxSkelOutWithMinAda Params
theParams) ([TxSkelOut] -> Either GenerateTxError [TxSkelOut])
-> [TxSkelOut] -> Either GenerateTxError [TxSkelOut]
forall a b. (a -> b) -> a -> b
$ TxSkel
skel TxSkel -> Optic' A_Lens NoIx TxSkel [TxSkelOut] -> [TxSkelOut]
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx TxSkel [TxSkelOut]
txSkelOutsL of
    Left GenerateTxError
err -> MockChainError -> m TxSkel
forall a. MockChainError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MockChainError -> m TxSkel) -> MockChainError -> m TxSkel
forall a b. (a -> b) -> a -> b
$ GenerateTxError -> MockChainError
MCEGenerationError GenerateTxError
err
    Right [TxSkelOut]
newTxSkelOuts -> 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
skel TxSkel -> (TxSkel -> TxSkel) -> TxSkel
forall a b. a -> (a -> b) -> b
& Optic' A_Lens NoIx TxSkel [TxSkelOut]
txSkelOutsL Optic' A_Lens NoIx TxSkel [TxSkelOut]
-> [TxSkelOut] -> TxSkel -> TxSkel
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ [TxSkelOut]
newTxSkelOuts