{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MonoLocalBinds        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeOperators         #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -fno-specialise #-}
{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-}
{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:debug-context #-}
module Plutus.Contracts.Future(
    -- $future
      Future(..)
    , FutureAccounts(..)
    , mkAccounts
    , FutureError(..)
    , FutureSchema
    , FutureSetup(..)
    , Role(..)
    , futureContract
    , futureStateMachine
    , validator
    , initialiseFuture
    , initialMargin
    , futureAddress
    , tokenFor
    , initialState
    , typedValidator
    , setupTokens
    , setupTokensTrace
    ) where

import Control.Lens (makeClassyPrisms, prism', review)
import Control.Monad (void)
import Control.Monad.Error.Lens (throwing)
import Data.Aeson (FromJSON, ToJSON)
import GHC.Generics (Generic)

import PlutusTx qualified
import PlutusTx.Prelude

import Ledger (Address, POSIXTime, PaymentPubKey, PaymentPubKeyHash)
import Ledger.Scripts (unitDatum)
import Ledger.Tx.Constraints (TxConstraints)
import Ledger.Tx.Constraints qualified as Constraints
import Ledger.Tx.Constraints.ValidityInterval qualified as Interval
import Ledger.Typed.Scripts qualified as Scripts
import Plutus.Contract
import Plutus.Contract.Oracle (Observation (..), SignedMessage (..))
import Plutus.Contract.Oracle qualified as Oracle
import Plutus.Contract.Util (loopM)
import Plutus.Script.Utils.V2.Address (mkValidatorAddress)
import Plutus.Script.Utils.V2.Typed.Scripts qualified as V2
import Plutus.Script.Utils.Value as Value
import Plutus.V2.Ledger.Api (Datum (Datum), Validator, ValidatorHash)

import Plutus.Contract.StateMachine (AsSMContractError, State (..), StateMachine (..), Void)
import Plutus.Contract.StateMachine qualified as SM
import Plutus.Contracts.Currency qualified as Currency
import Plutus.Contracts.Escrow (AsEscrowError (..), EscrowError, EscrowParams (..), RefundSuccess)
import Plutus.Contracts.Escrow qualified as Escrow
import Plutus.Contracts.TokenAccount (Account (..))
import Plutus.Contracts.TokenAccount qualified as TokenAccount
import Plutus.Trace.Emulator qualified as Trace
import Wallet.Emulator.Wallet qualified as Wallet

import Prelude qualified as Haskell

-- $future
-- A futures contract in Plutus. This example illustrates a number of concepts.
--
--   1. Maintaining a margin (a kind of deposit) during the duration of the contract to protect against breach of contract (see note [Futures in Plutus])
--   2. Using oracle values to obtain current pricing information (see note [Oracles] in Plutus.Contracts)
--   3. Writing contracts as state machines
--   4. Using tokens to represent claims on future cash flows

-- | Basic data of a futures contract. `Future` contains all values that do not
--   change during the lifetime of the contract.
--
data Future =
    Future
        { Future -> POSIXTime
ftDeliveryDate  :: POSIXTime
        , Future -> Integer
ftUnits         :: Integer
        , Future -> Value
ftUnitPrice     :: Value
        , Future -> Value
ftInitialMargin :: Value
        , Future -> PaymentPubKey
ftPriceOracle   :: PaymentPubKey
        , Future -> Value
ftMarginPenalty :: Value
        -- ^ How much a participant loses if they fail to make the required
        --   margin payments.
        } deriving (forall x. Future -> Rep Future x)
-> (forall x. Rep Future x -> Future) -> Generic Future
forall x. Rep Future x -> Future
forall x. Future -> Rep Future x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Future x -> Future
$cfrom :: forall x. Future -> Rep Future x
Generic

-- | The two roles involved in the contract.
data Role = Long | Short
    deriving stock ((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
Haskell.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)

instance Eq Role where
    Role
Long == :: Role -> Role -> Bool
== Role
Long   = Bool
True
    Role
Short == Role
Short = Bool
True
    Role
_ == Role
_         = Bool
False

-- | The token accounts that represent ownership of the two sides of the future.
--   When the contract is done, payments will be made to these accounts.
data FutureAccounts =
    FutureAccounts
        { FutureAccounts -> Account
ftoLong         :: Account
        -- ^ The owner of the "long" account (represented by a token)
        , FutureAccounts -> ValidatorHash
ftoLongAccount  :: ValidatorHash
        -- ^ Address of the 'TokenAccount' validator script for 'ftoLong'. This
        --   hash can be derived from 'ftoLong', but only in off-chain code. We
        --   store it here so that we can lift it into on-chain code.
        , FutureAccounts -> Account
ftoShort        :: Account
        -- ^ The owner of the "short" account (represented by a token).
        , FutureAccounts -> ValidatorHash
ftoShortAccount :: ValidatorHash
        -- ^ Address of the 'TokenAccount' validator script for 'ftoShort'. The
        --   comment on 'ftoLongAccount' applies to this as well.
        } deriving stock (Int -> FutureAccounts -> ShowS
[FutureAccounts] -> ShowS
FutureAccounts -> String
(Int -> FutureAccounts -> ShowS)
-> (FutureAccounts -> String)
-> ([FutureAccounts] -> ShowS)
-> Show FutureAccounts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FutureAccounts] -> ShowS
$cshowList :: [FutureAccounts] -> ShowS
show :: FutureAccounts -> String
$cshow :: FutureAccounts -> String
showsPrec :: Int -> FutureAccounts -> ShowS
$cshowsPrec :: Int -> FutureAccounts -> ShowS
Haskell.Show, (forall x. FutureAccounts -> Rep FutureAccounts x)
-> (forall x. Rep FutureAccounts x -> FutureAccounts)
-> Generic FutureAccounts
forall x. Rep FutureAccounts x -> FutureAccounts
forall x. FutureAccounts -> Rep FutureAccounts x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FutureAccounts x -> FutureAccounts
$cfrom :: forall x. FutureAccounts -> Rep FutureAccounts x
Generic)
          deriving anyclass ([FutureAccounts] -> Encoding
[FutureAccounts] -> Value
FutureAccounts -> Encoding
FutureAccounts -> Value
(FutureAccounts -> Value)
-> (FutureAccounts -> Encoding)
-> ([FutureAccounts] -> Value)
-> ([FutureAccounts] -> Encoding)
-> ToJSON FutureAccounts
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [FutureAccounts] -> Encoding
$ctoEncodingList :: [FutureAccounts] -> Encoding
toJSONList :: [FutureAccounts] -> Value
$ctoJSONList :: [FutureAccounts] -> Value
toEncoding :: FutureAccounts -> Encoding
$ctoEncoding :: FutureAccounts -> Encoding
toJSON :: FutureAccounts -> Value
$ctoJSON :: FutureAccounts -> Value
ToJSON, Value -> Parser [FutureAccounts]
Value -> Parser FutureAccounts
(Value -> Parser FutureAccounts)
-> (Value -> Parser [FutureAccounts]) -> FromJSON FutureAccounts
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [FutureAccounts]
$cparseJSONList :: Value -> Parser [FutureAccounts]
parseJSON :: Value -> Parser FutureAccounts
$cparseJSON :: Value -> Parser FutureAccounts
FromJSON)

-- | The two margins.
data Margins =
    Margins
        { Margins -> Value
ftsShortMargin :: Value
        , Margins -> Value
ftsLongMargin  :: Value
        }
        deriving (Margins -> Margins -> Bool
(Margins -> Margins -> Bool)
-> (Margins -> Margins -> Bool) -> Eq Margins
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Margins -> Margins -> Bool
$c/= :: Margins -> Margins -> Bool
== :: Margins -> Margins -> Bool
$c== :: Margins -> Margins -> Bool
Haskell.Eq, Int -> Margins -> ShowS
[Margins] -> ShowS
Margins -> String
(Int -> Margins -> ShowS)
-> (Margins -> String) -> ([Margins] -> ShowS) -> Show Margins
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Margins] -> ShowS
$cshowList :: [Margins] -> ShowS
show :: Margins -> String
$cshow :: Margins -> String
showsPrec :: Int -> Margins -> ShowS
$cshowsPrec :: Int -> Margins -> ShowS
Haskell.Show, (forall x. Margins -> Rep Margins x)
-> (forall x. Rep Margins x -> Margins) -> Generic Margins
forall x. Rep Margins x -> Margins
forall x. Margins -> Rep Margins x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Margins x -> Margins
$cfrom :: forall x. Margins -> Rep Margins x
Generic)
        deriving anyclass ([Margins] -> Encoding
[Margins] -> Value
Margins -> Encoding
Margins -> Value
(Margins -> Value)
-> (Margins -> Encoding)
-> ([Margins] -> Value)
-> ([Margins] -> Encoding)
-> ToJSON Margins
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Margins] -> Encoding
$ctoEncodingList :: [Margins] -> Encoding
toJSONList :: [Margins] -> Value
$ctoJSONList :: [Margins] -> Value
toEncoding :: Margins -> Encoding
$ctoEncoding :: Margins -> Encoding
toJSON :: Margins -> Value
$ctoJSON :: Margins -> Value
ToJSON, Value -> Parser [Margins]
Value -> Parser Margins
(Value -> Parser Margins)
-> (Value -> Parser [Margins]) -> FromJSON Margins
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Margins]
$cparseJSONList :: Value -> Parser [Margins]
parseJSON :: Value -> Parser Margins
$cparseJSON :: Value -> Parser Margins
FromJSON)

instance Eq Margins where
    Margins
l == :: Margins -> Margins -> Bool
== Margins
r = Margins -> Value
ftsShortMargin Margins
l Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Margins -> Value
ftsShortMargin Margins
r Bool -> Bool -> Bool
&& Margins -> Value
ftsLongMargin Margins
l Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Margins -> Value
ftsLongMargin Margins
r

-- | The state of the future contract.
data FutureState =
    Running Margins
    -- ^ Ongoing contract, with the current margins.
    | Finished
    -- ^ Contract is finished.
    deriving stock (Int -> FutureState -> ShowS
[FutureState] -> ShowS
FutureState -> String
(Int -> FutureState -> ShowS)
-> (FutureState -> String)
-> ([FutureState] -> ShowS)
-> Show FutureState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FutureState] -> ShowS
$cshowList :: [FutureState] -> ShowS
show :: FutureState -> String
$cshow :: FutureState -> String
showsPrec :: Int -> FutureState -> ShowS
$cshowsPrec :: Int -> FutureState -> ShowS
Haskell.Show, (forall x. FutureState -> Rep FutureState x)
-> (forall x. Rep FutureState x -> FutureState)
-> Generic FutureState
forall x. Rep FutureState x -> FutureState
forall x. FutureState -> Rep FutureState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FutureState x -> FutureState
$cfrom :: forall x. FutureState -> Rep FutureState x
Generic, FutureState -> FutureState -> Bool
(FutureState -> FutureState -> Bool)
-> (FutureState -> FutureState -> Bool) -> Eq FutureState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FutureState -> FutureState -> Bool
$c/= :: FutureState -> FutureState -> Bool
== :: FutureState -> FutureState -> Bool
$c== :: FutureState -> FutureState -> Bool
Haskell.Eq)
    deriving anyclass ([FutureState] -> Encoding
[FutureState] -> Value
FutureState -> Encoding
FutureState -> Value
(FutureState -> Value)
-> (FutureState -> Encoding)
-> ([FutureState] -> Value)
-> ([FutureState] -> Encoding)
-> ToJSON FutureState
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [FutureState] -> Encoding
$ctoEncodingList :: [FutureState] -> Encoding
toJSONList :: [FutureState] -> Value
$ctoJSONList :: [FutureState] -> Value
toEncoding :: FutureState -> Encoding
$ctoEncoding :: FutureState -> Encoding
toJSON :: FutureState -> Value
$ctoJSON :: FutureState -> Value
ToJSON, Value -> Parser [FutureState]
Value -> Parser FutureState
(Value -> Parser FutureState)
-> (Value -> Parser [FutureState]) -> FromJSON FutureState
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [FutureState]
$cparseJSONList :: Value -> Parser [FutureState]
parseJSON :: Value -> Parser FutureState
$cparseJSON :: Value -> Parser FutureState
FromJSON)

