{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MonoLocalBinds        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE ViewPatterns          #-}
{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-}
-- | Thread token data type definition and minting policy.
--   Thread tokens are used to identify the contract instance on the blockchain,
--   and ensuring that the state was produced by running the state machine from its initial state.
module Plutus.Contract.StateMachine.ThreadToken where

import PlutusTx.Prelude hiding (Monoid (..), Semigroup (..))

import Data.Aeson (FromJSON, ToJSON)
import GHC.Generics (Generic)
import Ledger (TxOutRef (..))
import Ledger.Scripts
import Plutus.Contract.StateMachine.MintingPolarity (MintingPolarity (..))
import Plutus.Script.Utils.Typed (ScriptContextV2, mkUntypedMintingPolicy)
import Plutus.Script.Utils.Value (CurrencySymbol, TokenName (..), Value (..))
import Plutus.Script.Utils.Value qualified as Value
import Plutus.V2.Ledger.Contexts qualified as V2
import PlutusTx qualified
import Prelude qualified as Haskell

data ThreadToken = ThreadToken
    { ThreadToken -> TxOutRef
ttOutRef         :: TxOutRef
    , ThreadToken -> CurrencySymbol
ttCurrencySymbol :: CurrencySymbol
    }
    deriving stock (ThreadToken -> ThreadToken -> Bool
(ThreadToken -> ThreadToken -> Bool)
-> (ThreadToken -> ThreadToken -> Bool) -> Eq ThreadToken
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ThreadToken -> ThreadToken -> Bool
$c/= :: ThreadToken -> ThreadToken -> Bool
== :: ThreadToken -> ThreadToken -> Bool
$c== :: ThreadToken -> ThreadToken -> Bool
Haskell.Eq, Int -> ThreadToken -> ShowS
[ThreadToken] -> ShowS
ThreadToken -> String
(Int -> ThreadToken -> ShowS)
-> (ThreadToken -> String)
-> ([ThreadToken] -> ShowS)
-> Show ThreadToken
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ThreadToken] -> ShowS
$cshowList :: [ThreadToken] -> ShowS
show :: ThreadToken -> String
$cshow :: ThreadToken -> String
showsPrec :: Int -> ThreadToken -> ShowS
$cshowsPrec :: Int -> ThreadToken -> ShowS
Haskell.Show, Eq ThreadToken
Eq ThreadToken
-> (ThreadToken -> ThreadToken -> Ordering)
-> (ThreadToken -> ThreadToken -> Bool)
-> (ThreadToken -> ThreadToken -> Bool)
-> (ThreadToken -> ThreadToken -> Bool)
-> (ThreadToken -> ThreadToken -> Bool)
-> (ThreadToken -> ThreadToken -> ThreadToken)
-> (ThreadToken -> ThreadToken -> ThreadToken)
-> Ord ThreadToken
ThreadToken -> ThreadToken -> Bool
ThreadToken -> ThreadToken -> Ordering
ThreadToken -> ThreadToken -> ThreadToken
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ThreadToken -> ThreadToken -> ThreadToken
$cmin :: ThreadToken -> ThreadToken -> ThreadToken
max :: ThreadToken -> ThreadToken -> ThreadToken
$cmax :: ThreadToken -> ThreadToken -> ThreadToken
>= :: ThreadToken -> ThreadToken -> Bool
$c>= :: ThreadToken -> ThreadToken -> Bool
> :: ThreadToken -> ThreadToken -> Bool
$c> :: ThreadToken -> ThreadToken -> Bool
<= :: ThreadToken -> ThreadToken -> Bool
$c<= :: ThreadToken -> ThreadToken -> Bool
< :: ThreadToken -> ThreadToken -> Bool
$c< :: ThreadToken -> ThreadToken -> Bool
compare :: ThreadToken -> ThreadToken -> Ordering
$ccompare :: ThreadToken -> ThreadToken -> Ordering
$cp1Ord :: Eq ThreadToken
Haskell.Ord, (forall x. ThreadToken -> Rep ThreadToken x)
-> (forall x. Rep ThreadToken x -> ThreadToken)
-> Generic ThreadToken
forall x. Rep ThreadToken x -> ThreadToken
forall x. ThreadToken -> Rep ThreadToken x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ThreadToken x -> ThreadToken
$cfrom :: forall x. ThreadToken -> Rep ThreadToken x
Generic)
    deriving anyclass ([ThreadToken] -> Encoding
[ThreadToken] -> Value
ThreadToken -> Encoding
ThreadToken -> Value
(ThreadToken -> Value)
-> (ThreadToken -> Encoding)
-> ([ThreadToken] -> Value)
-> ([ThreadToken] -> Encoding)
-> ToJSON ThreadToken
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ThreadToken] -> Encoding
$ctoEncodingList :: [ThreadToken] -> Encoding
toJSONList :: [ThreadToken] -> Value
$ctoJSONList :: [ThreadToken] -> Value
toEncoding :: ThreadToken -> Encoding
$ctoEncoding :: ThreadToken -> Encoding
toJSON :: ThreadToken -> Value
$ctoJSON :: ThreadToken -> Value
ToJSON, Value -> Parser [ThreadToken]
Value -> Parser ThreadToken
(Value -> Parser ThreadToken)
-> (Value -> Parser [ThreadToken]) -> FromJSON ThreadToken
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ThreadToken]
$cparseJSONList :: Value -> Parser [ThreadToken]
parseJSON :: Value -> Parser ThreadToken
$cparseJSON :: Value -> Parser ThreadToken
FromJSON)


