From b767404e5b70c400bdebf1bce15c82f80f41da48 Mon Sep 17 00:00:00 2001 From: Jann Mueller Date: Thu, 11 Oct 2018 12:10:36 +0200 Subject: [PATCH 1/3] use-cases: Add TH module for tests * Add a Spec.TH module with quoted expressions for creating `PendingTx` values --- .hlint.yaml | 2 +- pkgs/default.nix | 1 + plutus-use-cases/plutus-use-cases.cabal | 4 +- .../Coordination/Contracts/CrowdFunding.hs | 13 ++-- plutus-use-cases/test/Spec/Crowdfunding.hs | 57 +++++------------ plutus-use-cases/test/Spec/TH.hs | 50 +++++++++++++++ plutus-use-cases/test/Spec/Vesting.hs | 62 ++++++++++--------- 7 files changed, 110 insertions(+), 79 deletions(-) create mode 100644 plutus-use-cases/test/Spec/TH.hs diff --git a/.hlint.yaml b/.hlint.yaml index 7007ce9378a..9c93fbd4748 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -33,7 +33,7 @@ - ignore: {name: Parse error} - ignore: {name: Eta reduce, within: [Language.PlutusCore.MkPlc]} # PLC plugin only accepts lists that are constructed in a certain way -- ignore: {name: Use list literal, within: [Spec.Crowdfunding]} +- ignore: {name: Use list literal, within: [Spec.TH]} # PLC plugin requires && to be defined in side TH splices - ignore: {name: Redundant if, within: [Language.Plutus.Coordination.Contracts.CrowdFunding, Language.Plutus.Coordination.Contracts.Vesting]} diff --git a/pkgs/default.nix b/pkgs/default.nix index 151abbaf3e7..1bcd81e8a0e 100644 --- a/pkgs/default.nix +++ b/pkgs/default.nix @@ -55719,6 +55719,7 @@ microlens plutus-th tasty tasty-hedgehog +template-haskell text wallet-api ]; diff --git a/plutus-use-cases/plutus-use-cases.cabal b/plutus-use-cases/plutus-use-cases.cabal index 3b47409d0c7..d898c2b5cb0 100644 --- a/plutus-use-cases/plutus-use-cases.cabal +++ b/plutus-use-cases/plutus-use-cases.cabal @@ -56,6 +56,7 @@ test-suite plutus-use-cases-test other-modules: Spec.Crowdfunding Spec.Vesting + Spec.TH build-depends: base >=4.9 && <5, containers -any, @@ -67,4 +68,5 @@ test-suite plutus-use-cases-test plutus-use-cases, plutus-th -any, microlens -any, - core-to-plc -any \ No newline at end of file + core-to-plc -any, + template-haskell -any \ No newline at end of file diff --git a/plutus-use-cases/src/Language/Plutus/Coordination/Contracts/CrowdFunding.hs b/plutus-use-cases/src/Language/Plutus/Coordination/Contracts/CrowdFunding.hs index 5bde333b99d..355bf5c76a0 100644 --- a/plutus-use-cases/src/Language/Plutus/Coordination/Contracts/CrowdFunding.hs +++ b/plutus-use-cases/src/Language/Plutus/Coordination/Contracts/CrowdFunding.hs @@ -2,12 +2,13 @@ -- This is the fully parallel version that collects all contributions -- in a single transaction. This is, of course, limited by the maximum -- number of inputs a transaction can have. -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS -fplugin=Language.Plutus.CoreToPLC.Plugin -fplugin-opt Language.Plutus.CoreToPLC.Plugin:dont-typecheck #-} module Language.Plutus.Coordination.Contracts.CrowdFunding ( -- * Campaign parameters diff --git a/plutus-use-cases/test/Spec/Crowdfunding.hs b/plutus-use-cases/test/Spec/Crowdfunding.hs index a0ce1fcbda0..6b1a8e8da06 100644 --- a/plutus-use-cases/test/Spec/Crowdfunding.hs +++ b/plutus-use-cases/test/Spec/Crowdfunding.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS -fplugin=Language.Plutus.CoreToPLC.Plugin -fplugin-opt Language.Plutus.CoreToPLC.Plugin:dont-typecheck #-} module Spec.Crowdfunding(tests) where @@ -23,11 +25,12 @@ import qualified Wallet.Generators as Gen import Language.Plutus.Coordination.Contracts.CrowdFunding (Campaign (..), CampaignActor, CampaignPLC (..), contribute, refund) import qualified Language.Plutus.Coordination.Contracts.CrowdFunding as CF -import Language.Plutus.CoreToPLC.Plugin (plc) -import Language.Plutus.Runtime (Hash (..), PendingTx (..), PendingTxIn (..), - PendingTxOut (..), PendingTxOutRef (..), Value) +import qualified Language.Plutus.Runtime as Runtime +import Language.Plutus.TH (plutus) import qualified Wallet.UTXO as UTXO +import Spec.TH (pendingTxCrowdfunding) + tests :: TestTree tests = testGroup "crowdfunding" [ testProperty "make a contribution" makeContribution, @@ -40,7 +43,7 @@ tests = testGroup "crowdfunding" [ -- | Make a contribution to the campaign from a wallet. Returns the reference -- to the transaction output that is locked by the campaign's validator -- script (and can be collected by the campaign owner) -contrib :: Wallet -> CampaignPLC -> Value -> Trace TxOutRef' +contrib :: Wallet -> CampaignPLC -> Runtime.Value -> Trace TxOutRef' contrib w c v = exContrib <$> walletAction w (contribute c v) where exContrib = snd . head . filter (isPayToScriptOut . fst) . txOutRefs . head @@ -72,14 +75,7 @@ successfulCampaign = checkCFTrace scenario1 $ do con2 <- contrib w2 c 600 con3 <- contrib w3 c 800 updateAll' - setValidationData $ ValidationData $ plc PendingTx { - pendingTxCurrentInput = (PendingTxIn (PendingTxOutRef 100 1) (), 600), - pendingTxOtherInputs = (PendingTxIn (PendingTxOutRef 200 1) (), 800):[], - pendingTxOutputs = []::[PendingTxOut CampaignActor], - pendingTxForge = 0, - pendingTxFee = 0, - pendingTxBlockHeight = 11 - } + setValidationData $ ValidationData $(plutus [| $(pendingTxCrowdfunding) 11 600 (Just 800) |]) collect w1 c [(con2, w2, 600), (con3, w3, 800)] updateAll' mapM_ (uncurry assertOwnFundsEq) [(w2, 400), (w3, 200), (w1, 1400)] @@ -93,14 +89,7 @@ cantCollectEarly = checkCFTrace scenario1 $ do con2 <- contrib w2 c 600 con3 <- contrib w3 c 800 updateAll' - setValidationData $ ValidationData $ plc PendingTx { - pendingTxCurrentInput = (PendingTxIn (PendingTxOutRef 100 1) (), 600), - pendingTxOtherInputs = (PendingTxIn (PendingTxOutRef 200 1) (), 800):[], - pendingTxOutputs = []::[PendingTxOut CampaignActor], - pendingTxForge = 0, - pendingTxFee = 0, - pendingTxBlockHeight = 8 - } + setValidationData $ ValidationData $(plutus [| $(pendingTxCrowdfunding) 8 600 (Just 800) |]) collect w1 c [(con2, w2, 600), (con3, w3, 800)] updateAll' mapM_ (uncurry assertOwnFundsEq) [(w2, 400), (w3, 200), (w1, 0)] @@ -116,14 +105,7 @@ cantCollectLate = checkCFTrace scenario1 $ do con2 <- contrib w2 c 600 con3 <- contrib w3 c 800 updateAll' - setValidationData $ ValidationData $ plc PendingTx { - pendingTxCurrentInput = (PendingTxIn (PendingTxOutRef 100 1) (), 600), - pendingTxOtherInputs = (PendingTxIn (PendingTxOutRef 200 1) (), 800):[], - pendingTxOutputs = []::[PendingTxOut CampaignActor], - pendingTxForge = 0, - pendingTxFee = 0, - pendingTxBlockHeight = 17 - } + setValidationData $ ValidationData $(plutus [| $(pendingTxCrowdfunding) 17 600 (Just 800) |]) collect w1 c [(con2, w2, 600), (con3, w3, 800)] updateAll' mapM_ (uncurry assertOwnFundsEq) [(w2, 400), (w3, 200), (w1, 0)] @@ -138,14 +120,7 @@ canRefund = checkCFTrace scenario1 $ do con2 <- contrib w2 c 600 con3 <- contrib w3 c 800 updateAll' - setValidationData $ ValidationData $ plc PendingTx { - pendingTxCurrentInput = (PendingTxIn (PendingTxOutRef 100 1) (), 600), - pendingTxOtherInputs = []::[(PendingTxIn (), Value)], - pendingTxOutputs = []::[PendingTxOut CampaignActor], - pendingTxForge = 0, - pendingTxFee = 0, - pendingTxBlockHeight = 18 - } + setValidationData $ ValidationData $(plutus [| $(pendingTxCrowdfunding) 18 600 Nothing |]) walletAction w2 (refund c con2 600) walletAction w3 (refund c con3 800) updateAll' @@ -160,12 +135,12 @@ data CFScenario = CFScenario { scenario1 :: CFScenario scenario1 = CFScenario{..} where - cfCampaign = CampaignPLC $ plc Campaign { + cfCampaign = CampaignPLC $(plutus [| Campaign { campaignDeadline = 10, campaignTarget = 1000, campaignCollectionDeadline = 15, campaignOwner = PubKey 1 - } + } |]) cfWallets = Wallet <$> [1..3] cfInitialBalances = Map.fromList [ (PubKey 1, 0), diff --git a/plutus-use-cases/test/Spec/TH.hs b/plutus-use-cases/test/Spec/TH.hs new file mode 100644 index 00000000000..1fa98ae1261 --- /dev/null +++ b/plutus-use-cases/test/Spec/TH.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +-- | Quoted expressions for generating validation data +module Spec.TH( + pendingTxVesting, + pendingTxCrowdfunding + ) where + +import Language.Haskell.TH (Exp, Q) +import qualified Language.Plutus.CoreToPLC.Primitives as Prim +import Language.Plutus.Runtime (Hash (..), Height, PendingTx (..), + PendingTxIn (..), PendingTxOut (..), + PendingTxOutRef (..), PendingTxOutType (..), + Value) +import Wallet.API (PubKey (..)) + +import Language.Plutus.Coordination.Contracts.CrowdFunding (CampaignActor) +import Language.Plutus.Coordination.Contracts.Vesting (VestingData (..)) + +-- | Create a `PendingTx () VestingData` from a block height and a value +-- (of funds taken out of the scheme) +pendingTxVesting :: Q Exp +pendingTxVesting = [| \(h :: Height) (out :: Value) -> + let total = 600 + rest = total - out + in PendingTx { + pendingTxCurrentInput = (PendingTxIn (PendingTxOutRef 100 0) (), 600), + pendingTxOtherInputs = []::[(PendingTxIn (), Value)], + pendingTxOutputs = (PendingTxOut out Nothing (PubKeyTxOut (PubKey 1))::(PendingTxOut VestingData)):(PendingTxOut rest (Just (VestingData 1123 out)) DataTxOut::(PendingTxOut VestingData)):([]::[PendingTxOut VestingData]), + pendingTxForge = 0, + pendingTxFee = 0, + pendingTxBlockHeight = h + } |] + +-- | Create a `PendingTx () CampaignActor` from a block height and one or two inputs. +pendingTxCrowdfunding :: Q Exp +pendingTxCrowdfunding = [| \(h :: Height) (v1::Value) (v2::Maybe Value) -> + let i1 = (PendingTxIn (PendingTxOutRef 100 1) (), v1) + i2 = case v2 of + Just v2' -> (PendingTxIn (PendingTxOutRef 200 1) (), v2'):[] + Nothing -> []::[(PendingTxIn (), Value)] + in PendingTx { + pendingTxCurrentInput = i1, + pendingTxOtherInputs = i2, + pendingTxOutputs = []::[PendingTxOut CampaignActor], + pendingTxForge = 0, + pendingTxFee = 0, + pendingTxBlockHeight = h + } + |] diff --git a/plutus-use-cases/test/Spec/Vesting.hs b/plutus-use-cases/test/Spec/Vesting.hs index 41da0eb97b4..77f169d8278 100644 --- a/plutus-use-cases/test/Spec/Vesting.hs +++ b/plutus-use-cases/test/Spec/Vesting.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS -fplugin=Language.Plutus.CoreToPLC.Plugin -fplugin-opt Language.Plutus.CoreToPLC.Plugin:dont-typecheck #-} module Spec.Vesting(tests) where @@ -16,26 +17,27 @@ import Test.Tasty.Hedgehog (testProperty) import Language.Plutus.Coordination.Contracts.Vesting (Vesting (..), VestingData (..), VestingPLC (..), VestingTranche (..), retrieveFunds, vestFunds) -import Language.Plutus.Runtime (Hash (..), PendingTx (..), PendingTxIn (..), - PendingTxOut (..), PendingTxOutRef (..), - PendingTxOutType (..), Value) +import qualified Language.Plutus.Runtime as Runtime import Language.Plutus.TH (plutus) import Wallet.API (PubKey (..)) import Wallet.Emulator hiding (Value) import qualified Wallet.Generators as Gen import qualified Wallet.UTXO as UTXO +import Spec.TH (pendingTxVesting) + tests :: TestTree tests = testGroup "vesting" [ testProperty "secure some funds with the vesting script" secureFunds, testProperty "retrieve some funds" canRetrieveFunds, - testProperty "cannot retrieve more than allowed" cannotRetrieveTooMuch + testProperty "cannot retrieve more than allowed" cannotRetrieveTooMuch, + testProperty "can retrieve everything at end" canRetrieveFundsAtEnd ] -- | Commit some funds from a wallet to a vesting scheme. Returns the reference -- to the transaction output that is locked by the schemes's validator -- script (and can be collected by the scheme's owner) -commit :: Wallet -> Vesting -> VestingPLC -> Value -> Trace TxOutRef' +commit :: Wallet -> Vesting -> VestingPLC -> Runtime.Value -> Trace TxOutRef' commit w vv vplc vl = exScriptOut <$> walletAction w (void $ vestFunds vplc vv vl) where exScriptOut = snd . head . filter (isPayToScriptOut . fst) . txOutRefs . head @@ -49,6 +51,7 @@ secureFunds = checkVestingTrace scen1 $ do updateAll' mapM_ (uncurry assertOwnFundsEq) [(w2, 400), (w1, 1000)] + canRetrieveFunds :: Property canRetrieveFunds = checkVestingTrace scen1 $ do let VestingScenario splc s [w1, w2] _ = scen1 @@ -57,14 +60,7 @@ canRetrieveFunds = checkVestingTrace scen1 $ do updateAll' ref <- commit w2 s splc total updateAll' - setValidationData $ ValidationData $(plutus [| PendingTx { - pendingTxCurrentInput = (PendingTxIn (PendingTxOutRef 100 0) (), 600), - pendingTxOtherInputs = []::[(PendingTxIn (), Value)], - pendingTxOutputs = (PendingTxOut 150 Nothing (PubKeyTxOut (PubKey 1))::(PendingTxOut VestingData)):(PendingTxOut 450 (Just (VestingData 1123 150)) DataTxOut::(PendingTxOut VestingData)):([]::[PendingTxOut VestingData]), - pendingTxForge = 0, - pendingTxFee = 0, - pendingTxBlockHeight = 11 - } |]) + setValidationData $ ValidationData $(plutus [| $(pendingTxVesting) 11 150 |]) let ds = DataScript $(plutus [| VestingData 1123 150 |]) walletAction w1 $ void (retrieveFunds s splc (VestingData 1123 0) ds ref 150) updateAll' @@ -78,22 +74,28 @@ cannotRetrieveTooMuch = checkVestingTrace scen1 $ do updateAll' ref <- commit w2 s splc total updateAll' - setValidationData $ ValidationData $(plutus [| - - let tooMuch = 250 in -- at block height 11, not more than 200 may be taken out - PendingTx { - pendingTxCurrentInput = (PendingTxIn (PendingTxOutRef 100 0) (), 600), - pendingTxOtherInputs = []::[(PendingTxIn (), Value)], - pendingTxOutputs = (PendingTxOut tooMuch Nothing (PubKeyTxOut (PubKey 1))::(PendingTxOut VestingData)):(PendingTxOut 350 (Just (VestingData 1123 250)) DataTxOut::(PendingTxOut VestingData)):([]::[PendingTxOut VestingData]), - pendingTxForge = 0, - pendingTxFee = 0, - pendingTxBlockHeight = 11 - } |]) - let ds = DataScript $(plutus [| VestingData 1123 150 |]) - walletAction w1 $ void (retrieveFunds s splc (VestingData 1123 0) ds ref 300) + -- at block height 11, not more than 200 may be taken out + setValidationData $ ValidationData $(plutus [| $(pendingTxVesting) 11 250 |]) + let ds = DataScript $(plutus [| VestingData 1123 250 |]) + walletAction w1 $ void (retrieveFunds s splc (VestingData 1123 0) ds ref 250) updateAll' mapM_ (uncurry assertOwnFundsEq) [(w2, 400), (w1, 1000)] +canRetrieveFundsAtEnd :: Property +canRetrieveFundsAtEnd = checkVestingTrace scen1 $ do + let VestingScenario splc s [w1, w2] _ = scen1 + total = 600 + updateAll' = updateAll scen1 + updateAll' + ref <- commit w2 s splc total + updateAll' + -- everything can be taken out at h=21 + setValidationData $ ValidationData $(plutus [| $(pendingTxVesting) 21 600 |]) + let ds = DataScript $(plutus [| VestingData 1123 600 |]) + walletAction w1 $ void (retrieveFunds s splc (VestingData 1123 0) ds ref 600) + updateAll' + mapM_ (uncurry assertOwnFundsEq) [(w2, 400), (w1, 1600)] + -- | Vesting scenario with test parameters data VestingScenario = VestingScenario { vsVestingSchemePLC :: VestingPLC, From 530da1c082a55306e9728d050a60062145aba220 Mon Sep 17 00:00:00 2001 From: Jann Mueller Date: Thu, 11 Oct 2018 15:06:33 +0200 Subject: [PATCH 2/3] use-cases: Fewer magic numbers --- .../Plutus/Coordination/Contracts/Vesting.hs | 3 +- plutus-use-cases/test/Spec/Crowdfunding.hs | 18 ++++++---- plutus-use-cases/test/Spec/TH.hs | 5 +-- plutus-use-cases/test/Spec/Vesting.hs | 35 ++++++++++++------- wallet-api/src/Wallet/UTXO.hs | 1 - 5 files changed, 39 insertions(+), 23 deletions(-) diff --git a/plutus-use-cases/src/Language/Plutus/Coordination/Contracts/Vesting.hs b/plutus-use-cases/src/Language/Plutus/Coordination/Contracts/Vesting.hs index 5b11954403c..1e9217ffba2 100644 --- a/plutus-use-cases/src/Language/Plutus/Coordination/Contracts/Vesting.hs +++ b/plutus-use-cases/src/Language/Plutus/Coordination/Contracts/Vesting.hs @@ -11,7 +11,8 @@ module Language.Plutus.Coordination.Contracts.Vesting ( VestingData(..), vestFunds, retrieveFunds, - validatorScript + validatorScript, + totalAmount ) where import Control.Monad.Error.Class (MonadError (..)) diff --git a/plutus-use-cases/test/Spec/Crowdfunding.hs b/plutus-use-cases/test/Spec/Crowdfunding.hs index 6b1a8e8da06..17a73407f12 100644 --- a/plutus-use-cases/test/Spec/Crowdfunding.hs +++ b/plutus-use-cases/test/Spec/Crowdfunding.hs @@ -59,7 +59,7 @@ makeContribution :: Property makeContribution = checkCFTrace scenario1 $ do let w = Wallet 2 contribution = 600 - rest = fromIntegral $ 1000 - contribution + rest = startingBalance - fromIntegral contribution blockchainActions >>= walletNotifyBlock w contrib w (cfCampaign scenario1) contribution blockchainActions >>= walletNotifyBlock w @@ -78,7 +78,7 @@ successfulCampaign = checkCFTrace scenario1 $ do setValidationData $ ValidationData $(plutus [| $(pendingTxCrowdfunding) 11 600 (Just 800) |]) collect w1 c [(con2, w2, 600), (con3, w3, 800)] updateAll' - mapM_ (uncurry assertOwnFundsEq) [(w2, 400), (w3, 200), (w1, 1400)] + mapM_ (uncurry assertOwnFundsEq) [(w2, startingBalance - 600), (w3, startingBalance - 800), (w1, 600 + 800)] -- | Check that the campaign owner cannot collect the monies before the campaign deadline cantCollectEarly :: Property @@ -92,7 +92,7 @@ cantCollectEarly = checkCFTrace scenario1 $ do setValidationData $ ValidationData $(plutus [| $(pendingTxCrowdfunding) 8 600 (Just 800) |]) collect w1 c [(con2, w2, 600), (con3, w3, 800)] updateAll' - mapM_ (uncurry assertOwnFundsEq) [(w2, 400), (w3, 200), (w1, 0)] + mapM_ (uncurry assertOwnFundsEq) [(w2, startingBalance - 600), (w3, startingBalance - 800), (w1, 0)] -- | Check that the campaign owner cannot collect the monies after the @@ -108,7 +108,7 @@ cantCollectLate = checkCFTrace scenario1 $ do setValidationData $ ValidationData $(plutus [| $(pendingTxCrowdfunding) 17 600 (Just 800) |]) collect w1 c [(con2, w2, 600), (con3, w3, 800)] updateAll' - mapM_ (uncurry assertOwnFundsEq) [(w2, 400), (w3, 200), (w1, 0)] + mapM_ (uncurry assertOwnFundsEq) [(w2, startingBalance - 600), (w3, startingBalance - 800), (w1, 0)] -- | Run a successful campaign that ends with a refund @@ -124,7 +124,7 @@ canRefund = checkCFTrace scenario1 $ do walletAction w2 (refund c con2 600) walletAction w3 (refund c con3 800) updateAll' - mapM_ (uncurry assertOwnFundsEq) [(w2, 1000), (w3, 1000), (w1, 0)] + mapM_ (uncurry assertOwnFundsEq) [(w2, startingBalance), (w3, startingBalance), (w1, 0)] -- | Crowdfunding scenario with test parameters data CFScenario = CFScenario { @@ -144,8 +144,12 @@ scenario1 = CFScenario{..} where cfWallets = Wallet <$> [1..3] cfInitialBalances = Map.fromList [ (PubKey 1, 0), - (PubKey 2, 1000), - (PubKey 3, 1000)] + (PubKey 2, startingBalance), + (PubKey 3, startingBalance)] + +-- | Funds available to wallets `Wallet 2` and `Wallet 3` +startingBalance :: UTXO.Value +startingBalance = 1000 -- | Run a trace with the given scenario and check that the emulator finished -- successfully with an empty transaction pool. diff --git a/plutus-use-cases/test/Spec/TH.hs b/plutus-use-cases/test/Spec/TH.hs index 1fa98ae1261..05f1e3e6dc4 100644 --- a/plutus-use-cases/test/Spec/TH.hs +++ b/plutus-use-cases/test/Spec/TH.hs @@ -22,11 +22,12 @@ import Language.Plutus.Coordination.Contracts.Vesting (VestingDat pendingTxVesting :: Q Exp pendingTxVesting = [| \(h :: Height) (out :: Value) -> let total = 600 + hash = 1123 -- stand-in for a transaction hash rest = total - out in PendingTx { - pendingTxCurrentInput = (PendingTxIn (PendingTxOutRef 100 0) (), 600), + pendingTxCurrentInput = (PendingTxIn (PendingTxOutRef 100 0) (), total), pendingTxOtherInputs = []::[(PendingTxIn (), Value)], - pendingTxOutputs = (PendingTxOut out Nothing (PubKeyTxOut (PubKey 1))::(PendingTxOut VestingData)):(PendingTxOut rest (Just (VestingData 1123 out)) DataTxOut::(PendingTxOut VestingData)):([]::[PendingTxOut VestingData]), + pendingTxOutputs = (PendingTxOut out Nothing (PubKeyTxOut (PubKey 1))::(PendingTxOut VestingData)):(PendingTxOut rest (Just (VestingData hash out)) DataTxOut::(PendingTxOut VestingData)):([]::[PendingTxOut VestingData]), pendingTxForge = 0, pendingTxFee = 0, pendingTxBlockHeight = h diff --git a/plutus-use-cases/test/Spec/Vesting.hs b/plutus-use-cases/test/Spec/Vesting.hs index 77f169d8278..7a88eec10ba 100644 --- a/plutus-use-cases/test/Spec/Vesting.hs +++ b/plutus-use-cases/test/Spec/Vesting.hs @@ -16,7 +16,8 @@ import Test.Tasty import Test.Tasty.Hedgehog (testProperty) import Language.Plutus.Coordination.Contracts.Vesting (Vesting (..), VestingData (..), VestingPLC (..), - VestingTranche (..), retrieveFunds, vestFunds) + VestingTranche (..), retrieveFunds, totalAmount, + vestFunds) import qualified Language.Plutus.Runtime as Runtime import Language.Plutus.TH (plutus) import Wallet.API (PubKey (..)) @@ -44,32 +45,29 @@ commit w vv vplc vl = exScriptOut <$> walletAction w (void $ vestFunds vplc vv v secureFunds :: Property secureFunds = checkVestingTrace scen1 $ do let VestingScenario splc s [w1, w2] _ = scen1 - total = 600 updateAll' = updateAll scen1 updateAll' _ <- commit w2 s splc total updateAll' - mapM_ (uncurry assertOwnFundsEq) [(w2, 400), (w1, 1000)] - + mapM_ (uncurry assertOwnFundsEq) [(w2, w2Funds), (w1, startingBalance)] canRetrieveFunds :: Property canRetrieveFunds = checkVestingTrace scen1 $ do let VestingScenario splc s [w1, w2] _ = scen1 - total = 600 updateAll' = updateAll scen1 updateAll' ref <- commit w2 s splc total updateAll' setValidationData $ ValidationData $(plutus [| $(pendingTxVesting) 11 150 |]) let ds = DataScript $(plutus [| VestingData 1123 150 |]) + -- Take 150 out of the scheme walletAction w1 $ void (retrieveFunds s splc (VestingData 1123 0) ds ref 150) updateAll' - mapM_ (uncurry assertOwnFundsEq) [(w2, 400), (w1, 1150)] + mapM_ (uncurry assertOwnFundsEq) [(w2, w2Funds), (w1, startingBalance + 150)] cannotRetrieveTooMuch :: Property cannotRetrieveTooMuch = checkVestingTrace scen1 $ do let VestingScenario splc s [w1, w2] _ = scen1 - total = 600 updateAll' = updateAll scen1 updateAll' ref <- commit w2 s splc total @@ -79,12 +77,11 @@ cannotRetrieveTooMuch = checkVestingTrace scen1 $ do let ds = DataScript $(plutus [| VestingData 1123 250 |]) walletAction w1 $ void (retrieveFunds s splc (VestingData 1123 0) ds ref 250) updateAll' - mapM_ (uncurry assertOwnFundsEq) [(w2, 400), (w1, 1000)] + mapM_ (uncurry assertOwnFundsEq) [(w2, w2Funds), (w1, startingBalance)] canRetrieveFundsAtEnd :: Property canRetrieveFundsAtEnd = checkVestingTrace scen1 $ do let VestingScenario splc s [w1, w2] _ = scen1 - total = 600 updateAll' = updateAll scen1 updateAll' ref <- commit w2 s splc total @@ -94,7 +91,7 @@ canRetrieveFundsAtEnd = checkVestingTrace scen1 $ do let ds = DataScript $(plutus [| VestingData 1123 600 |]) walletAction w1 $ void (retrieveFunds s splc (VestingData 1123 0) ds ref 600) updateAll' - mapM_ (uncurry assertOwnFundsEq) [(w2, 400), (w1, 1600)] + mapM_ (uncurry assertOwnFundsEq) [(w2, w2Funds), (w1, startingBalance + fromIntegral total)] -- | Vesting scenario with test parameters data VestingScenario = VestingScenario { @@ -117,8 +114,22 @@ scen1 = VestingScenario{..} where vestingOwner = PubKey 1 } vsWallets = Wallet <$> [1..2] vsInitialBalances = Map.fromList [ - (PubKey 1, 1000), - (PubKey 2, 1000)] + (PubKey 1, startingBalance), + (PubKey 2, startingBalance)] + +-- | Funds available to each wallet after the initial transaction on the +-- mockchain +startingBalance :: UTXO.Value +startingBalance = 1000 + +-- | Amount of money left in wallet `Wallet 2` after committing funds to the +-- vesting scheme +w2Funds :: UTXO.Value +w2Funds = startingBalance - fromIntegral total + +-- | Total amount of money vested in the scheme `scen1` +total :: Runtime.Value +total = totalAmount $ vsVestingScheme scen1 -- | Run a trace with the given scenario and check that the emulator finished -- successfully with an empty transaction pool. diff --git a/wallet-api/src/Wallet/UTXO.hs b/wallet-api/src/Wallet/UTXO.hs index a089d99789a..6e27ee4eb43 100644 --- a/wallet-api/src/Wallet/UTXO.hs +++ b/wallet-api/src/Wallet/UTXO.hs @@ -612,7 +612,6 @@ runScript (ValidationData (getAst -> valData)) (Validator (getAst -> validator)) -- TODO: Enable type checking of the program -- void typecheck - -- | () as a data script unitData :: DataScript unitData = DataScript $(plutus [| () |]) From 2bc8e774f0d65a4b5df079e135d9d2375f326db5 Mon Sep 17 00:00:00 2001 From: Jann Mueller Date: Thu, 11 Oct 2018 15:34:45 +0200 Subject: [PATCH 3/3] use-cases: traverse_ --- plutus-use-cases/test/Spec/Crowdfunding.hs | 9 +++++---- plutus-use-cases/test/Spec/Vesting.hs | 9 +++++---- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/plutus-use-cases/test/Spec/Crowdfunding.hs b/plutus-use-cases/test/Spec/Crowdfunding.hs index 17a73407f12..fdb855fce12 100644 --- a/plutus-use-cases/test/Spec/Crowdfunding.hs +++ b/plutus-use-cases/test/Spec/Crowdfunding.hs @@ -8,6 +8,7 @@ module Spec.Crowdfunding(tests) where import Data.Bifunctor (Bifunctor (..)) import Data.Either (isLeft, isRight) +import Data.Foldable (traverse_) import qualified Data.Map as Map import Hedgehog (Property, forAll, property) import qualified Hedgehog @@ -78,7 +79,7 @@ successfulCampaign = checkCFTrace scenario1 $ do setValidationData $ ValidationData $(plutus [| $(pendingTxCrowdfunding) 11 600 (Just 800) |]) collect w1 c [(con2, w2, 600), (con3, w3, 800)] updateAll' - mapM_ (uncurry assertOwnFundsEq) [(w2, startingBalance - 600), (w3, startingBalance - 800), (w1, 600 + 800)] + traverse_ (uncurry assertOwnFundsEq) [(w2, startingBalance - 600), (w3, startingBalance - 800), (w1, 600 + 800)] -- | Check that the campaign owner cannot collect the monies before the campaign deadline cantCollectEarly :: Property @@ -92,7 +93,7 @@ cantCollectEarly = checkCFTrace scenario1 $ do setValidationData $ ValidationData $(plutus [| $(pendingTxCrowdfunding) 8 600 (Just 800) |]) collect w1 c [(con2, w2, 600), (con3, w3, 800)] updateAll' - mapM_ (uncurry assertOwnFundsEq) [(w2, startingBalance - 600), (w3, startingBalance - 800), (w1, 0)] + traverse_ (uncurry assertOwnFundsEq) [(w2, startingBalance - 600), (w3, startingBalance - 800), (w1, 0)] -- | Check that the campaign owner cannot collect the monies after the @@ -108,7 +109,7 @@ cantCollectLate = checkCFTrace scenario1 $ do setValidationData $ ValidationData $(plutus [| $(pendingTxCrowdfunding) 17 600 (Just 800) |]) collect w1 c [(con2, w2, 600), (con3, w3, 800)] updateAll' - mapM_ (uncurry assertOwnFundsEq) [(w2, startingBalance - 600), (w3, startingBalance - 800), (w1, 0)] + traverse_ (uncurry assertOwnFundsEq) [(w2, startingBalance - 600), (w3, startingBalance - 800), (w1, 0)] -- | Run a successful campaign that ends with a refund @@ -124,7 +125,7 @@ canRefund = checkCFTrace scenario1 $ do walletAction w2 (refund c con2 600) walletAction w3 (refund c con3 800) updateAll' - mapM_ (uncurry assertOwnFundsEq) [(w2, startingBalance), (w3, startingBalance), (w1, 0)] + traverse_ (uncurry assertOwnFundsEq) [(w2, startingBalance), (w3, startingBalance), (w1, 0)] -- | Crowdfunding scenario with test parameters data CFScenario = CFScenario { diff --git a/plutus-use-cases/test/Spec/Vesting.hs b/plutus-use-cases/test/Spec/Vesting.hs index 7a88eec10ba..ff9551f2962 100644 --- a/plutus-use-cases/test/Spec/Vesting.hs +++ b/plutus-use-cases/test/Spec/Vesting.hs @@ -8,6 +8,7 @@ module Spec.Vesting(tests) where import Control.Monad (void) import Data.Either (isRight) +import Data.Foldable (traverse_) import qualified Data.Map as Map import Hedgehog (Property, forAll, property) import qualified Hedgehog @@ -49,7 +50,7 @@ secureFunds = checkVestingTrace scen1 $ do updateAll' _ <- commit w2 s splc total updateAll' - mapM_ (uncurry assertOwnFundsEq) [(w2, w2Funds), (w1, startingBalance)] + traverse_ (uncurry assertOwnFundsEq) [(w2, w2Funds), (w1, startingBalance)] canRetrieveFunds :: Property canRetrieveFunds = checkVestingTrace scen1 $ do @@ -63,7 +64,7 @@ canRetrieveFunds = checkVestingTrace scen1 $ do -- Take 150 out of the scheme walletAction w1 $ void (retrieveFunds s splc (VestingData 1123 0) ds ref 150) updateAll' - mapM_ (uncurry assertOwnFundsEq) [(w2, w2Funds), (w1, startingBalance + 150)] + traverse_ (uncurry assertOwnFundsEq) [(w2, w2Funds), (w1, startingBalance + 150)] cannotRetrieveTooMuch :: Property cannotRetrieveTooMuch = checkVestingTrace scen1 $ do @@ -77,7 +78,7 @@ cannotRetrieveTooMuch = checkVestingTrace scen1 $ do let ds = DataScript $(plutus [| VestingData 1123 250 |]) walletAction w1 $ void (retrieveFunds s splc (VestingData 1123 0) ds ref 250) updateAll' - mapM_ (uncurry assertOwnFundsEq) [(w2, w2Funds), (w1, startingBalance)] + traverse_ (uncurry assertOwnFundsEq) [(w2, w2Funds), (w1, startingBalance)] canRetrieveFundsAtEnd :: Property canRetrieveFundsAtEnd = checkVestingTrace scen1 $ do @@ -91,7 +92,7 @@ canRetrieveFundsAtEnd = checkVestingTrace scen1 $ do let ds = DataScript $(plutus [| VestingData 1123 600 |]) walletAction w1 $ void (retrieveFunds s splc (VestingData 1123 0) ds ref 600) updateAll' - mapM_ (uncurry assertOwnFundsEq) [(w2, w2Funds), (w1, startingBalance + fromIntegral total)] + traverse_ (uncurry assertOwnFundsEq) [(w2, w2Funds), (w1, startingBalance + fromIntegral total)] -- | Vesting scenario with test parameters data VestingScenario = VestingScenario {