{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE TemplateHaskell    #-}

-- | Minting policy script for credential tokens.
module Plutus.Contracts.Prism.Credential(
    CredentialAuthority(..)
    , Credential(..)
    , policy
    , token
    , tokens
    , tokenAccount
    ) where

import Data.Aeson (FromJSON, ToJSON)
import Data.Hashable (Hashable)
import GHC.Generics (Generic)
import Ledger.Address (PaymentPubKeyHash (unPaymentPubKeyHash))
import Plutus.Contracts.TokenAccount (Account (..))
import Plutus.Script.Utils.Typed qualified as Scripts
import Plutus.Script.Utils.V2.Scripts (mintingPolicyHash)
import Plutus.Script.Utils.Value (TokenName, Value)
import Plutus.Script.Utils.Value qualified as Value
import Plutus.V2.Ledger.Api (MintingPolicy, ScriptContext (..), mkMintingPolicyScript)
import Plutus.V2.Ledger.Contexts (txSignedBy)
import PlutusTx qualified
import PlutusTx.Prelude
import Prelude qualified as Haskell

-- | Entity that is authorised to mint credential tokens
newtype CredentialAuthority =
    CredentialAuthority
        { CredentialAuthority -> PaymentPubKeyHash
unCredentialAuthority :: PaymentPubKeyHash
        }
    deriving stock ((forall x. CredentialAuthority -> Rep CredentialAuthority x)
-> (forall x. Rep CredentialAuthority x -> CredentialAuthority)
-> Generic CredentialAuthority
forall x. Rep CredentialAuthority x -> CredentialAuthority
forall x. CredentialAuthority -> Rep CredentialAuthority x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CredentialAuthority x -> CredentialAuthority
$cfrom :: forall x. CredentialAuthority -> Rep CredentialAuthority x
Generic, CredentialAuthority -> CredentialAuthority -> Bool
(CredentialAuthority -> CredentialAuthority -> Bool)
-> (CredentialAuthority -> CredentialAuthority -> Bool)
-> Eq CredentialAuthority
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CredentialAuthority -> CredentialAuthority -> Bool
$c/= :: CredentialAuthority -> CredentialAuthority -> Bool
== :: CredentialAuthority -> CredentialAuthority -> Bool
$c== :: CredentialAuthority -> CredentialAuthority -> Bool
Haskell.Eq, Int -> CredentialAuthority -> ShowS
[CredentialAuthority] -> ShowS
CredentialAuthority -> String
(Int -> CredentialAuthority -> ShowS)
-> (CredentialAuthority -> String)
-> ([CredentialAuthority] -> ShowS)
-> Show CredentialAuthority
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CredentialAuthority] -> ShowS
$cshowList :: [CredentialAuthority] -> ShowS
show :: CredentialAuthority -> String
$cshow :: CredentialAuthority -> String
showsPrec :: Int -> CredentialAuthority -> ShowS
$cshowsPrec :: Int -> CredentialAuthority -> ShowS
Haskell.Show, Eq CredentialAuthority
Eq CredentialAuthority
-> (CredentialAuthority -> CredentialAuthority -> Ordering)
-> (CredentialAuthority -> CredentialAuthority -> Bool)
-> (CredentialAuthority -> CredentialAuthority -> Bool)
-> (CredentialAuthority -> CredentialAuthority -> Bool)
-> (CredentialAuthority -> CredentialAuthority -> Bool)
-> (CredentialAuthority
    -> CredentialAuthority -> CredentialAuthority)
-> (CredentialAuthority
    -> CredentialAuthority -> CredentialAuthority)
-> Ord CredentialAuthority
CredentialAuthority -> CredentialAuthority -> Bool
CredentialAuthority -> CredentialAuthority -> Ordering
CredentialAuthority -> CredentialAuthority -> CredentialAuthority
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 :: CredentialAuthority -> CredentialAuthority -> CredentialAuthority
$cmin :: CredentialAuthority -> CredentialAuthority -> CredentialAuthority
max :: CredentialAuthority -> CredentialAuthority -> CredentialAuthority
$cmax :: CredentialAuthority -> CredentialAuthority -> CredentialAuthority
>= :: CredentialAuthority -> CredentialAuthority -> Bool
$c>= :: CredentialAuthority -> CredentialAuthority -> Bool
> :: CredentialAuthority -> CredentialAuthority -> Bool
$c> :: CredentialAuthority -> CredentialAuthority -> Bool
<= :: CredentialAuthority -> CredentialAuthority -> Bool
$c<= :: CredentialAuthority -> CredentialAuthority -> Bool
< :: CredentialAuthority -> CredentialAuthority -> Bool
$c< :: CredentialAuthority -> CredentialAuthority -> Bool
compare :: CredentialAuthority -> CredentialAuthority -> Ordering
$ccompare :: CredentialAuthority -> CredentialAuthority -> Ordering
$cp1Ord :: Eq CredentialAuthority
Haskell.Ord)
    deriving anyclass ([CredentialAuthority] -> Encoding
[CredentialAuthority] -> Value
CredentialAuthority -> Encoding
CredentialAuthority -> Value
(CredentialAuthority -> Value)
-> (CredentialAuthority -> Encoding)
-> ([CredentialAuthority] -> Value)
-> ([CredentialAuthority] -> Encoding)
-> ToJSON CredentialAuthority
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [CredentialAuthority] -> Encoding
$ctoEncodingList :: [CredentialAuthority] -> Encoding
toJSONList :: [CredentialAuthority] -> Value
$ctoJSONList :: [CredentialAuthority] -> Value
toEncoding :: CredentialAuthority -> Encoding
$ctoEncoding :: CredentialAuthority -> Encoding
toJSON :: CredentialAuthority -> Value
$ctoJSON :: CredentialAuthority -> Value
ToJSON, Value -> Parser [CredentialAuthority]
Value -> Parser CredentialAuthority
(Value -> Parser CredentialAuthority)
-> (Value -> Parser [CredentialAuthority])
-> FromJSON CredentialAuthority
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [CredentialAuthority]
$cparseJSONList :: Value -> Parser [CredentialAuthority]
parseJSON :: Value -> Parser CredentialAuthority
$cparseJSON :: Value -> Parser CredentialAuthority
FromJSON, Int -> CredentialAuthority -> Int
CredentialAuthority -> Int
(Int -> CredentialAuthority -> Int)
-> (CredentialAuthority -> Int) -> Hashable CredentialAuthority
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: CredentialAuthority -> Int
$chash :: CredentialAuthority -> Int
hashWithSalt :: Int -> CredentialAuthority -> Int
$chashWithSalt :: Int -> CredentialAuthority -> Int
Hashable)

