mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-11-25 08:12:00 +01:00
test suite
This commit is contained in:
parent
f1664d6c31
commit
64d795fbb2
5 changed files with 80 additions and 21 deletions
|
@ -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"
|
||||||
|
|
|
@ -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
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 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)
|
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue