test suite

This commit is contained in:
Lars Brünjes 2021-05-26 00:34:34 +02:00
parent f1664d6c31
commit 64d795fbb2
No known key found for this signature in database
GPG key ID: B488B9045DC1A087
5 changed files with 80 additions and 21 deletions

View file

@ -2,3 +2,5 @@ cradle:
cabal: cabal:
- path: "./src" - path: "./src"
component: "lib:plutus-pioneer-program-week08" component: "lib:plutus-pioneer-program-week08"
- path: "./test"
component: "test:plutus-pioneer-program-week08-tests"

View file

@ -11,14 +11,9 @@ License-files: LICENSE
library library
hs-source-dirs: src hs-source-dirs: src
exposed-modules: Week08.TokenSale exposed-modules: Week08.TokenSale
, Week08.TestTokenSale
, Week08.TraceTokenSale
build-depends: aeson build-depends: aeson
, base ^>=4.14.1.0 , base ^>=4.14.1.0
, containers , containers
, data-default
, freer-extras
, lens
, playground-common , playground-common
, plutus-contract , plutus-contract
, plutus-ledger , plutus-ledger
@ -27,7 +22,30 @@ library
, plutus-tx , plutus-tx
, plutus-use-cases , plutus-use-cases
, prettyprinter , prettyprinter
, QuickCheck
, text , text
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fno-strictness -fno-spec-constr -fno-specialise ghc-options: -Wall -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fno-strictness -fno-spec-constr -fno-specialise
test-suite plutus-pioneer-program-week08-tests
type: exitcode-stdio-1.0
main-is: Spec.hs
hs-source-dirs: test
other-modules: Spec.Model
, Spec.Trace
default-language: Haskell2010
ghc-options: -Wall -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas
build-depends: base ^>=4.14.1.0
, containers
, data-default
, freer-extras
, lens
, plutus-contract
, plutus-ledger
, plutus-pioneer-program-week08
, plutus-tx
, QuickCheck
, tasty
, tasty-quickcheck
, text
if !(impl(ghcjs) || os(ghcjs))
build-depends: plutus-tx-plugin -any

16
code/week08/test/Spec.hs Normal file
View file

@ -0,0 +1,16 @@
module Main
( main
) where
import qualified Spec.Model
import qualified Spec.Trace
import Test.Tasty
main :: IO ()
main = defaultMain tests
tests :: TestTree
tests = testGroup "token sale"
[ Spec.Trace.tests
, Spec.Model.tests
]

View file

@ -14,7 +14,10 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
module Week08.TestTokenSale where module Spec.Model
( tests
, test
) where
import Control.Lens hiding (elements) import Control.Lens hiding (elements)
import Control.Monad (void, when) import Control.Monad (void, when)
@ -31,6 +34,8 @@ import Ledger hiding (singleton)
import Ledger.Ada as Ada import Ledger.Ada as Ada
import Ledger.Value import Ledger.Value
import Test.QuickCheck import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck
import Week08.TokenSale (TokenSale (..), TSStartSchema', TSUseSchema, startEndpoint', useEndpoints, nftName) import Week08.TokenSale (TokenSale (..), TSStartSchema', TSUseSchema, startEndpoint', useEndpoints, nftName)
@ -47,6 +52,9 @@ newtype TSModel = TSModel {_tsModel :: Map Wallet TSState}
makeLenses ''TSModel makeLenses ''TSModel
tests :: TestTree
tests = testProperty "token sale model" prop_TS
instance ContractModel TSModel where instance ContractModel TSModel where
data Action TSModel = data Action TSModel =
@ -127,7 +135,10 @@ instance ContractModel TSModel where
(Withdraw v w n l) -> callEndpoint @"withdraw" (h $ UseKey v w) (n, l) >> delay 1 (Withdraw v w n l) -> callEndpoint @"withdraw" (h $ UseKey v w) (n, l) >> delay 1
precondition s (Start w) = isNothing $ getTSState' s w precondition s (Start w) = isNothing $ getTSState' s w
precondition _ _ = True precondition s (SetPrice v _ _) = isJust $ getTSState' s v
precondition s (AddTokens v _ _) = isJust $ getTSState' s v
precondition s (BuyTokens v _ _) = isJust $ getTSState' s v
precondition s (Withdraw v _ _ _) = isJust $ getTSState' s v
deriving instance Eq (ContractInstanceKey TSModel w s e) deriving instance Eq (ContractInstanceKey TSModel w s e)
deriving instance Show (ContractInstanceKey TSModel w s e) deriving instance Show (ContractInstanceKey TSModel w s e)
@ -193,7 +204,7 @@ tokenAmt :: Integer
tokenAmt = 1_000 tokenAmt = 1_000
prop_TS :: Actions TSModel -> Property prop_TS :: Actions TSModel -> Property
prop_TS = withMaxSuccess 1000 . propRunActionsWithOptions prop_TS = withMaxSuccess 100 . propRunActionsWithOptions
(defaultCheckOptions & emulatorConfig .~ EmulatorConfig (Left d)) (defaultCheckOptions & emulatorConfig .~ EmulatorConfig (Left d))
instanceSpec instanceSpec
(const $ pure True) (const $ pure True)

View file

@ -12,8 +12,12 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
module Week08.TraceTokenSale where module Spec.Trace
( tests
, runMyTrace
) where
import Control.Lens
import Control.Monad hiding (fmap) import Control.Monad hiding (fmap)
import Control.Monad.Freer.Extras as Extras import Control.Monad.Freer.Extras as Extras
import Data.Default (Default (..)) import Data.Default (Default (..))
@ -22,22 +26,30 @@ import Data.Monoid (Last (..))
import Ledger import Ledger
import Ledger.Value import Ledger.Value
import Ledger.Ada as Ada import Ledger.Ada as Ada
import Plutus.Contract.Test
import Plutus.Trace.Emulator as Emulator import Plutus.Trace.Emulator as Emulator
import PlutusTx.Prelude import PlutusTx.Prelude
import Prelude (IO, String, Show (..)) import Prelude (IO, String, Show (..))
import Wallet.Emulator.Wallet import Test.Tasty
import Week08.TokenSale import Week08.TokenSale
test :: IO () tests :: TestTree
test = runEmulatorTraceIO' def emCfg myTrace tests = checkPredicateOptions
where (defaultCheckOptions & emulatorConfig .~ emCfg)
emCfg :: EmulatorConfig "token sale trace"
emCfg = EmulatorConfig $ Left $ Map.fromList ( walletFundsChange (Wallet 1) (Ada.lovelaceValueOf 10_000_000 <> assetClassValue token (-60))
[ (Wallet w, v) .&&. walletFundsChange (Wallet 2) (Ada.lovelaceValueOf (-20_000_000) <> assetClassValue token 20)
| w <- [1 .. 3] .&&. walletFundsChange (Wallet 3) (Ada.lovelaceValueOf (- 5_000_000) <> assetClassValue token 5)
] )
myTrace
runMyTrace :: IO ()
runMyTrace = runEmulatorTraceIO' def emCfg myTrace
emCfg :: EmulatorConfig
emCfg = EmulatorConfig $ Left $ Map.fromList [(Wallet w, v) | w <- [1 .. 3]]
where
v :: Value v :: Value
v = Ada.lovelaceValueOf 1000_000_000 <> assetClassValue token 1000 v = Ada.lovelaceValueOf 1000_000_000 <> assetClassValue token 1000