{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE MonoLocalBinds     #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# LANGUAGE TypeApplications   #-}
{-# LANGUAGE TypeOperators      #-}
{-

This module defines an STO that allocates coins to anyone who

* Presents a specific credential token (one that has been issued by a specific
  credential authority with a specific name) and
* Pays 1 Lovelace to a predefined public key address for every coin minted

The supply (number of tokens created) of the STO is unlimited. This is done so
that we do not need a state machine and can participate in the STO with a single
transaction. In a more realistic setting we would also need constraints on the
validity range of the minting transaction.

-}
module Plutus.Contracts.Prism.STO(
    STOData(..)
    , policy
    , coins
    ) where

import Data.Aeson (FromJSON, ToJSON)
import GHC.Generics (Generic)
import Ledger.Address (PaymentPubKeyHash (unPaymentPubKeyHash))
import Plutus.Script.Utils.Ada (Ada (Lovelace), fromValue)
import Plutus.Script.Utils.Typed qualified as Scripts
import Plutus.Script.Utils.V2.Scripts qualified as V2
import Plutus.Script.Utils.Value (TokenName, Value)
import Plutus.Script.Utils.Value qualified as Value
import Plutus.V2.Ledger.Api (MintingPolicy, ScriptContext (..), ScriptPurpose (..), mkMintingPolicyScript)
import Plutus.V2.Ledger.Contexts qualified as V2
import PlutusTx qualified
import PlutusTx.Prelude
import Prelude qualified as Haskell

data STOData =
    STOData
        { STOData -> PaymentPubKeyHash
stoIssuer          :: PaymentPubKeyHash
        , STOData -> TokenName
stoTokenName       :: TokenName
        , STOData -> Value
stoCredentialToken :: Value
        }
    deriving stock ((forall x. STOData -> Rep STOData x)
-> (forall x. Rep STOData x -> STOData) -> Generic STOData
forall x. Rep STOData x -> STOData
forall x. STOData -> Rep STOData x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep STOData x -> STOData
$cfrom :: forall x. STOData -> Rep STOData x
Generic, STOData -> STOData -> Bool
(STOData -> STOData -> Bool)
-> (STOData -> STOData -> Bool) -> Eq STOData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: STOData -> STOData -> Bool
$c/= :: STOData -> STOData -> Bool
== :: STOData -> STOData -> Bool
$c== :: STOData -> STOData -> Bool
Haskell.Eq, Int -> STOData -> ShowS
[STOData] -> ShowS
STOData -> String
(Int -> STOData -> ShowS)
-> (STOData -> String) -> ([STOData] -> ShowS) -> Show STOData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [STOData] -> ShowS
$cshowList :: [STOData] -> ShowS
show :: STOData -> String
$cshow :: STOData -> String
showsPrec :: Int -> STOData -> ShowS
$cshowsPrec :: Int -> STOData -> ShowS
Haskell.Show)
    deriving anyclass ([STOData] -> Encoding
[STOData] -> Value
STOData -> Encoding
STOData -> Value
(STOData -> Value)
-> (STOData -> Encoding)
-> ([STOData] -> Value)
-> ([STOData] -> Encoding)
-> ToJSON STOData
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [STOData] -> Encoding
$ctoEncodingList :: [STOData] -> Encoding
toJSONList :: [STOData] -> Value
$ctoJSONList :: [STOData] -> Value
toEncoding :: STOData -> Encoding
$ctoEncoding :: STOData -> Encoding
toJSON :: STOData -> Value
$ctoJSON :: STOData -> Value
ToJSON, Value -> Parser [STOData]
Value -> Parser STOData
(Value -> Parser STOData)
-> (Value -> Parser [STOData]) -> FromJSON STOData
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [STOData]
$cparseJSONList :: Value -> Parser [STOData]
parseJSON :: Value -> Parser STOData
$cparseJSON :: Value -> Parser STOData
FromJSON)

{-# INLINABLE validateSTO #-}
validateSTO :: STOData -> () -> ScriptContext -> Bool
validateSTO :: STOData -> () -> ScriptContext -> Bool
validateSTO STOData{PaymentPubKeyHash
stoIssuer :: PaymentPubKeyHash
stoIssuer :: STOData -> PaymentPubKeyHash
stoIssuer,Value
stoCredentialToken :: Value
stoCredentialToken :: STOData -> Value
stoCredentialToken,TokenName
stoTokenName :: TokenName
stoTokenName :: STOData -> TokenName
stoTokenName} ()
_ ScriptContext{scriptContextTxInfo :: ScriptContext -> TxInfo
scriptContextTxInfo=TxInfo
txInfo,scriptContextPurpose :: ScriptContext -> ScriptPurpose
scriptContextPurpose=Minting CurrencySymbol
ownHash} =
    let tokenOK :: Bool
tokenOK = Value
stoCredentialToken Value -> Value -> Bool
`Value.leq` TxInfo -> Value
V2.valueSpent TxInfo
txInfo
        Lovelace Integer
paidToIssuer = Value -> Ada
fromValue (TxInfo -> PubKeyHash -> Value
V2.valuePaidTo TxInfo
txInfo (PaymentPubKeyHash -> PubKeyHash
unPaymentPubKeyHash PaymentPubKeyHash
stoIssuer))
        mintOK :: Bool
mintOK =
            -- Note that this doesn't prevent any tokens with a name other than
            -- 'stoTokenName' from being minted
            Value -> CurrencySymbol -> TokenName -> Integer
Value.valueOf (TxInfo -> Value
V2.txInfoMint TxInfo
txInfo) CurrencySymbol
ownHash TokenName
stoTokenName Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
paidToIssuer
    in Bool
tokenOK Bool -> Bool -> Bool
&& Bool
mintOK
validateSTO STOData
_ ()
_ ScriptContext
_ = () -> Bool
forall a. () -> a
error ()

policy :: STOData -> MintingPolicy
policy :: STOData -> MintingPolicy
policy STOData
stoData = 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 (validateSTO c) ||]) CompiledCode (STOData -> BuiltinData -> BuiltinData -> ())
-> CompiledCodeIn DefaultUni DefaultFun STOData
-> 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` STOData -> CompiledCodeIn DefaultUni DefaultFun STOData
forall (uni :: * -> *) a fun.
(Lift uni a, Throwable uni fun, Typecheckable uni fun) =>
a -> CompiledCodeIn uni fun a
PlutusTx.liftCode STOData
stoData

-- | A 'Value' of a number of coins issued in the STO
coins :: STOData -> Integer -> Value
coins :: STOData -> Integer -> Value
coins d :: STOData
d@STOData{TokenName
stoTokenName :: TokenName
stoTokenName :: STOData -> TokenName
stoTokenName} Integer
n =
    let sym :: CurrencySymbol
sym = MintingPolicyHash -> CurrencySymbol
Value.mpsSymbol (MintingPolicy -> MintingPolicyHash
V2.mintingPolicyHash (MintingPolicy -> MintingPolicyHash)
-> MintingPolicy -> MintingPolicyHash
forall a b. (a -> b) -> a -> b
$ STOData -> MintingPolicy
policy STOData
d)
    in CurrencySymbol -> TokenName -> Integer -> Value
Value.singleton CurrencySymbol
sym TokenName
stoTokenName Integer
n

PlutusTx.makeLift ''STOData
PlutusTx.unstableMakeIsData ''STOData