Skip to content

Commit

Permalink
Review comments
Browse files Browse the repository at this point in the history
  • Loading branch information
@j-mueller
j-mueller committed Feb 14, 2020
1 parent c7aff1f commit 9a6bc55
Show file tree
Hide file tree
Showing 19 changed files with 28,527 additions and 25,055 deletions.
22 changes: 12 additions & 10 deletions plutus-contract/src/Language/Plutus/Contract/StateMachine.hs
View file
Expand Up @@ -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
Expand All @@ -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)
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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.
Expand All @@ -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)
4 changes: 2 additions & 2 deletions plutus-playground-server/usecases/Vesting.hs
View file
Expand Up @@ -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 ()
Expand Down
85 changes: 44 additions & 41 deletions plutus-use-cases/src/Language/PlutusTx/Coordination/Contracts/Future.hs
View file
Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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,
Expand Down
30 changes: 16 additions & 14 deletions plutus-use-cases/src/Language/PlutusTx/Coordination/Contracts/GameStateMachine.hs
View file
Expand Up @@ -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
Expand Down Expand Up @@ -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 #-}
Expand Down
3 changes: 1 addition & 2 deletions plutus-use-cases/src/Language/PlutusTx/Coordination/Contracts/MultiSig.hs
View file
Expand Up @@ -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
Expand Down Expand Up @@ -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.
Expand Down

0 comments on commit 9a6bc55

Please sign in to comment.