-- | Named credential issued by a credential authority
data Credential =
    Credential
        { Credential -> CredentialAuthority
credAuthority :: CredentialAuthority
        , Credential -> TokenName
credName      :: TokenName
        }
    deriving stock ((forall x. Credential -> Rep Credential x)
-> (forall x. Rep Credential x -> Credential) -> Generic Credential
forall x. Rep Credential x -> Credential
forall x. Credential -> Rep Credential x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Credential x -> Credential
$cfrom :: forall x. Credential -> Rep Credential x
Generic, Credential -> Credential -> Bool
(Credential -> Credential -> Bool)
-> (Credential -> Credential -> Bool) -> Eq Credential
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Credential -> Credential -> Bool
$c/= :: Credential -> Credential -> Bool
== :: Credential -> Credential -> Bool
$c== :: Credential -> Credential -> Bool
Haskell.Eq, Int -> Credential -> ShowS
[Credential] -> ShowS
Credential -> String
(Int -> Credential -> ShowS)
-> (Credential -> String)
-> ([Credential] -> ShowS)
-> Show Credential
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Credential] -> ShowS
$cshowList :: [Credential] -> ShowS
show :: Credential -> String
$cshow :: Credential -> String
showsPrec :: Int -> Credential -> ShowS
$cshowsPrec :: Int -> Credential -> ShowS
Haskell.Show, Eq Credential
Eq Credential
-> (Credential -> Credential -> Ordering)
-> (Credential -> Credential -> Bool)
-> (Credential -> Credential -> Bool)
-> (Credential -> Credential -> Bool)
-> (Credential -> Credential -> Bool)
-> (Credential -> Credential -> Credential)
-> (Credential -> Credential -> Credential)
-> Ord Credential
Credential -> Credential -> Bool
Credential -> Credential -> Ordering
Credential -> Credential -> Credential
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 :: Credential -> Credential -> Credential
$cmin :: Credential -> Credential -> Credential
max :: Credential -> Credential -> Credential
$cmax :: Credential -> Credential -> Credential
>= :: Credential -> Credential -> Bool
$c>= :: Credential -> Credential -> Bool
> :: Credential -> Credential -> Bool
$c> :: Credential -> Credential -> Bool
<= :: Credential -> Credential -> Bool
$c<= :: Credential -> Credential -> Bool
< :: Credential -> Credential -> Bool
$c< :: Credential -> Credential -> Bool
compare :: Credential -> Credential -> Ordering
$ccompare :: Credential -> Credential -> Ordering
$cp1Ord :: Eq Credential
Haskell.Ord)
    deriving anyclass ([Credential] -> Encoding
[Credential] -> Value
Credential -> Encoding
Credential -> Value
(Credential -> Value)
-> (Credential -> Encoding)
-> ([Credential] -> Value)
-> ([Credential] -> Encoding)
-> ToJSON Credential
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Credential] -> Encoding
$ctoEncodingList :: [Credential] -> Encoding
toJSONList :: [Credential] -> Value
$ctoJSONList :: [Credential] -> Value
toEncoding :: Credential -> Encoding
$ctoEncoding :: Credential -> Encoding
toJSON :: Credential -> Value
$ctoJSON :: Credential -> Value
ToJSON, Value -> Parser [Credential]
Value -> Parser Credential
(Value -> Parser Credential)
-> (Value -> Parser [Credential]) -> FromJSON Credential
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Credential]
$cparseJSONList :: Value -> Parser [Credential]
parseJSON :: Value -> Parser Credential
$cparseJSON :: Value -> Parser Credential
FromJSON, Int -> Credential -> Int
Credential -> Int
(Int -> Credential -> Int)
-> (Credential -> Int) -> Hashable Credential
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Credential -> Int
$chash :: Credential -> Int
hashWithSalt :: Int -> Credential -> Int
$chashWithSalt :: Int -> Credential -> Int
Hashable)

