{-# LANGUAGE ConstraintKinds   #-}
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE DerivingVia       #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE TypeFamilies      #-}
{-# LANGUAGE TypeOperators     #-}
-- | Plutus implementation of an account that can be unlocked with a token.
--   Whoever owns the token can spend the outputs locked by the contract.
--   (A suitable token can be created with the 'Plutus.Contracts.Currency'
--   contract, or with 'newAccount' in this module)
module Plutus.Contracts.TokenAccount(
  Account(..)
  -- * Contract functionality
  , pay
  , redeem
  , newAccount
  , balance
  , address
  , accountToken
  , payTx
  , redeemTx
  -- * Endpoints
  , TokenAccountSchema
  , HasTokenAccountSchema
  , tokenAccountContract
  -- * Etc.
  , TokenAccount
  , TokenAccountError(..)
  , AsTokenAccountError(..)
  , validatorHash
  , typedValidator
  ) where

import Cardano.Node.Emulator.Internal.Node.Params qualified as Params
import Control.Lens (makeClassyPrisms, review)
import Control.Monad (void)
import Data.Aeson (FromJSON, ToJSON)
import Data.Map qualified as Map
import GHC.Generics (Generic)
import Prettyprinter (Pretty)

import Plutus.Contract (AsContractError (_ContractError), Contract, ContractError, Endpoint, HasEndpoint,
                        adjustUnbalancedTx, endpoint, logInfo, mapError, mkTxConstraints, selectList,
                        submitUnbalancedTx, type (.\/), utxosAt)
import Plutus.Contract.Constraints (ScriptLookups, TxConstraints)
import PlutusTx qualified

import Ledger (CardanoAddress, toPlutusAddress)
import Ledger.Tx (CardanoTx, decoratedTxOutPlutusValue)
import Ledger.Tx.Constraints qualified as Constraints
import Ledger.Typed.Scripts (DatumType, RedeemerType, ValidatorTypes)
import Ledger.Typed.Scripts qualified as Scripts
import Plutus.Contracts.Currency qualified as Currency
import Plutus.Script.Utils.V2.Address (mkValidatorCardanoAddress)
import Plutus.Script.Utils.V2.Typed.Scripts qualified as V2
import Plutus.Script.Utils.Value (AssetClass, TokenName, Value)
import Plutus.Script.Utils.Value qualified as Value
import Plutus.V2.Ledger.Api qualified as V2
import Plutus.V2.Ledger.Contexts qualified as V2

import Prettyprinter.Extras (PrettyShow (PrettyShow))

newtype Account = Account { Account -> AssetClass
accountOwner :: AssetClass }
    deriving stock    (Account -> Account -> Bool
(Account -> Account -> Bool)
-> (Account -> Account -> Bool) -> Eq Account
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Account -> Account -> Bool
$c/= :: Account -> Account -> Bool
== :: Account -> Account -> Bool
$c== :: Account -> Account -> Bool
Eq, Int -> Account -> ShowS
[Account] -> ShowS
Account -> String
(Int -> Account -> ShowS)
-> (Account -> String) -> ([Account] -> ShowS) -> Show Account
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Account] -> ShowS
$cshowList :: [Account] -> ShowS
show :: Account -> String
$cshow :: Account -> String
showsPrec :: Int -> Account -> ShowS
$cshowsPrec :: Int -> Account -> ShowS
Show, (forall x. Account -> Rep Account x)
-> (forall x. Rep Account x -> Account) -> Generic Account
forall x. Rep Account x -> Account
forall x. Account -> Rep Account x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Account x -> Account
$cfrom :: forall x. Account -> Rep Account x
Generic)
    deriving anyclass ([Account] -> Encoding
[Account] -> Value
Account -> Encoding
Account -> Value
(Account -> Value)
-> (Account -> Encoding)
-> ([Account] -> Value)
-> ([Account] -> Encoding)
-> ToJSON Account
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Account] -> Encoding
$ctoEncodingList :: [Account] -> Encoding
toJSONList :: [Account] -> Value
$ctoJSONList :: [Account] -> Value
toEncoding :: Account -> Encoding
$ctoEncoding :: Account -> Encoding
toJSON :: Account -> Value
$ctoJSON :: Account -> Value
ToJSON, Value -> Parser [Account]
Value -> Parser Account
(Value -> Parser Account)
-> (Value -> Parser [Account]) -> FromJSON Account
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Account]
$cparseJSONList :: Value -> Parser [Account]
parseJSON :: Value -> Parser Account
$cparseJSON :: Value -> Parser Account
FromJSON)
    deriving [Account] -> Doc ann
