Skip to content
Permalink
Browse files

Review comments

  • Loading branch information
j-mueller committed Feb 14, 2020
1 parent c7aff1f commit 9a6bc557f08ac1440efd025684ac9061816b3ddc
@@ -15,8 +15,7 @@ module Language.Plutus.Contract.StateMachine(
, AsSMContractError(..)
, SM.StateMachine(..)
, SM.StateMachineInstance(..)
, SM.OldState(..)
, SM.NewState(..)
, SM.State(..)
-- * Constructing the machine instance
, SM.mkValidator
, SM.mkStateMachine
@@ -26,16 +25,19 @@ module Language.Plutus.Contract.StateMachine(
-- * Running the state machine
, runStep
, runInitialise
-- * Re-exports
, Void
) where

import Control.Lens
import Control.Monad.Error.Lens
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Void (Void)

import Language.Plutus.Contract
import qualified Language.PlutusTx as PlutusTx
import Language.PlutusTx.StateMachine (NewState (..), OldState (..), StateMachine (..),
import Language.PlutusTx.StateMachine (State (..), StateMachine (..),
StateMachineInstance (..))
import qualified Language.PlutusTx.StateMachine as SM
import Ledger (Value)
@@ -137,15 +139,15 @@ runStep ::
-> Contract schema e state
runStep smc input = do
let StateMachineInstance{stateMachine} = scInstance smc
(NewState{newData=s, newValue=v, newConstraints}, inp, lookups) <- mkStep smc input
(newConstraints, State{stateData=s, stateValue=v}, inp, lookups) <- mkStep smc input
pk <- ownPubKey
let lookups' = lookups { Constraints.slOwnPubkey = Just $ pubKeyHash pk }
txConstraints =
if smFinal stateMachine s
then TxConstraints{ txConstraints = newConstraints, txOwnInputs = [inp], txOwnOutputs = [] }
then newConstraints { txOwnInputs = [inp], txOwnOutputs = [] }
else
let output = OutputConstraint{ocData = s, ocValue = v}
in TxConstraints{ txConstraints = newConstraints, txOwnInputs = [inp], txOwnOutputs = [output] }
in newConstraints { txOwnInputs = [inp], txOwnOutputs = [output] }
utx <- either (throwing _ConstraintResolutionError) pure (Constraints.mkTx lookups' txConstraints)
submitTxConfirmed utx
pure s
@@ -174,7 +176,7 @@ runInitialise StateMachineClient{scInstance} initialState initialValue = do
submitTxConfirmed utx
pure initialState

type StateMachineTypedTx state input = (NewState state, InputConstraint input, ScriptLookups (StateMachine state input))
type StateMachineTypedTx state input = (TxConstraints Void Void, State state, InputConstraint input, ScriptLookups (StateMachine state input))

mkStep ::
forall e state schema input.
@@ -189,11 +191,11 @@ mkStep client@StateMachineClient{scInstance} input = do
let StateMachineInstance{stateMachine=StateMachine{smTransition}, validatorInstance} = scInstance
(onChainState, utxo) <- getOnChainState client
let (TypedScriptTxOut{tyTxOutData=currentState, tyTxOutTxOut}, txOutRef) = onChainState
oldState = OldState{oldData = currentState, oldValue = Ledger.txOutValue tyTxOutTxOut}
oldState = State{stateData = currentState, stateValue = Ledger.txOutValue tyTxOutTxOut}

case smTransition oldState input of
Just newState ->
Just (newConstraints, newState) ->
let lookups = (Constraints.scriptLookups validatorInstance) { Constraints.slTxOutputs = utxo }

in pure (newState, InputConstraint{icRedeemer=input, icTxOutRef = Typed.tyTxOutRefRef txOutRef }, lookups)
in pure (newConstraints, newState, InputConstraint{icRedeemer=input, icTxOutRef = Typed.tyTxOutRefRef txOutRef }, lookups)
Nothing -> throwing _InvalidTransition (currentState, input)
@@ -213,8 +213,8 @@ retrieveFundsC vesting payment = do
-- we don't need to add a pubkey output for 'vestingOwner' here
-- because this will be done by the wallet when it balances the
-- transaction.
lookups = (scriptLookups inst) { slTxOutputs = unspentOutputs }
void $ submitTxConstraintsWith lookups tx
in
void $ submitConstraintsUtxo inst unspentOutputs lookups tx
return liveness

endpoints :: Contract VestingSchema T.Text ()
@@ -46,7 +46,7 @@ import Control.Monad.Error.Lens (throwing)
import GHC.Generics (Generic)
import Language.Plutus.Contract
import qualified Ledger.Constraints as Constraints
import Ledger.Constraints.TxConstraints (TxConstraint(..))
import Ledger.Constraints.TxConstraints (TxConstraints)
import Language.Plutus.Contract.Util (loopM)
import qualified Language.PlutusTx as PlutusTx
import Language.PlutusTx.Prelude
@@ -66,7 +66,7 @@ import Language.PlutusTx.Coordination.Contracts.Escrow (EscrowParams(..), AsEscr
import qualified Language.PlutusTx.Coordination.Contracts.Escrow as Escrow
import qualified Language.PlutusTx.Coordination.Contracts.TokenAccount as TokenAccount
import Language.PlutusTx.Coordination.Contracts.TokenAccount (Account(..))
import Language.Plutus.Contract.StateMachine (AsSMContractError, StateMachine(..), NewState(..), OldState(..))
import Language.Plutus.Contract.StateMachine (AsSMContractError, StateMachine(..), State(..), Void)
import qualified Language.Plutus.Contract.StateMachine as SM

import qualified Prelude as Haskell
@@ -316,7 +316,7 @@ validator :: Future -> FutureAccounts -> Validator
validator ft fos = Scripts.validatorScript (scriptInstance ft fos)

{-# INLINABLE verifyOracle #-}
verifyOracle :: PlutusTx.IsData a => PubKey -> SignedMessage a -> Maybe (a, TxConstraint)
verifyOracle :: PlutusTx.IsData a => PubKey -> SignedMessage a -> Maybe (a, TxConstraints Void Void)
verifyOracle pubKey sm =
either (const Nothing) pure
$ Oracle.verifySignedMessageConstraints pubKey sm
@@ -328,41 +328,45 @@ verifyOracleOffChain Future{ftPriceOracle} sm =
Right Observation{obsValue, obsSlot} -> Just (obsSlot, obsValue)

{-# INLINABLE transition #-}
transition :: Future -> FutureAccounts -> OldState FutureState -> FutureAction -> Maybe (NewState FutureState)
transition future owners OldState{oldData=s, oldValue=currentValue} i =
let Future{ftDeliveryDate, ftPriceOracle} = future in
case (s, i) of
(Running accounts, AdjustMargin role topUp) ->
Just NewState
{ newData = Running (adjustMargin role topUp accounts)
, newValue = topUp + totalMargin accounts
, newConstraints = []
}
(Running accounts, Settle ov)
| Just (Observation{obsValue=spotPrice, obsSlot=oracleDate}, constraint) <- verifyOracle ftPriceOracle ov, ftDeliveryDate == oracleDate ->
let payment = payouts future accounts spotPrice in
Just NewState
{ newData = Finished
, newValue = mempty
, newConstraints =
(Constraints.MustValidateIn (Interval.from ftDeliveryDate)
: constraint
: payoutsTx payment owners)
transition :: Future -> FutureAccounts -> State FutureState -> FutureAction -> Maybe (TxConstraints Void Void, State FutureState)
transition future@Future{ftDeliveryDate, ftPriceOracle} owners State{stateData=s, stateValue=currentValue} i =
case (s, i) of
(Running accounts, AdjustMargin role topUp) ->
Just ( mempty
, State
{ stateData = Running (adjustMargin role topUp accounts)
, stateValue = topUp + totalMargin accounts
}
)
(Running accounts, Settle ov)
| Just (Observation{obsValue=spotPrice, obsSlot=oracleDate}, oracleConstraints) <- verifyOracle ftPriceOracle ov, ftDeliveryDate == oracleDate ->
let payment = payouts future accounts spotPrice
constraints =
Constraints.mustValidateIn (Interval.from ftDeliveryDate)
<> oracleConstraints
<> payoutsTx payment owners
in Just ( constraints
, State
{ stateData = Finished
, stateValue = mempty
}
(Running accounts, SettleEarly ov)
| Just (Observation{obsValue=spotPrice, obsSlot=oracleDate}, constraint) <- verifyOracle ftPriceOracle ov, Just vRole <- violatingRole future accounts spotPrice, ftDeliveryDate > oracleDate ->
let
total = totalMargin accounts
FutureAccounts{ftoLongAccount, ftoShortAccount} = owners
payment = case vRole of
Short -> Constraints.MustPayToOtherScript ftoLongAccount unitData total
Long -> Constraints.MustPayToOtherScript ftoShortAccount unitData total
in Just NewState
{ newData = Finished
, newValue = mempty
, newConstraints = [payment, constraint]
}
_ -> Nothing
)
(Running accounts, SettleEarly ov)
| Just (Observation{obsValue=spotPrice, obsSlot=oracleDate}, oracleConstraints) <- verifyOracle ftPriceOracle ov, Just vRole <- violatingRole future accounts spotPrice, ftDeliveryDate > oracleDate ->
let
total = totalMargin accounts
FutureAccounts{ftoLongAccount, ftoShortAccount} = owners
payment = case vRole of
Short -> Constraints.mustPayToOtherScript ftoLongAccount unitData total
Long -> Constraints.mustPayToOtherScript ftoShortAccount unitData total
constraints = payment <> oracleConstraints
in Just ( constraints
, State
{ stateData = Finished
, stateValue = mempty
}
)
_ -> Nothing

data Payouts =
Payouts
@@ -374,13 +378,12 @@ data Payouts =
payoutsTx
:: Payouts
-> FutureAccounts
-> [TxConstraint]
-> TxConstraints Void Void
payoutsTx
Payouts{payoutsShort, payoutsLong}
FutureAccounts{ftoLongAccount, ftoShortAccount} =
[ Constraints.MustPayToOtherScript ftoLongAccount unitData payoutsLong
, Constraints.MustPayToOtherScript ftoShortAccount unitData payoutsShort
]
Constraints.mustPayToOtherScript ftoLongAccount unitData payoutsLong
<> Constraints.mustPayToOtherScript ftoShortAccount unitData payoutsShort

{-# INLINABLE payouts #-}
-- | Compute the payouts for each role given the future data,
@@ -36,13 +36,14 @@ import Control.Monad (void)
import qualified Language.PlutusTx as PlutusTx
import Language.PlutusTx.Prelude hiding (check, Applicative (..))
import Ledger hiding (to)
import Ledger.Constraints (TxConstraints)
import qualified Ledger.Constraints as Constraints
import qualified Ledger.Value as V
import qualified Ledger.Typed.Scripts as Scripts

import qualified Data.ByteString.Lazy.Char8 as C

import Language.Plutus.Contract.StateMachine (AsSMContractError, NewState(..), OldState(..))
import Language.Plutus.Contract.StateMachine (AsSMContractError, State(..), Void)
import qualified Language.Plutus.Contract.StateMachine as SM

import Language.Plutus.Contract
@@ -133,24 +134,25 @@ data GameInput =
deriving (Show)

{-# INLINABLE transition #-}
transition :: OldState GameState -> GameInput -> Maybe (NewState GameState)
transition OldState{oldData, oldValue} input = case (oldData, input) of
transition :: State GameState -> GameInput -> Maybe (TxConstraints Void Void, State GameState)
transition State{stateData=oldData, stateValue=oldValue} input = case (oldData, input) of
(Initialised mph tn s, ForgeToken) ->
Just NewState
{ newData = Locked mph tn s
, newValue = oldValue
, newConstraints = [Constraints.MustForgeValue mph tn 1]
let constraints = Constraints.mustForgeValue mph tn 1 in
Just ( constraints
, State
{ stateData = Locked mph tn s
, stateValue = oldValue
}
)
(Locked mph tn currentSecret, Guess theGuess nextSecret takenOut)
| checkGuess currentSecret theGuess ->
Just NewState
{ newData = Locked mph tn nextSecret
, newValue = oldValue - takenOut
, newConstraints =
[ Constraints.MustSpendValue (token mph tn)
, Constraints.MustForgeValue mph tn 0
]
let constraints = Constraints.mustSpendValue (token mph tn) <> Constraints.mustForgeValue mph tn 0 in
Just ( constraints
, State
{ stateData = Locked mph tn nextSecret
, stateValue = oldValue - takenOut
}
)
_ -> Nothing

{-# INLINABLE machine #-}
@@ -24,7 +24,6 @@ module Language.PlutusTx.Coordination.Contracts.MultiSig
import Control.Monad (void)
import Language.Plutus.Contract
import qualified Ledger.Constraints as Constraints
import Ledger.Constraints.OffChain (scriptLookups)
import qualified Language.Plutus.Contract.Typed.Tx as Tx
import Language.PlutusTx.Prelude hiding (Semigroup(..), foldMap)
import qualified Language.PlutusTx as PlutusTx
@@ -77,7 +76,7 @@ lock = do
(ms, vl) <- endpoint @"lock"
let tx = Constraints.mustPayToScript () vl
let inst = scriptInstance ms
void $ submitTxConstraintsWith (scriptLookups inst) tx
void $ submitTxConstraints inst tx

-- | The @"unlock"@ endpoint, unlocking some funds with a list
-- of signatures.

0 comments on commit 9a6bc55

Please sign in to comment.
You can’t perform that action at this time.