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

{-
This module and its submodules define the Plutus part of a credential
management dapp such as Atala PRISM / Mirror.

There are two actors:

* Mirror. Issues and revokes the on-chain credential tokens.
* User. Uses credentials in transactions

We have the following modules.

1. .Credential: Defines the 'Credential' type and a minting policy script
   for creating and destroying credential tokens
2. .StateMachine: Defines the state machine script that allows Users to
   present their credentials in transactions and Mirror to revoke/destroy
   credentials.
3. .STO: A simple Security Token Offering (STO) that requires a credential
   to be presented by anyone who wants to participate. This is provided for
   testing and demo purposes
4. .CredentialManager: A Plutus application managing all the credentials
   that are available to the User.
5. .Mirror: A Plutus application that locks credentials in state machines
   and revokes them when necessary.
6. .Unlock: Two Plutus applications that each present a credential to unlock
   some funds.

We work with two different script hashes: The hash of the minting policy that
mints the tokens (see 'policy'), and the hash of the state machine instance
that locks a specific credential token for a specific user, identified by their
public key address.

-}
module Plutus.Contracts.Prism(
    -- * Unlock (STO)
    STOSubscriber(..)
    , STOSubscriberSchema
    , UnlockError(..)
    , subscribeSTO
    -- * Unlock (exchange)
    , UnlockExchangeSchema
    , unlockExchange
    -- * Mirror app
    , MirrorSchema
    , CredentialOwnerReference(..)
    , MirrorError(..)
    , mirror
    -- * Credential manager app
    , Credential(..)
    , UserCredential(..)
    , CredentialAuthority(..)
    -- * all-in-one
    , Role(..)
    , PrismSchema
    , PrismError(..)
    , contract
    ) where

import Control.Lens
import Data.Aeson (FromJSON, ToJSON)
import GHC.Generics (Generic)
import Plutus.Contracts.Prism.Credential
import Plutus.Contracts.Prism.Mirror
import Plutus.Contracts.Prism.StateMachine
import Plutus.Contracts.Prism.Unlock

import Plutus.Contract

-- | The roles that we pass to 'contract'.
data Role
    = Mirror -- ^ The 'mirror' contract
    | UnlockSTO -- ^ The 'subscribeSTO' contract
    | UnlockExchange -- ^ The 'unlockExchange' contract
    deriving stock (Role -> Role -> Bool
(Role -> Role -> Bool) -> (Role -> Role -> Bool) -> Eq Role
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Role -> Role -> Bool
$c/= :: Role -> Role -> Bool
== :: Role -> Role -> Bool
$c== :: Role -> Role -> Bool
Eq, (forall x. Role -> Rep Role x)
-> (forall x. Rep Role x -> Role) -> Generic Role
forall x. Rep Role x -> Role
forall x. Role -> Rep Role x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Role x -> Role
$cfrom :: forall x. Role -> Rep Role x
Generic, Int -> Role -> ShowS
[Role] -> ShowS
Role -> String
(Int -> Role -> ShowS)
-> (Role -> String) -> ([Role] -> ShowS) -> Show Role
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Role] -> ShowS
$cshowList :: [Role] -> ShowS
show :: Role -> String
$cshow :: Role -> String
showsPrec :: Int -> Role -> ShowS
$cshowsPrec :: Int -> Role -> ShowS
Show)
    deriving anyclass ([Role] -> Encoding
[Role] -> Value
Role -> Encoding
Role -> Value
(Role -> Value)
-> (Role -> Encoding)
-> ([Role] -> Value)
-> ([Role] -> Encoding)
-> ToJSON Role
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Role] -> Encoding
$ctoEncodingList :: [Role] -> Encoding
toJSONList :: [Role] -> Value
$ctoJSONList :: [Role] -> Value
toEncoding :: Role -> Encoding
$ctoEncoding :: Role -> Encoding
toJSON :: Role -> Value
$ctoJSON :: Role -> Value
ToJSON, Value -> Parser [Role]
Value -> Parser Role
(Value -> Parser Role) -> (Value -> Parser [Role]) -> FromJSON Role
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Role]
$cparseJSONList :: Value -> Parser [Role]
parseJSON :: Value -> Parser Role
$cparseJSON :: Value -> Parser Role
FromJSON)

