{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# LANGUAGE TypeApplications   #-}
-- | State machine that manages credential tokens
module Plutus.Contracts.Prism.StateMachine(
    IDState(..)
    , IDAction(..)
    , UserCredential(..)
    , typedValidator
    , machineClient
    , mkMachineClient
    ) where

import Data.Aeson (FromJSON, ToJSON)
import Data.Hashable (Hashable)
import GHC.Generics (Generic)
import Ledger.Address (PaymentPubKeyHash)
import Ledger.Tx.Constraints (TxConstraints)
import Ledger.Tx.Constraints qualified as Constraints
import Ledger.Typed.Scripts qualified as Scripts
import Plutus.Contract.StateMachine (State (..), StateMachine (..), StateMachineClient (..), Void)
import Plutus.Contract.StateMachine qualified as StateMachine
import Plutus.Contracts.Prism.Credential (Credential (..), CredentialAuthority (..))
import Plutus.Contracts.Prism.Credential qualified as Credential
import Plutus.Script.Utils.V2.Typed.Scripts qualified as V2
import Plutus.Script.Utils.Value (TokenName, Value)
import PlutusTx qualified
import PlutusTx.Prelude
import Prelude qualified as Haskell

data IDState =
    Active -- ^ The credential is active and can be used in transactions
    | Revoked -- ^ The credential has been revoked and can't be used anymore.
    deriving stock ((forall x. IDState -> Rep IDState x)
-> (forall x. Rep IDState x -> IDState) -> Generic IDState
forall x. Rep IDState x -> IDState
forall x. IDState -> Rep IDState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep IDState x -> IDState
$cfrom :: forall x. IDState -> Rep IDState x
Generic, IDState -> IDState -> Bool
(IDState -> IDState -> Bool)
-> (IDState -> IDState -> Bool) -> Eq IDState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IDState -> IDState -> Bool
$c/= :: IDState -> IDState -> Bool
== :: IDState -> IDState -> Bool
$c== :: IDState -> IDState -> Bool
Haskell.Eq, Int -> IDState -> ShowS
[IDState] -> ShowS
IDState -> String
(Int -> IDState -> ShowS)
-> (IDState -> String) -> ([IDState] -> ShowS) -> Show IDState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IDState] -> ShowS
$cshowList :: [IDState] -> ShowS
show :: IDState -> String
$cshow :: IDState -> String
showsPrec :: Int -> IDState -> ShowS
$cshowsPrec :: Int -> IDState -> ShowS
Haskell.Show)
    deriving anyclass ([IDState] -> Encoding
[IDState] -> Value
IDState -> Encoding
IDState -> Value
(IDState -> Value)
-> (IDState -> Encoding)
-> ([IDState] -> Value)
-> ([IDState] -> Encoding)
-> ToJSON IDState
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [IDState] -> Encoding
$ctoEncodingList :: [IDState] -> Encoding
toJSONList :: [IDState] -> Value
$ctoJSONList :: [IDState] -> Value
toEncoding :: IDState -> Encoding
$ctoEncoding :: IDState -> Encoding
toJSON :: IDState -> Value
$ctoJSON :: IDState -> Value
ToJSON, Value -> Parser [IDState]
Value -> Parser IDState
(Value -> Parser IDState)
-> (Value -> Parser [IDState]) -> FromJSON IDState
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [IDState]
$cparseJSONList :: Value -> Parser [IDState]
parseJSON :: Value -> Parser IDState
$cparseJSON :: Value -> Parser IDState
FromJSON)

