From b767404e5b70c400bdebf1bce15c82f80f41da48 Mon Sep 17 00:00:00 2001 From: Jann Mueller Date: Thu, 11 Oct 2018 12:10:36 +0200 Subject: [PATCH] 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,