type PrismSchema =
    MirrorSchema
    .\/ STOSubscriberSchema
    .\/ UnlockExchangeSchema
    .\/ Endpoint "role" Role

data PrismError =
    UnlockSTOErr UnlockError
    | MirrorErr MirrorError
    | EPError ContractError
    | UnlockExchangeErr UnlockError
    deriving stock (PrismError -> PrismError -> Bool
(PrismError -> PrismError -> Bool)
-> (PrismError -> PrismError -> Bool) -> Eq PrismError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PrismError -> PrismError -> Bool
$c/= :: PrismError -> PrismError -> Bool
== :: PrismError -> PrismError -> Bool
$c== :: PrismError -> PrismError -> Bool
Eq, (forall x. PrismError -> Rep PrismError x)
-> (forall x. Rep PrismError x -> PrismError) -> Generic PrismError
forall x. Rep PrismError x -> PrismError
forall x. PrismError -> Rep PrismError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PrismError x -> PrismError
$cfrom :: forall x. PrismError -> Rep PrismError x
Generic, Int -> PrismError -> ShowS
[PrismError] -> ShowS
PrismError -> String
(Int -> PrismError -> ShowS)
-> (PrismError -> String)
-> ([PrismError] -> ShowS)
-> Show PrismError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PrismError] -> ShowS
$cshowList :: [PrismError] -> ShowS
show :: PrismError -> String
$cshow :: PrismError -> String
showsPrec :: Int -> PrismError -> ShowS
$cshowsPrec :: Int -> PrismError -> ShowS
Show)
    deriving anyclass ([PrismError] -> Encoding
[PrismError] -> Value
PrismError -> Encoding
PrismError -> Value
(PrismError -> Value)
-> (PrismError -> Encoding)
-> ([PrismError] -> Value)
-> ([PrismError] -> Encoding)
-> ToJSON PrismError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [PrismError] -> Encoding
$ctoEncodingList :: [PrismError] -> Encoding
toJSONList :: [PrismError] -> Value
$ctoJSONList :: [PrismError] -> Value
toEncoding :: PrismError -> Encoding
$ctoEncoding :: PrismError -> Encoding
toJSON :: PrismError -> Value
$ctoJSON :: PrismError -> Value
ToJSON, Value -> Parser [PrismError]
Value -> Parser PrismError
(Value -> Parser PrismError)
-> (Value -> Parser [PrismError]) -> FromJSON PrismError
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [PrismError]
$cparseJSONList :: Value -> Parser [PrismError]
parseJSON :: Value -> Parser PrismError
$cparseJSON :: Value -> Parser PrismError
FromJSON)

makeClassyPrisms ''PrismError

instance AsContractError PrismError where
    _ContractError :: p ContractError (f ContractError) -> p PrismError (f PrismError)
_ContractError = p ContractError (f ContractError) -> p PrismError (f PrismError)
forall r. AsPrismError r => Prism' r ContractError
_EPError (p ContractError (f ContractError) -> p PrismError (f PrismError))
-> (p ContractError (f ContractError)
    -> p ContractError (f ContractError))
-> p ContractError (f ContractError)
-> p PrismError (f PrismError)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p ContractError (f ContractError)
-> p ContractError (f ContractError)
forall r. AsContractError r => Prism' r ContractError
_ContractError