-- | The minting policy script validating the creation of credential tokens
{-# INLINABLE validateMint #-}
validateMint :: CredentialAuthority -> () -> ScriptContext -> Bool
validateMint :: CredentialAuthority -> () -> ScriptContext -> Bool
validateMint CredentialAuthority{PaymentPubKeyHash
unCredentialAuthority :: PaymentPubKeyHash
unCredentialAuthority :: CredentialAuthority -> PaymentPubKeyHash
unCredentialAuthority} ()
_ ScriptContext{scriptContextTxInfo :: ScriptContext -> TxInfo
scriptContextTxInfo=TxInfo
txinfo} =
    -- the credential authority is allowed to mint or destroy any number of
    -- tokens, so we just need to check the signature
    TxInfo
txinfo TxInfo -> PubKeyHash -> Bool
`txSignedBy` PaymentPubKeyHash -> PubKeyHash
unPaymentPubKeyHash PaymentPubKeyHash
unCredentialAuthority

policy :: CredentialAuthority -> MintingPolicy
policy :: CredentialAuthority -> MintingPolicy
policy CredentialAuthority
credential = CompiledCode (BuiltinData -> BuiltinData -> ()) -> MintingPolicy
mkMintingPolicyScript (CompiledCode (BuiltinData -> BuiltinData -> ()) -> MintingPolicy)
-> CompiledCode (BuiltinData -> BuiltinData -> ()) -> MintingPolicy
forall a b. (a -> b) -> a -> b
$
    $$(PlutusTx.compile [|| \c -> Scripts.mkUntypedMintingPolicy (validateMint c) ||])
        CompiledCode
  (CredentialAuthority -> BuiltinData -> BuiltinData -> ())
-> CompiledCodeIn DefaultUni DefaultFun CredentialAuthority
-> 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`
            CredentialAuthority
-> CompiledCodeIn DefaultUni DefaultFun CredentialAuthority
forall (uni :: * -> *) a fun.
(Lift uni a, Throwable uni fun, Typecheckable uni fun) =>
a -> CompiledCodeIn uni fun a
PlutusTx.liftCode CredentialAuthority
credential

-- | A single credential of the given name
token :: Credential -> Value
token :: Credential -> Value
token Credential
credential = Credential -> Integer -> Value
tokens Credential
credential Integer
1

-- | A number of credentials of the given name
tokens :: Credential -> Integer -> Value
tokens :: Credential -> Integer -> Value
tokens Credential{CredentialAuthority
credAuthority :: CredentialAuthority
credAuthority :: Credential -> CredentialAuthority
credAuthority, TokenName
credName :: TokenName
credName :: Credential -> TokenName
credName} Integer
n =
    let sym :: CurrencySymbol
sym = MintingPolicyHash -> CurrencySymbol
Value.mpsSymbol (MintingPolicy -> MintingPolicyHash
mintingPolicyHash (MintingPolicy -> MintingPolicyHash)
-> MintingPolicy -> MintingPolicyHash
forall a b. (a -> b) -> a -> b
$ CredentialAuthority -> MintingPolicy
policy CredentialAuthority
credAuthority)
    in CurrencySymbol -> TokenName -> Integer -> Value
Value.singleton CurrencySymbol
sym TokenName
credName Integer
n

-- | The 'Account' that can be spent by presenting the credential
tokenAccount :: Credential -> Account
tokenAccount :: Credential -> Account
tokenAccount Credential{CredentialAuthority
credAuthority :: CredentialAuthority
credAuthority :: Credential -> CredentialAuthority
credAuthority, TokenName
credName :: TokenName
credName :: Credential -> TokenName
credName} =
    let sym :: CurrencySymbol
sym = MintingPolicyHash -> CurrencySymbol
Value.mpsSymbol (MintingPolicy -> MintingPolicyHash
mintingPolicyHash (MintingPolicy -> MintingPolicyHash)
-> MintingPolicy -> MintingPolicyHash
forall a b. (a -> b) -> a -> b
$ CredentialAuthority -> MintingPolicy
policy CredentialAuthority
credAuthority)
    in AssetClass -> Account
Account (AssetClass -> Account) -> AssetClass -> Account
forall a b. (a -> b) -> a -> b
$ CurrencySymbol -> TokenName -> AssetClass
Value.assetClass CurrencySymbol
sym TokenName
credName

PlutusTx.makeLift ''CredentialAuthority
PlutusTx.unstableMakeIsData ''CredentialAuthority
PlutusTx.makeLift ''Credential
PlutusTx.unstableMakeIsData ''Credential