instance Eq FutureState where
    Running Margins
ma == :: FutureState -> FutureState -> Bool
== Running Margins
ma' = Margins
ma Margins -> Margins -> Bool
forall a. Eq a => a -> a -> Bool
== Margins
ma'
    FutureState
Finished   == FutureState
Finished    = Bool
True
    FutureState
_ == FutureState
_                    = Bool
False

-- | Actions that can be performed on the future contract.
data FutureAction =
    AdjustMargin Role Value
    -- ^ Change the margin of one of the roles.
    | Settle (SignedMessage (Observation Value))
    -- ^ Close the contract at the delivery date by making the agreed payment
    --   and returning the margin deposits to their owners
    | SettleEarly (SignedMessage (Observation Value))
    -- ^ Close the contract early after a margin payment has been missed.
    --   The value of both margin accounts will be paid to the role that
    --   *didn't* violate the margin requirement
    deriving stock (Int -> FutureAction -> ShowS
[FutureAction] -> ShowS
FutureAction -> String
(Int -> FutureAction -> ShowS)
-> (FutureAction -> String)
-> ([FutureAction] -> ShowS)
-> Show FutureAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FutureAction] -> ShowS
$cshowList :: [FutureAction] -> ShowS
show :: FutureAction -> String
$cshow :: FutureAction -> String
showsPrec :: Int -> FutureAction -> ShowS
$cshowsPrec :: Int -> FutureAction -> ShowS
Haskell.Show, (forall x. FutureAction -> Rep FutureAction x)
-> (forall x. Rep FutureAction x -> FutureAction)
-> Generic FutureAction
forall x. Rep FutureAction x -> FutureAction
forall x. FutureAction -> Rep FutureAction x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FutureAction x -> FutureAction
$cfrom :: forall x. FutureAction -> Rep FutureAction x
Generic)
    deriving anyclass ([FutureAction] -> Encoding
[FutureAction] -> Value
FutureAction -> Encoding
FutureAction -> Value
(FutureAction -> Value)
-> (FutureAction -> Encoding)
-> ([FutureAction] -> Value)
-> ([FutureAction] -> Encoding)
-> ToJSON FutureAction
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [FutureAction] -> Encoding
$ctoEncodingList :: [FutureAction] -> Encoding
toJSONList :: [FutureAction] -> Value
$ctoJSONList :: [FutureAction] -> Value
toEncoding :: FutureAction -> Encoding
$ctoEncoding :: FutureAction -> Encoding
toJSON :: FutureAction -> Value
$ctoJSON :: FutureAction -> Value
ToJSON, Value -> Parser [FutureAction]
Value -> Parser FutureAction
(Value -> Parser FutureAction)
-> (Value -> Parser [FutureAction]) -> FromJSON FutureAction
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [FutureAction]
$cparseJSONList :: Value -> Parser [FutureAction]
parseJSON :: Value -> Parser FutureAction
$cparseJSON :: Value -> Parser FutureAction
FromJSON)

data FutureError =
    TokenSetupFailed Currency.CurrencyError
    -- ^ Something went wrong during the setup of the two tokens
    | StateMachineError SM.SMContractError
    | OtherFutureError ContractError
    | EscrowFailed EscrowError
    -- ^ The escrow that initialises the future contract failed
    | EscrowRefunded RefundSuccess
    -- ^ The other party didn't make their payment in time so the contract never
    --   started.
    deriving stock (Int -> FutureError -> ShowS
[FutureError] -> ShowS
FutureError -> String
(Int -> FutureError -> ShowS)
-> (FutureError -> String)
-> ([FutureError] -> ShowS)
-> Show FutureError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FutureError] -> ShowS
$cshowList :: [FutureError] -> ShowS
show :: FutureError -> String
$cshow :: FutureError -> String
showsPrec :: Int -> FutureError -> ShowS
$cshowsPrec :: Int -> FutureError -> ShowS
Haskell.Show, (forall x. FutureError -> Rep FutureError x)
-> (forall x. Rep FutureError x -> FutureError)
-> Generic FutureError
forall x. Rep FutureError x -> FutureError
forall x. FutureError -> Rep FutureError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FutureError x -> FutureError
$cfrom :: forall x. FutureError -> Rep FutureError x
Generic)
    deriving anyclass ([FutureError] -> Encoding
[FutureError] -> Value
FutureError -> Encoding
FutureError -> Value
(FutureError -> Value)
-> (FutureError -> Encoding)
-> ([FutureError] -> Value)
-> ([FutureError] -> Encoding)
-> ToJSON FutureError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [FutureError] -> Encoding
$ctoEncodingList :: [FutureError] -> Encoding
toJSONList :: [FutureError] -> Value
$ctoJSONList :: [FutureError] -> Value
toEncoding :: FutureError -> Encoding
$ctoEncoding :: FutureError -> Encoding
toJSON :: FutureError -> Value
$ctoJSON :: FutureError -> Value
ToJSON, Value -> Parser [FutureError]
Value -> Parser FutureError
(Value -> Parser FutureError)
-> (Value -> Parser [FutureError]) -> FromJSON FutureError
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [FutureError]
$cparseJSONList :: Value -> Parser [FutureError]
parseJSON :: Value -> Parser FutureError
$cparseJSON :: Value -> Parser FutureError
FromJSON)

makeClassyPrisms ''FutureError

instance AsSMContractError FutureError where
    _SMContractError :: p SMContractError (f SMContractError)
-> p FutureError (f FutureError)
_SMContractError = p SMContractError (f SMContractError)
-> p FutureError (f FutureError)
forall r. AsFutureError r => Prism' r SMContractError
_StateMachineError

instance AsContractError FutureError where
    _ContractError :: p ContractError (f ContractError) -> p FutureError (f FutureError)
_ContractError = p ContractError (f ContractError) -> p FutureError (f FutureError)
forall r. AsFutureError r => Prism' r ContractError
_OtherFutureError

instance AsCheckpointError FutureError where
    _CheckpointError :: p CheckpointError (f CheckpointError)
-> p FutureError (f FutureError)
_CheckpointError = p ContractError (f ContractError) -> p FutureError (f FutureError)
forall r. AsFutureError r => Prism' r ContractError
_OtherFutureError (p ContractError (f ContractError)
 -> p FutureError (f FutureError))
-> (p CheckpointError (f CheckpointError)
    -> p ContractError (f ContractError))
-> p CheckpointError (f CheckpointError)
-> p FutureError (f FutureError)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p CheckpointError (f CheckpointError)
-> p ContractError (f ContractError)
forall r. AsCheckpointError r => Prism' r CheckpointError
_CheckpointError

type FutureSchema =
        Endpoint "initialise-future" (FutureSetup, Role)
        .\/ Endpoint "join-future" (FutureAccounts, FutureSetup)
        .\/ Endpoint "increase-margin" (Value, Role)
        .\/ Endpoint "settle-early" (SignedMessage (Observation Value))
        .\/ Endpoint "settle-future" (SignedMessage (Observation Value))

instance AsEscrowError FutureError where
    _EscrowError :: p EscrowError (f EscrowError) -> p FutureError (f FutureError)
_EscrowError = (EscrowError -> FutureError)
-> (FutureError -> Maybe EscrowError)
-> Prism' FutureError EscrowError
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' EscrowError -> FutureError
EscrowFailed (\case { EscrowFailed EscrowError
e -> EscrowError -> Maybe EscrowError
forall a. a -> Maybe a
Just EscrowError
e; FutureError
_ -> Maybe EscrowError
forall a. Maybe a
Nothing})

futureContract :: Future -> Contract () FutureSchema FutureError ()
futureContract :: Future -> Contract () FutureSchema FutureError ()
futureContract Future
ft = do
    StateMachineClient FutureState FutureAction
client <- Promise
  ()
  ('R
     '[ "increase-margin"
        ':-> (EndpointValue (Value, Role), ActiveEndpoint),
        "initialise-future"
        ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
        "join-future"
        ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
        "settle-early"
        ':-> (EndpointValue (SignedMessage (Observation Value)),
              ActiveEndpoint),
        "settle-future"
        ':-> (EndpointValue (SignedMessage (Observation Value)),
              ActiveEndpoint)])
  FutureError
  (StateMachineClient FutureState FutureAction)
-> Contract
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     (StateMachineClient FutureState FutureAction)
forall w (s :: Row *) e a. Promise w s e a -> Contract w s e a
awaitPromise (Future
-> Promise
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     (StateMachineClient FutureState FutureAction)
forall (s :: Row *) e w.
(HasEndpoint "join-future" (FutureAccounts, FutureSetup) s,
 AsFutureError e) =>
Future
-> Promise w s e (StateMachineClient FutureState FutureAction)
joinFuture Future
ft Promise
  ()
  ('R
     '[ "increase-margin"
        ':-> (EndpointValue (Value, Role), ActiveEndpoint),
        "initialise-future"
        ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
        "join-future"
        ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
        "settle-early"
        ':-> (EndpointValue (SignedMessage (Observation Value)),
              ActiveEndpoint),
        "settle-future"
        ':-> (EndpointValue (SignedMessage (Observation Value)),
              ActiveEndpoint)])
  FutureError
  (StateMachineClient FutureState FutureAction)
-> Promise
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     (StateMachineClient FutureState FutureAction)
-> Promise
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     (StateMachineClient FutureState FutureAction)
forall w (s :: Row *) e a.
Promise w s e a -> Promise w s e a -> Promise w s e a
`select` Future
-> Promise
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     (StateMachineClient FutureState FutureAction)
forall (s :: Row *) e w.
(HasEndpoint "initialise-future" (FutureSetup, Role) s,
 AsFutureError e) =>
Future
-> Promise w s e (StateMachineClient FutureState FutureAction)
initialiseFuture Future
ft)
    Contract
  ()
  ('R
     '[ "increase-margin"
        ':-> (EndpointValue (Value, Role), ActiveEndpoint),
        "initialise-future"
        ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
        "join-future"
        ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
        "settle-early"
        ':-> (EndpointValue (SignedMessage (Observation Value)),
              ActiveEndpoint),
        "settle-future"
        ':-> (EndpointValue (SignedMessage (Observation Value)),
              ActiveEndpoint)])
  FutureError
  ()
-> Contract
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Contract
   ()
   ('R
      '[ "increase-margin"
         ':-> (EndpointValue (Value, Role), ActiveEndpoint),
         "initialise-future"
         ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
         "join-future"
         ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
         "settle-early"
         ':-> (EndpointValue (SignedMessage (Observation Value)),
               ActiveEndpoint),
         "settle-future"
         ':-> (EndpointValue (SignedMessage (Observation Value)),
               ActiveEndpoint)])
   FutureError
   ()
 -> Contract
      ()
      ('R
         '[ "increase-margin"
            ':-> (EndpointValue (Value, Role), ActiveEndpoint),
            "initialise-future"
            ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
            "join-future"
            ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
            "settle-early"
            ':-> (EndpointValue (SignedMessage (Observation Value)),
                  ActiveEndpoint),
            "settle-future"
            ':-> (EndpointValue (SignedMessage (Observation Value)),
                  ActiveEndpoint)])
      FutureError
      ())