Account -> Doc ann
(forall ann. Account -> Doc ann)
-> (forall ann. [Account] -> Doc ann) -> Pretty Account
forall ann. [Account] -> Doc ann
forall ann. Account -> Doc ann
forall a.
(forall ann. a -> Doc ann)
-> (forall ann. [a] -> Doc ann) -> Pretty a
prettyList :: [Account] -> Doc ann
$cprettyList :: forall ann. [Account] -> Doc ann
pretty :: Account -> Doc ann
$cpretty :: forall ann. Account -> Doc ann
Pretty via (PrettyShow Account)

data TokenAccount

instance ValidatorTypes TokenAccount where
    type RedeemerType TokenAccount = ()
    type DatumType TokenAccount = ()

type TokenAccountSchema =
        Endpoint "redeem" (Account, CardanoAddress)
        .\/ Endpoint "pay" (Account, Value)
        .\/ Endpoint "new-account" (TokenName, CardanoAddress)

type HasTokenAccountSchema s =
    ( HasEndpoint "redeem" (Account, CardanoAddress) s
    , HasEndpoint "pay" (Account, Value) s
    , HasEndpoint "new-account" (TokenName, CardanoAddress) s
    )

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

makeClassyPrisms ''TokenAccountError

instance AsContractError TokenAccountError where
    _ContractError :: p ContractError (f ContractError)
-> p TokenAccountError (f TokenAccountError)
_ContractError = p ContractError (f ContractError)
-> p TokenAccountError (f TokenAccountError)
forall r. AsTokenAccountError r => Prism' r ContractError
_TAContractError

instance Currency.AsCurrencyError TokenAccountError where
    _CurrencyError :: p CurrencyError (f CurrencyError)
-> p TokenAccountError (f TokenAccountError)
_CurrencyError = p CurrencyError (f CurrencyError)
-> p TokenAccountError (f TokenAccountError)
forall r. AsTokenAccountError r => Prism' r CurrencyError
_TACurrencyError

-- | 'redeem', 'pay' and 'newAccount' with endpoints.
tokenAccountContract
    :: forall w s e.
       ( HasTokenAccountSchema s
       , AsTokenAccountError e
       )
    => Contract w s e ()
tokenAccountContract :: Contract w s e ()
tokenAccountContract = (TokenAccountError -> e)
-> Contract w s TokenAccountError () -> Contract w s e ()
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError (AReview e TokenAccountError -> TokenAccountError -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e TokenAccountError
forall r. AsTokenAccountError r => Prism' r TokenAccountError
_TokenAccountError) ([Promise w s TokenAccountError ()]
-> Contract w s TokenAccountError ()
forall w (s :: Row *) e a. [Promise w s e a] -> Contract w s e a
selectList [Promise w s TokenAccountError ()
redeem_, Promise w s TokenAccountError ()
pay_, Promise w s TokenAccountError ()
newAccount_]) where
    redeem_ :: Promise w s TokenAccountError ()
redeem_ = forall e b.
(HasEndpoint "redeem" (Account, CardanoAddress) s,
 AsContractError e, FromJSON (Account, CardanoAddress)) =>
