{-# LANGUAGE CPP #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoPolyKinds #-}
{-# OPTIONS_GHC -fno-specialize #-}
{-# OPTIONS_GHC -fplugin-opt Plinth.Plugin:conservative-optimisation #-}
{-# OPTIONS_GHC -fplugin-opt Plinth.Plugin:defer-errors #-}
-- Avoid trace calls to be optimized away when inlining functions.
{-# OPTIONS_GHC -fplugin-opt Plinth.Plugin:no-simplifier-inline #-}
{-# OPTIONS_GHC -fplugin-opt Plinth.Plugin:optimize #-}
{-# OPTIONS_GHC -fplugin-opt Plinth.Plugin:target-version=1.1.0 #-}

-- | Minting policy for a single head tokens.
module Hydra.Contract.HeadTokens where

import PlutusTx.Prelude

#ifdef HYDRA_PRECOMPILED_SCRIPTS
import Hydra.Contract.Precompiled qualified as Precompiled
import Hydra.Plutus.Extras (MintingPolicyType)
#else
import Hydra.Plutus.Extras (MintingPolicyType, scriptValidatorHash, wrapMintingPolicy)
#endif

import Hydra.Cardano.Api (
  PolicyId,
  TxIn,
  scriptPolicyId,
  toPlutusTxOutRef,
  pattern PlutusScript,
  pattern PlutusScriptSerialised,
 )
import Hydra.Cardano.Api qualified as Api
import PlutusTx.Foldable qualified as F
import PlutusTx.List qualified as L

import Hydra.Contract.Head qualified as Head
import Hydra.Contract.HeadState qualified as Head
import Hydra.Contract.HeadTokensError (HeadTokensError (..), errorCode)
import Hydra.Contract.MintAction (MintAction (Burn, Mint))
import Hydra.Contract.Util (hasST, hydraHeadV2, scriptOutputsAt)
import PlutusCore.Version (plcVersion110)
import PlutusLedgerApi.V3 (
  Datum (getDatum),
  OutputDatum (..),
  ScriptContext (..),
  ScriptHash,
  TokenName (..),
  TxInInfo (..),
  TxInfo (..),
  TxOutRef,
  Value (getValue),
  mintValueToMap,
  serialiseCompiledCode,
 )
import PlutusLedgerApi.V3.Contexts (ownCurrencySymbol)
import PlutusTx (CompiledCode)
import PlutusTx qualified
import PlutusTx.AssocMap qualified as AssocMap
import PlutusTx.Foldable (length)

validate ::
  ScriptHash ->
  TxOutRef ->
  MintAction ->
  ScriptContext ->
  Bool
validate :: ScriptHash -> TxOutRef -> MintAction -> ScriptContext -> Bool
validate ScriptHash
headValidator TxOutRef
seedInput MintAction
action ScriptContext
context =
  case MintAction
action of
    MintAction
Mint -> ScriptHash -> TxOutRef -> ScriptContext -> Bool
validateTokensMinting ScriptHash
headValidator TxOutRef
seedInput ScriptContext
context
    MintAction
Burn -> ScriptContext -> Bool
validateTokensBurning ScriptContext
context
{-# INLINEABLE validate #-}

-- | When minting head tokens we want to make sure that:
--
-- * The number of minted PTs == number of participants (+1 for the ST) evident
--   from the datum.
--
-- * There is single state token that is paid into v_head, which ensures
--   continuity.
--
-- * Ensure out-ref and the headId are in the datum of the first output of the
--   transaction which mints tokens.
validateTokensMinting :: ScriptHash -> TxOutRef -> ScriptContext -> Bool
validateTokensMinting :: ScriptHash -> TxOutRef -> ScriptContext -> Bool
validateTokensMinting ScriptHash
headValidator TxOutRef
seedInput ScriptContext
context =
  Bool
seedInputIsConsumed
    Bool -> Bool -> Bool
&& Bool
checkNumberOfTokens
    Bool -> Bool -> Bool
&& Bool
singleSTIsPaidToTheHead
    Bool -> Bool -> Bool
&& Bool
enoughUniquePTsPaidToHead
    Bool -> Bool -> Bool
&& Bool
checkDatum
 where
  seedInputIsConsumed :: Bool
seedInputIsConsumed =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode SeedNotSpent) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      TxOutRef
seedInput TxOutRef -> [TxOutRef] -> Bool
forall a. Eq a => a -> [a] -> Bool
`L.elem` (TxInInfo -> TxOutRef
txInInfoOutRef (TxInInfo -> TxOutRef) -> [TxInInfo] -> [TxOutRef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxInfo -> [TxInInfo]
txInfoInputs TxInfo
txInfo)

  checkNumberOfTokens :: Bool
checkNumberOfTokens =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode WrongNumberOfTokensMinted) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      Integer
mintedTokenCount Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
nParties Integer -> Integer -> Integer
forall a. AdditiveSemigroup a => a -> a -> a
+ Integer
1

  singleSTIsPaidToTheHead :: Bool
singleSTIsPaidToTheHead =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode MissingST) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      CurrencySymbol -> Value -> Bool
hasST CurrencySymbol
currency Value
headValue

  enoughUniquePTsPaidToHead :: Bool
enoughUniquePTsPaidToHead =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode MissingPTs) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      [TokenName] -> Integer
forall (t :: * -> *) a. Foldable t => t a -> Integer
length (Value -> [TokenName]
uniquePTs Value
headValue) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
nParties

  uniquePTs :: Value -> [TokenName]
uniquePTs Value
val =
    case CurrencySymbol
-> Map CurrencySymbol (Map TokenName Integer)
-> Maybe (Map TokenName Integer)
forall k v. Eq k => k -> Map k v -> Maybe v
AssocMap.lookup CurrencySymbol
currency (Value -> Map CurrencySymbol (Map TokenName Integer)
getValue Value
val) of
      Maybe (Map TokenName Integer)
Nothing -> BuiltinString -> [TokenName]
forall a. BuiltinString -> a
traceError $(errorCode NoPTs)
      (Just Map TokenName Integer
tokenMap) ->
        -- NOTE: Ideally this would be a filterWithKey
        Map TokenName TokenName -> [TokenName]
forall k v. Map k v -> [v]
AssocMap.elems (Map TokenName TokenName -> [TokenName])
-> ((TokenName -> Integer -> Maybe TokenName)
    -> Map TokenName TokenName)
-> (TokenName -> Integer -> Maybe TokenName)
-> [TokenName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TokenName -> Integer -> Maybe TokenName)
 -> Map TokenName Integer -> Map TokenName TokenName)
-> Map TokenName Integer
-> (TokenName -> Integer -> Maybe TokenName)
-> Map TokenName TokenName
forall a b c. (a -> b -> c) -> b -> a -> c
flip (TokenName -> Integer -> Maybe TokenName)
-> Map TokenName Integer -> Map TokenName TokenName
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
AssocMap.mapMaybeWithKey Map TokenName Integer
tokenMap ((TokenName -> Integer -> Maybe TokenName) -> [TokenName])
-> (TokenName -> Integer -> Maybe TokenName) -> [TokenName]
forall a b. (a -> b) -> a -> b
$ \TokenName
an Integer
qty ->
          if
            | TokenName
an TokenName -> TokenName -> Bool
forall a. Eq a => a -> a -> Bool
== BuiltinByteString -> TokenName
TokenName BuiltinByteString
hydraHeadV2 -> Maybe TokenName
forall a. Maybe a
Nothing
            | Integer
qty Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 -> TokenName -> Maybe TokenName
forall a. a -> Maybe a
Just TokenName
an
            | Bool
otherwise -> BuiltinString -> Maybe TokenName
forall a. BuiltinString -> a
traceError $(errorCode WrongQuantity)

  checkDatum :: Bool
checkDatum =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode WrongDatum) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      CurrencySymbol
headId CurrencySymbol -> CurrencySymbol -> Bool
forall a. Eq a => a -> a -> Bool
== CurrencySymbol
currency Bool -> Bool -> Bool
&& TxOutRef
seed TxOutRef -> TxOutRef -> Bool
forall a. Eq a => a -> a -> Bool
== TxOutRef
seedInput

  mintedTokenCount :: Integer
mintedTokenCount =
    Integer
-> (Map TokenName Integer -> Integer)
-> Maybe (Map TokenName Integer)
-> Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Integer
0 Map TokenName Integer -> Integer
forall (t :: * -> *) a. (Foldable t, AdditiveMonoid a) => t a -> a
F.sum
      (Maybe (Map TokenName Integer) -> Integer)
-> (MintValue -> Maybe (Map TokenName Integer))
-> MintValue
-> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CurrencySymbol
-> Map CurrencySymbol (Map TokenName Integer)
-> Maybe (Map TokenName Integer)
forall k v. Eq k => k -> Map k v -> Maybe v
AssocMap.lookup CurrencySymbol
currency
      (Map CurrencySymbol (Map TokenName Integer)
 -> Maybe (Map TokenName Integer))
-> (MintValue -> Map CurrencySymbol (Map TokenName Integer))
-> MintValue
-> Maybe (Map TokenName Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MintValue -> Map CurrencySymbol (Map TokenName Integer)
mintValueToMap
      (MintValue -> Integer) -> MintValue -> Integer
forall a b. (a -> b) -> a -> b
$ TxInfo -> MintValue
txInfoMint TxInfo
txInfo

  (CurrencySymbol
headId, TxOutRef
seed, Integer
nParties) =
    case OutputDatum
headDatum of
      OutputDatum Datum
datum ->
        case forall a. FromData a => BuiltinData -> Maybe a
fromBuiltinData @Head.DatumType (BuiltinData -> Maybe DatumType) -> BuiltinData -> Maybe DatumType
forall a b. (a -> b) -> a -> b
$ Datum -> BuiltinData
getDatum Datum
datum of
          Just (Head.Open Head.OpenDatum{$sel:parties:OpenDatum :: OpenDatum -> [Party]
Head.parties = [Party]
parties, $sel:headId:OpenDatum :: OpenDatum -> CurrencySymbol
headId = CurrencySymbol
h, $sel:headSeed:OpenDatum :: OpenDatum -> TxOutRef
headSeed = TxOutRef
s}) ->
            (CurrencySymbol
h, TxOutRef
s, [Party] -> Integer
forall a. [a] -> Integer
L.length [Party]
parties)
          Maybe DatumType
_ -> BuiltinString -> (CurrencySymbol, TxOutRef, Integer)
forall a. BuiltinString -> a
traceError $(errorCode ExpectedHeadDatumType)
      OutputDatum
_ -> BuiltinString -> (CurrencySymbol, TxOutRef, Integer)
forall a. BuiltinString -> a
traceError $(errorCode ExpectedInlineDatum)

  (OutputDatum
headDatum, Value
headValue) =
    case ScriptHash -> TxInfo -> [(OutputDatum, Value)]
scriptOutputsAt ScriptHash
headValidator TxInfo
txInfo of
      [(OutputDatum
dat, Value
val)] -> (OutputDatum
dat, Value
val)
      [(OutputDatum, Value)]
_ -> BuiltinString -> (OutputDatum, Value)
forall a. BuiltinString -> a
traceError $(errorCode MultipleHeadOutput)

  currency :: CurrencySymbol
currency = ScriptContext -> CurrencySymbol
ownCurrencySymbol ScriptContext
context

  ScriptContext{scriptContextTxInfo :: ScriptContext -> TxInfo
scriptContextTxInfo = TxInfo
txInfo} = ScriptContext
context

-- | Token burning check should:
-- * Not restrict burning on the mu_head at all.
--
-- It is ensured by the v_head validator, when tokens of a specific headId may
-- be burned.
--
-- 'validateTokensBurning' just makes sure all tokens have negative quantity.
validateTokensBurning :: ScriptContext -> Bool
validateTokensBurning :: ScriptContext -> Bool
validateTokensBurning ScriptContext
context =
  BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode MintingNotAllowed) Bool
burnHeadTokens
 where
  currency :: CurrencySymbol
currency = ScriptContext -> CurrencySymbol
ownCurrencySymbol ScriptContext
context

  ScriptContext{scriptContextTxInfo :: ScriptContext -> TxInfo
scriptContextTxInfo = TxInfo
txInfo} = ScriptContext
context

  minted :: Map CurrencySymbol (Map TokenName Integer)
minted = MintValue -> Map CurrencySymbol (Map TokenName Integer)
mintValueToMap (MintValue -> Map CurrencySymbol (Map TokenName Integer))
-> MintValue -> Map CurrencySymbol (Map TokenName Integer)
forall a b. (a -> b) -> a -> b
$ TxInfo -> MintValue
txInfoMint TxInfo
txInfo

  burnHeadTokens :: Bool
burnHeadTokens =
    case CurrencySymbol
-> Map CurrencySymbol (Map TokenName Integer)
-> Maybe (Map TokenName Integer)
forall k v. Eq k => k -> Map k v -> Maybe v
AssocMap.lookup CurrencySymbol
currency Map CurrencySymbol (Map TokenName Integer)
minted of
      Maybe (Map TokenName Integer)
Nothing -> Bool
False
      Just Map TokenName Integer
tokenMap -> (Integer -> Bool) -> Map TokenName Integer -> Bool
forall a k. (a -> Bool) -> Map k a -> Bool
AssocMap.all (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0) Map TokenName Integer
tokenMap

-- | Raw minting policy code where the 'TxOutRef' is still a parameter.
unappliedMintingPolicy :: CompiledCode (TxOutRef -> MintingPolicyType)
#ifdef HYDRA_PRECOMPILED_SCRIPTS
unappliedMintingPolicy = Precompiled.unappliedMintingPolicy
#else
unappliedMintingPolicy :: CompiledCode (TxOutRef -> MintingPolicyType)
unappliedMintingPolicy =
  $$(PlutusTx.compile [||\vHead ref -> wrapMintingPolicy (validate vHead ref)||])
    CompiledCode (ScriptHash -> TxOutRef -> MintingPolicyType)
-> CompiledCodeIn DefaultUni DefaultFun ScriptHash
-> CompiledCode (TxOutRef -> MintingPolicyType)
forall (uni :: * -> *) fun a b.
(Closed uni, Everywhere uni Flat, Flat fun, Pretty fun,
 Everywhere uni PrettyConst,
 PrettyBy RenderContext (SomeTypeIn uni)) =>
CompiledCodeIn uni fun (a -> b)
-> CompiledCodeIn uni fun a -> CompiledCodeIn uni fun b
`PlutusTx.unsafeApplyCode` Version
-> ScriptHash -> CompiledCodeIn DefaultUni DefaultFun ScriptHash
forall (uni :: * -> *) a fun.
(Lift uni a, GEq uni, Everywhere uni Eq, ThrowableBuiltins uni fun,
 Typecheckable uni fun, CaseBuiltin uni,
 Default (CostingPart uni fun), Default (BuiltinsInfo uni fun),
 Default (RewriteRules uni fun), Hashable fun) =>
Version -> a -> CompiledCodeIn uni fun a
PlutusTx.liftCode Version
plcVersion110 (PlutusScript PlutusScriptV3 -> ScriptHash
forall lang.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> ScriptHash
scriptValidatorHash PlutusScript PlutusScriptV3
Head.validatorScript)
#endif

-- | Get the applied head minting policy script given a seed 'TxOutRef'.
mintingPolicyScript :: TxOutRef -> Api.PlutusScript
mintingPolicyScript :: TxOutRef -> PlutusScript PlutusScriptV3
mintingPolicyScript TxOutRef
txOutRef =
  ShortByteString -> PlutusScript PlutusScriptV3
PlutusScriptSerialised (ShortByteString -> PlutusScript PlutusScriptV3)
-> (CompiledCode MintingPolicyType -> ShortByteString)
-> CompiledCode MintingPolicyType
-> PlutusScript PlutusScriptV3
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompiledCode MintingPolicyType -> ShortByteString
forall a. CompiledCode a -> ShortByteString
serialiseCompiledCode (CompiledCode MintingPolicyType -> PlutusScript PlutusScriptV3)
-> CompiledCode MintingPolicyType -> PlutusScript PlutusScriptV3
forall a b. (a -> b) -> a -> b
$
    CompiledCode (TxOutRef -> MintingPolicyType)
unappliedMintingPolicy
      CompiledCode (TxOutRef -> MintingPolicyType)
-> CompiledCodeIn DefaultUni DefaultFun TxOutRef
-> CompiledCode MintingPolicyType
forall (uni :: * -> *) fun a b.
(Closed uni, Everywhere uni Flat, Flat fun, Pretty fun,
 Everywhere uni PrettyConst,
 PrettyBy RenderContext (SomeTypeIn uni)) =>
CompiledCodeIn uni fun (a -> b)
-> CompiledCodeIn uni fun a -> CompiledCodeIn uni fun b
`PlutusTx.unsafeApplyCode` Version
-> TxOutRef -> CompiledCodeIn DefaultUni DefaultFun TxOutRef
forall (uni :: * -> *) a fun.
(Lift uni a, GEq uni, Everywhere uni Eq, ThrowableBuiltins uni fun,
 Typecheckable uni fun, CaseBuiltin uni,
 Default (CostingPart uni fun), Default (BuiltinsInfo uni fun),
 Default (RewriteRules uni fun), Hashable fun) =>
Version -> a -> CompiledCodeIn uni fun a
PlutusTx.liftCode Version
plcVersion110 TxOutRef
txOutRef

-- * Create PolicyId

-- | Get the head policy id (a.k.a headId) given a seed 'TxIn'.
headPolicyId :: TxIn -> PolicyId
headPolicyId :: TxIn -> PolicyId
headPolicyId =
  Script PlutusScriptV3 -> PolicyId
forall lang. Script lang -> PolicyId
scriptPolicyId (Script PlutusScriptV3 -> PolicyId)
-> (TxIn -> Script PlutusScriptV3) -> TxIn -> PolicyId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlutusScript PlutusScriptV3 -> Script PlutusScriptV3
PlutusScript (PlutusScript PlutusScriptV3 -> Script PlutusScriptV3)
-> (TxIn -> PlutusScript PlutusScriptV3)
-> TxIn
-> Script PlutusScriptV3
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxIn -> PlutusScript PlutusScriptV3
mkHeadTokenScript

-- | Get the applied head minting policy script given a seed 'TxIn'.
mkHeadTokenScript :: TxIn -> Api.PlutusScript
mkHeadTokenScript :: TxIn -> PlutusScript PlutusScriptV3
mkHeadTokenScript =
  TxOutRef -> PlutusScript PlutusScriptV3
mintingPolicyScript (TxOutRef -> PlutusScript PlutusScriptV3)
-> (TxIn -> TxOutRef) -> TxIn -> PlutusScript PlutusScriptV3
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxIn -> TxOutRef
toPlutusTxOutRef