-- | A wrapper around the four prism contracts. This is just a workaround
--   for the emulator, where we can only ever run a single 'Contract'. In
--   the PAB we could simply start all four contracts (credentialManager,
--   mirror, subscribeSTO, subscribeExchange) separately.
contract :: Contract () PrismSchema PrismError ()
contract :: Contract () PrismSchema PrismError ()
contract = Promise
  ()
  ('R
     '[ "issue"
        ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
        "revoke"
        ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
        "role" ':-> (EndpointValue Role, ActiveEndpoint),
        "sto" ':-> (EndpointValue STOSubscriber, ActiveEndpoint),
        "unlock from exchange"
        ':-> (EndpointValue Credential, ActiveEndpoint)])
  PrismError
  ()
-> Contract
     ()
     ('R
        '[ "issue"
           ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
           "revoke"
           ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
           "role" ':-> (EndpointValue Role, ActiveEndpoint),
           "sto" ':-> (EndpointValue STOSubscriber, ActiveEndpoint),
           "unlock from exchange"
           ':-> (EndpointValue Credential, ActiveEndpoint)])
     PrismError
     ()
forall w (s :: Row *) e a. Promise w s e a -> Contract w s e a
awaitPromise (Promise
   ()
   ('R
      '[ "issue"
         ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
         "revoke"
         ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
         "role" ':-> (EndpointValue Role, ActiveEndpoint),
         "sto" ':-> (EndpointValue STOSubscriber, ActiveEndpoint),
         "unlock from exchange"
         ':-> (EndpointValue Credential, ActiveEndpoint)])
   PrismError
   ()
 -> Contract
      ()
      ('R
         '[ "issue"
            ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
            "revoke"
            ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
            "role" ':-> (EndpointValue Role, ActiveEndpoint),
            "sto" ':-> (EndpointValue STOSubscriber, ActiveEndpoint),
            "unlock from exchange"
            ':-> (EndpointValue Credential, ActiveEndpoint)])
      PrismError
      ())
-> Promise
     ()
     ('R
        '[ "issue"
           ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
           "revoke"
           ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
           "role" ':-> (EndpointValue Role, ActiveEndpoint),
           "sto" ':-> (EndpointValue STOSubscriber, ActiveEndpoint),
           "unlock from exchange"
           ':-> (EndpointValue Credential, ActiveEndpoint)])
     PrismError
     ()
-> Contract
     ()
     ('R
        '[ "issue"
           ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
           "revoke"
           ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
           "role" ':-> (EndpointValue Role, ActiveEndpoint),
           "sto" ':-> (EndpointValue STOSubscriber, ActiveEndpoint),
           "unlock from exchange"
           ':-> (EndpointValue Credential, ActiveEndpoint)])
     PrismError
     ()
forall a b. (a -> b) -> a -> b
$ forall a w (s :: Row *) e b.
(HasEndpoint "role" a s, AsContractError e, FromJSON a) =>
(a -> Contract w s e b) -> Promise w s e b
forall (l :: Symbol) a w (s :: Row *) e b.
(HasEndpoint l a s, AsContractError e, FromJSON a) =>
(a -> Contract w s e b) -> Promise w s e b
endpoint @"role" ((Role
  -> Contract
       ()
       ('R
          '[ "issue"
             ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
             "revoke"
             ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
             "role" ':-> (EndpointValue Role, ActiveEndpoint),
             "sto" ':-> (EndpointValue STOSubscriber, ActiveEndpoint),
             "unlock from exchange"
             ':-> (EndpointValue Credential, ActiveEndpoint)])
       PrismError
       ())
 -> Promise
      ()
      ('R
         '[ "issue"
            ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
            "revoke"
            ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
            "role" ':-> (EndpointValue Role, ActiveEndpoint),
            "sto" ':-> (EndpointValue STOSubscriber, ActiveEndpoint),
            "unlock from exchange"
            ':-> (EndpointValue Credential, ActiveEndpoint)])
      PrismError
      ())
-> (Role
    -> Contract
         ()
         ('R
            '[ "issue"
               ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
               "revoke"
               ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
               "role" ':-> (EndpointValue Role, ActiveEndpoint),
               "sto" ':-> (EndpointValue STOSubscriber, ActiveEndpoint),
               "unlock from exchange"
               ':-> (EndpointValue Credential, ActiveEndpoint)])
         PrismError
         ())
-> Promise
     ()
     ('R
        '[ "issue"
           ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
           "revoke"
           ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
           "role" ':-> (EndpointValue Role, ActiveEndpoint),
           "sto" ':-> (EndpointValue STOSubscriber, ActiveEndpoint),
           "unlock from exchange"
           ':-> (EndpointValue Credential, ActiveEndpoint)])
     PrismError
     ()
forall a b. (a -> b) -> a -> b
$ \Role
r -> do
    case Role
r of
        Role
Mirror         -> (MirrorError -> PrismError)
-> Contract
     ()
     ('R
        '[ "issue"
           ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
           "revoke"
           ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
           "role" ':-> (EndpointValue Role, ActiveEndpoint),
           "sto" ':-> (EndpointValue STOSubscriber, ActiveEndpoint),
           "unlock from exchange"
           ':-> (EndpointValue Credential, ActiveEndpoint)])
     MirrorError
     ()
-> Contract
     ()
     ('R
        '[ "issue"
           ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
           "revoke"
           ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
           "role" ':-> (EndpointValue Role, ActiveEndpoint),
           "sto" ':-> (EndpointValue STOSubscriber, ActiveEndpoint),
           "unlock from exchange"
           ':-> (EndpointValue Credential, ActiveEndpoint)])
     PrismError
     ()
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError MirrorError -> PrismError
MirrorErr Contract
  ()
  ('R
     '[ "issue"
        ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
        "revoke"
        ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
        "role" ':-> (EndpointValue Role, ActiveEndpoint),
        "sto" ':-> (EndpointValue STOSubscriber, ActiveEndpoint),
        "unlock from exchange"
        ':-> (EndpointValue Credential, ActiveEndpoint)])
  MirrorError
  ()
forall (s :: Row *) w.
(HasEndpoint "revoke" CredentialOwnerReference s,
 HasEndpoint "issue" CredentialOwnerReference s) =>
Contract w s MirrorError ()
mirror
        Role
UnlockSTO      -> (UnlockError -> PrismError)
-> Contract
     ()
     ('R
        '[ "issue"
           ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
           "revoke"
           ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
           "role" ':-> (EndpointValue Role, ActiveEndpoint),
           "sto" ':-> (EndpointValue STOSubscriber, ActiveEndpoint),
           "unlock from exchange"
           ':-> (EndpointValue Credential, ActiveEndpoint)])
     UnlockError
     ()
-> Contract
     ()
     ('R
        '[ "issue"
           ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
           "revoke"
           ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
           "role" ':-> (EndpointValue Role, ActiveEndpoint),
           "sto" ':-> (EndpointValue STOSubscriber, ActiveEndpoint),
           "unlock from exchange"
           ':-> (EndpointValue Credential, ActiveEndpoint)])
     PrismError
     ()
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError UnlockError -> PrismError
UnlockSTOErr Contract
  ()
  ('R
     '[ "issue"
        ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
        "revoke"
        ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
        "role" ':-> (EndpointValue Role, ActiveEndpoint),
        "sto" ':-> (EndpointValue STOSubscriber, ActiveEndpoint),
        "unlock from exchange"
        ':-> (EndpointValue Credential, ActiveEndpoint)])
  UnlockError
  ()
forall w (s :: Row *).
HasEndpoint "sto" STOSubscriber s =>
Contract w s UnlockError ()
subscribeSTO
        Role
UnlockExchange -> (UnlockError -> PrismError)
-> Contract
     ()
     ('R
        '[ "issue"
           ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
           "revoke"
           ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
           "role" ':-> (EndpointValue Role, ActiveEndpoint),
           "sto" ':-> (EndpointValue STOSubscriber, ActiveEndpoint),
           "unlock from exchange"
           ':-> (EndpointValue Credential, ActiveEndpoint)])
     UnlockError
     ()
-> Contract
     ()
     ('R
        '[ "issue"
           ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
           "revoke"
           ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
           "role" ':-> (EndpointValue Role, ActiveEndpoint),
           "sto" ':-> (EndpointValue STOSubscriber, ActiveEndpoint),
           "unlock from exchange"
           ':-> (EndpointValue Credential, ActiveEndpoint)])
     PrismError
     ()
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError UnlockError -> PrismError
UnlockExchangeErr Contract
  ()
  ('R
     '[ "issue"
        ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
        "revoke"
        ':-> (EndpointValue CredentialOwnerReference, ActiveEndpoint),
        "role" ':-> (EndpointValue Role, ActiveEndpoint),
        "sto" ':-> (EndpointValue STOSubscriber, ActiveEndpoint),
        "unlock from exchange"
        ':-> (EndpointValue Credential, ActiveEndpoint)])
  UnlockError
  ()
forall w (s :: Row *).
HasEndpoint "unlock from exchange" Credential s =>
Contract w s UnlockError ()
unlockExchange