((Account, CardanoAddress) -> 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 @"redeem" @(Account, CardanoAddress) @w @s (((Account, CardanoAddress) -> Contract w s TokenAccountError ())
 -> Promise w s TokenAccountError ())
-> ((Account, CardanoAddress) -> Contract w s TokenAccountError ())
-> Promise w s TokenAccountError ()
forall a b. (a -> b) -> a -> b
$ \(Account
accountOwner, CardanoAddress
destination) -> do
        Contract w s TokenAccountError CardanoTx
-> Contract w s TokenAccountError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Contract w s TokenAccountError CardanoTx
 -> Contract w s TokenAccountError ())
-> Contract w s TokenAccountError CardanoTx
-> Contract w s TokenAccountError ()
forall a b. (a -> b) -> a -> b
$ CardanoAddress
-> Account -> Contract w s TokenAccountError CardanoTx
forall e w (s :: Row *).
AsTokenAccountError e =>
CardanoAddress -> Account -> Contract w s e CardanoTx
redeem CardanoAddress
destination Account
accountOwner
        Contract w s TokenAccountError ()
forall w (s :: Row *) e.
(HasTokenAccountSchema s, AsTokenAccountError e) =>
Contract w s e ()
tokenAccountContract
    pay_ :: Promise w s TokenAccountError ()
pay_ = forall e b.
(HasEndpoint "pay" (Account, Value) s, AsContractError e,
 FromJSON (Account, Value)) =>
((Account, Value) -> 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 @"pay" @_ @w @s (((Account, Value) -> Contract w s TokenAccountError ())
 -> Promise w s TokenAccountError ())
-> ((Account, Value) -> Contract w s TokenAccountError ())
-> Promise w s TokenAccountError ()
forall a b. (a -> b) -> a -> b
$ \(Account
accountOwner, Value
value) -> do
        Contract w s TokenAccountError CardanoTx
-> Contract w s TokenAccountError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Contract w s TokenAccountError CardanoTx
 -> Contract w s TokenAccountError ())
-> Contract w s TokenAccountError CardanoTx
-> Contract w s TokenAccountError ()
forall a b. (a -> b) -> a -> b
$ Account -> Value -> Contract w s TokenAccountError CardanoTx
forall e w (s :: Row *).
AsTokenAccountError e =>
Account -> Value -> Contract w s e CardanoTx
pay Account
accountOwner Value
value
        Contract w s TokenAccountError ()
forall w (s :: Row *) e.
(HasTokenAccountSchema s, AsTokenAccountError e) =>
Contract w s e ()
tokenAccountContract
    newAccount_ :: Promise w s TokenAccountError ()
newAccount_ = forall e b.
(HasEndpoint "new-account" (TokenName, CardanoAddress) s,
 AsContractError e, FromJSON (TokenName, CardanoAddress)) =>
((TokenName, CardanoAddress) -> 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 @"new-account" @_ @w @s (((TokenName, CardanoAddress) -> Contract w s TokenAccountError ())
 -> Promise w s TokenAccountError ())
-> ((TokenName, CardanoAddress)
    -> Contract w s TokenAccountError ())
-> Promise w s TokenAccountError ()
forall a b. (a -> b) -> a -> b
$ \(TokenName
tokenName, CardanoAddress
initialOwner) -> do
        Contract w s TokenAccountError Account
-> Contract w s TokenAccountError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Contract w s TokenAccountError Account
 -> Contract w s TokenAccountError ())
-> Contract w s TokenAccountError Account
-> Contract w s TokenAccountError ()
forall a b. (a -> b) -> a -> b
$ TokenName
-> CardanoAddress -> Contract w s TokenAccountError Account
forall w (s :: Row *) e.
AsTokenAccountError e =>
TokenName -> CardanoAddress -> Contract w s e Account
newAccount TokenName
tokenName CardanoAddress
initialOwner
        Contract w s TokenAccountError ()
forall w (s :: Row *) e.
(HasTokenAccountSchema s, AsTokenAccountError e) =>
Contract w s e ()
tokenAccountContract