data IDAction =
    PresentCredential -- ^ Present the credential in a transaction
    | RevokeCredential -- ^ Revoke the credential
    deriving stock ((forall x. IDAction -> Rep IDAction x)
-> (forall x. Rep IDAction x -> IDAction) -> Generic IDAction
forall x. Rep IDAction x -> IDAction
forall x. IDAction -> Rep IDAction x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep IDAction x -> IDAction
$cfrom :: forall x. IDAction -> Rep IDAction x
Generic, IDAction -> IDAction -> Bool
(IDAction -> IDAction -> Bool)
-> (IDAction -> IDAction -> Bool) -> Eq IDAction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IDAction -> IDAction -> Bool
$c/= :: IDAction -> IDAction -> Bool
== :: IDAction -> IDAction -> Bool
$c== :: IDAction -> IDAction -> Bool
Haskell.Eq, Int -> IDAction -> ShowS
[IDAction] -> ShowS
IDAction -> String
(Int -> IDAction -> ShowS)
-> (IDAction -> String) -> ([IDAction] -> ShowS) -> Show IDAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IDAction] -> ShowS
$cshowList :: [IDAction] -> ShowS
show :: IDAction -> String
$cshow :: IDAction -> String
showsPrec :: Int -> IDAction -> ShowS
$cshowsPrec :: Int -> IDAction -> ShowS
Haskell.Show)
    deriving anyclass ([IDAction] -> Encoding
[IDAction] -> Value
IDAction -> Encoding
IDAction -> Value
(IDAction -> Value)
-> (IDAction -> Encoding)
-> ([IDAction] -> Value)
-> ([IDAction] -> Encoding)
-> ToJSON IDAction
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [IDAction] -> Encoding
$ctoEncodingList :: [IDAction] -> Encoding
toJSONList :: [IDAction] -> Value
$ctoJSONList :: [IDAction] -> Value
toEncoding :: IDAction -> Encoding
$ctoEncoding :: IDAction -> Encoding
toJSON :: IDAction -> Value
$ctoJSON :: IDAction -> Value
ToJSON, Value -> Parser [IDAction]
Value -> Parser IDAction
(Value -> Parser IDAction)
-> (Value -> Parser [IDAction]) -> FromJSON IDAction
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [IDAction]
$cparseJSONList :: Value -> Parser [IDAction]
parseJSON :: Value -> Parser IDAction
$cparseJSON :: Value -> Parser IDAction
FromJSON)

-- | A 'Credential' issued to a user (public key address)
data UserCredential =
    UserCredential
        { UserCredential -> PaymentPubKeyHash
ucAddress    :: PaymentPubKeyHash
        -- ^ Address of the credential holder
        , UserCredential -> Credential
ucCredential ::  Credential
        -- ^ The credential
        , UserCredential -> Value
ucToken      :: Value
        -- ^ The 'Value' containing a token of the credential
        -- (this needs to be included here because 'Credential.token'
        -- is not available in on-chain code)
        } deriving stock (UserCredential -> UserCredential -> Bool
(UserCredential -> UserCredential -> Bool)
-> (UserCredential -> UserCredential -> Bool) -> Eq UserCredential
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UserCredential -> UserCredential -> Bool
$c/= :: UserCredential -> UserCredential -> Bool
== :: UserCredential -> UserCredential -> Bool
$c== :: UserCredential -> UserCredential -> Bool
Haskell.Eq, Int -> UserCredential -> ShowS
[UserCredential] -> ShowS
UserCredential -> String
(Int -> UserCredential -> ShowS)
-> (UserCredential -> String)
-> ([UserCredential] -> ShowS)
-> Show UserCredential
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserCredential] -> ShowS
$cshowList :: [UserCredential] -> ShowS
show :: UserCredential -> String
$cshow :: UserCredential -> String
showsPrec :: Int -> UserCredential -> ShowS
$cshowsPrec :: Int -> UserCredential -> ShowS
Haskell.Show, (forall x. UserCredential -> Rep UserCredential x)
-> (forall x. Rep UserCredential x -> UserCredential)
-> Generic UserCredential
forall x. Rep UserCredential x -> UserCredential
forall x. UserCredential -> Rep UserCredential x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep UserCredential x -> UserCredential
$cfrom :: forall x. UserCredential -> Rep UserCredential x
Generic)
          deriving anyclass ([UserCredential] -> Encoding
[UserCredential] -> Value
UserCredential -> Encoding
UserCredential -> Value
(UserCredential -> Value)
-> (UserCredential -> Encoding)
-> ([UserCredential] -> Value)
-> ([UserCredential] -> Encoding)
-> ToJSON UserCredential
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [UserCredential] -> Encoding
$ctoEncodingList :: [UserCredential] -> Encoding
toJSONList :: [UserCredential] -> Value
$ctoJSONList :: [UserCredential] -> Value
toEncoding :: UserCredential -> Encoding
$ctoEncoding :: UserCredential -> Encoding
toJSON :: UserCredential -> Value
$ctoJSON :: UserCredential -> Value
ToJSON, Value -> Parser [UserCredential]
Value -> Parser UserCredential
(Value -> Parser UserCredential)
-> (Value -> Parser [UserCredential]) -> FromJSON UserCredential
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [UserCredential]
$cparseJSONList :: Value -> Parser [UserCredential]
parseJSON :: Value -> Parser UserCredential
$cparseJSON :: Value -> Parser UserCredential
FromJSON, Int -> UserCredential -> Int
UserCredential -> Int
(Int -> UserCredential -> Int)
-> (UserCredential -> Int) -> Hashable UserCredential
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: UserCredential -> Int
$chash :: UserCredential -> Int
hashWithSalt :: Int -> UserCredential -> Int
$chashWithSalt :: Int -> UserCredential -> Int
Hashable)

