{-# 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

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 Hydra.Plutus.Extras (MintingPolicyType, scriptValidatorHash, wrapMintingPolicy)
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)
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)

-- | 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