{-# INLINEABLE accountToken #-}
accountToken :: Account -> Value
accountToken :: Account -> Value
accountToken (Account AssetClass
currency) = AssetClass -> Integer -> Value
Value.assetClassValue AssetClass
currency Integer
1

{-# INLINEABLE validate #-}
validate :: Account -> () -> () -> V2.ScriptContext -> Bool
validate :: Account -> () -> () -> ScriptContext -> Bool
validate Account
account ()
_ ()
_ ScriptContext
ptx = TxInfo -> Value
V2.valueSpent (ScriptContext -> TxInfo
V2.scriptContextTxInfo ScriptContext
ptx) Value -> Value -> Bool
`Value.geq` Account -> Value
accountToken Account
account

typedValidator :: Account -> V2.TypedValidator TokenAccount
typedValidator :: Account -> TypedValidator TokenAccount
typedValidator = CompiledCode (Account -> ValidatorType TokenAccount)
-> CompiledCode (ValidatorType TokenAccount -> UntypedValidator)
-> Account
-> TypedValidator TokenAccount
forall a param.
Lift DefaultUni param =>
CompiledCode (param -> ValidatorType a)
-> CompiledCode (ValidatorType a -> UntypedValidator)
-> param
-> TypedValidator a
V2.mkTypedValidatorParam @TokenAccount
    $$(PlutusTx.compile [|| validate ||])
    $$(PlutusTx.compile [|| wrap ||])
    where
        wrap :: (() -> () -> ScriptContext -> Bool) -> UntypedValidator
wrap = (() -> () -> ScriptContext -> Bool) -> UntypedValidator
forall sc d r.
(IsScriptContext sc, UnsafeFromData d, UnsafeFromData r) =>
(d -> r -> sc -> Bool) -> UntypedValidator
Scripts.mkUntypedValidator

address :: Account -> CardanoAddress
address :: Account -> CardanoAddress
address = NetworkId -> Validator -> CardanoAddress
mkValidatorCardanoAddress NetworkId
Params.testnet (Validator -> CardanoAddress)
-> (Account -> Validator) -> Account -> CardanoAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypedValidator TokenAccount -> Validator
forall a. TypedValidator a -> Validator
Scripts.validatorScript (TypedValidator TokenAccount -> Validator)
-> (Account -> TypedValidator TokenAccount) -> Account -> Validator
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Account -> TypedValidator TokenAccount
typedValidator

validatorHash :: Account -> V2.ValidatorHash
validatorHash :: Account -> ValidatorHash
validatorHash = TypedValidator TokenAccount -> ValidatorHash
forall a. TypedValidator a -> ValidatorHash
V2.validatorHash (TypedValidator TokenAccount -> ValidatorHash)
-> (Account -> TypedValidator TokenAccount)
-> Account
-> ValidatorHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Account -> TypedValidator TokenAccount
typedValidator

-- | A transaction that pays the given value to the account
payTx
    ::
    Value
    -> TxConstraints (Scripts.RedeemerType TokenAccount) (Scripts.DatumType TokenAccount)
payTx :: Value
-> TxConstraints
     (RedeemerType TokenAccount) (DatumType TokenAccount)
payTx = () -> Value -> TxConstraints () ()
forall o i. o -> Value -> TxConstraints i o
Constraints.mustPayToTheScriptWithDatumInTx ()

-- | Pay some money to the given token account
pay
    :: ( AsTokenAccountError e
       )
    => Account
    -> Value
    -> Contract w s e CardanoTx
pay :: Account -> Value -> Contract w s e CardanoTx
pay Account
account Value
vl = do
    let inst :: TypedValidator TokenAccount
inst = Account -> TypedValidator TokenAccount
typedValidator Account
account
    forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
forall w (s :: Row *) e.
ToJSON String =>
String -> Contract w s e ()
logInfo @String
        (String -> Contract w s e ()) -> String -> Contract w s e ()
forall a b. (a -> b) -> a -> b
$ String
"TokenAccount.pay: Paying "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
vl
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" into "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Account -> String
forall a. Show a => a -> String
show Account
account
    (ContractError -> e)
-> Contract w s ContractError CardanoTx -> Contract w s e CardanoTx
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError (AReview e ContractError -> ContractError -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e ContractError
forall r. AsTokenAccountError r => Prism' r ContractError
_TAContractError) (Contract w s ContractError CardanoTx -> Contract w s e CardanoTx)
-> Contract w s ContractError CardanoTx -> Contract w s e CardanoTx
forall a b. (a -> b) -> a -> b
$
          ScriptLookups TokenAccount
-> TxConstraints
     (RedeemerType TokenAccount) (DatumType TokenAccount)
-> Contract w s ContractError UnbalancedTx
forall a w (s :: Row *) e.
(ToData (RedeemerType a), FromData (DatumType a),
 ToData (DatumType a), AsContractError e) =>
ScriptLookups a
-> TxConstraints (RedeemerType a) (DatumType a)
-> Contract w s e UnbalancedTx
mkTxConstraints (TypedValidator TokenAccount -> ScriptLookups TokenAccount
forall a. TypedValidator a -> ScriptLookups a
Constraints.typedValidatorLookups TypedValidator TokenAccount
inst) (Value
-> TxConstraints
     (RedeemerType TokenAccount) (DatumType TokenAccount)
payTx Value
vl)
      Contract w s ContractError UnbalancedTx
-> (UnbalancedTx -> Contract w s ContractError UnbalancedTx)
-> Contract w s ContractError UnbalancedTx
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnbalancedTx -> Contract w s ContractError UnbalancedTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e UnbalancedTx
adjustUnbalancedTx Contract w s ContractError UnbalancedTx
-> (UnbalancedTx -> Contract w s ContractError CardanoTx)
-> Contract w s ContractError CardanoTx
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnbalancedTx -> Contract w s ContractError CardanoTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e CardanoTx
submitUnbalancedTx

-- | Create a transaction that spends all outputs belonging to the 'Account'.
redeemTx :: forall w s e.
    ( AsTokenAccountError e
    )
    => Account
    -> CardanoAddress
    -> Contract w s e (TxConstraints () (), ScriptLookups TokenAccount)
redeemTx :: Account
-> CardanoAddress
-> Contract w s e (TxConstraints () (), ScriptLookups TokenAccount)
redeemTx Account
account CardanoAddress
addr = (ContractError -> e)
-> Contract
     w s ContractError (TxConstraints () (), ScriptLookups TokenAccount)
-> Contract w s e (TxConstraints () (), ScriptLookups TokenAccount)
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError (AReview e ContractError -> ContractError -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e ContractError
forall r. AsTokenAccountError r => Prism' r ContractError
_TAContractError) (Contract
   w s ContractError (TxConstraints () (), ScriptLookups TokenAccount)
 -> Contract
      w s e (TxConstraints () (), ScriptLookups TokenAccount))
-> Contract
     w s ContractError (TxConstraints () (), ScriptLookups TokenAccount)
-> Contract w s e (TxConstraints () (), ScriptLookups TokenAccount)
forall a b. (a -> b) -> a -> b
$ do
    let inst :: TypedValidator TokenAccount
inst = Account -> TypedValidator TokenAccount
typedValidator Account
account
    Map TxOutRef DecoratedTxOut
utxos <- CardanoAddress
-> Contract w s ContractError (Map TxOutRef DecoratedTxOut)
forall w (s :: Row *) e.
AsContractError e =>
CardanoAddress -> Contract w s e (Map TxOutRef DecoratedTxOut)
utxosAt (Account -> CardanoAddress
address Account
account)
    let totalVal :: Value
totalVal = (DecoratedTxOut -> Value) -> Map TxOutRef DecoratedTxOut -> Value
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DecoratedTxOut -> Value
decoratedTxOutPlutusValue Map TxOutRef DecoratedTxOut
utxos
        numInputs :: Int
numInputs = Map TxOutRef DecoratedTxOut -> Int
forall k a. Map k a -> Int
Map.size Map TxOutRef DecoratedTxOut
utxos
    forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
forall w (s :: Row *) e.
ToJSON String =>
String -> Contract w s e ()
logInfo @String
        (String -> Contract w s ContractError ())
-> String -> Contract w s ContractError ()
forall a b. (a -> b) -> a -> b
$ String
"TokenAccount.redeemTx: Redeeming "
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
numInputs
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" outputs with a total value of "
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
totalVal
    let constraints :: TxConstraints () ()
constraints = Map TxOutRef DecoratedTxOut -> () -> TxConstraints () ()
forall i o. Map TxOutRef DecoratedTxOut -> i -> TxConstraints i o
Constraints.spendUtxosFromTheScript Map TxOutRef DecoratedTxOut
utxos ()
                TxConstraints () () -> TxConstraints () () -> TxConstraints () ()
forall a. Semigroup a => a -> a -> a
<> Address -> Value -> TxConstraints () ()
forall i o. Address -> Value -> TxConstraints i o
Constraints.mustPayToAddress (CardanoAddress -> Address
forall era. AddressInEra era -> Address
toPlutusAddress CardanoAddress
addr) (Account -> Value
accountToken Account
account)
        lookups :: ScriptLookups TokenAccount
lookups = TypedValidator TokenAccount -> ScriptLookups TokenAccount
forall a. TypedValidator a -> ScriptLookups a
Constraints.typedValidatorLookups TypedValidator TokenAccount
inst
                ScriptLookups TokenAccount
-> ScriptLookups TokenAccount -> ScriptLookups TokenAccount
forall a. Semigroup a => a -> a -> a
<> Map TxOutRef DecoratedTxOut -> ScriptLookups TokenAccount
forall a. Map TxOutRef DecoratedTxOut -> ScriptLookups a
Constraints.unspentOutputs Map TxOutRef DecoratedTxOut
utxos
    (TxConstraints () (), ScriptLookups TokenAccount)
-> Contract
     w s ContractError (TxConstraints () (), ScriptLookups TokenAccount)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxConstraints () ()
constraints, ScriptLookups TokenAccount
lookups)

-- | Empty the account by spending all outputs belonging to the 'Account'.
redeem
  :: ( AsTokenAccountError e
     )
  => CardanoAddress
  -- ^ Where the token should go after the transaction
  -> Account
  -- ^ The token account
  -> Contract w s e CardanoTx
redeem :: CardanoAddress -> Account -> Contract w s e CardanoTx
redeem CardanoAddress
pk Account
account = (TokenAccountError -> e)
-> Contract w s TokenAccountError CardanoTx
-> Contract w s e CardanoTx
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError (AReview e TokenAccountError -> TokenAccountError -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e TokenAccountError
forall r. AsTokenAccountError r => Prism' r TokenAccountError
_TokenAccountError) (Contract w s TokenAccountError CardanoTx
 -> Contract w s e CardanoTx)
-> Contract w s TokenAccountError CardanoTx
-> Contract w s e CardanoTx
forall a b. (a -> b) -> a -> b
$ do
    (TxConstraints () ()
constraints, ScriptLookups TokenAccount
lookups) <- Account
-> CardanoAddress
-> Contract
     w
     s
     TokenAccountError
     (TxConstraints () (), ScriptLookups TokenAccount)
forall w (s :: Row *) e.
AsTokenAccountError e =>
Account
-> CardanoAddress
-> Contract w s e (TxConstraints () (), ScriptLookups TokenAccount)
redeemTx Account
account CardanoAddress
pk
    ScriptLookups TokenAccount
-> TxConstraints
     (RedeemerType TokenAccount) (DatumType TokenAccount)
-> Contract w s TokenAccountError UnbalancedTx
forall a w (s :: Row *) e.
(ToData (RedeemerType a), FromData (DatumType a),
 ToData (DatumType a), AsContractError e) =>
ScriptLookups a
-> TxConstraints (RedeemerType a) (DatumType a)
-> Contract w s e UnbalancedTx
mkTxConstraints ScriptLookups TokenAccount
lookups TxConstraints () ()
TxConstraints (RedeemerType TokenAccount) (DatumType TokenAccount)
constraints Contract w s TokenAccountError UnbalancedTx
-> (UnbalancedTx -> Contract w s TokenAccountError UnbalancedTx)
-> Contract w s TokenAccountError UnbalancedTx
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnbalancedTx -> Contract w s TokenAccountError UnbalancedTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e UnbalancedTx
adjustUnbalancedTx Contract w s TokenAccountError UnbalancedTx
-> (UnbalancedTx -> Contract w s TokenAccountError CardanoTx)
-> Contract w s TokenAccountError CardanoTx
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnbalancedTx -> Contract w s TokenAccountError CardanoTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e CardanoTx
submitUnbalancedTx

-- | @balance account@ returns the value of all unspent outputs that can be
--   unlocked with @accountToken account@
balance
    :: ( AsTokenAccountError e
       )
    => Account
    -> Contract w s e Value
balance :: Account -> Contract w s e Value
balance Account
account = (ContractError -> e)
-> Contract w s ContractError Value -> Contract w s e Value
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError (AReview e ContractError -> ContractError -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e ContractError
forall r. AsTokenAccountError r => Prism' r ContractError
_TAContractError) (Contract w s ContractError Value -> Contract w s e Value)
-> Contract w s ContractError Value -> Contract w s e Value
forall a b. (a -> b) -> a -> b
$ do
    Map TxOutRef DecoratedTxOut
utxos <- CardanoAddress
-> Contract w s ContractError (Map TxOutRef DecoratedTxOut)
forall w (s :: Row *) e.
AsContractError e =>
CardanoAddress -> Contract w s e (Map TxOutRef DecoratedTxOut)
utxosAt (Account -> CardanoAddress
address Account
account)
    Value -> Contract w s ContractError Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Contract w s ContractError Value)
