{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE MonoLocalBinds     #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE ViewPatterns       #-}
{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
{-# OPTIONS_GHC -fno-specialise #-}
{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
module Ledger.Tx.Constraints.OnChain.V1
    ( checkScriptContext
    , checkOwnInputConstraint
    , checkOwnOutputConstraint
    ) where

import PlutusTx (ToData (toBuiltinData))
import PlutusTx.Prelude (Bool (False, True), Eq ((==)), Functor (fmap), Maybe (Just), all, any, elem, isJust, isNothing,
                         maybe, snd, traceIfFalse, ($), (&&), (.))

import Ledger qualified
import Ledger.Address (PaymentPubKeyHash (unPaymentPubKeyHash))
import Ledger.Credential (Credential (ScriptCredential))
import Ledger.Tx.Constraints.TxConstraints (ScriptInputConstraint (ScriptInputConstraint, icRedeemer, icReferenceTxOutRef, icTxOutRef),
                                            ScriptOutputConstraint (ScriptOutputConstraint, ocDatum, ocReferenceScriptHash, ocValue),
                                            TxConstraint (MustBeSignedBy, MustIncludeDatumInTx, MustIncludeDatumInTxWithHash, MustMintValue, MustPayToAddress, MustProduceAtLeast, MustReferenceOutput, MustSatisfyAnyOf, MustSpendAtLeast, MustSpendPubKeyOutput, MustSpendScriptOutput, MustUseOutputAsCollateral, MustValidateInTimeRange),
                                            TxConstraintFun (MustSpendScriptOutputWithMatchingDatumAndValue),
                                            TxConstraintFuns (TxConstraintFuns),
                                            TxConstraints (TxConstraints, txConstraintFuns, txConstraints, txOwnInputs, txOwnOutputs),
                                            TxOutDatum (TxOutDatumHash, TxOutDatumInTx))
import Ledger.Tx.Constraints.ValidityInterval (toPlutusInterval)
import Plutus.Script.Utils.V1.Contexts (ScriptContext (ScriptContext, scriptContextTxInfo),
                                        TxInInfo (TxInInfo, txInInfoResolved),
                                        TxInfo (txInfoData, txInfoInputs, txInfoMint, txInfoValidRange),
                                        TxOut (TxOut, txOutAddress, txOutDatumHash))
import Plutus.Script.Utils.V1.Contexts qualified as V
import Plutus.Script.Utils.Value (leq)
import Plutus.Script.Utils.Value qualified as Value
import Plutus.V1.Ledger.Interval (contains)

{-# INLINABLE checkScriptContext #-}
-- | Does the 'ScriptContext' satisfy the constraints?
checkScriptContext :: forall i o. (ToData i, ToData o) => TxConstraints i o -> ScriptContext -> Bool
checkScriptContext :: TxConstraints i o -> ScriptContext -> Bool
checkScriptContext TxConstraints{[TxConstraint]
txConstraints :: [TxConstraint]
txConstraints :: forall i o. TxConstraints i o -> [TxConstraint]
txConstraints, txConstraintFuns :: forall i o. TxConstraints i o -> TxConstraintFuns
txConstraintFuns = TxConstraintFuns [TxConstraintFun]
txCnsFuns, [ScriptInputConstraint i]
txOwnInputs :: [ScriptInputConstraint i]
txOwnInputs :: forall i o. TxConstraints i o -> [ScriptInputConstraint i]
txOwnInputs, [ScriptOutputConstraint o]
txOwnOutputs :: [ScriptOutputConstraint o]
txOwnOutputs :: forall i o. TxConstraints i o -> [ScriptOutputConstraint o]
txOwnOutputs} ScriptContext
ptx =
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"L!" -- "checkScriptContext failed"
    (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (TxConstraint -> Bool) -> [TxConstraint] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ScriptContext -> TxConstraint -> Bool
checkTxConstraint ScriptContext
ptx) [TxConstraint]
txConstraints
    Bool -> Bool -> Bool
&& (TxConstraintFun -> Bool) -> [TxConstraintFun] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ScriptContext -> TxConstraintFun -> Bool
checkTxConstraintFun ScriptContext
ptx) [TxConstraintFun]
txCnsFuns
    Bool -> Bool -> Bool
&& (ScriptInputConstraint i -> Bool)
-> [ScriptInputConstraint i] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ScriptContext -> ScriptInputConstraint i -> Bool
forall i.
ToData i =>
ScriptContext -> ScriptInputConstraint i -> Bool
checkOwnInputConstraint ScriptContext
ptx) [ScriptInputConstraint i]
txOwnInputs
    Bool -> Bool -> Bool
&& (ScriptOutputConstraint o -> Bool)
-> [ScriptOutputConstraint o] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ScriptContext -> ScriptOutputConstraint o -> Bool
forall o.
ToData o =>
ScriptContext -> ScriptOutputConstraint o -> Bool
checkOwnOutputConstraint ScriptContext
ptx) [ScriptOutputConstraint o]
txOwnOutputs

{-# INLINABLE checkOwnInputConstraint #-}
checkOwnInputConstraint
    :: ToData i
    => ScriptContext
    -> ScriptInputConstraint i
    -> Bool
checkOwnInputConstraint :: ScriptContext -> ScriptInputConstraint i -> Bool
checkOwnInputConstraint ScriptContext
ctx ScriptInputConstraint{TxOutRef
icTxOutRef :: TxOutRef
icTxOutRef :: forall a. ScriptInputConstraint a -> TxOutRef
icTxOutRef, i
icRedeemer :: i
icRedeemer :: forall a. ScriptInputConstraint a -> a
icRedeemer, Maybe TxOutRef
icReferenceTxOutRef :: Maybe TxOutRef
icReferenceTxOutRef :: forall a. ScriptInputConstraint a -> Maybe TxOutRef
icReferenceTxOutRef} =
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"L0" -- "Input constraint"
    (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ScriptContext -> TxConstraint -> Bool
checkTxConstraint ScriptContext
ctx (TxOutRef -> Redeemer -> Maybe TxOutRef -> TxConstraint
MustSpendScriptOutput TxOutRef
icTxOutRef (BuiltinData -> Redeemer
Ledger.Redeemer (BuiltinData -> Redeemer) -> BuiltinData -> Redeemer
forall a b. (a -> b) -> a -> b
$ i -> BuiltinData
forall a. ToData a => a -> BuiltinData
toBuiltinData i
icRedeemer) Maybe TxOutRef
icReferenceTxOutRef)

{-# INLINABLE checkOwnOutputConstraint #-}
checkOwnOutputConstraint
    :: ToData o
    => ScriptContext
    -> ScriptOutputConstraint o
    -> Bool
checkOwnOutputConstraint :: ScriptContext -> ScriptOutputConstraint o -> Bool
checkOwnOutputConstraint ScriptContext
ctx ScriptOutputConstraint{TxOutDatum o
ocDatum :: TxOutDatum o
ocDatum :: forall a. ScriptOutputConstraint a -> TxOutDatum a
ocDatum, Value
ocValue :: Value
ocValue :: forall a. ScriptOutputConstraint a -> Value
ocValue, Maybe ScriptHash
ocReferenceScriptHash :: Maybe ScriptHash
ocReferenceScriptHash :: forall a. ScriptOutputConstraint a -> Maybe ScriptHash
ocReferenceScriptHash} =
    let d :: TxOutDatum Datum
d = (o -> Datum) -> TxOutDatum o -> TxOutDatum Datum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BuiltinData -> Datum
Ledger.Datum (BuiltinData -> Datum) -> (o -> BuiltinData) -> o -> Datum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. o -> BuiltinData
forall a. ToData a => a -> BuiltinData
toBuiltinData) TxOutDatum o
ocDatum
    in BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"L1" -- "Output constraint"
    (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool -> (TxInInfo -> Bool) -> Maybe TxInInfo -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\TxInInfo{txInInfoResolved :: TxInInfo -> TxOut
txInInfoResolved=TxOut{Address
txOutAddress :: Address
txOutAddress :: TxOut -> Address
txOutAddress}} ->
                        ScriptContext -> TxConstraint -> Bool
checkTxConstraint ScriptContext
ctx (Address
-> Maybe (TxOutDatum Datum)
-> Maybe ScriptHash
-> Value
-> TxConstraint
MustPayToAddress Address
txOutAddress (TxOutDatum Datum -> Maybe (TxOutDatum Datum)
forall a. a -> Maybe a
Just TxOutDatum Datum
d) Maybe ScriptHash
ocReferenceScriptHash Value
ocValue))
        (ScriptContext -> Maybe TxInInfo
V.findOwnInput ScriptContext
ctx)

{-# INLINABLE checkTxConstraint #-}
checkTxConstraint :: ScriptContext -> TxConstraint -> Bool
checkTxConstraint :: ScriptContext -> TxConstraint -> Bool
checkTxConstraint ctx :: ScriptContext
ctx@ScriptContext{TxInfo
scriptContextTxInfo :: TxInfo
scriptContextTxInfo :: ScriptContext -> TxInfo
scriptContextTxInfo} = \case
    MustIncludeDatumInTx Datum
dv ->
        BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"L2" -- "Missing datum"
        (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Datum
dv Datum -> [Datum] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((DatumHash, Datum) -> Datum) -> [(DatumHash, Datum)] -> [Datum]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DatumHash, Datum) -> Datum
forall a b. (a, b) -> b
snd (TxInfo -> [(DatumHash, Datum)]
txInfoData TxInfo
scriptContextTxInfo)
    MustValidateInTimeRange ValidityInterval POSIXTime
interval ->
        BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"L3" -- "Wrong validation interval"
        (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ValidityInterval POSIXTime -> Interval POSIXTime
forall a. ValidityInterval a -> Interval a
toPlutusInterval ValidityInterval POSIXTime
interval Interval POSIXTime -> Interval POSIXTime -> Bool
forall a. Ord a => Interval a -> Interval a -> Bool
`contains` TxInfo -> Interval POSIXTime
txInfoValidRange TxInfo
scriptContextTxInfo
    MustBeSignedBy PaymentPubKeyHash
pkh ->
        BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"L4" -- "Missing signature"
        (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ TxInfo
scriptContextTxInfo TxInfo -> PubKeyHash -> Bool
`V.txSignedBy` PaymentPubKeyHash -> PubKeyHash
unPaymentPubKeyHash PaymentPubKeyHash
pkh
    MustSpendAtLeast Value
vl ->
        BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"L5" -- "Spent value not OK"
        (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Value
vl Value -> Value -> Bool
`leq` TxInfo -> Value
V.valueSpent TxInfo
scriptContextTxInfo
    MustProduceAtLeast Value
vl ->
        BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"L6" -- "Produced value not OK"
        (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Value
vl Value -> Value -> Bool
`leq` TxInfo -> Value
V.valueProduced TxInfo
scriptContextTxInfo
    MustSpendPubKeyOutput TxOutRef
txOutRef ->
        BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"L7" -- "Public key output not spent"
        (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool -> (TxInInfo -> Bool) -> Maybe TxInInfo -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Maybe DatumHash -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe DatumHash -> Bool)
-> (TxInInfo -> Maybe DatumHash) -> TxInInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut -> Maybe DatumHash
txOutDatumHash (TxOut -> Maybe DatumHash)
-> (TxInInfo -> TxOut) -> TxInInfo -> Maybe DatumHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxInInfo -> TxOut
txInInfoResolved) (TxOutRef -> TxInfo -> Maybe TxInInfo
V.findTxInByTxOutRef TxOutRef
txOutRef TxInfo
scriptContextTxInfo)
    MustSpendScriptOutput TxOutRef
txOutRef Redeemer
_ Maybe TxOutRef
_ ->
        BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"L8" -- "Script output not spent"
        -- Unfortunately we can't check the redeemer, because TxInfo only
        -- gives us the redeemer's hash, but 'MustSpendScriptOutput' gives
        -- us the full redeemer
        (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe TxInInfo -> Bool
forall a. Maybe a -> Bool
isJust (TxOutRef -> TxInfo -> Maybe TxInInfo
V.findTxInByTxOutRef TxOutRef
txOutRef TxInfo
scriptContextTxInfo)
    MustMintValue MintingPolicyHash
mps Redeemer
_ TokenName
tn Integer
v Maybe TxOutRef
_ ->
        BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"L9" -- "Value minted not OK"
        (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Value -> CurrencySymbol -> TokenName -> Integer
Value.valueOf (TxInfo -> Value
txInfoMint TxInfo
scriptContextTxInfo) (MintingPolicyHash -> CurrencySymbol
Value.mpsSymbol MintingPolicyHash
mps) TokenName
tn Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
v
    MustPayToAddress Address
addr Maybe (TxOutDatum Datum)
mdv Maybe ScriptHash
refScript Value
vl ->
        let outs :: [TxOut]
outs = TxInfo -> [TxOut]
V.txInfoOutputs TxInfo
scriptContextTxInfo
            hsh :: Datum -> Maybe DatumHash
hsh Datum
dv = Datum -> TxInfo -> Maybe DatumHash
V.findDatumHash Datum
dv TxInfo
scriptContextTxInfo
            checkOutput :: TxOutDatum Datum -> TxOut -> Bool
checkOutput (TxOutDatumHash Datum
_) TxOut{txOutDatumHash :: TxOut -> Maybe DatumHash
txOutDatumHash=Just DatumHash
_} =
                -- The datum is not added in the tx body with so we can't verify
                -- that the tx output's datum hash is the correct one w.r.t the
                -- provide datum.
                Bool
True
            checkOutput (TxOutDatumInTx Datum
dv) TxOut{txOutDatumHash :: TxOut -> Maybe DatumHash
txOutDatumHash=Just DatumHash
svh} =
                Datum -> Maybe DatumHash
hsh Datum
dv Maybe DatumHash -> Maybe DatumHash -> Bool
forall a. Eq a => a -> a -> Bool
== DatumHash -> Maybe DatumHash
forall a. a -> Maybe a
Just DatumHash
svh
            checkOutput TxOutDatum Datum
_ TxOut
_ = Bool
False
        in
        BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"La" -- "MustPayToAddress"
        (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Value
vl Value -> Value -> Bool
`leq` TxInfo -> Address -> Value
V.valuePaidTo TxInfo
scriptContextTxInfo Address
addr
            Bool -> Bool -> Bool
&& Bool
-> (TxOutDatum Datum -> Bool) -> Maybe (TxOutDatum Datum) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\TxOutDatum Datum
dv -> (TxOut -> Bool) -> [TxOut] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TxOutDatum Datum -> TxOut -> Bool
checkOutput TxOutDatum Datum
dv) [TxOut]
outs) Maybe (TxOutDatum Datum)
mdv
            Bool -> Bool -> Bool
&& Maybe ScriptHash -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ScriptHash
refScript
    MustIncludeDatumInTxWithHash DatumHash
dvh Datum
dv ->
        BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"Lc" -- "missing datum"
        (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ DatumHash -> TxInfo -> Maybe Datum
V.findDatum DatumHash
dvh TxInfo
scriptContextTxInfo Maybe Datum -> Maybe Datum -> Bool
forall a. Eq a => a -> a -> Bool
== Datum -> Maybe Datum
forall a. a -> Maybe a
Just Datum
dv
    MustSatisfyAnyOf [[TxConstraint]]
xs ->
        BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"Ld" -- "MustSatisfyAnyOf"
        (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ([TxConstraint] -> Bool) -> [[TxConstraint]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((TxConstraint -> Bool) -> [TxConstraint] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ScriptContext -> TxConstraint -> Bool
checkTxConstraint ScriptContext
ctx)) [[TxConstraint]]
xs
    MustUseOutputAsCollateral TxOutRef
_ ->
        Bool
True -- TxInfo does not have the collateral inputs
    MustReferenceOutput TxOutRef
_ ->
        BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"Lf" -- "Cannot use reference inputs in PlutusV1.ScriptContext"
        Bool
False

{-# INLINABLE checkTxConstraintFun #-}
checkTxConstraintFun :: ScriptContext -> TxConstraintFun -> Bool
checkTxConstraintFun :: ScriptContext -> TxConstraintFun -> Bool
checkTxConstraintFun ScriptContext{TxInfo
scriptContextTxInfo :: TxInfo
scriptContextTxInfo :: ScriptContext -> TxInfo
scriptContextTxInfo} = \case
    MustSpendScriptOutputWithMatchingDatumAndValue ValidatorHash
vh Datum -> Bool
datumPred Value -> Bool
valuePred Redeemer
_ ->
        let findDatum :: Maybe DatumHash -> Maybe Datum
findDatum Maybe DatumHash
mdh = do
                DatumHash
dh <- Maybe DatumHash
mdh
                DatumHash -> TxInfo -> Maybe Datum
V.findDatum DatumHash
dh TxInfo
scriptContextTxInfo
            isMatch :: TxOut -> Bool
isMatch (TxOut (Ledger.Address (ScriptCredential ValidatorHash
vh') Maybe StakingCredential
_) Value
val (Maybe DatumHash -> Maybe Datum
findDatum -> Just Datum
d)) =
                ValidatorHash
vh ValidatorHash -> ValidatorHash -> Bool
forall a. Eq a => a -> a -> Bool
== ValidatorHash
vh' Bool -> Bool -> Bool
&& Value -> Bool
valuePred Value
val Bool -> Bool -> Bool
&& Datum -> Bool
datumPred Datum
d
            isMatch TxOut
_ = Bool
False
        in
        BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"Le" -- "MustSpendScriptOutputWithMatchingDatumAndValue"
        (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (TxInInfo -> Bool) -> [TxInInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TxOut -> Bool
isMatch (TxOut -> Bool) -> (TxInInfo -> TxOut) -> TxInInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxInInfo -> TxOut
txInInfoResolved) (TxInfo -> [TxInInfo]
txInfoInputs TxInfo
scriptContextTxInfo)