{-# INLINABLE transition #-}
transition :: UserCredential -> State IDState -> IDAction -> Maybe (TxConstraints Void Void, State IDState)
transition :: UserCredential
-> State IDState
-> IDAction
-> Maybe (TxConstraints Void Void, State IDState)
transition UserCredential{PaymentPubKeyHash
ucAddress :: PaymentPubKeyHash
ucAddress :: UserCredential -> PaymentPubKeyHash
ucAddress, Credential
ucCredential :: Credential
ucCredential :: UserCredential -> Credential
ucCredential, Value
ucToken :: Value
ucToken :: UserCredential -> Value
ucToken} State{stateData :: forall s. State s -> s
stateData=IDState
state, stateValue :: forall s. State s -> Value
stateValue=Value
currentValue} IDAction
input =
    case (IDState
state, IDAction
input) of
        (IDState
Active, IDAction
PresentCredential) ->
            (TxConstraints Void Void, State IDState)
-> Maybe (TxConstraints Void Void, State IDState)
forall a. a -> Maybe a
Just
                ( PaymentPubKeyHash -> TxConstraints Void Void
forall i o. PaymentPubKeyHash -> TxConstraints i o
Constraints.mustBeSignedBy PaymentPubKeyHash
ucAddress
                , State :: forall s. s -> Value -> State s
State{stateData :: IDState
stateData=IDState
Active,stateValue :: Value
stateValue=Value
currentValue}
                )
        (IDState
Active, IDAction
RevokeCredential) ->
            (TxConstraints Void Void, State IDState)
-> Maybe (TxConstraints Void Void, State IDState)
forall a. a -> Maybe a
Just
                ( PaymentPubKeyHash -> TxConstraints Void Void
forall i o. PaymentPubKeyHash -> TxConstraints i o
Constraints.mustBeSignedBy (CredentialAuthority -> PaymentPubKeyHash
unCredentialAuthority (CredentialAuthority -> PaymentPubKeyHash)
-> CredentialAuthority -> PaymentPubKeyHash
forall a b. (a -> b) -> a -> b
$ Credential -> CredentialAuthority
credAuthority Credential
ucCredential)
                TxConstraints Void Void
-> TxConstraints Void Void -> TxConstraints Void Void
forall a. Semigroup a => a -> a -> a
<> Value -> TxConstraints Void Void
forall i o. Value -> TxConstraints i o
Constraints.mustMintValue (Value -> Value
forall a. Group a => a -> a
inv Value
ucToken) -- Destroy the token
                , State :: forall s. s -> Value -> State s
State{stateData :: IDState
stateData=IDState
Revoked, stateValue :: Value
stateValue=Value
forall a. Monoid a => a
mempty}
                )
        (IDState, IDAction)
_ -> Maybe (TxConstraints Void Void, State IDState)
forall a. Maybe a
Nothing

{-# INLINABLE credentialStateMachine #-}
credentialStateMachine ::
  UserCredential
  -> StateMachine IDState IDAction
credentialStateMachine :: UserCredential -> StateMachine IDState IDAction
credentialStateMachine UserCredential
cd = Maybe ThreadToken
-> (State IDState
    -> IDAction -> Maybe (TxConstraints Void Void, State IDState))
-> (IDState -> Bool)
-> StateMachine IDState IDAction
forall s i.
Maybe ThreadToken
-> (State s -> i -> Maybe (TxConstraints Void Void, State s))
-> (s -> Bool)
-> StateMachine s i
StateMachine.mkStateMachine Maybe ThreadToken
forall a. Maybe a
Nothing (UserCredential
-> State IDState
-> IDAction
-> Maybe (TxConstraints Void Void, State IDState)
transition UserCredential
cd) IDState -> Bool
isFinal where
  isFinal :: IDState -> Bool
isFinal IDState
Revoked = Bool
True
  isFinal IDState
_       = Bool
False

typedValidator ::
  UserCredential
  -> Scripts.TypedValidator (StateMachine IDState IDAction)
typedValidator :: UserCredential -> TypedValidator (StateMachine IDState IDAction)
typedValidator UserCredential
credentialData =
    let val :: CompiledCodeIn
  DefaultUni
  DefaultFun
  (IDState -> IDAction -> ScriptContext -> Bool)
val = $$(PlutusTx.compile [|| validator ||]) CompiledCode
  (UserCredential -> IDState -> IDAction -> ScriptContext -> Bool)
-> CompiledCodeIn DefaultUni DefaultFun UserCredential
-> CompiledCodeIn
     DefaultUni
     DefaultFun
     (IDState -> IDAction -> ScriptContext -> Bool)
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` UserCredential
-> CompiledCodeIn DefaultUni DefaultFun UserCredential
forall (uni :: * -> *) a fun.
(Lift uni a, Throwable uni fun, Typecheckable uni fun) =>
a -> CompiledCodeIn uni fun a
PlutusTx.liftCode UserCredential
credentialData
        validator :: UserCredential -> ValidatorType (StateMachine IDState IDAction)
validator UserCredential
d = StateMachine IDState IDAction
-> ValidatorType (StateMachine IDState IDAction)
forall s i.
ToData s =>
StateMachine s i -> ValidatorType (StateMachine s i)
StateMachine.mkValidator (UserCredential -> StateMachine IDState IDAction
credentialStateMachine UserCredential
d)
        wrap :: (IDState -> IDAction -> ScriptContext -> Bool) -> UntypedValidator
wrap = (UnsafeFromData IDState, UnsafeFromData IDAction) =>
(IDState -> IDAction -> ScriptContext -> Bool) -> UntypedValidator
forall sc d r.
(IsScriptContext sc, UnsafeFromData d, UnsafeFromData r) =>
(d -> r -> sc -> Bool) -> UntypedValidator
Scripts.mkUntypedValidator @Scripts.ScriptContextV2 @IDState @IDAction
    in CompiledCode (ValidatorType (StateMachine IDState IDAction))
-> CompiledCode
     (ValidatorType (StateMachine IDState IDAction) -> UntypedValidator)
-> TypedValidator (StateMachine IDState IDAction)
forall a.
CompiledCode (ValidatorType a)
-> CompiledCode (ValidatorType a -> UntypedValidator)
-> TypedValidator a
V2.mkTypedValidator @(StateMachine IDState IDAction) CompiledCode (ValidatorType (StateMachine IDState IDAction))
CompiledCodeIn
  DefaultUni
  DefaultFun
  (IDState -> IDAction -> ScriptContext -> Bool)
val $$(PlutusTx.compile [|| wrap ||])

machineClient ::
    Scripts.TypedValidator (StateMachine IDState IDAction)
    -> UserCredential
    -> StateMachineClient IDState IDAction
machineClient :: TypedValidator (StateMachine IDState IDAction)
-> UserCredential -> StateMachineClient IDState IDAction
machineClient TypedValidator (StateMachine IDState IDAction)
inst UserCredential
credentialData =
    let machine :: StateMachine IDState IDAction
machine = UserCredential -> StateMachine IDState IDAction
credentialStateMachine UserCredential
credentialData
    in StateMachineInstance IDState IDAction
-> StateMachineClient IDState IDAction
forall state input.
StateMachineInstance state input -> StateMachineClient state input
StateMachine.mkStateMachineClient (StateMachine IDState IDAction
-> TypedValidator (StateMachine IDState IDAction)
-> StateMachineInstance IDState IDAction
forall s i.
StateMachine s i
-> TypedValidator (StateMachine s i) -> StateMachineInstance s i
StateMachine.StateMachineInstance StateMachine IDState IDAction
machine TypedValidator (StateMachine IDState IDAction)
inst)

mkMachineClient :: CredentialAuthority -> PaymentPubKeyHash -> TokenName -> StateMachineClient IDState IDAction
mkMachineClient :: CredentialAuthority
-> PaymentPubKeyHash
-> TokenName
-> StateMachineClient IDState IDAction
mkMachineClient CredentialAuthority
authority PaymentPubKeyHash
credentialOwner TokenName
tokenName =
    let credential :: Credential
credential = Credential :: CredentialAuthority -> TokenName -> Credential
Credential{credAuthority :: CredentialAuthority
credAuthority=CredentialAuthority
authority,credName :: TokenName
credName=TokenName
tokenName}
        userCredential :: UserCredential
userCredential =
            UserCredential :: PaymentPubKeyHash -> Credential -> Value -> UserCredential
UserCredential
                { ucAddress :: PaymentPubKeyHash
ucAddress = PaymentPubKeyHash
credentialOwner
                , ucCredential :: Credential
ucCredential = Credential
credential
                , ucToken :: Value
ucToken = Credential -> Value
Credential.token Credential
credential
                }
    in TypedValidator (StateMachine IDState IDAction)
-> UserCredential -> StateMachineClient IDState IDAction
machineClient (UserCredential -> TypedValidator (StateMachine IDState IDAction)
typedValidator UserCredential
userCredential) UserCredential
userCredential

PlutusTx.makeLift ''UserCredential
PlutusTx.makeLift ''IDState
PlutusTx.makeLift ''IDAction
PlutusTx.unstableMakeIsData ''IDState
PlutusTx.unstableMakeIsData ''IDAction