-> Contract
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     ()
-> Contract
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     ()
forall a b. (a -> b) -> a -> b
$ (()
 -> Contract
      ()
      ('R
         '[ "increase-margin"
            ':-> (EndpointValue (Value, Role), ActiveEndpoint),
            "initialise-future"
            ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
            "join-future"
            ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
            "settle-early"
            ':-> (EndpointValue (SignedMessage (Observation Value)),
                  ActiveEndpoint),
            "settle-future"
            ':-> (EndpointValue (SignedMessage (Observation Value)),
                  ActiveEndpoint)])
      FutureError
      (Either () ()))
-> ()
-> Contract
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     ()
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Either a b)) -> a -> m b
loopM (Contract
  ()
  ('R
     '[ "increase-margin"
        ':-> (EndpointValue (Value, Role), ActiveEndpoint),
        "initialise-future"
        ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
        "join-future"
        ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
        "settle-early"
        ':-> (EndpointValue (SignedMessage (Observation Value)),
              ActiveEndpoint),
        "settle-future"
        ':-> (EndpointValue (SignedMessage (Observation Value)),
              ActiveEndpoint)])
  FutureError
  (Either () ())
-> ()
-> Contract
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     (Either () ())
forall a b. a -> b -> a
const (Contract
   ()
   ('R
      '[ "increase-margin"
         ':-> (EndpointValue (Value, Role), ActiveEndpoint),
         "initialise-future"
         ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
         "join-future"
         ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
         "settle-early"
         ':-> (EndpointValue (SignedMessage (Observation Value)),
               ActiveEndpoint),
         "settle-future"
         ':-> (EndpointValue (SignedMessage (Observation Value)),
               ActiveEndpoint)])
   FutureError
   (Either () ())
 -> ()
 -> Contract
      ()
      ('R
         '[ "increase-margin"
            ':-> (EndpointValue (Value, Role), ActiveEndpoint),
            "initialise-future"
            ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
            "join-future"
            ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
            "settle-early"
            ':-> (EndpointValue (SignedMessage (Observation Value)),
                  ActiveEndpoint),
            "settle-future"
            ':-> (EndpointValue (SignedMessage (Observation Value)),
                  ActiveEndpoint)])
      FutureError
      (Either () ()))
-> (Promise
      ()
      ('R
         '[ "increase-margin"
            ':-> (EndpointValue (Value, Role), ActiveEndpoint),
            "initialise-future"
            ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
            "join-future"
            ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
            "settle-early"
            ':-> (EndpointValue (SignedMessage (Observation Value)),
                  ActiveEndpoint),
            "settle-future"
            ':-> (EndpointValue (SignedMessage (Observation Value)),
                  ActiveEndpoint)])
      FutureError
      (Either () ())
    -> Contract
         ()
         ('R
            '[ "increase-margin"
               ':-> (EndpointValue (Value, Role), ActiveEndpoint),
               "initialise-future"
               ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
               "join-future"
               ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
               "settle-early"
               ':-> (EndpointValue (SignedMessage (Observation Value)),
                     ActiveEndpoint),
               "settle-future"
               ':-> (EndpointValue (SignedMessage (Observation Value)),
                     ActiveEndpoint)])
         FutureError
         (Either () ()))
-> Promise
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     (Either () ())
-> ()
-> Contract
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     (Either () ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Promise
  ()
  ('R
     '[ "increase-margin"
        ':-> (EndpointValue (Value, Role), ActiveEndpoint),
        "initialise-future"
        ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
        "join-future"
        ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
        "settle-early"
        ':-> (EndpointValue (SignedMessage (Observation Value)),
              ActiveEndpoint),
        "settle-future"
        ':-> (EndpointValue (SignedMessage (Observation Value)),
              ActiveEndpoint)])
  FutureError
  (Either () ())
-> Contract
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     (Either () ())
forall w (s :: Row *) e a. Promise w s e a -> Contract w s e a
awaitPromise (Promise
   ()
   ('R
      '[ "increase-margin"
         ':-> (EndpointValue (Value, Role), ActiveEndpoint),
         "initialise-future"
         ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
         "join-future"
         ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
         "settle-early"
         ':-> (EndpointValue (SignedMessage (Observation Value)),
               ActiveEndpoint),
         "settle-future"
         ':-> (EndpointValue (SignedMessage (Observation Value)),
               ActiveEndpoint)])
   FutureError
   (Either () ())
 -> ()
 -> Contract
      ()
      ('R
         '[ "increase-margin"
            ':-> (EndpointValue (Value, Role), ActiveEndpoint),
            "initialise-future"
            ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
            "join-future"
            ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
            "settle-early"
            ':-> (EndpointValue (SignedMessage (Observation Value)),
                  ActiveEndpoint),
            "settle-future"
            ':-> (EndpointValue (SignedMessage (Observation Value)),
                  ActiveEndpoint)])
      FutureError
      (Either () ()))
-> Promise
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     (Either () ())
-> ()
-> Contract
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     (Either () ())
forall a b. (a -> b) -> a -> b
$ Promise
  ()
  ('R
     '[ "increase-margin"
        ':-> (EndpointValue (Value, Role), ActiveEndpoint),
        "initialise-future"
        ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
        "join-future"
        ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
        "settle-early"
        ':-> (EndpointValue (SignedMessage (Observation Value)),
              ActiveEndpoint),
        "settle-future"
        ':-> (EndpointValue (SignedMessage (Observation Value)),
              ActiveEndpoint)])
  FutureError
  ()
-> Promise
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     ()
-> Promise
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     (Either () ())
forall w (s :: Row *) e a b.
Promise w s e a -> Promise w s e b -> Promise w s e (Either a b)
selectEither (StateMachineClient FutureState FutureAction
-> Promise
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     ()
forall (s :: Row *) e w.
(HasEndpoint "increase-margin" (Value, Role) s,
 AsSMContractError e, AsContractError e) =>
StateMachineClient FutureState FutureAction -> Promise w s e ()
increaseMargin StateMachineClient FutureState FutureAction
client) (StateMachineClient FutureState FutureAction
-> Promise
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     ()
forall (s :: Row *) e w.
(HasEndpoint "settle-future" (SignedMessage (Observation Value)) s,
 AsFutureError e) =>
StateMachineClient FutureState FutureAction -> Promise w s e ()
settleFuture StateMachineClient FutureState FutureAction
client Promise
  ()
  ('R
     '[ "increase-margin"
        ':-> (EndpointValue (Value, Role), ActiveEndpoint),
        "initialise-future"
        ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
        "join-future"
        ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
        "settle-early"
        ':-> (EndpointValue (SignedMessage (Observation Value)),
              ActiveEndpoint),
        "settle-future"
        ':-> (EndpointValue (SignedMessage (Observation Value)),
              ActiveEndpoint)])
  FutureError
  ()
-> Promise
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     ()
-> Promise
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     ()
forall w (s :: Row *) e a.
Promise w s e a -> Promise w s e a -> Promise w s e a
`select` StateMachineClient FutureState FutureAction
-> Promise
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     ()
forall (s :: Row *) e w.
(HasEndpoint "settle-early" (SignedMessage (Observation Value)) s,
 AsSMContractError e, AsContractError e) =>
StateMachineClient FutureState FutureAction -> Promise w s e ()
settleEarly StateMachineClient FutureState FutureAction
client)) ()

-- | The data needed to initialise the futures contract.
data FutureSetup =
    FutureSetup
        { FutureSetup -> PaymentPubKeyHash
shortPK       :: PaymentPubKeyHash
        -- ^ Initial owner of the short token
        , FutureSetup -> PaymentPubKeyHash
longPK        :: PaymentPubKeyHash
        -- ^ Initial owner of the long token
        , FutureSetup -> POSIXTime
contractStart :: POSIXTime
        -- ^ Start of the futures contract itself. By this time the setup code
        --   has to be finished, otherwise the contract is void.
        } deriving stock (Int -> FutureSetup -> ShowS
[FutureSetup] -> ShowS
FutureSetup -> String
(Int -> FutureSetup -> ShowS)
-> (FutureSetup -> String)
-> ([FutureSetup] -> ShowS)
-> Show FutureSetup
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FutureSetup] -> ShowS
$cshowList :: [FutureSetup] -> ShowS
show :: FutureSetup -> String
$cshow :: FutureSetup -> String
showsPrec :: Int -> FutureSetup -> ShowS
$cshowsPrec :: Int -> FutureSetup -> ShowS
Haskell.Show, (forall x. FutureSetup -> Rep FutureSetup x)
-> (forall x. Rep FutureSetup x -> FutureSetup)
-> Generic FutureSetup
forall x. Rep FutureSetup x -> FutureSetup
forall x. FutureSetup -> Rep FutureSetup x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FutureSetup x -> FutureSetup
$cfrom :: forall x. FutureSetup -> Rep FutureSetup x
Generic)
          deriving anyclass ([FutureSetup] -> Encoding
[FutureSetup] -> Value
FutureSetup -> Encoding
FutureSetup -> Value
(FutureSetup -> Value)
-> (FutureSetup -> Encoding)
-> ([FutureSetup] -> Value)
-> ([FutureSetup] -> Encoding)
-> ToJSON FutureSetup
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [FutureSetup] -> Encoding
$ctoEncodingList :: [FutureSetup] -> Encoding
toJSONList :: [FutureSetup] -> Value
$ctoJSONList :: [FutureSetup] -> Value
toEncoding :: FutureSetup -> Encoding
$ctoEncoding :: FutureSetup -> Encoding
toJSON :: FutureSetup -> Value
$ctoJSON :: FutureSetup -> Value
ToJSON, Value -> Parser [FutureSetup]
Value -> Parser FutureSetup
(Value -> Parser FutureSetup)
-> (Value -> Parser [FutureSetup]) -> FromJSON FutureSetup
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [FutureSetup]
$cparseJSONList :: Value -> Parser [FutureSetup]
parseJSON :: Value -> Parser FutureSetup
$cparseJSON :: Value -> Parser FutureSetup
FromJSON)

