diff --git a/marlowe/marlowe.cabal b/marlowe/marlowe.cabal index d328db78101..a21f416a697 100644 --- a/marlowe/marlowe.cabal +++ b/marlowe/marlowe.cabal @@ -36,11 +36,13 @@ library bytestring, containers -any, deriving-aeson -any, + lens, mtl, newtype-generics, template-haskell -any, plutus-tx -any, plutus-contract -any, + plutus-core, plutus-ledger, text, vector, @@ -94,7 +96,6 @@ test-suite marlowe-test aeson -any, base >=4.9 && <5, containers -any, - hedgehog -any, hint -any, lens -any, memory -any, @@ -103,7 +104,6 @@ test-suite marlowe-test tasty -any, tasty-hunit -any, tasty-quickcheck, - tasty-hedgehog >=0.2.0.0, text -any, serialise, cborg, diff --git a/marlowe/src/Language/Marlowe/Client.hs b/marlowe/src/Language/Marlowe/Client.hs index 1749a1e5e87..cd858fb200d 100644 --- a/marlowe/src/Language/Marlowe/Client.hs +++ b/marlowe/src/Language/Marlowe/Client.hs @@ -1,240 +1,239 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-specialise #-} module Language.Marlowe.Client where +import Control.Lens +import Control.Monad (void) +import Language.Marlowe.Semantics hiding (Contract) +import qualified Language.Marlowe.Semantics as Marlowe +import Language.Plutus.Contract +import Language.Plutus.Contract.StateMachine (AsSMContractError, StateMachine (..), Void) +import qualified Language.Plutus.Contract.StateMachine as SM +import qualified Language.PlutusCore.Universe as PLC +import qualified Language.PlutusTx as PlutusTx +import Language.PlutusTx.AssocMap (Map) +import qualified Language.PlutusTx.AssocMap as Map +import qualified Language.PlutusTx.Prelude as P +import Ledger (CurrencySymbol, Datum (..), Slot (..), SlotRange, TokenName, + ValidatorCtx (..), mkValidatorScript, pubKeyHash, validatorHash, + valueSpent) +import Ledger.Ada (adaSymbol, adaValueOf) +import Ledger.Constraints +import Ledger.Interval +import Ledger.Scripts (Validator) +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Typed.Tx (TypedScriptTxOut (..)) +import qualified Ledger.Value as Val + +type MarloweInput = (SlotRange, [Input]) + +type MarloweSchema = + BlockchainActions + .\/ Endpoint "create" (MarloweParams, Marlowe.Contract) + .\/ Endpoint "apply-inputs" (MarloweParams, [Input]) + .\/ Endpoint "wait" MarloweParams + +data MarloweError = + StateMachineError (SM.SMContractError MarloweData MarloweInput) + | OtherContractError ContractError + deriving (Show) + +makeClassyPrisms ''MarloweError + +instance AsSMContractError MarloweError MarloweData MarloweInput where + _SMContractError = _StateMachineError + +instance AsContractError MarloweError where + _ContractError = _OtherContractError + + +marlowePlutusContract :: forall e. (AsContractError e + , AsSMContractError e MarloweData MarloweInput + ) + => Contract MarloweSchema e () +marlowePlutusContract = do + create `select` wait + where + create = do + (params, cont) <- endpoint @"create" @(MarloweParams, Marlowe.Contract) @MarloweSchema + createContract params cont + apply `select` wait + wait = do + params <- endpoint @"wait" @MarloweParams @MarloweSchema + r <- SM.waitForUpdate (mkMarloweClient params) + case r of + Just (TypedScriptTxOut{tyTxOutData=_currentState}, _txOutRef) -> do + apply `select` wait + Nothing -> pure () -- the contract is closed, no UTxO + apply = do + (params, inputs) <- endpoint @"apply-inputs" @(MarloweParams, [Input]) @MarloweSchema + MarloweData{..} <- applyInputs params inputs + case marloweContract of + Close -> pure () + _ -> apply `select` wait -import Control.Monad.Freer -import Control.Monad.Freer.Error (Error) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (maybeToList) -import qualified Data.Set as Set -import qualified Data.Text as Text -import Language.Marlowe.Semantics as Marlowe -import qualified Language.PlutusTx as PlutusTx -import qualified Language.PlutusTx.Prelude as P -import Ledger (Address, CurrencySymbol, Datum (..), Slot (..), TokenName, Tx, interval, - mkValidatorScript, pubKeyHash, pubKeyHashTxOut, scriptAddress, scriptTxIn, - scriptTxOut, scriptTxOut', txOutRefs) -import Ledger.Ada (adaSymbol, adaValueOf) -import Ledger.Scripts (Redeemer (..), Validator, validatorHash) -import qualified Ledger.Typed.Scripts as Scripts -import Ledger.Validation -import qualified Ledger.Value as Val -import Wallet (WalletAPIError, createPaymentWithChange, createTxAndSubmit, emptyPayment, - throwOtherError) -import Wallet.Effects hiding (Payment) -import qualified Wallet.Effects as Wallet {-| Create a Marlowe contract. Uses wallet public key to generate a unique script address. -} -createContract :: ( - Member WalletEffect effs, - Member SigningProcessEffect effs - ) +createContract :: (AsContractError e, AsSMContractError e MarloweData MarloweInput) => MarloweParams - -> Contract - -> Eff effs (MarloweData, Tx) + -> Marlowe.Contract + -> Contract MarloweSchema e () createContract params contract = do - slot <- walletSlot - creator <- pubKeyHash <$> ownPubKey - let validator = validatorScript params - - marloweData = MarloweData { + slot <- awaitSlot 0 + _creator <- pubKeyHash <$> ownPubKey + let marloweData = MarloweData { marloweContract = contract, marloweState = emptyState slot } - ds = Datum $ PlutusTx.toData marloweData - let payValue = adaValueOf 1 - Wallet.Payment{paymentInputs, paymentChangeOutput} <- createPaymentWithChange payValue - let o = scriptTxOut P.zero validator ds - slotRange = interval slot (slot + 10) - outputs = o : (pubKeyHashTxOut payValue creator) : maybeToList paymentChangeOutput + let payValue = adaValueOf 0 + let theClient = mkMarloweClient params - tx <- createTxAndSubmit slotRange paymentInputs outputs [ds] - return (marloweData, tx) + void $ SM.runInitialise theClient marloweData payValue -{-| Deposit 'amount' of 'token' to 'accountId' to a Marlowe contract - from 'tx' with 'MarloweData' data script. - -} -deposit :: ( - Member WalletEffect effs, - Member SigningProcessEffect effs, - Member (Error WalletAPIError) effs - ) - => Tx - -> MarloweParams - -> MarloweData - -> AccountId - -> Token - -> Integer - -> Eff effs (MarloweData, Tx) -deposit tx params marloweData accountId token amount = do - pubKeyHash <- pubKeyHash <$> ownPubKey - applyInputs tx params marloweData [IDeposit accountId (PK pubKeyHash) token amount] - - -{-| Notify a contract -} -notify :: ( - Member WalletEffect effs, - Member SigningProcessEffect effs, - Member (Error WalletAPIError) effs - ) - => Tx - -> MarloweParams - -> MarloweData - -> Eff effs (MarloweData, Tx) -notify tx params marloweData = applyInputs tx params marloweData [INotify] - - -{-| Make a 'choice' identified as 'choiceId'. -} -makeChoice :: ( - Member WalletEffect effs, - Member SigningProcessEffect effs, - Member (Error WalletAPIError) effs - ) - => Tx - -> MarloweParams - -> MarloweData - -> ChoiceId - -> Integer - -> Eff effs (MarloweData, Tx) -makeChoice tx params marloweData choiceId choice = - applyInputs tx params marloweData [IChoice choiceId choice] - - -{-| Create a simple transaction that just evaluates/reduces a contract. - - Imagine a contract: - @ - If (SlotIntervalStart `ValueLT` (Constant 100)) - (When [] 200 (.. receive payment ..)) - Close - @ - In order to receive a payment, one have to firts evaluate the contract - before slot 100, and this transaction should not have any inputs. - Then, after slot 200, one can evaluate again to claim the payment. --} -makeProgress :: ( - Member WalletEffect effs, - Member SigningProcessEffect effs, - Member (Error WalletAPIError) effs - ) - => Tx - -> MarloweParams - -> MarloweData - -> Eff effs (MarloweData, Tx) -makeProgress tx params marloweData = applyInputs tx params marloweData [] - - -{-| Apply a list of 'Input' to a Marlowe contract. - All inputs must be from a wallet owner. - One can only apply an input that's expected from his/her PubKey. --} -applyInputs :: ( - Member WalletEffect effs, - Member SigningProcessEffect effs, - Member (Error WalletAPIError) effs - ) - => Tx - -> MarloweParams - -> MarloweData +applyInputs :: (AsContractError e, AsSMContractError e MarloweData MarloweInput) + => MarloweParams -> [Input] - -> Eff effs (MarloweData, Tx) -applyInputs tx params marloweData@MarloweData{..} inputs = do - let redeemer = mkRedeemer inputs - validator = validatorScript params - dataValue = Datum (PlutusTx.toData marloweData) - address = scriptAddress validator - slot <- walletSlot - - -- For now, we expect a transaction to happen whithin 10 slots from now. - -- That's about 3 minutes, should be fine. - let slotRange = interval slot (slot + Slot 10) + -> Contract MarloweSchema e MarloweData +applyInputs params inputs = do + (Slot slot) <- awaitSlot 1 + let slotRange = interval (Slot $ slot - 1) (Slot $ slot + 10) + let theClient = mkMarloweClient params + dat <- SM.runStep theClient (slotRange, inputs) + return dat + + +rolePayoutScript :: Validator +rolePayoutScript = mkValidatorScript ($$(PlutusTx.compile [|| wrapped ||])) + where + wrapped = Scripts.wrapValidator rolePayoutValidator + + +{-# INLINABLE rolePayoutValidator #-} +rolePayoutValidator :: (CurrencySymbol, TokenName) -> () -> ValidatorCtx -> Bool +rolePayoutValidator (currency, role) _ ctx = + Val.valueOf (valueSpent (valCtxTxInfo ctx)) currency role P.> 0 + + +marloweParams :: CurrencySymbol -> MarloweParams +marloweParams rolesCurrency = MarloweParams + { rolesCurrency = rolesCurrency + , rolePayoutValidatorHash = validatorHash rolePayoutScript } + + +defaultMarloweParams :: MarloweParams +defaultMarloweParams = marloweParams adaSymbol + + +{-# INLINABLE mkMarloweStateMachineTransition #-} +mkMarloweStateMachineTransition + :: MarloweParams + -> SM.State MarloweData + -> MarloweInput + -> Maybe (TxConstraints Void Void, SM.State MarloweData) +mkMarloweStateMachineTransition params SM.State{ SM.stateData=MarloweData{..}, SM.stateValue=scriptInValue} (range, inputs) = do + let interval = case range of + Interval (LowerBound (Finite l) True) (UpperBound (Finite h) True) -> (l, h) + _ -> P.traceError "Tx valid slot must have lower bound and upper bounds" + + let positiveBalances = validateBalances marloweState || + P.traceError "Invalid contract state. There exists an account with non positive balance" + + {- We do not check that a transaction contains exact input payments. + We only require an evidence from a party, e.g. a signature for PubKey party, + or a spend of a 'party role' token. + This gives huge flexibility by allowing parties to provide multiple + inputs (either other contracts or P2PKH). + Then, we check scriptOutput to be correct. + -} + let inputsConstraints = validateInputs params inputs + + -- total balance of all accounts in State + -- accounts must be positive, and we checked it above + let inputBalance = totalBalance (accounts marloweState) + + -- ensure that a contract TxOut has what it suppose to have + let balancesOk = inputBalance == scriptInValue + + let preconditionsOk = P.traceIfFalse "Preconditions are false" $ positiveBalances && balancesOk + let txInput = TransactionInput { - txInterval = (slot, slot + Slot 10), + txInterval = interval, txInputs = inputs } - ref <- case filter (isAddress address) (txOutRefs tx) of - [(_, ref)] -> pure ref - [] -> throwOtherError ("Tx has no Marlowe contract of address " - <> Text.pack (show address)) - _ -> throwOtherError ("Tx has multiple contracts of address " - <> Text.pack (show address)) - - let scriptIn = scriptTxIn ref validator redeemer dataValue let computedResult = computeTransaction txInput marloweState marloweContract - - ((deducedTxOutputs, dataValues), marloweData) <- case computedResult of + case computedResult of TransactionOutput {txOutPayments, txOutState, txOutContract} -> do let marloweData = MarloweData { marloweContract = txOutContract, marloweState = txOutState } - let deducedTxOutputsAndDataValues = case txOutContract of - Close -> txPaymentOuts txOutPayments + let (deducedTxOutputs, finalBalance) = case txOutContract of + Close -> (txPaymentOuts txOutPayments, P.zero) _ -> let - (payouts, dataValues) = txPaymentOuts txOutPayments - totalPayouts = foldMap txOutValue payouts + txWithPayouts = txPaymentOuts txOutPayments + totalPayouts = foldMap (\(Payment _ v) -> v) txOutPayments finalBalance = totalIncome P.- totalPayouts - dataValue = Datum (PlutusTx.toData marloweData) - scriptOut = scriptTxOut finalBalance validator dataValue - in (scriptOut : payouts, dataValue : dataValues) - - return (deducedTxOutputsAndDataValues, marloweData) - Error txError -> throwOtherError (Text.pack $ show txError) + in (txWithPayouts, finalBalance) + let constraints = inputsConstraints <> deducedTxOutputs <> mustValidateIn range + if preconditionsOk + then Just (constraints, SM.State marloweData finalBalance) + else Nothing + Error _ -> Nothing + where + validateInputWitness :: CurrencySymbol -> Input -> TxConstraints Void Void + validateInputWitness rolesCurrency input = + case input of + IDeposit _ party _ _ -> validatePartyWitness party + IChoice (ChoiceId _ party) _ -> validatePartyWitness party + INotify -> mempty + where + validatePartyWitness (PK pk) = mustBeSignedBy pk + validatePartyWitness (Role role) = mustSpendValue (Val.singleton rolesCurrency role 1) - Wallet.Payment{paymentInputs, paymentChangeOutput} <- if totalIncome `Val.gt` P.zero - then createPaymentWithChange totalIncome - else return Wallet.emptyPayment - - tx <- createTxAndSubmit - slotRange - (Set.insert scriptIn paymentInputs) - (deducedTxOutputs ++ maybeToList paymentChangeOutput) - dataValues + validateInputs :: MarloweParams -> [Input] -> TxConstraints Void Void + validateInputs MarloweParams{..} = foldMap (validateInputWitness rolesCurrency) - return (marloweData, tx) - where + collectDeposits :: Input -> Val.Value collectDeposits (IDeposit _ _ (Token cur tok) amount) = Val.singleton cur tok amount collectDeposits _ = P.zero + totalIncome :: Val.Value totalIncome = foldMap collectDeposits inputs - isAddress address (TxOut{txOutAddress}, _) = txOutAddress == address - - rolePayoutScriptAddress :: Address - rolePayoutScriptAddress = scriptAddress rolePayoutScript - - txPaymentOuts :: [Payment] -> ([TxOut], [Datum]) + txPaymentOuts :: [Payment] -> TxConstraints i0 o0 txPaymentOuts payments = foldMap paymentToTxOut paymentsByParty where paymentsByParty = Map.toList $ foldr collectPayments Map.empty payments paymentToTxOut (party, value) = case party of - PK pk -> ([pubKeyHashTxOut value pk], []) + PK pk -> mustPayToPubKey pk value Role role -> let dataValue = Datum $ PlutusTx.toData (rolesCurrency params, role) - txout = scriptTxOut' value rolePayoutScriptAddress dataValue - in ([txout], [dataValue]) + in mustPayToOtherScript (rolePayoutValidatorHash params) dataValue value collectPayments :: Payment -> Map Party Money -> Map Party Money collectPayments (Payment party money) payments = let @@ -242,37 +241,39 @@ applyInputs tx params marloweData@MarloweData{..} inputs = do in Map.insert party newValue payments -rolePayoutScript :: Validator -rolePayoutScript = mkValidatorScript ($$(PlutusTx.compile [|| wrapped ||])) - where - wrapped = Scripts.wrapValidator rolePayoutValidator +{-# INLINABLE isFinal #-} +isFinal :: MarloweData -> Bool +isFinal MarloweData{marloweContract=c} = c P.== Close -{-# INLINABLE rolePayoutValidator #-} -rolePayoutValidator :: (CurrencySymbol, TokenName) -> () -> ValidatorCtx -> Bool -rolePayoutValidator (currency, role) _ ctx = - Val.valueOf (valueSpent (valCtxTxInfo ctx)) currency role P.> 0 +{-# INLINABLE mkValidator #-} +mkValidator :: MarloweParams -> Scripts.ValidatorType MarloweStateMachine +mkValidator p = SM.mkValidator $ SM.mkStateMachine (mkMarloweStateMachineTransition p) isFinal -marloweParams :: CurrencySymbol -> MarloweParams -marloweParams rolesCurrency = MarloweParams - { rolesCurrency = rolesCurrency - , rolePayoutValidatorHash = validatorHash rolePayoutScript } +mkMarloweValidatorCode + :: MarloweParams + -> PlutusTx.CompiledCode PLC.DefaultUni (Scripts.ValidatorType MarloweStateMachine) +mkMarloweValidatorCode params = + $$(PlutusTx.compile [|| mkValidator ||]) `PlutusTx.applyCode` PlutusTx.liftCode params -defaultMarloweParams :: MarloweParams -defaultMarloweParams = marloweParams adaSymbol +type MarloweStateMachine = StateMachine MarloweData MarloweInput +scriptInstance :: MarloweParams -> Scripts.ScriptInstance MarloweStateMachine +scriptInstance params = Scripts.validator @MarloweStateMachine + (mkMarloweValidatorCode params) + $$(PlutusTx.compile [|| wrap ||]) + where + wrap = Scripts.wrapValidator @MarloweData @MarloweInput -{-| Generate a validator script for given Marlowe params -} -validatorScript :: MarloweParams -> Validator -validatorScript params = mkValidatorScript ($$(PlutusTx.compile [|| validatorParam ||]) - `PlutusTx.applyCode` - PlutusTx.liftCode params) - where - validatorParam k = Scripts.wrapValidator (marloweValidator k) + +mkMachineInstance :: MarloweParams -> SM.StateMachineInstance MarloweData MarloweInput +mkMachineInstance params = + SM.StateMachineInstance + (SM.mkStateMachine (mkMarloweStateMachineTransition params) isFinal) + (scriptInstance params) -{-| Make redeemer script -} -mkRedeemer :: [Input] -> Redeemer -mkRedeemer inputs = Redeemer (PlutusTx.toData inputs) +mkMarloweClient :: MarloweParams -> SM.StateMachineClient MarloweData MarloweInput +mkMarloweClient params = SM.mkStateMachineClient (mkMachineInstance params) diff --git a/marlowe/src/Language/Marlowe/Semantics.hs b/marlowe/src/Language/Marlowe/Semantics.hs index 337b4f507d9..5e1d6511063 100644 --- a/marlowe/src/Language/Marlowe/Semantics.hs +++ b/marlowe/src/Language/Marlowe/Semantics.hs @@ -287,7 +287,7 @@ data Input = IDeposit AccountId Party Token Integer | IChoice ChoiceId ChosenNum | INotify deriving stock (Show,P.Eq,Generic) - deriving anyclass (Pretty) + deriving anyclass (Pretty,FromJSON,ToJSON) {-| Slot interval errors. @@ -421,7 +421,9 @@ data MarloweData = MarloweData { data MarloweParams = MarloweParams { rolePayoutValidatorHash :: ValidatorHash, rolesCurrency :: CurrencySymbol - } deriving stock (Show) + } + deriving stock (Show,Generic) + deriving anyclass (FromJSON,ToJSON) -- | Empty State for a given minimal 'Slot' diff --git a/marlowe/test/Spec/Marlowe/Marlowe.hs b/marlowe/test/Spec/Marlowe/Marlowe.hs index 6d269ed692a..b4b4bd6ea7a 100644 --- a/marlowe/test/Spec/Marlowe/Marlowe.hs +++ b/marlowe/test/Spec/Marlowe/Marlowe.hs @@ -3,6 +3,8 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + {-# OPTIONS_GHC -w #-} module Spec.Marlowe.Marlowe ( prop_noFalsePositives, tests, prop_showWorksForContracts, runManuallySameAsOldImplementation, prop_jsonLoops @@ -11,52 +13,39 @@ where import Control.Exception (SomeException, catch) import Data.Maybe (isJust) -import Language.Marlowe (ada, applyInputs, createContract, defaultMarloweParams, deposit, - makeProgress, marloweParams, notify, rolePayoutScript, - validatorScript) import Language.Marlowe.Analysis.FSSemantics +import Language.Marlowe.Client import Language.Marlowe.Semantics -import Ledger (pubKeyHash) +import Language.Marlowe.Util import qualified OldAnalysis.FSSemantics as OldAnalysis import System.IO.Unsafe (unsafePerformIO) -import Control.Lens (view) -import Control.Monad (void) -import qualified Control.Monad.Freer as Eff import Data.Aeson (decode, encode) import qualified Data.ByteString as BS import Data.Either (isRight) -import qualified Data.Map.Strict as Map import Data.Ratio ((%)) import Data.String import qualified Codec.CBOR.Write as Write import qualified Codec.Serialise as Serialise -import qualified Hedgehog import Language.Haskell.Interpreter (Extension (OverloadedStrings), MonadInterpreter, OptionVal ((:=)), as, interpret, languageExtensions, runInterpreter, set, setImports) +import Language.Plutus.Contract.Test +import Language.PlutusTx.Lattice + import qualified Language.PlutusTx.Prelude as P import Ledger hiding (Value) -import Ledger.Ada (adaValueOf) -import qualified Ledger.Generators as Gen -import qualified Ledger.Value as Val +import Ledger.Ada (lovelaceValueOf) +import Ledger.Typed.Scripts (scriptHash, validatorScript) import Spec.Marlowe.Common import Test.Tasty -import Test.Tasty.Hedgehog (HedgehogTestLimit (..)) -import qualified Test.Tasty.Hedgehog as Hedgehog import Test.Tasty.HUnit import Test.Tasty.QuickCheck -import Wallet.Emulator -import qualified Wallet.Emulator.Generators as Gen -import Wallet.Emulator.MultiAgent (EmulatedWalletEffects) {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} {-# ANN module ("HLint: ignore Redundant if" :: String) #-} -limitedProperty :: TestName -> Hedgehog.Property -> TestTree -limitedProperty a b = localOption (HedgehogTestLimit $ Just 3) $ Hedgehog.testProperty a b - tests :: TestTree tests = testGroup "Marlowe" [ testCase "Contracts with different creators have different hashes" uniqueContractHash @@ -72,107 +61,83 @@ tests = testGroup "Marlowe" , testProperty "Scale Value multiplies by a constant rational" scaleMulTest , testProperty "Multiply by zero" mulTest , testProperty "Scale rounding" scaleRoundingTest - , limitedProperty "Zero Coupon Bond Contract" zeroCouponBondTest - , limitedProperty "Zero Coupon Bond w/ Roles Contract" zeroCouponBondRolesTest - , limitedProperty "Trust Fund Contract" trustFundTest - , limitedProperty "Make progress Contract" makeProgressTest + , zeroCouponBondTest + , trustFundTest ] -alice, bob, carol :: Wallet +alice, bob :: Wallet alice = Wallet 1 bob = Wallet 2 -carol = Wallet 3 -zeroCouponBondTest :: Hedgehog.Property -zeroCouponBondTest = checkMarloweTrace (MarloweScenario { - mlInitialBalances = Map.fromList - [ (walletPubKey alice, adaValueOf 1000), (walletPubKey bob, adaValueOf 1000) ] }) $ do +zeroCouponBondTest :: TestTree +zeroCouponBondTest = checkPredicate @MarloweSchema @MarloweError "Zero Coupon Bond Contract" marlowePlutusContract + (assertNoFailedTransactions + -- /\ emulatorLog (const False) "" + /\ assertDone alice (const True) "contract should close" + /\ assertDone bob (const True) "contract should close" + /\ walletFundsChange alice (lovelaceValueOf (150)) + /\ walletFundsChange bob (lovelaceValueOf (-150)) + ) $ do -- Init a contract - let alicePk = PK $ pubKeyHash $ walletPubKey alice + let alicePk = PK $ (pubKeyHash $ walletPubKey alice) aliceAcc = AccountId 0 alicePk - bobPk = PK $ pubKeyHash $ walletPubKey bob - update = updateAll [alice, bob] - update + bobPk = PK $ (pubKeyHash $ walletPubKey bob) let params = defaultMarloweParams let zeroCouponBond = When [ Case - (Deposit aliceAcc alicePk ada (Constant 850_000_000)) - (Pay aliceAcc (Party bobPk) ada (Constant 850_000_000) + (Deposit aliceAcc alicePk ada (Constant 850)) + (Pay aliceAcc (Party bobPk) ada (Constant 850) (When - [ Case (Deposit aliceAcc bobPk ada (Constant 1000_000_000)) - (Pay aliceAcc (Party alicePk) ada (Constant 1000_000_000) - Close) - ] (Slot 200) Close + [ Case (Deposit aliceAcc bobPk ada (Constant 1000)) Close] (Slot 200) Close ))] (Slot 100) Close + callEndpoint @"create" alice (params, zeroCouponBond) + handleBlockchainEvents alice + addBlocks 1 + handleBlockchainEvents alice - let performs = performNotify [alice, bob] - (md, tx) <- alice `performs` createContract params zeroCouponBond - (md, tx) <- alice `performs` deposit tx params md aliceAcc ada 850_000_000 - bob `performs` deposit tx params md aliceAcc ada 1000_000_000 + callEndpoint @"wait" bob (params) + handleBlockchainEvents bob - assertOwnFundsEq alice (adaValueOf 1150) - assertOwnFundsEq bob (adaValueOf 850) + callEndpoint @"apply-inputs" alice (params, [IDeposit aliceAcc alicePk ada 850]) + handleBlockchainEvents alice + addBlocks 1 + handleBlockchainEvents alice + callEndpoint @"wait" alice (params) -aliceToken :: Val.Value -aliceToken = Val.singleton "11" "alice" 1 + handleBlockchainEvents bob + callEndpoint @"apply-inputs" bob (params, [IDeposit aliceAcc bobPk ada 1000]) -bobToken :: Val.Value -bobToken = Val.singleton "11" "bob" 1 + handleBlockchainEvents alice + handleBlockchainEvents bob + addBlocks 1 + handleBlockchainEvents alice + handleBlockchainEvents bob -zeroCouponBondRolesTest :: Hedgehog.Property -zeroCouponBondRolesTest = checkMarloweTrace (MarloweScenario { - mlInitialBalances = Map.fromList - [ (walletPubKey alice, adaValueOf 1000 <> aliceToken) - , (walletPubKey bob, adaValueOf 1000 <> bobToken) ] }) $ do - -- Init a contract - let aliceRole = Role "alice" - aliceAcc = AccountId 0 aliceRole - bobRole = Role "bob" - update = updateAll [alice, bob] - update - - let params = marloweParams "11" - - let zeroCouponBond = When [ Case - (Deposit aliceAcc aliceRole ada (Constant 850_000_000)) - (Pay aliceAcc (Party bobRole) ada (Constant 850_000_000) - (When - [ Case (Deposit aliceAcc bobRole ada (Constant 1000_000_000)) - (Pay aliceAcc (Party aliceRole) ada (Constant 1000_000_000) - Close) - ] (Slot 200) Close - ))] (Slot 100) Close - let performs = performNotify [alice, bob] - (md, tx) <- alice `performs` createContract params zeroCouponBond - (md, tx) <- alice `performs` applyInputs tx params md [IDeposit aliceAcc aliceRole ada 850_000_000] - bob `performs` applyInputs tx params md [IDeposit aliceAcc bobRole ada 1000_000_000] - - assertOwnFundsEq alice (adaValueOf 150 <> aliceToken) - assertOwnFundsEq bob (adaValueOf 0 <> bobToken) - - -trustFundTest :: Hedgehog.Property -trustFundTest = checkMarloweTrace (MarloweScenario { - mlInitialBalances = Map.fromList - [ (walletPubKey alice, adaValueOf 1000), (walletPubKey bob, adaValueOf 1000) ] }) $ do +trustFundTest :: TestTree +trustFundTest = checkPredicate @MarloweSchema @MarloweError "Trust Fund Contract" marlowePlutusContract + (assertNoFailedTransactions + -- /\ emulatorLog (const False) "" + /\ assertDone alice (const True) "contract should close" + /\ assertDone bob (const True) "contract should close" + /\ walletFundsChange alice (lovelaceValueOf (-256)) + /\ walletFundsChange bob (lovelaceValueOf (256)) + ) $ do -- Init a contract let alicePk = PK $ pubKeyHash $ walletPubKey alice aliceAcc = AccountId 0 alicePk bobPk = PK $ pubKeyHash $ walletPubKey bob - update = updateAll [alice, bob] - update let params = defaultMarloweParams let chId = ChoiceId "1" alicePk let contract = When [ - Case (Choice chId [Bound 100_000000 1500_000000]) + Case (Choice chId [Bound 100 1500]) (When [Case (Deposit aliceAcc alicePk ada (ChoiceValue chId)) (When [Case (Notify (SlotIntervalStart `ValueGE` Constant 150)) @@ -182,46 +147,33 @@ trustFundTest = checkMarloweTrace (MarloweScenario { ] (Slot 200) Close) ] (Slot 100) Close - let performs = performNotify [alice, bob] - (md, tx) <- alice `performs` createContract params contract - (md, tx) <- alice `performs` applyInputs tx params md - [ IChoice chId 256_000000 - , IDeposit aliceAcc alicePk ada 256_000000] - addBlocksAndNotify [alice, bob] 150 - bob `performs` notify tx params md - - assertOwnFundsEq alice (adaValueOf 744) - assertOwnFundsEq bob (adaValueOf 1256) + callEndpoint @"create" alice (params, contract) + handleBlockchainEvents alice + addBlocks 1 + handleBlockchainEvents alice + callEndpoint @"wait" bob (params) + handleBlockchainEvents bob -makeProgressTest :: Hedgehog.Property -makeProgressTest = checkMarloweTrace (MarloweScenario { - mlInitialBalances = Map.fromList - [ (walletPubKey alice, adaValueOf 1000), (walletPubKey bob, adaValueOf 1000) ] }) $ do - -- Init a contract - let alicePk = PK $ pubKeyHash $ walletPubKey alice - aliceAcc = AccountId 0 alicePk - bobPk = PK $ pubKeyHash $ walletPubKey bob - update = updateAll [alice, bob] - update + callEndpoint @"apply-inputs" alice (params, + [ IChoice chId 256 + , IDeposit aliceAcc alicePk ada 256 + ]) + handleBlockchainEvents alice + addBlocks 150 + handleBlockchainEvents alice - let params = defaultMarloweParams + callEndpoint @"wait" alice (params) - let contract = If (SlotIntervalStart `ValueLT` Constant 10) - (When [Case (Deposit aliceAcc alicePk ada (Constant 500_000000)) - (Pay aliceAcc (Party bobPk) ada - (AvailableMoney aliceAcc ada) Close) - ] (Slot 100) Close) - Close + handleBlockchainEvents bob - let performs = performNotify [alice, bob] - (md, tx) <- alice `performs` createContract params contract - addBlocksAndNotify [alice, bob] 5 - (md, tx) <- alice `performs` makeProgress tx params md - void $ alice `performs` deposit tx params md aliceAcc ada 500_000000 + callEndpoint @"apply-inputs" bob (params, [INotify]) - assertOwnFundsEq alice (adaValueOf 500) - assertOwnFundsEq bob (adaValueOf 1500) + handleBlockchainEvents alice + handleBlockchainEvents bob + addBlocks 1 + handleBlockchainEvents alice + handleBlockchainEvents bob uniqueContractHash :: IO () @@ -230,40 +182,18 @@ uniqueContractHash = do { rolesCurrency = cs , rolePayoutValidatorHash = validatorHash rolePayoutScript } - let hash1 = validatorHash $ validatorScript (params "11") - let hash2 = validatorHash $ validatorScript (params "22") - let hash3 = validatorHash $ validatorScript (params "22") + let hash1 = scriptHash $ scriptInstance (params "11") + let hash2 = scriptHash $ scriptInstance (params "22") + let hash3 = scriptHash $ scriptInstance (params "22") assertBool "Hashes must be different" (hash1 /= hash2) assertBool "Hashes must be same" (hash2 == hash3) validatorSize :: IO () validatorSize = do - let validator = validatorScript defaultMarloweParams + let validator = validatorScript $ scriptInstance defaultMarloweParams let vsize = BS.length $ Write.toStrictByteString (Serialise.encode validator) - assertBool "Validator is too large" (vsize < 700000) - - --- | Run a trace with the given scenario and check that the emulator finished --- successfully with an empty transaction pool. -checkMarloweTrace :: MarloweScenario -> Eff.Eff EmulatorEffs () -> Hedgehog.Property -checkMarloweTrace MarloweScenario{mlInitialBalances} t = Hedgehog.property $ do - let model = Gen.generatorModel { Gen.gmInitialBalance = mlInitialBalances } - (result, st) <- Hedgehog.forAll $ Gen.runTraceOn model t - Hedgehog.assert (isRight result) - Hedgehog.assert (null (view (chainState . txPool) st)) - - -updateAll :: [Wallet] -> Eff.Eff EmulatorEffs () -updateAll wallets = processPending >>= void . walletsNotifyBlock wallets - - -performNotify :: [Wallet] -> Wallet -> Eff.Eff EmulatedWalletEffects (MarloweData, Tx) -> Eff.Eff EmulatorEffs (MarloweData, Tx) -performNotify wallets actor action = do - (md, tx) <- walletAction actor action - processPending >>= void . walletsNotifyBlock wallets - assertIsValidated tx - return (md, tx) + assertBool ("Validator is too large " <> show vsize) (vsize < 1100000) checkEqValue :: Property @@ -305,6 +235,7 @@ valuesFormAbelianGroup = property $ do -- substraction works eval (SubValue (AddValue a b) b) === eval a + scaleRoundingTest :: Property scaleRoundingTest = property $ do let eval = evalValue (Environment (Slot 10, Slot 1000)) (emptyState (Slot 10)) @@ -317,18 +248,21 @@ scaleRoundingTest = property $ do where halfAwayRound fraction = let (n,f) = properFraction fraction in n + round (f + 1) - 1 + scaleMulTest :: Property scaleMulTest = property $ do let eval = evalValue (Environment (Slot 10, Slot 1000)) (emptyState (Slot 10)) forAll valueGen $ \a -> eval (Scale (0 P.% 1) a) === 0 .&&. eval (Scale (1 P.% 1) a) === eval a + mulTest :: Property mulTest = property $ do let eval = evalValue (Environment (Slot 10, Slot 1000)) (emptyState (Slot 10)) forAll valueGen $ \a -> eval (MulValue (Constant 0) a) === 0 + valueSerialization :: Property valueSerialization = property $ forAll valueGen $ \a -> @@ -336,6 +270,7 @@ valueSerialization = property $ decoded = decode $ encode a in Just a === decoded + mulAnalysisTest :: IO () mulAnalysisTest = do let muliply = foldl (\a _ -> MulValue (UseValue $ ValueId "a") a) (Constant 1) [1..100] @@ -382,6 +317,7 @@ stateSerialization = do prop_showWorksForContracts :: Property prop_showWorksForContracts = forAllShrink contractGen shrinkContract showWorksForContract + showWorksForContract :: Contract -> Property showWorksForContract contract = unsafePerformIO $ do res <- runInterpreter $ setImports ["Language.Marlowe"] @@ -391,9 +327,11 @@ showWorksForContract contract = unsafePerformIO $ do Right x -> x === contract Left err -> counterexample (show err) False) + interpretContractString :: MonadInterpreter m => String -> m Contract interpretContractString contractStr = interpret contractStr (as :: Contract) + noFalsePositivesForContract :: Contract -> Property noFalsePositivesForContract cont = unsafePerformIO (do res <- catch (wrapLeft $ warningsTrace cont) diff --git a/nix/stack.materialized/marlowe.nix b/nix/stack.materialized/marlowe.nix index d6fe1e7c223..f6a27270dcd 100644 --- a/nix/stack.materialized/marlowe.nix +++ b/nix/stack.materialized/marlowe.nix @@ -38,11 +38,13 @@ (hsPkgs."bytestring" or (errorHandler.buildDepError "bytestring")) (hsPkgs."containers" or (errorHandler.buildDepError "containers")) (hsPkgs."deriving-aeson" or (errorHandler.buildDepError "deriving-aeson")) + (hsPkgs."lens" or (errorHandler.buildDepError "lens")) (hsPkgs."mtl" or (errorHandler.buildDepError "mtl")) (hsPkgs."newtype-generics" or (errorHandler.buildDepError "newtype-generics")) (hsPkgs."template-haskell" or (errorHandler.buildDepError "template-haskell")) (hsPkgs."plutus-tx" or (errorHandler.buildDepError "plutus-tx")) (hsPkgs."plutus-contract" or (errorHandler.buildDepError "plutus-contract")) + (hsPkgs."plutus-core" or (errorHandler.buildDepError "plutus-core")) (hsPkgs."plutus-ledger" or (errorHandler.buildDepError "plutus-ledger")) (hsPkgs."text" or (errorHandler.buildDepError "text")) (hsPkgs."vector" or (errorHandler.buildDepError "vector")) @@ -71,7 +73,6 @@ (hsPkgs."aeson" or (errorHandler.buildDepError "aeson")) (hsPkgs."base" or (errorHandler.buildDepError "base")) (hsPkgs."containers" or (errorHandler.buildDepError "containers")) - (hsPkgs."hedgehog" or (errorHandler.buildDepError "hedgehog")) (hsPkgs."hint" or (errorHandler.buildDepError "hint")) (hsPkgs."lens" or (errorHandler.buildDepError "lens")) (hsPkgs."memory" or (errorHandler.buildDepError "memory")) @@ -80,7 +81,6 @@ (hsPkgs."tasty" or (errorHandler.buildDepError "tasty")) (hsPkgs."tasty-hunit" or (errorHandler.buildDepError "tasty-hunit")) (hsPkgs."tasty-quickcheck" or (errorHandler.buildDepError "tasty-quickcheck")) - (hsPkgs."tasty-hedgehog" or (errorHandler.buildDepError "tasty-hedgehog")) (hsPkgs."text" or (errorHandler.buildDepError "text")) (hsPkgs."serialise" or (errorHandler.buildDepError "serialise")) (hsPkgs."cborg" or (errorHandler.buildDepError "cborg"))