/
ThreadToken.hs
88 lines (74 loc) · 3.63 KB
/
ThreadToken.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
{-# 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 Data.OpenApi qualified as OpenApi
import GHC.Generics (Generic)
import Ledger (CurrencySymbol, TxOutRef (..))
import Ledger.Contexts qualified as V
import Ledger.Scripts
import Ledger.Typed.Scripts qualified as Scripts
import Ledger.Value (TokenName (..), Value (..))
import Ledger.Value qualified as Value
import Plutus.Contract.StateMachine.MintingPolarity (MintingPolarity (..))
import PlutusTx qualified
import Prelude qualified as Haskell
data ThreadToken = ThreadToken
{ ttOutRef :: TxOutRef
, ttCurrencySymbol :: CurrencySymbol
}
deriving stock (Haskell.Eq, Haskell.Show, Haskell.Ord, Generic)
deriving anyclass (ToJSON, FromJSON, OpenApi.ToSchema)
PlutusTx.makeIsDataIndexed ''ThreadToken [('ThreadToken,0)]
PlutusTx.makeLift ''ThreadToken
checkPolicy :: TxOutRef -> (ValidatorHash, MintingPolarity) -> V.ScriptContext -> Bool
checkPolicy (TxOutRef refHash refIdx) (vHash, mintingPolarity) ctx@V.ScriptContext{V.scriptContextTxInfo=txinfo} =
let
ownSymbol = V.ownCurrencySymbol ctx
minted = V.txInfoMint txinfo
expected = if mintingPolarity == Burn then -1 else 1
-- True if the pending transaction mints the amount of
-- currency that we expect
mintOK =
let v = checkThreadTokenInner ownSymbol vHash minted expected
in traceIfFalse "S7" {-"Value minted different from expected"-} v
-- True if the pending transaction spends the output
-- identified by @(refHash, refIdx)@
txOutputSpent =
let v = V.spendsOutput txinfo refHash refIdx
in traceIfFalse "S8" {-"Pending transaction does not spend the designated transaction output"-} v
in mintOK && (if mintingPolarity == Mint then txOutputSpent else True)
curPolicy :: TxOutRef -> MintingPolicy
curPolicy outRef = mkMintingPolicyScript $
$$(PlutusTx.compile [|| \r -> Scripts.wrapMintingPolicy (checkPolicy r) ||])
`PlutusTx.applyCode`
PlutusTx.liftCode outRef
{-# INLINABLE threadTokenValue #-}
-- | The 'Value' containing exactly the thread token.
threadTokenValue :: CurrencySymbol -> ValidatorHash -> Value
threadTokenValue currency (ValidatorHash vHash) = Value.singleton currency (TokenName vHash) 1
{-# INLINABLE checkThreadTokenInner #-}
checkThreadTokenInner :: CurrencySymbol -> ValidatorHash -> Value -> Integer -> Bool
checkThreadTokenInner currency (ValidatorHash vHash) vl i =
Value.valueOf vl currency (TokenName vHash) == i
{-# INLINABLE checkThreadToken #-}
checkThreadToken :: Maybe ThreadToken -> ValidatorHash -> Value -> Integer -> Bool
checkThreadToken Nothing _ _ _ = True
checkThreadToken (Just threadToken) vHash vl i =
checkThreadTokenInner (ttCurrencySymbol threadToken) vHash vl i