-> Value -> Contract w s ContractError Value
forall a b. (a -> b) -> a -> b
$ (DecoratedTxOut -> Value) -> Map TxOutRef DecoratedTxOut -> Value
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DecoratedTxOut -> Value
decoratedTxOutPlutusValue Map TxOutRef DecoratedTxOut
utxos

-- | Create a new token and return its 'Account' information.
newAccount
    :: forall w s e.
    (AsTokenAccountError e)
    => TokenName
    -- ^ Name of the token
    -> CardanoAddress
    -- ^ Address of the token's initial owner
    -> Contract w s e Account
newAccount :: TokenName -> CardanoAddress -> Contract w s e Account
newAccount TokenName
tokenName CardanoAddress
addr = (TokenAccountError -> e)
-> Contract w s TokenAccountError Account -> Contract w s e Account
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError (AReview e TokenAccountError -> TokenAccountError -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e TokenAccountError
forall r. AsTokenAccountError r => Prism' r TokenAccountError
_TokenAccountError) (Contract w s TokenAccountError Account -> Contract w s e Account)
-> Contract w s TokenAccountError Account -> Contract w s e Account
forall a b. (a -> b) -> a -> b
$ do
    OneShotCurrency
cur <- CardanoAddress
-> [(TokenName, Integer)]
-> Contract w s TokenAccountError OneShotCurrency
forall w (s :: Row *) e.
AsCurrencyError e =>
CardanoAddress
-> [(TokenName, Integer)] -> Contract w s e OneShotCurrency
Currency.mintContract CardanoAddress
addr [(TokenName
tokenName, Integer
1)]
    let sym :: CurrencySymbol
sym = OneShotCurrency -> CurrencySymbol
Currency.currencySymbol OneShotCurrency
cur
    Account -> Contract w s TokenAccountError Account
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Account -> Contract w s TokenAccountError Account)
-> Account -> Contract w s TokenAccountError Account
forall a b. (a -> b) -> a -> b
$ AssetClass -> Account
Account (AssetClass -> Account) -> AssetClass -> Account
forall a b. (a -> b) -> a -> b
$ CurrencySymbol -> TokenName -> AssetClass
Value.assetClass CurrencySymbol
sym TokenName
tokenName

PlutusTx.makeLift ''Account
PlutusTx.unstableMakeIsData ''Account