{- note [Futures in Plutus]

A futures contract ("future") is an agreement to change ownership of an
asset at a certain time (the delivery time) for an agreed price (the forward
price). The time of the transfer, and the price, are fixed at the beginning of
the contract.

A future can be settled either by actually exchanging the asset for the price
(physical settlement) or by exchanging the difference between the forward price
and the spot (current) price.

In Plutus we could do physical settlement for assets that exist on the
blockchain, that is, for tokens and currencies (everything that's a 'Value'). But
the contract implemented here is for cash settlement.

The agreement involves two parties, a buyer (long position) and a seller (short
position). At the delivery time the actual price of the asset (spot price) is
quite likely different from the forward price. If the spot price is higher than
the forward price, then the seller transfers the difference to the buyer. If
the spot price is lower than the forward price, then the buyer transfers money
to the seller. In either case there is a risk that the payer does not meet their
obligation (by simply not paying). To protect against this risk, the contract
includes a kind of deposit called "margin".

Each party deposits an initial margin. If the price moves against the seller,
then the seller has to top up their margin periodically (in our case, once each
block). Likewise, if it moves against the buyer then the buyer has to top up
their margin. If either party fails to make a margin payment then the contract
will be settled early.

The current value of the underlying asset is determined by an oracle. See note
[Oracles] in Plutus.Contracts. Also note that we
wouldn't need oracles if this was a contract with physical settlement,

The contract has three phases: Initialisation, runtime, and settlement. In the
first phase both parties deposit their initial margins into an escrow contract.
The second phase is when the contract is "live". In this phase the contract
is a state machine whose state is the 'MarginnAccounts' with the current margins.
The transition from the second to the third phase happens either after the
settlement date, or if the sport price has moved so far that one of the margin
accounts is underfunded. The runtime and settlement phases are modeled as a state
machine, with 'FutureState' and 'FutureAction' types.

-}


mkAccounts
    :: Account
    -> Account
    -> FutureAccounts
mkAccounts :: Account -> Account -> FutureAccounts
mkAccounts Account
long Account
short =
    FutureAccounts :: Account
-> ValidatorHash -> Account -> ValidatorHash -> FutureAccounts
FutureAccounts
        { ftoLong :: Account
ftoLong = Account
long
        , ftoLongAccount :: ValidatorHash
ftoLongAccount = Account -> ValidatorHash
TokenAccount.validatorHash Account
long
        , ftoShort :: Account
ftoShort = Account
short
        , ftoShortAccount :: ValidatorHash
ftoShortAccount = Account -> ValidatorHash
TokenAccount.validatorHash Account
short
        }

{-# INLINABLE tokenFor #-}
tokenFor :: Role -> FutureAccounts -> Value
tokenFor :: Role -> FutureAccounts -> Value
tokenFor = \case
    Role
Long  -> \case FutureAccounts{ftoLong :: FutureAccounts -> Account
ftoLong=Account AssetClass
cur} -> AssetClass -> Integer -> Value
Value.assetClassValue AssetClass
cur Integer
1
    Role
Short -> \case FutureAccounts{ftoShort :: FutureAccounts -> Account
ftoShort=Account AssetClass
cur} -> AssetClass -> Integer -> Value
Value.assetClassValue AssetClass
cur Integer
1

{-# INLINABLE adjustMargin #-}
-- | Change the margin account of the role by the given amount.
adjustMargin :: Role -> Value -> Margins -> Margins
adjustMargin :: Role -> Value -> Margins -> Margins
adjustMargin Role
role Value
value Margins
accounts =
    case Role
role of
        Role
Long  -> Margins
accounts { ftsLongMargin :: Value
ftsLongMargin = Margins -> Value
ftsLongMargin Margins
accounts Value -> Value -> Value
forall a. AdditiveSemigroup a => a -> a -> a
+ Value
value }
        Role
Short -> Margins
accounts { ftsShortMargin :: Value
ftsShortMargin = Margins -> Value
ftsShortMargin Margins
accounts Value -> Value -> Value
forall a. AdditiveSemigroup a => a -> a -> a
+ Value
value }

{-# INLINABLE totalMargin #-}
-- | The combined value of both margin accounts.
totalMargin :: Margins -> Value
totalMargin :: Margins -> Value
totalMargin Margins{Value
ftsShortMargin :: Value
ftsShortMargin :: Margins -> Value
ftsShortMargin, Value
ftsLongMargin :: Value
ftsLongMargin :: Margins -> Value
ftsLongMargin} =
    Value
ftsShortMargin Value -> Value -> Value
forall a. AdditiveSemigroup a => a -> a -> a
+ Value
ftsLongMargin

{-# INLINABLE futureStateMachine #-}
futureStateMachine
    :: Future
    -> FutureAccounts
    -> StateMachine FutureState FutureAction
futureStateMachine :: Future -> FutureAccounts -> StateMachine FutureState FutureAction
futureStateMachine Future
ft FutureAccounts
fos = Maybe ThreadToken
-> (State FutureState
    -> FutureAction
    -> Maybe (TxConstraints Void Void, State FutureState))
-> (FutureState -> Bool)
-> StateMachine FutureState FutureAction
forall s i.
Maybe ThreadToken
-> (State s -> i -> Maybe (TxConstraints Void Void, State s))
-> (s -> Bool)
-> StateMachine s i
SM.mkStateMachine Maybe ThreadToken
forall a. Maybe a
Nothing (Future
-> FutureAccounts
-> State FutureState
-> FutureAction
-> Maybe (TxConstraints Void Void, State FutureState)
transition Future
ft FutureAccounts
fos) FutureState -> Bool
isFinal where
    isFinal :: FutureState -> Bool
isFinal FutureState
Finished = Bool
True
    isFinal FutureState
_        = Bool
False

typedValidator :: Future -> FutureAccounts -> V2.TypedValidator (SM.StateMachine FutureState FutureAction)
typedValidator :: Future
-> FutureAccounts
-> TypedValidator (StateMachine FutureState FutureAction)
typedValidator Future
future FutureAccounts
ftos =
    let val :: CompiledCodeIn
  DefaultUni
  DefaultFun
  (FutureState -> FutureAction -> ScriptContext -> Bool)
val = $$(PlutusTx.compile [|| validatorParam ||])
            CompiledCode
  (Future
   -> FutureAccounts
   -> FutureState
   -> FutureAction
   -> ScriptContext
   -> Bool)
-> CompiledCodeIn DefaultUni DefaultFun Future
-> CompiledCodeIn
     DefaultUni
     DefaultFun
     (FutureAccounts
      -> FutureState -> FutureAction -> 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`
                Future -> CompiledCodeIn DefaultUni DefaultFun Future
forall (uni :: * -> *) a fun.
(Lift uni a, Throwable uni fun, Typecheckable uni fun) =>
a -> CompiledCodeIn uni fun a
PlutusTx.liftCode Future
future
                CompiledCodeIn
  DefaultUni
  DefaultFun
  (FutureAccounts
   -> FutureState -> FutureAction -> ScriptContext -> Bool)
-> CompiledCodeIn DefaultUni DefaultFun FutureAccounts
-> CompiledCodeIn
     DefaultUni
     DefaultFun
     (FutureState -> FutureAction -> 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`
                    FutureAccounts
-> CompiledCodeIn DefaultUni DefaultFun FutureAccounts
forall (uni :: * -> *) a fun.
(Lift uni a, Throwable uni fun, Typecheckable uni fun) =>
a -> CompiledCodeIn uni fun a
PlutusTx.liftCode FutureAccounts
ftos
        validatorParam :: Future
-> FutureAccounts
-> ValidatorType (StateMachine FutureState FutureAction)
validatorParam Future
f FutureAccounts
g = StateMachine FutureState FutureAction
-> ValidatorType (StateMachine FutureState FutureAction)
forall s i.
ToData s =>
StateMachine s i -> ValidatorType (StateMachine s i)
SM.mkValidator (Future -> FutureAccounts -> StateMachine FutureState FutureAction
futureStateMachine Future
f FutureAccounts
g)
        wrap :: (FutureState -> FutureAction -> ScriptContext -> Bool)
-> UntypedValidator
wrap = (UnsafeFromData FutureState, UnsafeFromData FutureAction) =>
(FutureState -> FutureAction -> ScriptContext -> Bool)
-> UntypedValidator
forall sc d r.
(IsScriptContext sc, UnsafeFromData d, UnsafeFromData r) =>
(d -> r -> sc -> Bool) -> UntypedValidator
Scripts.mkUntypedValidator @Scripts.ScriptContextV2 @FutureState @FutureAction

    in CompiledCode
  (ValidatorType (StateMachine FutureState FutureAction))
-> CompiledCode
     (ValidatorType (StateMachine FutureState FutureAction)
      -> UntypedValidator)
-> TypedValidator (StateMachine FutureState FutureAction)
forall a.
CompiledCode (ValidatorType a)
-> CompiledCode (ValidatorType a -> UntypedValidator)
-> TypedValidator a
V2.mkTypedValidator @(SM.StateMachine FutureState FutureAction)
        CompiledCode
  (ValidatorType (StateMachine FutureState FutureAction))
CompiledCodeIn
  DefaultUni
  DefaultFun
  (FutureState -> FutureAction -> ScriptContext -> Bool)
val
        $$(PlutusTx.compile [|| wrap ||])

machineClient
    :: Scripts.TypedValidator (SM.StateMachine FutureState FutureAction)
    -> Future
    -> FutureAccounts
    -> SM.StateMachineClient FutureState FutureAction
machineClient :: TypedValidator (StateMachine FutureState FutureAction)
-> Future
-> FutureAccounts
-> StateMachineClient FutureState FutureAction
machineClient TypedValidator (StateMachine FutureState FutureAction)
inst Future
future FutureAccounts
ftos =
    let machine :: StateMachine FutureState FutureAction
machine = Future -> FutureAccounts -> StateMachine FutureState FutureAction
futureStateMachine Future
future FutureAccounts
ftos
    in StateMachineInstance FutureState FutureAction
-> StateMachineClient FutureState FutureAction
forall state input.
StateMachineInstance state input -> StateMachineClient state input
SM.mkStateMachineClient (StateMachine FutureState FutureAction
-> TypedValidator (StateMachine FutureState FutureAction)
-> StateMachineInstance FutureState FutureAction
forall s i.
StateMachine s i
-> TypedValidator (StateMachine s i) -> StateMachineInstance s i
SM.StateMachineInstance StateMachine FutureState FutureAction
machine TypedValidator (StateMachine FutureState FutureAction)
inst)

validator :: Future -> FutureAccounts -> Validator
validator :: Future -> FutureAccounts -> Validator
validator Future
ft FutureAccounts
fos = TypedValidator (StateMachine FutureState FutureAction) -> Validator
forall a. TypedValidator a -> Validator
Scripts.validatorScript (Future
-> FutureAccounts
-> TypedValidator (StateMachine FutureState FutureAction)
typedValidator Future
ft FutureAccounts
fos)

{-# INLINABLE verifyOracle #-}
verifyOracle :: PlutusTx.FromData a => PaymentPubKey -> SignedMessage a -> Maybe (a, TxConstraints Void Void)
verifyOracle :: PaymentPubKey
-> SignedMessage a -> Maybe (a, TxConstraints Void Void)
verifyOracle PaymentPubKey
pubKey SignedMessage a
sm =
    (SignedMessageCheckError -> Maybe (a, TxConstraints Void Void))
-> ((a, TxConstraints Void Void)
    -> Maybe (a, TxConstraints Void Void))
-> Either SignedMessageCheckError (a, TxConstraints Void Void)
-> Maybe (a, TxConstraints Void Void)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe (a, TxConstraints Void Void)
-> SignedMessageCheckError -> Maybe (a, TxConstraints Void Void)
forall a b. a -> b -> a
const Maybe (a, TxConstraints Void Void)
forall a. Maybe a
Nothing) (a, TxConstraints Void Void) -> Maybe (a, TxConstraints Void Void)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Either SignedMessageCheckError (a, TxConstraints Void Void)
 -> Maybe (a, TxConstraints Void Void))
-> Either SignedMessageCheckError (a, TxConstraints Void Void)
-> Maybe (a, TxConstraints Void Void)
forall a b. (a -> b) -> a -> b
$ PaymentPubKey
-> SignedMessage a
-> Either SignedMessageCheckError (a, TxConstraints Void Void)
forall a i o.
FromData a =>
PaymentPubKey
-> SignedMessage a
-> Either SignedMessageCheckError (a, TxConstraints i o)
Oracle.verifySignedMessageConstraints PaymentPubKey
pubKey SignedMessage a
sm

verifyOracleOffChain :: PlutusTx.FromData a => Future -> SignedMessage (Observation a) -> Maybe (POSIXTime, a)
verifyOracleOffChain :: Future -> SignedMessage (Observation a) -> Maybe (POSIXTime, a)
verifyOracleOffChain Future{PaymentPubKey
ftPriceOracle :: PaymentPubKey
ftPriceOracle :: Future -> PaymentPubKey
ftPriceOracle} SignedMessage (Observation a)
sm =
    case PaymentPubKey
-> SignedMessage (Observation a)
-> Either SignedMessageCheckError (Observation a)
forall a.
FromData a =>
PaymentPubKey
-> SignedMessage a -> Either SignedMessageCheckError a
Oracle.verifySignedMessageOffChain PaymentPubKey
ftPriceOracle SignedMessage (Observation a)
sm of
        Left SignedMessageCheckError
_                               -> Maybe (POSIXTime, a)
forall a. Maybe a
Nothing
        Right Observation{a
obsValue :: forall a. Observation a -> a
obsValue :: a
obsValue, POSIXTime
obsTime :: forall a. Observation a -> POSIXTime
obsTime :: POSIXTime
obsTime} -> (POSIXTime, a) -> Maybe (POSIXTime, a)
forall a. a -> Maybe a
Just (POSIXTime
obsTime, a
obsValue)

{-# INLINABLE transition #-}
transition :: Future -> FutureAccounts -> State FutureState -> FutureAction -> Maybe (TxConstraints Void Void, State FutureState)
transition :: Future
-> FutureAccounts
-> State FutureState
-> FutureAction
-> Maybe (TxConstraints Void Void, State FutureState)
transition future :: Future
future@Future{POSIXTime
ftDeliveryDate :: POSIXTime
ftDeliveryDate :: Future -> POSIXTime
ftDeliveryDate, PaymentPubKey
ftPriceOracle :: PaymentPubKey
ftPriceOracle :: Future -> PaymentPubKey
ftPriceOracle} FutureAccounts
owners State{stateData :: forall s. State s -> s
stateData=FutureState
s, stateValue :: forall s. State s -> Value
stateValue=Value
currentValue} FutureAction
i =
    case (FutureState
s, FutureAction
i) of
        (Running Margins
accounts, AdjustMargin Role
role Value
topUp) ->
            (TxConstraints Void Void, State FutureState)
-> Maybe (TxConstraints Void Void, State FutureState)
forall a. a -> Maybe a
Just ( TxConstraints Void Void
forall a. Monoid a => a
mempty
                    , State :: forall s. s -> Value -> State s
State
                    { stateData :: FutureState
stateData = Margins -> FutureState
Running (Role -> Value -> Margins -> Margins
adjustMargin Role
role Value
topUp Margins
accounts)
                    , stateValue :: Value
stateValue = Value
topUp Value -> Value -> Value
forall a. AdditiveSemigroup a => a -> a -> a
+ Margins -> Value
totalMargin Margins
accounts
                    }
                    )
        (Running Margins
accounts, Settle SignedMessage (Observation Value)
ov)
            | Just (Observation{obsValue :: forall a. Observation a -> a
obsValue=Value
spotPrice, obsTime :: forall a. Observation a -> POSIXTime
obsTime=POSIXTime
oracleDate}, TxConstraints Void Void
oracleConstraints) <- PaymentPubKey
-> SignedMessage (Observation Value)
-> Maybe (Observation Value, TxConstraints Void Void)
forall a.
FromData a =>
PaymentPubKey
-> SignedMessage a -> Maybe (a, TxConstraints Void Void)
verifyOracle PaymentPubKey
ftPriceOracle SignedMessage (Observation Value)
ov, POSIXTime
ftDeliveryDate POSIXTime -> POSIXTime -> Bool
forall a. Eq a => a -> a -> Bool
== POSIXTime
oracleDate ->
                let payment :: Payouts
payment = Future -> Margins -> Value -> Payouts
payouts Future
future Margins
accounts Value
spotPrice
                    constraints :: TxConstraints Void Void
constraints =
                        ValidityInterval POSIXTime -> TxConstraints Void Void
forall i o. ValidityInterval POSIXTime -> TxConstraints i o
Constraints.mustValidateInTimeRange (POSIXTime -> ValidityInterval POSIXTime
forall a. a -> ValidityInterval a
Interval.from POSIXTime
ftDeliveryDate)
                        TxConstraints Void Void
-> TxConstraints Void Void -> TxConstraints Void Void
forall a. Semigroup a => a -> a -> a
<> TxConstraints Void Void
oracleConstraints
                        TxConstraints Void Void
-> TxConstraints Void Void -> TxConstraints Void Void
forall a. Semigroup a => a -> a -> a
<> Payouts -> FutureAccounts -> TxConstraints Void Void
payoutsTx Payouts
payment FutureAccounts
owners
                in (TxConstraints Void Void, State FutureState)
-> Maybe (TxConstraints Void Void, State FutureState)
forall a. a -> Maybe a
Just ( TxConstraints Void Void
constraints
                        , State :: forall s. s -> Value -> State s
State
                            { stateData :: FutureState
stateData = FutureState
Finished
                            , stateValue :: Value
stateValue = Value
forall a. Monoid a => a
mempty
                            }
                        )
        (Running Margins
accounts, SettleEarly SignedMessage (Observation Value)
ov)
            | Just (Observation{obsValue :: forall a. Observation a -> a
obsValue=Value
spotPrice, obsTime :: forall a. Observation a -> POSIXTime
obsTime=POSIXTime
oracleDate}, TxConstraints Void Void
oracleConstraints) <- PaymentPubKey
-> SignedMessage (Observation Value)
-> Maybe (Observation Value, TxConstraints Void Void)
forall a.
FromData a =>
PaymentPubKey
-> SignedMessage a -> Maybe (a, TxConstraints Void Void)
verifyOracle PaymentPubKey
ftPriceOracle SignedMessage (Observation Value)
ov, Just Role
vRole <- Future -> Margins -> Value -> Maybe Role
violatingRole Future
future Margins
accounts Value
spotPrice, POSIXTime
ftDeliveryDate POSIXTime -> POSIXTime -> Bool
forall a. Ord a => a -> a -> Bool
> POSIXTime
oracleDate ->
                let
                    total :: Value
total = Margins -> Value
totalMargin Margins
accounts
                    FutureAccounts{ValidatorHash
ftoLongAccount :: ValidatorHash
ftoLongAccount :: FutureAccounts -> ValidatorHash
ftoLongAccount, ValidatorHash
ftoShortAccount :: ValidatorHash
ftoShortAccount :: FutureAccounts -> ValidatorHash
ftoShortAccount} = FutureAccounts
owners
                    payment :: TxConstraints Void Void
payment =
                        case Role
vRole of
                          Role
Short -> ValidatorHash -> Datum -> Value -> TxConstraints Void Void
forall i o. ValidatorHash -> Datum -> Value -> TxConstraints i o
Constraints.mustPayToOtherScriptWithDatumInTx ValidatorHash
ftoLongAccount Datum
unitDatum Value
total
                                TxConstraints Void Void
-> TxConstraints Void Void -> TxConstraints Void Void
forall a. Semigroup a => a -> a -> a
<> Datum -> TxConstraints Void Void
forall i o. Datum -> TxConstraints i o
Constraints.mustIncludeDatumInTx Datum
unitDatum
                          Role
Long  -> ValidatorHash -> Datum -> Value -> TxConstraints Void Void
forall i o. ValidatorHash -> Datum -> Value -> TxConstraints i o
Constraints.mustPayToOtherScriptWithDatumInTx ValidatorHash
ftoShortAccount Datum
unitDatum Value
total
                                TxConstraints Void Void
-> TxConstraints Void Void -> TxConstraints Void Void
forall a. Semigroup a => a -> a -> a
<> Datum -> TxConstraints Void Void
forall i o. Datum -> TxConstraints i o
Constraints.mustIncludeDatumInTx Datum
unitDatum
                    constraints :: TxConstraints Void Void
constraints = TxConstraints Void Void
payment TxConstraints Void Void
-> TxConstraints Void Void -> TxConstraints Void Void
forall a. Semigroup a => a -> a -> a
<> TxConstraints Void Void
oracleConstraints
                in (TxConstraints Void Void, State FutureState)
-> Maybe (TxConstraints Void Void, State FutureState)
forall a. a -> Maybe a
Just ( TxConstraints Void Void
constraints
                        , State :: forall s. s -> Value -> State s
State
                            { stateData :: FutureState
stateData = FutureState
Finished
                            , stateValue :: Value
stateValue = Value
forall a. Monoid a => a
mempty
                            }
                        )
        (FutureState, FutureAction)
_ -> Maybe (TxConstraints Void Void, State FutureState)
forall a. Maybe a
Nothing

data Payouts =
    Payouts
        { Payouts -> Value
payoutsShort :: Value
        , Payouts -> Value
payoutsLong  :: Value
        }

{-# INLINABLE payoutsTx #-}
payoutsTx
    :: Payouts
    -> FutureAccounts
    -> TxConstraints Void Void
payoutsTx :: Payouts -> FutureAccounts -> TxConstraints Void Void
payoutsTx
    Payouts{Value
payoutsShort :: Value
payoutsShort :: Payouts -> Value
payoutsShort, Value
payoutsLong :: Value
payoutsLong :: Payouts -> Value
payoutsLong}
    FutureAccounts{ValidatorHash
ftoLongAccount :: ValidatorHash
ftoLongAccount :: FutureAccounts -> ValidatorHash
ftoLongAccount, ValidatorHash
ftoShortAccount :: ValidatorHash
ftoShortAccount :: FutureAccounts -> ValidatorHash
ftoShortAccount} =
        ValidatorHash -> Datum -> Value -> TxConstraints Void Void
forall i o. ValidatorHash -> Datum -> Value -> TxConstraints i o
Constraints.mustPayToOtherScriptWithDatumInTx ValidatorHash
ftoLongAccount Datum
unitDatum Value
payoutsLong
        TxConstraints Void Void
-> TxConstraints Void Void -> TxConstraints Void Void
forall a. Semigroup a => a -> a -> a
<> ValidatorHash -> Datum -> Value -> TxConstraints Void Void
forall i o. ValidatorHash -> Datum -> Value -> TxConstraints i o
Constraints.mustPayToOtherScriptWithDatumInTx ValidatorHash
ftoShortAccount Datum
unitDatum Value
payoutsShort
        TxConstraints Void Void
-> TxConstraints Void Void -> TxConstraints Void Void
forall a. Semigroup a => a -> a -> a
<> Datum -> TxConstraints Void Void
forall i o. Datum -> TxConstraints i o
Constraints.mustIncludeDatumInTx Datum
unitDatum

{-# INLINABLE payouts #-}
-- | Compute the payouts for each role given the future data,
--   margin accounts, and current (spot) price
payouts :: Future -> Margins -> Value -> Payouts
payouts :: Future -> Margins -> Value -> Payouts
payouts Future{Integer
ftUnits :: Integer
ftUnits :: Future -> Integer
ftUnits, Value
ftUnitPrice :: Value
ftUnitPrice :: Future -> Value
ftUnitPrice} Margins{Value
ftsShortMargin :: Value
ftsShortMargin :: Margins -> Value
ftsShortMargin, Value
ftsLongMargin :: Value
ftsLongMargin :: Margins -> Value
ftsLongMargin} Value
spotPrice =
    let delta :: Value
delta = Integer -> Value -> Value
forall s v. Module s v => s -> v -> v
scale Integer
ftUnits (Value
spotPrice Value -> Value -> Value
forall a. AdditiveGroup a => a -> a -> a
- Value
ftUnitPrice)
    in Payouts :: Value -> Value -> Payouts
Payouts
        { payoutsShort :: Value
payoutsShort = Value
ftsShortMargin Value -> Value -> Value
forall a. AdditiveGroup a => a -> a -> a
- Value
delta
        , payoutsLong :: Value
payoutsLong  = Value
ftsLongMargin Value -> Value -> Value
forall a. AdditiveSemigroup a => a -> a -> a
+ Value
delta
        }

-- | Compute the required margin from the current price of the
--   underlying asset.
{-# INLINABLE requiredMargin #-}
requiredMargin :: Future -> Value -> Value
requiredMargin :: Future -> Value -> Value
requiredMargin Future{Integer
ftUnits :: Integer
ftUnits :: Future -> Integer
ftUnits, Value
ftUnitPrice :: Value
ftUnitPrice :: Future -> Value
ftUnitPrice, Value
ftMarginPenalty :: Value
ftMarginPenalty :: Future -> Value
ftMarginPenalty} Value
spotPrice =
    let
        delta :: Value
delta  = Integer -> Value -> Value
forall s v. Module s v => s -> v -> v
scale Integer
ftUnits (Value
spotPrice Value -> Value -> Value
forall a. AdditiveGroup a => a -> a -> a
- Value
ftUnitPrice)
    in
        Value
ftMarginPenalty Value -> Value -> Value
forall a. AdditiveSemigroup a => a -> a -> a
+ Value
delta

{-# INLINABLE initialMargin #-}
initialMargin :: Future -> Value
initialMargin :: Future -> Value
initialMargin ft :: Future
ft@Future{Value
ftUnitPrice :: Value
ftUnitPrice :: Future -> Value
ftUnitPrice, Value
ftMarginPenalty :: Value
ftMarginPenalty :: Future -> Value
ftMarginPenalty} =
    Value
ftMarginPenalty Value -> Value -> Value
forall a. AdditiveSemigroup a => a -> a -> a
+ Value
ftUnitPrice

{-# INLINABLE initialState #-}
-- | The initial state of the 'Future' contract
initialState :: Future -> FutureState
initialState :: Future -> FutureState
initialState Future
ft =
    let im :: Value
im = Future -> Value
initialMargin Future
ft in
    Margins -> FutureState
Running (Margins :: Value -> Value -> Margins
Margins{ftsShortMargin :: Value
ftsShortMargin=Value
im, ftsLongMargin :: Value
ftsLongMargin=Value
im})

futureAddress :: Future -> FutureAccounts -> Address
futureAddress :: Future -> FutureAccounts -> Address
futureAddress Future
ft FutureAccounts
fo = Validator -> Address
mkValidatorAddress (Future -> FutureAccounts -> Validator
validator Future
ft FutureAccounts
fo)

{-# INLINABLE violatingRole #-}
-- | The role that violated its margin requirements
violatingRole :: Future -> Margins -> Value -> Maybe Role
violatingRole :: Future -> Margins -> Value -> Maybe Role
violatingRole Future
future Margins
margins Value
spotPrice =
    let
        minMargin :: Value
minMargin = Future -> Value -> Value
requiredMargin Future
future Value
spotPrice
        Margins{Value
ftsShortMargin :: Value
ftsShortMargin :: Margins -> Value
ftsShortMargin, Value
ftsLongMargin :: Value
ftsLongMargin :: Margins -> Value
ftsLongMargin} = Margins
margins
    in
    if Value
ftsShortMargin Value -> Value -> Bool
`lt` Value
minMargin then Role -> Maybe Role
forall a. a -> Maybe a
Just Role
Short
    else if Value
ftsLongMargin Value -> Value -> Bool
`lt` Value
minMargin then Role -> Maybe Role
forall a. a -> Maybe a
Just Role
Long
    else Maybe Role
forall a. Maybe a
Nothing

-- | Initialise the contract by
--   * Generating the tokens for long and short
--   * Setting up an escrow contract for the initial margins
--   * Paying the initial margin for the given role
initialiseFuture
    :: ( HasEndpoint "initialise-future" (FutureSetup, Role) s
       , AsFutureError e
       )
    => Future
    -> Promise w s e (SM.StateMachineClient FutureState FutureAction)
initialiseFuture :: Future
-> Promise w s e (StateMachineClient FutureState FutureAction)
initialiseFuture Future
future = (Contract
   w s FutureError (StateMachineClient FutureState FutureAction)
 -> Contract w s e (StateMachineClient FutureState FutureAction))
-> Promise
     w s FutureError (StateMachineClient FutureState FutureAction)
-> Promise w s e (StateMachineClient FutureState FutureAction)
forall w1 (s1 :: Row *) e1 a1 w2 (s2 :: Row *) e2 a2.
(Contract w1 s1 e1 a1 -> Contract w2 s2 e2 a2)
-> Promise w1 s1 e1 a1 -> Promise w2 s2 e2 a2
promiseMap ((FutureError -> e)
-> Contract
     w s FutureError (StateMachineClient FutureState FutureAction)
-> Contract w s e (StateMachineClient FutureState FutureAction)
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError (AReview e FutureError -> FutureError -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e FutureError
forall r. AsFutureError r => Prism' r FutureError
_FutureError)) (Promise
   w s FutureError (StateMachineClient FutureState FutureAction)
 -> Promise w s e (StateMachineClient FutureState FutureAction))
-> Promise
     w s FutureError (StateMachineClient FutureState FutureAction)
-> Promise w s e (StateMachineClient FutureState FutureAction)
forall a b. (a -> b) -> a -> b
$ forall w (s :: Row *) e b.
(HasEndpoint "initialise-future" (FutureSetup, Role) s,
 AsContractError e, FromJSON (FutureSetup, Role)) =>
((FutureSetup, Role) -> 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 @"initialise-future" @(FutureSetup, Role) (((FutureSetup, Role)
  -> Contract
       w s FutureError (StateMachineClient FutureState FutureAction))
 -> Promise
      w s FutureError (StateMachineClient FutureState FutureAction))
-> ((FutureSetup, Role)
    -> Contract
         w s FutureError (StateMachineClient FutureState FutureAction))
-> Promise
     w s FutureError (StateMachineClient FutureState FutureAction)
forall a b. (a -> b) -> a -> b
$ \(FutureSetup
s, Role
ownRole) -> do
    -- Start by setting up the two tokens for the short and long positions.
    FutureAccounts
ftos <- Contract w s FutureError FutureAccounts
forall w (s :: Row *) e.
AsFutureError e =>
Contract w s e FutureAccounts
setupTokens

    -- Now we have a 'FutureAccountsValue' with the data of two new and unique
    -- tokens that we will use for the future contract. Now we use an escrow
    --  contract to initialise the future contract.

    TypedValidator (StateMachine FutureState FutureAction)
inst <- Contract
  w
  s
  FutureError
  (TypedValidator (StateMachine FutureState FutureAction))
-> Contract
     w
     s
     FutureError
     (TypedValidator (StateMachine FutureState FutureAction))
forall w (s :: Row *) e a.
(AsCheckpointError e, FromJSON a, ToJSON a) =>
Contract w s e a -> Contract w s e a
checkpoint (Contract
   w
   s
   FutureError
   (TypedValidator (StateMachine FutureState FutureAction))
 -> Contract
      w
      s
      FutureError
      (TypedValidator (StateMachine FutureState FutureAction)))
-> Contract
     w
     s
     FutureError
     (TypedValidator (StateMachine FutureState FutureAction))
-> Contract
     w
     s
     FutureError
     (TypedValidator (StateMachine FutureState FutureAction))
forall a b. (a -> b) -> a -> b
$ TypedValidator (StateMachine FutureState FutureAction)
-> Contract
     w
     s
     FutureError
     (TypedValidator (StateMachine FutureState FutureAction))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Future
-> FutureAccounts
-> TypedValidator (StateMachine FutureState FutureAction)
typedValidator Future
future FutureAccounts
ftos)

    let
        client :: StateMachineClient FutureState FutureAction
client = TypedValidator (StateMachine FutureState FutureAction)
-> Future
-> FutureAccounts
-> StateMachineClient FutureState FutureAction
machineClient TypedValidator (StateMachine FutureState FutureAction)
inst Future
future FutureAccounts
ftos

        -- The escrow parameters 'esc' ensure that the initial margin is paid
        -- to the future contract address, and the two tokens are transferred
        -- to their initial owners.
        escr :: EscrowParams Datum
escr = StateMachineClient FutureState FutureAction
-> Future -> FutureAccounts -> FutureSetup -> EscrowParams Datum
escrowParams StateMachineClient FutureState FutureAction
client Future
future FutureAccounts
ftos FutureSetup
s

        -- For the escrow to go through, both tokens and 2x the initial margin
        -- have to be deposited at the escrow address before the deadline
        -- (start of the future contract). Since we are currently in possession
        -- of both tokens, we pay the two tokens and our own initial margin to
        -- the escrow.
        payment :: Value
payment =
            Future -> Value
initialMargin Future
future Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Role -> FutureAccounts -> Value
tokenFor Role
Long FutureAccounts
ftos Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Role -> FutureAccounts -> Value
tokenFor Role
Short FutureAccounts
ftos

        -- By using 'Escrow.payRedeemRefund' we make our payment and wait for
        -- the other party to make theirs. If they fail to do so within the
        -- agreed timeframe, our own initial margin is refunded and the future
        -- contract never starts.
        escrowPayment :: Contract w s EscrowError (Either RefundSuccess RedeemSuccess)
escrowPayment = EscrowParams Datum
-> Value
-> Contract w s EscrowError (Either RefundSuccess RedeemSuccess)
forall w (s :: Row *).
EscrowParams Datum
-> Value
-> Contract w s EscrowError (Either RefundSuccess RedeemSuccess)
Escrow.payRedeemRefund EscrowParams Datum
escr Value
payment

    -- Run 'escrowPayment', wrapping any errors in 'EscrowFailed'. If the escrow
    -- contract ended with a refund (ie., 'escrowPayment' returns a 'Left') we
    -- throw an 'EscrowRefunded' error. If the escrow contract succeeded, the
    -- future is initialised and ready to go, so we return the 'FutureAccounts'
    -- with the token information.
    Either RefundSuccess RedeemSuccess
e <- (EscrowError -> FutureError)
-> Contract w s EscrowError (Either RefundSuccess RedeemSuccess)
-> Contract w s FutureError (Either RefundSuccess RedeemSuccess)
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError (AReview FutureError EscrowError -> EscrowError -> FutureError
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview FutureError EscrowError
forall r. AsFutureError r => Prism' r EscrowError
_EscrowFailed) Contract w s EscrowError (Either RefundSuccess RedeemSuccess)
escrowPayment
    (RefundSuccess
 -> Contract
      w s FutureError (StateMachineClient FutureState FutureAction))
-> (RedeemSuccess
    -> Contract
         w s FutureError (StateMachineClient FutureState FutureAction))
-> Either RefundSuccess RedeemSuccess
-> Contract
     w s FutureError (StateMachineClient FutureState FutureAction)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (AReview FutureError RefundSuccess
-> RefundSuccess
-> Contract
     w s FutureError (StateMachineClient FutureState FutureAction)
forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing AReview FutureError RefundSuccess
forall r. AsFutureError r => Prism' r RefundSuccess
_EscrowRefunded) (\RedeemSuccess
_ -> StateMachineClient FutureState FutureAction
-> Contract
     w s FutureError (StateMachineClient FutureState FutureAction)
forall (f :: * -> *) a. Applicative f => a -> f a
pure StateMachineClient FutureState FutureAction
client) Either RefundSuccess RedeemSuccess
e

-- | The @"settle-future"@ endpoint. Given an oracle value with the current spot
--   price, this endpoint creates the final transaction that distributes the
--   funds locked by the future to the token accounts specified in
--   the 'FutureAccounts' argument.
settleFuture
    :: ( HasEndpoint "settle-future" (SignedMessage (Observation Value)) s
       , AsFutureError e
       )
    => SM.StateMachineClient FutureState FutureAction
    -> Promise w s e ()
settleFuture :: StateMachineClient FutureState FutureAction -> Promise w s e ()
settleFuture StateMachineClient FutureState FutureAction
client = (Contract w s FutureError () -> Contract w s e ())
-> Promise w s FutureError () -> Promise w s e ()
forall w1 (s1 :: Row *) e1 a1 w2 (s2 :: Row *) e2 a2.
(Contract w1 s1 e1 a1 -> Contract w2 s2 e2 a2)
-> Promise w1 s1 e1 a1 -> Promise w2 s2 e2 a2
promiseMap ((FutureError -> e)
-> Contract w s FutureError () -> 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 FutureError -> FutureError -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e FutureError
forall r. AsFutureError r => Prism' r FutureError
_FutureError)) (Promise w s FutureError () -> Promise w s e ())
-> Promise w s FutureError () -> Promise w s e ()
forall a b. (a -> b) -> a -> b
$ forall a w (s :: Row *) e b.
(HasEndpoint "settle-future" 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 @"settle-future" ((SignedMessage (Observation Value) -> Contract w s FutureError ())
 -> Promise w s FutureError ())
-> (SignedMessage (Observation Value)
    -> Contract w s FutureError ())
-> Promise w s FutureError ()
forall a b. (a -> b) -> a -> b
$ \SignedMessage (Observation Value)
ov -> do
    Contract
  w s FutureError (TransitionResult FutureState FutureAction)
-> Contract w s FutureError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Contract
   w s FutureError (TransitionResult FutureState FutureAction)
 -> Contract w s FutureError ())
-> Contract
     w s FutureError (TransitionResult FutureState FutureAction)
-> Contract w s FutureError ()
forall a b. (a -> b) -> a -> b
$ StateMachineClient FutureState FutureAction
-> FutureAction
-> Contract
     w s FutureError (TransitionResult FutureState FutureAction)
forall w e state (schema :: Row *) input.
(AsSMContractError e, FromData state, ToData state,
 ToData input) =>
StateMachineClient state input
-> input -> Contract w schema e (TransitionResult state input)
SM.runStep StateMachineClient FutureState FutureAction
client (SignedMessage (Observation Value) -> FutureAction
Settle SignedMessage (Observation Value)
ov)

-- | The @"settle-early"@ endpoint. Given an oracle value with the current spot
--   price, this endpoint creates the final transaction that distributes the
--   funds locked by the future to the token account of the role that did not
--   violate its obligations. Throws a 'MarginRequirementsNotViolated' error if
--   the spot price is within the margin range.
settleEarly
    :: ( HasEndpoint "settle-early" (SignedMessage (Observation Value)) s
       , AsSMContractError e
       , AsContractError e
       )
    => SM.StateMachineClient FutureState FutureAction
    -> Promise w s e ()
settleEarly :: StateMachineClient FutureState FutureAction -> Promise w s e ()
settleEarly StateMachineClient FutureState FutureAction
client = forall a w (s :: Row *) e b.
(HasEndpoint "settle-early" 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 @"settle-early" ((SignedMessage (Observation Value) -> Contract w s e ())
 -> Promise w s e ())
-> (SignedMessage (Observation Value) -> Contract w s e ())
-> Promise w s e ()
forall a b. (a -> b) -> a -> b
$ \SignedMessage (Observation Value)
ov -> do
    Contract w s e (TransitionResult FutureState FutureAction)
-> Contract w s e ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Contract w s e (TransitionResult FutureState FutureAction)
 -> Contract w s e ())
-> Contract w s e (TransitionResult FutureState FutureAction)
-> Contract w s e ()
forall a b. (a -> b) -> a -> b
$ StateMachineClient FutureState FutureAction
-> FutureAction
-> Contract w s e (TransitionResult FutureState FutureAction)
forall w e state (schema :: Row *) input.
(AsSMContractError e, FromData state, ToData state,
 ToData input) =>
StateMachineClient state input
-> input -> Contract w schema e (TransitionResult state input)
SM.runStep StateMachineClient FutureState FutureAction
client (SignedMessage (Observation Value) -> FutureAction
SettleEarly SignedMessage (Observation Value)
ov)

-- | The @"increase-margin"@ endpoint. Increses the margin of one of
--   the roles by an amount.
increaseMargin
    :: ( HasEndpoint "increase-margin" (Value, Role) s
       , AsSMContractError e
       , AsContractError e
       )
    => SM.StateMachineClient FutureState FutureAction
    -> Promise w s e ()
increaseMargin :: StateMachineClient FutureState FutureAction -> Promise w s e ()
increaseMargin StateMachineClient FutureState FutureAction
client = forall a w (s :: Row *) e b.
(HasEndpoint "increase-margin" 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 @"increase-margin" (((Value, Role) -> Contract w s e ()) -> Promise w s e ())
-> ((Value, Role) -> Contract w s e ()) -> Promise w s e ()
forall a b. (a -> b) -> a -> b
$ \(Value
value, Role
role) -> do
    Contract w s e (TransitionResult FutureState FutureAction)
-> Contract w s e ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Contract w s e (TransitionResult FutureState FutureAction)
 -> Contract w s e ())
-> Contract w s e (TransitionResult FutureState FutureAction)
-> Contract w s e ()
forall a b. (a -> b) -> a -> b
$ StateMachineClient FutureState FutureAction
-> FutureAction
-> Contract w s e (TransitionResult FutureState FutureAction)
forall w e state (schema :: Row *) input.
(AsSMContractError e, FromData state, ToData state,
 ToData input) =>
StateMachineClient state input
-> input -> Contract w schema e (TransitionResult state input)
SM.runStep StateMachineClient FutureState FutureAction
client (Role -> Value -> FutureAction
AdjustMargin Role
role Value
value)

-- | The @"join-future"@ endpoint. Join a future contract by paying the initial
--   margin to the escrow that initialises the contract.
joinFuture
    :: ( HasEndpoint "join-future" (FutureAccounts, FutureSetup) s
       , AsFutureError e
       )
    => Future
    -> Promise w s e (SM.StateMachineClient FutureState FutureAction)
joinFuture :: Future
-> Promise w s e (StateMachineClient FutureState FutureAction)
joinFuture Future
ft = (Contract
   w s FutureError (StateMachineClient FutureState FutureAction)
 -> Contract w s e (StateMachineClient FutureState FutureAction))
-> Promise
     w s FutureError (StateMachineClient FutureState FutureAction)
-> Promise w s e (StateMachineClient FutureState FutureAction)
forall w1 (s1 :: Row *) e1 a1 w2 (s2 :: Row *) e2 a2.
(Contract w1 s1 e1 a1 -> Contract w2 s2 e2 a2)
-> Promise w1 s1 e1 a1 -> Promise w2 s2 e2 a2
promiseMap ((FutureError -> e)
-> Contract
     w s FutureError (StateMachineClient FutureState FutureAction)
-> Contract w s e (StateMachineClient FutureState FutureAction)
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError (AReview e FutureError -> FutureError -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e FutureError
forall r. AsFutureError r => Prism' r FutureError
_FutureError)) (Promise
   w s FutureError (StateMachineClient FutureState FutureAction)
 -> Promise w s e (StateMachineClient FutureState FutureAction))
-> Promise
     w s FutureError (StateMachineClient FutureState FutureAction)
-> Promise w s e (StateMachineClient FutureState FutureAction)
forall a b. (a -> b) -> a -> b
$ forall w (s :: Row *) e b.
(HasEndpoint "join-future" (FutureAccounts, FutureSetup) s,
 AsContractError e, FromJSON (FutureAccounts, FutureSetup)) =>
((FutureAccounts, FutureSetup) -> 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 @"join-future" @(FutureAccounts, FutureSetup) (((FutureAccounts, FutureSetup)
  -> Contract
       w s FutureError (StateMachineClient FutureState FutureAction))
 -> Promise
      w s FutureError (StateMachineClient FutureState FutureAction))
-> ((FutureAccounts, FutureSetup)
    -> Contract
         w s FutureError (StateMachineClient FutureState FutureAction))
-> Promise
     w s FutureError (StateMachineClient FutureState FutureAction)
forall a b. (a -> b) -> a -> b
$ \(FutureAccounts
owners, FutureSetup
stp) -> do
    TypedValidator (StateMachine FutureState FutureAction)
inst <- Contract
  w
  s
  FutureError
  (TypedValidator (StateMachine FutureState FutureAction))
-> Contract
     w
     s
     FutureError
     (TypedValidator (StateMachine FutureState FutureAction))
forall w (s :: Row *) e a.
(AsCheckpointError e, FromJSON a, ToJSON a) =>
Contract w s e a -> Contract w s e a
checkpoint (Contract
   w
   s
   FutureError
   (TypedValidator (StateMachine FutureState FutureAction))
 -> Contract
      w
      s
      FutureError
      (TypedValidator (StateMachine FutureState FutureAction)))
-> Contract
     w
     s
     FutureError
     (TypedValidator (StateMachine FutureState FutureAction))
-> Contract
     w
     s
     FutureError
     (TypedValidator (StateMachine FutureState FutureAction))
forall a b. (a -> b) -> a -> b
$ TypedValidator (StateMachine FutureState FutureAction)
-> Contract
     w
     s
     FutureError
     (TypedValidator (StateMachine FutureState FutureAction))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Future
-> FutureAccounts
-> TypedValidator (StateMachine FutureState FutureAction)
typedValidator Future
ft FutureAccounts
owners)
    let client :: StateMachineClient FutureState FutureAction
client = TypedValidator (StateMachine FutureState FutureAction)
-> Future
-> FutureAccounts
-> StateMachineClient FutureState FutureAction
machineClient TypedValidator (StateMachine FutureState FutureAction)
inst Future
ft FutureAccounts
owners
        escr :: EscrowParams Datum
escr = StateMachineClient FutureState FutureAction
-> Future -> FutureAccounts -> FutureSetup -> EscrowParams Datum
escrowParams StateMachineClient FutureState FutureAction
client Future
ft FutureAccounts
owners FutureSetup
stp
        payment :: Contract w s EscrowError TxId
payment = TypedValidator Escrow
-> EscrowParams Datum -> Value -> Contract w s EscrowError TxId
forall w (s :: Row *) e.
AsContractError e =>
TypedValidator Escrow
-> EscrowParams Datum -> Value -> Contract w s e TxId
Escrow.pay (EscrowParams Datum -> TypedValidator Escrow
Escrow.typedValidator EscrowParams Datum
escr) EscrowParams Datum
escr (Future -> Value
initialMargin Future
ft)
    Contract w s FutureError TxId -> Contract w s FutureError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Contract w s FutureError TxId -> Contract w s FutureError ())
-> Contract w s FutureError TxId -> Contract w s FutureError ()
forall a b. (a -> b) -> a -> b
$ (EscrowError -> FutureError)
-> Contract w s EscrowError TxId -> Contract w s FutureError TxId
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError EscrowError -> FutureError
EscrowFailed Contract w s EscrowError TxId
payment
    StateMachineClient FutureState FutureAction
-> Contract
     w s FutureError (StateMachineClient FutureState FutureAction)
forall (f :: * -> *) a. Applicative f => a -> f a
pure StateMachineClient FutureState FutureAction
client

-- | Create two unique tokens that can be used for the short and long positions
--   and return a 'FutureAccounts' value for them.
--
--   Note that after 'setupTokens' is complete, both tokens will be locked by a
--   public key output belonging to the wallet that ran 'setupTokens'.
setupTokens
    :: forall w s e.
    ( AsFutureError e
    )
    => Contract w s e FutureAccounts
setupTokens :: Contract w s e FutureAccounts
setupTokens = (FutureError -> e)
-> Contract w s FutureError FutureAccounts
-> Contract w s e FutureAccounts
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError (AReview e FutureError -> FutureError -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e FutureError
forall r. AsFutureError r => Prism' r FutureError
_FutureError) (Contract w s FutureError FutureAccounts
 -> Contract w s e FutureAccounts)
-> Contract w s FutureError FutureAccounts
-> Contract w s e FutureAccounts
forall a b. (a -> b) -> a -> b
$ do
    CardanoAddress
addr <- Contract w s FutureError CardanoAddress
forall w (s :: Row *) e.
AsContractError e =>
Contract w s e CardanoAddress
ownAddress

    -- Create the tokens using the currency contract, wrapping any errors in
    -- 'TokenSetupFailed'
    OneShotCurrency
cur <- (CurrencyError -> FutureError)
-> Contract w s CurrencyError OneShotCurrency
-> Contract w s FutureError OneShotCurrency
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError CurrencyError -> FutureError
TokenSetupFailed (Contract w s CurrencyError OneShotCurrency
 -> Contract w s FutureError OneShotCurrency)
-> Contract w s CurrencyError OneShotCurrency
-> Contract w s FutureError OneShotCurrency
forall a b. (a -> b) -> a -> b
$ CardanoAddress
-> [(TokenName, Integer)]
-> Contract w s CurrencyError OneShotCurrency
forall w (s :: Row *) e.
AsCurrencyError e =>
CardanoAddress
-> [(TokenName, Integer)] -> Contract w s e OneShotCurrency
Currency.mintContract CardanoAddress
addr [(TokenName
"long", Integer
1), (TokenName
"short", Integer
1)]
    let acc :: TokenName -> Account
acc = AssetClass -> Account
Account (AssetClass -> Account)
-> (TokenName -> AssetClass) -> TokenName -> Account
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CurrencySymbol -> TokenName -> AssetClass
Value.assetClass (OneShotCurrency -> CurrencySymbol
Currency.currencySymbol OneShotCurrency
cur)
    FutureAccounts -> Contract w s FutureError FutureAccounts
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FutureAccounts -> Contract w s FutureError FutureAccounts)
-> FutureAccounts -> Contract w s FutureError FutureAccounts
forall a b. (a -> b) -> a -> b
$ Account -> Account -> FutureAccounts
mkAccounts (TokenName -> Account
acc TokenName
"long") (TokenName -> Account
acc TokenName
"short")

-- | The escrow contract that initialises the future. Both parties have to pay
--   their initial margin to this contract in order to unlock their tokens.
escrowParams
    :: SM.StateMachineClient FutureState FutureAction
    -> Future
    -> FutureAccounts
    -> FutureSetup
    -> EscrowParams Datum
escrowParams :: StateMachineClient FutureState FutureAction
-> Future -> FutureAccounts -> FutureSetup -> EscrowParams Datum
escrowParams StateMachineClient FutureState FutureAction
client Future
future FutureAccounts
ftos FutureSetup{PaymentPubKeyHash
longPK :: PaymentPubKeyHash
longPK :: FutureSetup -> PaymentPubKeyHash
longPK, PaymentPubKeyHash
shortPK :: PaymentPubKeyHash
shortPK :: FutureSetup -> PaymentPubKeyHash
shortPK, POSIXTime
contractStart :: POSIXTime
contractStart :: FutureSetup -> POSIXTime
contractStart} =
    let
        address :: ValidatorHash
address = TypedValidator (StateMachine FutureState FutureAction)
-> ValidatorHash
forall a. TypedValidator a -> ValidatorHash
V2.validatorHash (TypedValidator (StateMachine FutureState FutureAction)
 -> ValidatorHash)
-> TypedValidator (StateMachine FutureState FutureAction)
-> ValidatorHash
forall a b. (a -> b) -> a -> b
$ StateMachineInstance FutureState FutureAction
-> TypedValidator (StateMachine FutureState FutureAction)
forall s i.
StateMachineInstance s i -> TypedValidator (StateMachine s i)
SM.typedValidator (StateMachineInstance FutureState FutureAction
 -> TypedValidator (StateMachine FutureState FutureAction))
-> StateMachineInstance FutureState FutureAction
-> TypedValidator (StateMachine FutureState FutureAction)
forall a b. (a -> b) -> a -> b
$ StateMachineClient FutureState FutureAction
-> StateMachineInstance FutureState FutureAction
forall s i. StateMachineClient s i -> StateMachineInstance s i
SM.scInstance StateMachineClient FutureState FutureAction
client
        dataScript :: Datum
dataScript  = BuiltinData -> Datum
Datum (BuiltinData -> Datum) -> BuiltinData -> Datum
forall a b. (a -> b) -> a -> b
$ FutureState -> BuiltinData
forall a. ToData a => a -> BuiltinData
PlutusTx.toBuiltinData (FutureState -> BuiltinData) -> FutureState -> BuiltinData
forall a b. (a -> b) -> a -> b
$ Future -> FutureState
initialState Future
future
        targets :: [EscrowTarget Datum]
targets =
            [ ValidatorHash -> Datum -> Value -> EscrowTarget Datum
Escrow.payToScriptTarget ValidatorHash
address
                Datum
dataScript
                (Integer -> Value -> Value
forall s v. Module s v => s -> v -> v
scale Integer
2 (Future -> Value
initialMargin Future
future))
            , PaymentPubKeyHash -> Value -> EscrowTarget Datum
forall d. PaymentPubKeyHash -> Value -> EscrowTarget d
Escrow.payToPaymentPubKeyTarget PaymentPubKeyHash
longPK (Role -> FutureAccounts -> Value
tokenFor Role
Long FutureAccounts
ftos)
            , PaymentPubKeyHash -> Value -> EscrowTarget Datum
forall d. PaymentPubKeyHash -> Value -> EscrowTarget d
Escrow.payToPaymentPubKeyTarget PaymentPubKeyHash
shortPK (Role -> FutureAccounts -> Value
tokenFor Role
Short FutureAccounts
ftos)
            ]
    in EscrowParams :: forall d. POSIXTime -> [EscrowTarget d] -> EscrowParams d
EscrowParams
        { escrowDeadline :: POSIXTime
escrowDeadline = POSIXTime
contractStart
        , escrowTargets :: [EscrowTarget Datum]
escrowTargets = [EscrowTarget Datum]
targets
        }

setupTokensTrace :: Trace.EmulatorTrace ()
setupTokensTrace :: EmulatorTrace ()
setupTokensTrace = do
    Slot
_ <- Natural -> Eff EmulatorEffects Slot
forall (effs :: [* -> *]).
Member Waiting effs =>
Natural -> Eff effs Slot
Trace.waitNSlots Natural
1
    ContractHandle
  ()
  ('R
     '[ "increase-margin"
        ':-> (EndpointValue (Value, Role), ActiveEndpoint),
        "initialise-future"
        ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
        "join-future"
        ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
        "settle-early"
        ':-> (EndpointValue (SignedMessage (Observation Value)),
              ActiveEndpoint),
        "settle-future"
        ':-> (EndpointValue (SignedMessage (Observation Value)),
              ActiveEndpoint)])
  FutureError
_ <- Wallet
-> Contract
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     ()
-> Eff
     EmulatorEffects
     (ContractHandle
        ()
        ('R
           '[ "increase-margin"
              ':-> (EndpointValue (Value, Role), ActiveEndpoint),
              "initialise-future"
              ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
              "join-future"
              ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
              "settle-early"
              ':-> (EndpointValue (SignedMessage (Observation Value)),
                    ActiveEndpoint),
              "settle-future"
              ':-> (EndpointValue (SignedMessage (Observation Value)),
                    ActiveEndpoint)])
        FutureError)
forall (contract :: * -> Row * -> * -> * -> *) w (s :: Row *) e
       (effs :: [* -> *]).
(IsContract contract, ContractConstraints s, Show e, ToJSON e,
 FromJSON e, ToJSON w, FromJSON w, Member StartContract effs,
 Monoid w) =>
Wallet -> contract w s e () -> Eff effs (ContractHandle w s e)
Trace.activateContractWallet (Integer -> Wallet
Wallet.knownWallet Integer
1) (Contract
  ()
  ('R
     '[ "increase-margin"
        ':-> (EndpointValue (Value, Role), ActiveEndpoint),
        "initialise-future"
        ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
        "join-future"
        ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
        "settle-early"
        ':-> (EndpointValue (SignedMessage (Observation Value)),
              ActiveEndpoint),
        "settle-future"
        ':-> (EndpointValue (SignedMessage (Observation Value)),
              ActiveEndpoint)])
  FutureError
  FutureAccounts
-> Contract
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Contract
   ()
   ('R
      '[ "increase-margin"
         ':-> (EndpointValue (Value, Role), ActiveEndpoint),
         "initialise-future"
         ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
         "join-future"
         ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
         "settle-early"
         ':-> (EndpointValue (SignedMessage (Observation Value)),
               ActiveEndpoint),
         "settle-future"
         ':-> (EndpointValue (SignedMessage (Observation Value)),
               ActiveEndpoint)])
   FutureError
   FutureAccounts
 -> Contract
      ()
      ('R
         '[ "increase-margin"
            ':-> (EndpointValue (Value, Role), ActiveEndpoint),
            "initialise-future"
            ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
            "join-future"
            ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
            "settle-early"
            ':-> (EndpointValue (SignedMessage (Observation Value)),
                  ActiveEndpoint),
            "settle-future"
            ':-> (EndpointValue (SignedMessage (Observation Value)),
                  ActiveEndpoint)])
      FutureError
      ())