PlutusTx.makeIsDataIndexed ''ThreadToken [('ThreadToken,0)]
PlutusTx.makeLift ''ThreadToken

checkPolicy :: TxOutRef -> (ValidatorHash, MintingPolarity) -> V2.ScriptContext -> Bool
checkPolicy :: TxOutRef
-> (ValidatorHash, MintingPolarity) -> ScriptContext -> Bool
checkPolicy (TxOutRef TxId
refHash Integer
refIdx) (ValidatorHash
vHash, MintingPolarity
mintingPolarity) ctx :: ScriptContext
ctx@V2.ScriptContext{scriptContextTxInfo :: ScriptContext -> TxInfo
V2.scriptContextTxInfo=TxInfo
txinfo} =
    let
        ownSymbol :: CurrencySymbol
ownSymbol = ScriptContext -> CurrencySymbol
V2.ownCurrencySymbol ScriptContext
ctx

        minted :: Value
minted = TxInfo -> Value
V2.txInfoMint TxInfo
txinfo
        expected :: Integer
expected = if MintingPolarity
mintingPolarity MintingPolarity -> MintingPolarity -> Bool
forall a. Eq a => a -> a -> Bool
== MintingPolarity
Burn then -Integer
1 else Integer
1

        -- True if the pending transaction mints the amount of
        -- currency that we expect
        mintOK :: Bool
mintOK =
            let v :: Bool
v = CurrencySymbol -> ValidatorHash -> Value -> Integer -> Bool
checkThreadTokenInner CurrencySymbol
ownSymbol ValidatorHash
vHash Value
minted Integer
expected
            in BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"S7" {-"Value minted different from expected"-} Bool
v

        -- True if the pending transaction spends the output
        -- identified by @(refHash, refIdx)@
        txOutputSpent :: Bool
txOutputSpent =
            let v :: Bool
v = TxInfo -> TxId -> Integer -> Bool
V2.spendsOutput TxInfo
txinfo TxId
refHash Integer
refIdx
            in  BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"S8" {-"Pending transaction does not spend the designated transaction output"-} Bool
v

    in Bool
mintOK Bool -> Bool -> Bool
&& (if MintingPolarity
mintingPolarity MintingPolarity -> MintingPolarity -> Bool
forall a. Eq a => a -> a -> Bool
== MintingPolarity
Mint then Bool
txOutputSpent else Bool
True)

curPolicy :: TxOutRef -> MintingPolicy
curPolicy :: TxOutRef -> MintingPolicy
curPolicy TxOutRef
outRef = CompiledCode (BuiltinData -> BuiltinData -> ()) -> MintingPolicy
mkMintingPolicyScript (CompiledCode (BuiltinData -> BuiltinData -> ()) -> MintingPolicy)
-> CompiledCode (BuiltinData -> BuiltinData -> ()) -> MintingPolicy
forall a b. (a -> b) -> a -> b
$
    $$(PlutusTx.compile [|| \r -> mkUntypedMintingPolicy @ScriptContextV2 (checkPolicy r) ||])
        CompiledCode (TxOutRef -> BuiltinData -> BuiltinData -> ())
-> CompiledCodeIn DefaultUni DefaultFun TxOutRef
-> CompiledCode (BuiltinData -> BuiltinData -> ())
forall (uni :: * -> *) fun a b.
(Closed uni, Everywhere uni Flat, Flat fun,
 Everywhere uni PrettyConst, GShow uni, Pretty fun) =>
CompiledCodeIn uni fun (a -> b)
-> CompiledCodeIn uni fun a -> CompiledCodeIn uni fun b
`PlutusTx.applyCode`
            TxOutRef -> CompiledCodeIn DefaultUni DefaultFun TxOutRef
forall (uni :: * -> *) a fun.
(Lift uni a, Throwable uni fun, Typecheckable uni fun) =>
a -> CompiledCodeIn uni fun a
PlutusTx.liftCode TxOutRef
outRef

{-# INLINABLE threadTokenValue #-}
-- | The 'Value' containing exactly the thread token.
threadTokenValue :: CurrencySymbol -> ValidatorHash -> Value
threadTokenValue :: CurrencySymbol -> ValidatorHash -> Value
threadTokenValue CurrencySymbol
currency (ValidatorHash BuiltinByteString
vHash) = CurrencySymbol -> TokenName -> Integer -> Value
Value.singleton CurrencySymbol
currency (BuiltinByteString -> TokenName
TokenName BuiltinByteString
vHash) Integer
1

-- | Check exactly `n` thread tokens and no other tokens with the given
-- @CurrencySymbol@ are in the given @Value@.
{-# INLINABLE checkThreadTokenInner #-}
checkThreadTokenInner ::
    -- | The currency symbol of the thread token.
    CurrencySymbol ->
    -- | The hash of the (state machine) validator script using this thread
    -- token. This is used as the @TokenName@ of the thread token.
    ValidatorHash ->
    -- | The value to check.
    Value ->
    -- | The expected number of thread tokens in the given value, `n`.
    Integer ->
    -- | True if and only if exactly `n` thread tokens (and no other tokens)
    -- with the given @CurrencySymbol@ are in the given @Value@.
    Bool
checkThreadTokenInner :: CurrencySymbol -> ValidatorHash -> Value -> Integer -> Bool
checkThreadTokenInner CurrencySymbol
currency (ValidatorHash BuiltinByteString
vHash) Value
value Integer
n =
    Value -> CurrencySymbol -> Value
Value.currencyValueOf Value
value CurrencySymbol
currency Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== CurrencySymbol -> TokenName -> Integer -> Value
Value.singleton CurrencySymbol
currency (BuiltinByteString -> TokenName
TokenName BuiltinByteString
vHash) Integer
n

{-# INLINABLE checkThreadToken #-}
checkThreadToken :: Maybe ThreadToken -> ValidatorHash -> Value -> Integer -> Bool
checkThreadToken :: Maybe ThreadToken -> ValidatorHash -> Value -> Integer -> Bool
checkThreadToken Maybe ThreadToken
Nothing ValidatorHash
_ Value
_ Integer
_ = Bool
True
checkThreadToken (Just ThreadToken
threadToken) ValidatorHash
vHash Value
vl Integer
i =
    CurrencySymbol -> ValidatorHash -> Value -> Integer -> Bool
checkThreadTokenInner (ThreadToken -> CurrencySymbol
ttCurrencySymbol ThreadToken
threadToken) ValidatorHash
vHash Value
vl Integer
i