{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-specialize #-}
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-}
-- Avoid trace calls to be optimized away when inlining functions.
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-simplifier-inline #-}
-- Plutus core version to compile to. In babbage era, that is Cardano protocol
-- version 7 and 8, only plutus-core version 1.0.0 is available.
{-# OPTIONS_GHC -fplugin-opt PlutusTx.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 (
  PlutusScriptV3,
  PolicyId,
  TxIn,
  fromPlutusScript,
  scriptPolicyId,
  toPlutusTxOutRef,
  pattern PlutusScript,
 )
import Hydra.Cardano.Api qualified as Api

import Hydra.Contract.Head qualified as Head
import Hydra.Contract.HeadState (seed)
import Hydra.Contract.HeadState qualified as Head
import Hydra.Contract.HeadTokensError (HeadTokensError (..), errorCode)
import Hydra.Contract.Initial qualified as Initial
import Hydra.Contract.MintAction (MintAction (Burn, Mint))
import Hydra.Contract.Util (hasST, scriptOutputsAt)
import Hydra.Plutus (initialValidatorScript)
import Hydra.Plutus.Extras (MintingPolicyType, scriptValidatorHash, wrapMintingPolicy)
import PlutusCore.Version (plcVersion110)
import PlutusLedgerApi.V3 (
  Datum (getDatum),
  FromData (fromBuiltinData),
  OutputDatum (..),
  ScriptContext (..),
  ScriptHash,
  SerialisedScript,
  TxInInfo (..),
  TxInfo (..),
  TxOutRef,
  Value (getValue),
  serialiseCompiledCode,
 )
import PlutusLedgerApi.V3.Contexts (ownCurrencySymbol)
import PlutusTx (CompiledCode)
import PlutusTx qualified
import PlutusTx.AssocMap qualified as AssocMap

validate ::
  ScriptHash ->
  ScriptHash ->
  TxOutRef ->
  MintAction ->
  ScriptContext ->
  Bool
validate :: ScriptHash
-> ScriptHash -> TxOutRef -> MintAction -> ScriptContext -> Bool
validate ScriptHash
initialValidator ScriptHash
headValidator TxOutRef
seedInput MintAction
action ScriptContext
context =
  case MintAction
action of
    MintAction
Mint -> ScriptHash -> ScriptHash -> TxOutRef -> ScriptContext -> Bool
validateTokensMinting ScriptHash
initialValidator 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.
--
-- * PTs are distributed to v_initial
--
-- * Each v_initial has the policy id as its datum
--
-- * Ensure out-ref and the headId are in the datum of the first output of the
--   transaction which mints tokens.
validateTokensMinting :: ScriptHash -> ScriptHash -> TxOutRef -> ScriptContext -> Bool
validateTokensMinting :: ScriptHash -> ScriptHash -> TxOutRef -> ScriptContext -> Bool
validateTokensMinting ScriptHash
initialValidator ScriptHash
headValidator TxOutRef
seedInput ScriptContext
context =
  Bool
seedInputIsConsumed
    Bool -> Bool -> Bool
&& Bool
checkNumberOfTokens
    Bool -> Bool -> Bool
&& Bool
singleSTIsPaidToTheHead
    Bool -> Bool -> Bool
&& Bool
allInitialOutsHavePTs
    Bool -> Bool -> Bool
&& Bool
allInitialOutsHaveCorrectDatum
    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
`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

  allInitialOutsHavePTs :: Bool
allInitialOutsHavePTs =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode WrongNumberOfInitialOutputs) (Integer
nParties Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== [Value] -> Integer
forall (t :: * -> *) a. Foldable t => t a -> Integer
length [Value]
initialTxOutValues)
      Bool -> Bool -> Bool
&& (Value -> Bool) -> [Value] -> Bool
forall a. (a -> Bool) -> [a] -> Bool
all Value -> Bool
hasASinglePT [Value]
initialTxOutValues

  allInitialOutsHaveCorrectDatum :: Bool
allInitialOutsHaveCorrectDatum =
    (OutputDatum -> Bool) -> [OutputDatum] -> Bool
forall a. (a -> Bool) -> [a] -> Bool
all OutputDatum -> Bool
hasHeadIdDatum ((OutputDatum, Value) -> OutputDatum
forall a b. (a, b) -> a
fst ((OutputDatum, Value) -> OutputDatum)
-> [(OutputDatum, Value)] -> [OutputDatum]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptHash -> TxInfo -> [(OutputDatum, Value)]
scriptOutputsAt ScriptHash
initialValidator TxInfo
txInfo)

  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

  hasASinglePT :: Value -> Bool
hasASinglePT 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 -> Bool
forall a. BuiltinString -> a
traceError $(errorCode NoPT)
      (Just Map TokenName Integer
tokenMap) -> case Map TokenName Integer -> [(TokenName, Integer)]
forall k v. Map k v -> [(k, v)]
AssocMap.toList Map TokenName Integer
tokenMap of
        [(TokenName
_, Integer
qty)]
          | Integer
qty Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 -> Bool
True
        [(TokenName, Integer)]
_ -> BuiltinString -> Bool
forall a. BuiltinString -> a
traceError $(errorCode WrongQuantity)

  hasHeadIdDatum :: OutputDatum -> Bool
hasHeadIdDatum = \case
    OutputDatum
NoOutputDatum ->
      BuiltinString -> Bool
forall a. BuiltinString -> a
traceError $(errorCode WrongInitialDatum)
    OutputDatum Datum
dat ->
      Datum -> Bool
checkInitialDatum Datum
dat
    OutputDatumHash DatumHash
_dh ->
      BuiltinString -> Bool
forall a. BuiltinString -> a
traceError $(errorCode WrongInitialDatum)

  checkInitialDatum :: Datum -> Bool
checkInitialDatum Datum
dat =
    case forall a. FromData a => BuiltinData -> Maybe a
fromBuiltinData @Initial.DatumType (BuiltinData -> Maybe CurrencySymbol)
-> BuiltinData -> Maybe CurrencySymbol
forall a b. (a -> b) -> a -> b
$ Datum -> BuiltinData
getDatum Datum
dat of
      Maybe CurrencySymbol
Nothing -> BuiltinString -> Bool
forall a. BuiltinString -> a
traceError $(errorCode WrongInitialDatum)
      Just CurrencySymbol
hid -> BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode WrongInitialDatum) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CurrencySymbol
hid CurrencySymbol -> CurrencySymbol -> Bool
forall a. Eq a => a -> a -> Bool
== CurrencySymbol
currency

  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
sum
      (Maybe (Map TokenName Integer) -> Integer)
-> (Value -> Maybe (Map TokenName Integer)) -> Value -> 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))
-> (Value -> Map CurrencySymbol (Map TokenName Integer))
-> Value
-> Maybe (Map TokenName Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Map CurrencySymbol (Map TokenName Integer)
getValue
      (Value -> Integer) -> Value -> Integer
forall a b. (a -> b) -> a -> b
$ TxInfo -> Value
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.Initial{$sel:parties:Initial :: DatumType -> [Party]
Head.parties = [Party]
parties, $sel:headId:Initial :: DatumType -> CurrencySymbol
headId = CurrencySymbol
h, $sel:seed:Initial :: DatumType -> TxOutRef
seed = TxOutRef
s} ->
            (CurrencySymbol
h, TxOutRef
s, [Party] -> Integer
forall (t :: * -> *) a. Foldable t => t a -> Integer
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)

  initialTxOutValues :: [Value]
initialTxOutValues = (OutputDatum, Value) -> Value
forall a b. (a, b) -> b
snd ((OutputDatum, Value) -> Value)
-> [(OutputDatum, Value)] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptHash -> TxInfo -> [(OutputDatum, Value)]
scriptOutputsAt ScriptHash
initialValidator TxInfo
txInfo

  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 = Value -> Map CurrencySymbol (Map TokenName Integer)
getValue (Value -> Map CurrencySymbol (Map TokenName Integer))
-> Value -> Map CurrencySymbol (Map TokenName Integer)
forall a b. (a -> b) -> a -> b
$ TxInfo -> Value
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 [||\vInitial vHead ref -> wrapMintingPolicy (validate vInitial vHead ref)||])
    CompiledCode
  (ScriptHash -> ScriptHash -> TxOutRef -> MintingPolicyType)
-> CompiledCodeIn DefaultUni DefaultFun ScriptHash
-> CompiledCodeIn
     DefaultUni DefaultFun (ScriptHash -> 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, ThrowableBuiltins uni fun,
 Typecheckable uni fun, Default (CostingPart uni fun),
 Default (BuiltinsInfo uni fun), Default (RewriteRules uni fun),
 Hashable fun) =>
Version -> a -> CompiledCodeIn uni fun a
PlutusTx.liftCode Version
plcVersion110 (PlutusScriptVersion PlutusScriptV3
-> SerialisedScript -> ScriptHash
forall lang.
PlutusScriptVersion lang -> SerialisedScript -> ScriptHash
scriptValidatorHash PlutusScriptVersion PlutusScriptV3
Api.PlutusScriptV3 SerialisedScript
initialValidatorScript)
    CompiledCodeIn
  DefaultUni DefaultFun (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, ThrowableBuiltins uni fun,
 Typecheckable uni fun, Default (CostingPart uni fun),
 Default (BuiltinsInfo uni fun), Default (RewriteRules uni fun),
 Hashable fun) =>
Version -> a -> CompiledCodeIn uni fun a
PlutusTx.liftCode Version
plcVersion110 ScriptHash
Head.validatorHash

-- | Get the applied head minting policy script given a seed 'TxOutRef'.
mintingPolicyScript :: TxOutRef -> SerialisedScript
mintingPolicyScript :: TxOutRef -> SerialisedScript
mintingPolicyScript TxOutRef
txOutRef =
  CompiledCode MintingPolicyType -> SerialisedScript
forall a. CompiledCode a -> SerialisedScript
serialiseCompiledCode (CompiledCode MintingPolicyType -> SerialisedScript)
-> CompiledCode MintingPolicyType -> SerialisedScript
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, ThrowableBuiltins uni fun,
 Typecheckable uni fun, 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 -> Script PlutusScriptV3
PlutusScript (PlutusScript -> Script PlutusScriptV3)
-> (TxIn -> PlutusScript) -> TxIn -> Script PlutusScriptV3
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxIn -> PlutusScript
mkHeadTokenScript

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