-> Contract
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     FutureAccounts
-> Contract
     ()
     ('R
        '[ "increase-margin"
           ':-> (EndpointValue (Value, Role), ActiveEndpoint),
           "initialise-future"
           ':-> (EndpointValue (FutureSetup, Role), ActiveEndpoint),
           "join-future"
           ':-> (EndpointValue (FutureAccounts, FutureSetup), ActiveEndpoint),
           "settle-early"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint),
           "settle-future"
           ':-> (EndpointValue (SignedMessage (Observation Value)),
                 ActiveEndpoint)])
     FutureError
     ()
forall a b. (a -> b) -> a -> b
$ AsFutureError FutureError =>
Contract () FutureSchema FutureError FutureAccounts
forall w (s :: Row *) e.
AsFutureError e =>
Contract w s e FutureAccounts
setupTokens @() @FutureSchema @FutureError)
    Eff EmulatorEffects Slot -> EmulatorTrace ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Eff EmulatorEffects Slot -> EmulatorTrace ())
-> Eff EmulatorEffects Slot -> EmulatorTrace ()
forall a b. (a -> b) -> a -> b
$ Natural -> Eff EmulatorEffects Slot
forall (effs :: [* -> *]).
Member Waiting effs =>
Natural -> Eff effs Slot
Trace.waitNSlots Natural
2

PlutusTx.makeLift ''Future
PlutusTx.makeLift ''FutureAccounts
PlutusTx.makeLift ''Margins
PlutusTx.unstableMakeIsData ''Margins
PlutusTx.makeLift ''Role
PlutusTx.unstableMakeIsData ''Role
PlutusTx.makeLift ''FutureState
PlutusTx.unstableMakeIsData ''FutureState
PlutusTx.makeLift ''FutureAction
PlutusTx.unstableMakeIsData ''FutureAction