mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-11-13 10:22:34 +01:00
test suite
This commit is contained in:
Lars Brünjes
parent
f1664d6c31
commit
64d795fbb2
5 changed files with 80 additions and 21 deletions
|
|
@ -2,3 +2,5 @@ cradle:
|
|||
cabal:
|
||||
- path: "./src"
|
||||
component: "lib:plutus-pioneer-program-week08"
|
||||
- path: "./test"
|
||||
component: "test:plutus-pioneer-program-week08-tests"
|
||||
|
|
|
|||
|
|
@ -11,14 +11,9 @@ License-files: LICENSE
|
|||
library
|
||||
hs-source-dirs: src
|
||||
exposed-modules: Week08.TokenSale
|
||||
, Week08.TestTokenSale
|
||||
, Week08.TraceTokenSale
|
||||
build-depends: aeson
|
||||
, base ^>=4.14.1.0
|
||||
, containers
|
||||
, data-default
|
||||
, freer-extras
|
||||
, lens
|
||||
, playground-common
|
||||
, plutus-contract
|
||||
, plutus-ledger
|
||||
|
|
@ -27,7 +22,30 @@ library
|
|||
, plutus-tx
|
||||
, plutus-use-cases
|
||||
, prettyprinter
|
||||
, QuickCheck
|
||||
, text
|
||||
default-language: Haskell2010
|
||||
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
16
code/week08/test/Spec.hs
Normal 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
|
||||
]
|
||||
|
|
@ -14,7 +14,10 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Week08.TestTokenSale where
|
||||
module Spec.Model
|
||||
( tests
|
||||
, test
|
||||
) where
|
||||
|
||||
import Control.Lens hiding (elements)
|
||||
import Control.Monad (void, when)
|
||||
|
|
@ -31,6 +34,8 @@ import Ledger hiding (singleton)
|
|||
import Ledger.Ada as Ada
|
||||
import Ledger.Value
|
||||
import Test.QuickCheck
|
||||
import Test.Tasty
|
||||
import Test.Tasty.QuickCheck
|
||||
|
||||
import Week08.TokenSale (TokenSale (..), TSStartSchema', TSUseSchema, startEndpoint', useEndpoints, nftName)
|
||||
|
||||
|
|
@ -47,6 +52,9 @@ newtype TSModel = TSModel {_tsModel :: Map Wallet TSState}
|
|||
|
||||
makeLenses ''TSModel
|
||||
|
||||
tests :: TestTree
|
||||
tests = testProperty "token sale model" prop_TS
|
||||
|
||||
instance ContractModel TSModel where
|
||||
|
||||
data Action TSModel =
|
||||
|
|
@ -126,8 +134,11 @@ instance ContractModel TSModel where
|
|||
(BuyTokens v w n) -> callEndpoint @"buy tokens" (h $ UseKey v w) n >> 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 _ _ = True
|
||||
precondition s (Start w) = isNothing $ getTSState' s w
|
||||
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 Show (ContractInstanceKey TSModel w s e)
|
||||
|
|
@ -193,7 +204,7 @@ tokenAmt :: Integer
|
|||
tokenAmt = 1_000
|
||||
|
||||
prop_TS :: Actions TSModel -> Property
|
||||
prop_TS = withMaxSuccess 1000 . propRunActionsWithOptions
|
||||
prop_TS = withMaxSuccess 100 . propRunActionsWithOptions
|
||||
(defaultCheckOptions & emulatorConfig .~ EmulatorConfig (Left d))
|
||||
instanceSpec
|
||||
(const $ pure True)
|
||||
|
|
@ -12,8 +12,12 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Week08.TraceTokenSale where
|
||||
module Spec.Trace
|
||||
( tests
|
||||
, runMyTrace
|
||||
) where
|
||||
|
||||
import Control.Lens
|
||||
import Control.Monad hiding (fmap)
|
||||
import Control.Monad.Freer.Extras as Extras
|
||||
import Data.Default (Default (..))
|
||||
|
|
@ -22,24 +26,32 @@ import Data.Monoid (Last (..))
|
|||
import Ledger
|
||||
import Ledger.Value
|
||||
import Ledger.Ada as Ada
|
||||
import Plutus.Contract.Test
|
||||
import Plutus.Trace.Emulator as Emulator
|
||||
import PlutusTx.Prelude
|
||||
import Prelude (IO, String, Show (..))
|
||||
import Wallet.Emulator.Wallet
|
||||
import Test.Tasty
|
||||
|
||||
import Week08.TokenSale
|
||||
|
||||
test :: IO ()
|
||||
test = runEmulatorTraceIO' def emCfg myTrace
|
||||
where
|
||||
emCfg :: EmulatorConfig
|
||||
emCfg = EmulatorConfig $ Left $ Map.fromList
|
||||
[ (Wallet w, v)
|
||||
| w <- [1 .. 3]
|
||||
]
|
||||
tests :: TestTree
|
||||
tests = checkPredicateOptions
|
||||
(defaultCheckOptions & emulatorConfig .~ emCfg)
|
||||
"token sale trace"
|
||||
( walletFundsChange (Wallet 1) (Ada.lovelaceValueOf 10_000_000 <> assetClassValue token (-60))
|
||||
.&&. walletFundsChange (Wallet 2) (Ada.lovelaceValueOf (-20_000_000) <> assetClassValue token 20)
|
||||
.&&. 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 = Ada.lovelaceValueOf 1000_000_000 <> assetClassValue token 1000
|
||||
v = Ada.lovelaceValueOf 1000_000_000 <> assetClassValue token 1000
|
||||
|
||||
currency :: CurrencySymbol
|
||||
currency = "aa"
|
||||
Loading…
Reference in a new issue