mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-11-25 00:02:18 +01:00
tests with multiple contract instances per wallet
This commit is contained in:
Lars Brünjes
parent
e583be0d3e
commit
f1664d6c31
3 changed files with 98 additions and 123 deletions
|
|
@ -22,6 +22,7 @@ import Data.Map (Map)
|
|||
import qualified Data.Map as Map
|
||||
import Data.Maybe (isJust, isNothing)
|
||||
import Data.Monoid (Last (..))
|
||||
import Data.String (IsString (..))
|
||||
import Data.Text (Text)
|
||||
import Plutus.Contract.Test
|
||||
import Plutus.Contract.Test.ContractModel
|
||||
|
|
@ -31,7 +32,7 @@ import Ledger.Ada as Ada
|
|||
import Ledger.Value
|
||||
import Test.QuickCheck
|
||||
|
||||
import Week08.TokenSale (TokenSale (..), TSOperateSchema', TSUseSchema, useTS, operateTS'', nftName)
|
||||
import Week08.TokenSale (TokenSale (..), TSStartSchema', TSUseSchema, startEndpoint', useEndpoints, nftName)
|
||||
|
||||
data TSState = TSState
|
||||
{ _tssPrice :: !Integer
|
||||
|
|
@ -50,22 +51,24 @@ instance ContractModel TSModel where
|
|||
|
||||
data Action TSModel =
|
||||
Start Wallet
|
||||
| SetPrice Wallet Integer
|
||||
| AddTokens Wallet Integer
|
||||
| Withdraw Wallet Integer Integer
|
||||
| SetPrice Wallet Wallet Integer
|
||||
| AddTokens Wallet Wallet Integer
|
||||
| Withdraw Wallet Wallet Integer Integer
|
||||
| BuyTokens Wallet Wallet Integer
|
||||
deriving (Show, Eq)
|
||||
|
||||
data ContractInstanceKey TSModel w s e where
|
||||
OperateKey :: Wallet -> ContractInstanceKey TSModel (Last TokenSale) TSOperateSchema' Text
|
||||
UseKey :: Wallet -> Wallet -> ContractInstanceKey TSModel () TSUseSchema Text
|
||||
StartKey :: Wallet -> ContractInstanceKey TSModel (Last TokenSale) TSStartSchema' Text
|
||||
UseKey :: Wallet -> Wallet -> ContractInstanceKey TSModel () TSUseSchema Text
|
||||
|
||||
instanceTag key _ = fromString $ "instance tag for: " ++ show key
|
||||
|
||||
arbitraryAction _ = oneof $
|
||||
(Start <$> genSeller) :
|
||||
[ SetPrice <$> genSeller <*> genNonNeg ] ++
|
||||
[ AddTokens <$> genSeller <*> genNonNeg ] ++
|
||||
[ Withdraw <$> genSeller <*> genNonNeg <*> genNonNeg ] ++
|
||||
[ BuyTokens <$> genSeller <*> genUser <*> genNonNeg ]
|
||||
(Start <$> genWallet) :
|
||||
[ SetPrice <$> genWallet <*> genWallet <*> genNonNeg ] ++
|
||||
[ AddTokens <$> genWallet <*> genWallet <*> genNonNeg ] ++
|
||||
[ BuyTokens <$> genWallet <*> genWallet <*> genNonNeg ] ++
|
||||
[ Withdraw <$> genWallet <*> genWallet <*> genNonNeg <*> genNonNeg ]
|
||||
|
||||
initialState = TSModel Map.empty
|
||||
|
||||
|
|
@ -74,18 +77,19 @@ instance ContractModel TSModel where
|
|||
(tsModel . at w) $= Just (TSState 0 0 0)
|
||||
wait 1
|
||||
|
||||
nextState (SetPrice w p) = do
|
||||
(tsModel . ix w . tssPrice) $= p
|
||||
nextState (SetPrice v w p) = do
|
||||
when (v == w) $
|
||||
(tsModel . ix v . tssPrice) $= p
|
||||
wait 1
|
||||
|
||||
nextState (AddTokens w n) = do
|
||||
started <- hasStarted w -- has the token sale started?
|
||||
nextState (AddTokens v w n) = do
|
||||
started <- hasStarted v -- has the token sale started?
|
||||
when (n > 0 && started) $ do
|
||||
bc <- askModelState $ view $ balanceChange w
|
||||
let token = tokens Map.! w
|
||||
let token = tokens Map.! v
|
||||
when (tokenAmt + assetClassValueOf bc token >= n) $ do -- does the wallet have the tokens to give?
|
||||
withdraw w $ assetClassValue token n
|
||||
(tsModel . ix w . tssToken) $~ (+ n)
|
||||
(tsModel . ix v . tssToken) $~ (+ n)
|
||||
wait 1
|
||||
|
||||
nextState (BuyTokens v w n) = do
|
||||
|
|
@ -103,23 +107,24 @@ instance ContractModel TSModel where
|
|||
_ -> return ()
|
||||
wait 1
|
||||
|
||||
nextState (Withdraw w n l) = do
|
||||
m <- getTSState w
|
||||
case m of
|
||||
Just t
|
||||
| t ^. tssToken >= n && t ^. tssLovelace >= l -> do
|
||||
deposit w $ lovelaceValueOf l <> assetClassValue (tokens Map.! w) n
|
||||
(tsModel . ix w . tssLovelace) $~ (+ (- l))
|
||||
(tsModel . ix w . tssToken) $~ (+ (- n))
|
||||
_ -> return ()
|
||||
nextState (Withdraw v w n l) = do
|
||||
when (v == w) $ do
|
||||
m <- getTSState v
|
||||
case m of
|
||||
Just t
|
||||
| t ^. tssToken >= n && t ^. tssLovelace >= l -> do
|
||||
deposit w $ lovelaceValueOf l <> assetClassValue (tokens Map.! w) n
|
||||
(tsModel . ix v . tssLovelace) $~ (+ (- l))
|
||||
(tsModel . ix v . tssToken) $~ (+ (- n))
|
||||
_ -> return ()
|
||||
wait 1
|
||||
|
||||
perform h _ cmd = case cmd of
|
||||
(Start w) -> callEndpoint @"start" (h $ OperateKey w) (css Map.! w, tokenCurrency, tokenNames Map.! w) >> delay 1
|
||||
(SetPrice w p) -> callEndpoint @"set price" (h $ OperateKey w) p >> delay 1
|
||||
(AddTokens w n) -> callEndpoint @"add tokens" (h $ OperateKey w) n >> delay 1
|
||||
(Withdraw w n l) -> callEndpoint @"withdraw" (h $ OperateKey w) (n, l) >> delay 1
|
||||
(BuyTokens v w n) -> callEndpoint @"buy tokens" (h $ UseKey v w) n >> delay 1
|
||||
(Start w) -> callEndpoint @"start" (h $ StartKey w) (nftCurrencies Map.! w, tokenCurrencies Map.! w, tokenNames Map.! w) >> delay 1
|
||||
(SetPrice v w p) -> callEndpoint @"set price" (h $ UseKey v w) p >> delay 1
|
||||
(AddTokens v w n) -> callEndpoint @"add tokens" (h $ UseKey v w) n >> delay 1
|
||||
(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
|
||||
|
|
@ -138,34 +143,36 @@ getTSState v = do
|
|||
hasStarted :: Wallet -> Spec TSModel Bool
|
||||
hasStarted v = isJust <$> getTSState v
|
||||
|
||||
w1, w2, w3, w4 :: Wallet
|
||||
w1, w2 :: Wallet
|
||||
w1 = Wallet 1
|
||||
w2 = Wallet 2
|
||||
w3 = Wallet 3
|
||||
w4 = Wallet 4
|
||||
|
||||
tokenCurrency :: CurrencySymbol
|
||||
tokenCurrency = "ff"
|
||||
|
||||
tokenNames :: Map Wallet TokenName
|
||||
tokenNames = Map.fromList [(w1, "A"), (w2, "B")]
|
||||
|
||||
tokens :: Map Wallet AssetClass
|
||||
tokens = (\tn -> AssetClass (tokenCurrency, tn)) <$> tokenNames
|
||||
|
||||
wallets :: [Wallet]
|
||||
wallets = [w1, w2, w3, w4]
|
||||
wallets = [w1, w2]
|
||||
|
||||
css :: Map Wallet CurrencySymbol
|
||||
css = Map.fromList [(w1, "01"), (w2, "02")]
|
||||
tokenCurrencies, nftCurrencies :: Map Wallet CurrencySymbol
|
||||
tokenCurrencies = Map.fromList $ zip wallets ["aa", "bb"]
|
||||
nftCurrencies = Map.fromList $ zip wallets ["01", "02"]
|
||||
|
||||
tokenNames :: Map Wallet TokenName
|
||||
tokenNames = Map.fromList $ zip wallets ["A", "B"]
|
||||
|
||||
tokens :: Map Wallet AssetClass
|
||||
tokens = Map.fromList [(w, AssetClass (tokenCurrencies Map.! w, tokenNames Map.! w)) | w <- wallets]
|
||||
|
||||
nftAssets :: Map Wallet AssetClass
|
||||
nftAssets = Map.fromList [(w, AssetClass (nftCurrencies Map.! w, nftName)) | w <- wallets]
|
||||
|
||||
nfts :: Map Wallet Value
|
||||
nfts = (\cs -> assetClassValue (AssetClass (cs, nftName)) 1) <$> css
|
||||
nfts = Map.fromList [(w, assetClassValue (nftAssets Map.! w) 1) | w <- wallets]
|
||||
|
||||
tss :: Map Wallet TokenSale
|
||||
tss = Map.fromList
|
||||
[ (w, TokenSale (pubKeyHash $ walletPubKey w) (tokens Map.! w) $ AssetClass (css Map.! w, nftName))
|
||||
| w <- [w1, w2]
|
||||
[ (w, TokenSale { tsSeller = pubKeyHash $ walletPubKey w
|
||||
, tsToken = tokens Map.! w
|
||||
, tsNFT = nftAssets Map.! w
|
||||
})
|
||||
| w <- wallets
|
||||
]
|
||||
|
||||
delay :: Int -> EmulatorTrace ()
|
||||
|
|
@ -173,12 +180,11 @@ delay = void . waitNSlots . fromIntegral
|
|||
|
||||
instanceSpec :: [ContractInstanceSpec TSModel]
|
||||
instanceSpec =
|
||||
[ContractInstanceSpec (OperateKey w) w $ operateTS'' | w <- [w1, w2]] ++
|
||||
[ContractInstanceSpec (UseKey v w) w $ useTS $ tss Map.! v | v <- [w1, w2], w <- [w3, w4]]
|
||||
[ContractInstanceSpec (StartKey w) w startEndpoint' | w <- wallets] ++
|
||||
[ContractInstanceSpec (UseKey v w) w $ useEndpoints $ tss Map.! v | v <- wallets, w <- wallets]
|
||||
|
||||
genSeller, genUser :: Gen Wallet
|
||||
genSeller = elements [w1, w2]
|
||||
genUser = elements [w3, w4]
|
||||
genWallet :: Gen Wallet
|
||||
genWallet = elements wallets
|
||||
|
||||
genNonNeg :: Gen Integer
|
||||
genNonNeg = getNonNegative <$> arbitrary
|
||||
|
|
@ -197,21 +203,8 @@ prop_TS = withMaxSuccess 1000 . propRunActionsWithOptions
|
|||
, lovelaceValueOf 1000_000_000 <>
|
||||
(nfts Map.! w) <>
|
||||
mconcat [assetClassValue t tokenAmt | t <- Map.elems tokens])
|
||||
| w <- [w1, w2]
|
||||
] ++
|
||||
[(w, lovelaceValueOf 1000_000_000) | w <- [w3, w4]]
|
||||
|
||||
| w <- wallets
|
||||
]
|
||||
|
||||
test :: IO ()
|
||||
test = quickCheck prop_TS
|
||||
|
||||
unitTest :: IO ()
|
||||
unitTest = quickCheck $ withMaxSuccess 1 $ prop_TS $ Actions
|
||||
[ Start (Wallet 1),
|
||||
SetPrice (Wallet 1) 2,
|
||||
AddTokens (Wallet 1) 4,
|
||||
BuyTokens (Wallet 1) (Wallet 3) 4,
|
||||
AddTokens (Wallet 1) 6,
|
||||
Withdraw (Wallet 1) 2 7
|
||||
]
|
||||
|
||||
|
|
|
|||
|
|
@ -15,12 +15,12 @@ module Week08.TokenSale
|
|||
( TokenSale (..)
|
||||
, TSRedeemer (..)
|
||||
, nftName
|
||||
, TSOperateSchema
|
||||
, TSOperateSchema'
|
||||
, TSStartSchema
|
||||
, TSStartSchema'
|
||||
, TSUseSchema
|
||||
, operateTS'
|
||||
, operateTS''
|
||||
, useTS
|
||||
, startEndpoint
|
||||
, startEndpoint'
|
||||
, useEndpoints
|
||||
) where
|
||||
|
||||
import Control.Monad hiding (fmap)
|
||||
|
|
@ -147,44 +147,30 @@ buyTokens ts n = void $ mapErrorSM $ runStep (tsClient ts) $ BuyTokens n
|
|||
withdraw :: HasBlockchainActions s => TokenSale -> Integer -> Integer -> Contract w s Text ()
|
||||
withdraw ts n l = void $ mapErrorSM $ runStep (tsClient ts) $ Withdraw n l
|
||||
|
||||
type TSOperateSchema = BlockchainActions
|
||||
type TSStartSchema = BlockchainActions
|
||||
.\/ Endpoint "start" (CurrencySymbol, TokenName)
|
||||
type TSStartSchema' = BlockchainActions
|
||||
.\/ Endpoint "start" (CurrencySymbol, CurrencySymbol, TokenName)
|
||||
type TSUseSchema = BlockchainActions
|
||||
.\/ Endpoint "set price" Integer
|
||||
.\/ Endpoint "add tokens" Integer
|
||||
.\/ Endpoint "buy tokens" Integer
|
||||
.\/ Endpoint "withdraw" (Integer, Integer)
|
||||
type TSOperateSchema' = BlockchainActions
|
||||
.\/ Endpoint "start" (CurrencySymbol, CurrencySymbol, TokenName)
|
||||
.\/ Endpoint "set price" Integer
|
||||
.\/ Endpoint "add tokens" Integer
|
||||
.\/ Endpoint "withdraw" (Integer, Integer)
|
||||
type TSUseSchema = BlockchainActions .\/ Endpoint "buy tokens" Integer
|
||||
|
||||
operateTS :: forall s.
|
||||
( HasBlockchainActions s
|
||||
, HasEndpoint "set price" Integer s
|
||||
, HasEndpoint "add tokens" Integer s
|
||||
, HasEndpoint "withdraw" (Integer, Integer) s
|
||||
)
|
||||
=> Maybe CurrencySymbol
|
||||
-> CurrencySymbol
|
||||
-> TokenName
|
||||
-> Contract (Last TokenSale) s Text ()
|
||||
operateTS mcs cs tn = startTS mcs (AssetClass (cs, tn)) >>= go
|
||||
startEndpoint :: Contract (Last TokenSale) TSStartSchema Text ()
|
||||
startEndpoint = startTS' >> startEndpoint
|
||||
where
|
||||
go :: TokenSale -> Contract (Last TokenSale) s Text ()
|
||||
go ts = (setPrice' `select` addTokens' `select` withdraw') >> go ts
|
||||
where
|
||||
setPrice' = handleError logError $ endpoint @"set price" >>= setPrice ts
|
||||
addTokens' = handleError logError $ endpoint @"add tokens" >>= addTokens ts
|
||||
withdraw' = handleError logError $ endpoint @"withdraw" >>= uncurry (withdraw ts)
|
||||
startTS' = handleError logError $ endpoint @"start" >>= void . startTS Nothing . AssetClass
|
||||
|
||||
operateTS' :: Contract (Last TokenSale) TSOperateSchema Text ()
|
||||
operateTS' = endpoint @"start" >>= uncurry (operateTS Nothing)
|
||||
|
||||
operateTS'' :: Contract (Last TokenSale) TSOperateSchema' Text ()
|
||||
operateTS'' = endpoint @"start" >>= \(cs1, cs2, tn) -> operateTS (Just cs1) cs2 tn
|
||||
|
||||
useTS :: TokenSale -> Contract () TSUseSchema Text ()
|
||||
useTS ts = buyTokens' >> useTS ts
|
||||
startEndpoint' :: Contract (Last TokenSale) TSStartSchema' Text ()
|
||||
startEndpoint' = startTS' >> startEndpoint'
|
||||
where
|
||||
startTS' = handleError logError $ endpoint @"start" >>= \(cs1, cs2, tn) -> void $ startTS (Just cs1) $ AssetClass (cs2, tn)
|
||||
|
||||
useEndpoints :: TokenSale -> Contract () TSUseSchema Text ()
|
||||
useEndpoints ts = (setPrice' `select` addTokens' `select` buyTokens' `select` withdraw') >> useEndpoints ts
|
||||
where
|
||||
setPrice' = handleError logError $ endpoint @"set price" >>= setPrice ts
|
||||
addTokens' = handleError logError $ endpoint @"add tokens" >>= addTokens ts
|
||||
buyTokens' = handleError logError $ endpoint @"buy tokens" >>= buyTokens ts
|
||||
withdraw' = handleError logError $ endpoint @"withdraw" >>= uncurry (withdraw ts)
|
||||
|
|
|
|||
|
|
@ -39,35 +39,31 @@ test = runEmulatorTraceIO' def emCfg myTrace
|
|||
]
|
||||
|
||||
v :: Value
|
||||
v = Ada.lovelaceValueOf 1000_000_000
|
||||
<> assetClassValue token1 1000
|
||||
<> assetClassValue token2 1000
|
||||
v = Ada.lovelaceValueOf 1000_000_000 <> assetClassValue token 1000
|
||||
|
||||
currency1, currency2 :: CurrencySymbol
|
||||
currency1 = "aa"
|
||||
currency2 = "bb"
|
||||
currency :: CurrencySymbol
|
||||
currency = "aa"
|
||||
|
||||
name1, name2 :: TokenName
|
||||
name1 = "A"
|
||||
name2 = "B"
|
||||
name :: TokenName
|
||||
name = "A"
|
||||
|
||||
token1, token2 :: AssetClass
|
||||
token1 = AssetClass (currency1, name1)
|
||||
token2 = AssetClass (currency2, name2)
|
||||
token :: AssetClass
|
||||
token = AssetClass (currency, name)
|
||||
|
||||
myTrace :: EmulatorTrace ()
|
||||
myTrace = do
|
||||
h1 <- activateContractWallet (Wallet 1) operateTS'
|
||||
callEndpoint @"start" h1 (currency1, name1)
|
||||
h <- activateContractWallet (Wallet 1) startEndpoint
|
||||
callEndpoint @"start" h (currency, name)
|
||||
void $ Emulator.waitNSlots 5
|
||||
Last m <- observableState h1
|
||||
Last m <- observableState h
|
||||
case m of
|
||||
Nothing -> Extras.logError @String "error starting token sale"
|
||||
Just ts -> do
|
||||
Extras.logInfo $ "started token sale " ++ show ts
|
||||
|
||||
h2 <- activateContractWallet (Wallet 2) $ useTS ts
|
||||
h3 <- activateContractWallet (Wallet 3) $ useTS ts
|
||||
h1 <- activateContractWallet (Wallet 1) $ useEndpoints ts
|
||||
h2 <- activateContractWallet (Wallet 2) $ useEndpoints ts
|
||||
h3 <- activateContractWallet (Wallet 3) $ useEndpoints ts
|
||||
|
||||
callEndpoint @"set price" h1 1_000_000
|
||||
void $ Emulator.waitNSlots 5
|
||||
|
|
|
|||
Loading…
Reference in a new issue