claudiomaradonna/plutus-pioneer-program
1
0
Fork 0
mirror of https://github.com/FiloSpaTeam/plutus-pioneer-program.git synced 2024-11-14 10:52:35 +01:00
Code Issues Projects Releases Packages Wiki Activity

tests with multiple contract instances per wallet

Browse source
This commit is contained in:
Lars Brünjes 2021-05-25 22:49:40 +02:00
parent e583be0d3e
commit f1664d6c31
No known key found for this signature in database
GPG key ID: B488B9045DC1A087
3 changed files with 98 additions and 123 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

131
code/week08/src/Week08/TestTokenSale.hs
View file

@ -22,6 +22,7 @@ import Data.Map (Map)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe (isJust, isNothing) import Data.Maybe (isJust, isNothing)
import Data.Monoid (Last (..)) import Data.Monoid (Last (..))
import Data.String (IsString (..))
import Data.Text (Text) import Data.Text (Text)
import Plutus.Contract.Test import Plutus.Contract.Test
import Plutus.Contract.Test.ContractModel import Plutus.Contract.Test.ContractModel
@ -31,7 +32,7 @@ import Ledger.Ada as Ada
import Ledger.Value import Ledger.Value
import Test.QuickCheck import Test.QuickCheck
import Week08.TokenSale (TokenSale (..), TSOperateSchema', TSUseSchema, useTS, operateTS'', nftName) import Week08.TokenSale (TokenSale (..), TSStartSchema', TSUseSchema, startEndpoint', useEndpoints, nftName)
data TSState = TSState data TSState = TSState
{ _tssPrice :: !Integer { _tssPrice :: !Integer
@ -50,22 +51,24 @@ instance ContractModel TSModel where
data Action TSModel = data Action TSModel =
Start Wallet Start Wallet
| SetPrice Wallet Integer | SetPrice Wallet Wallet Integer
| AddTokens Wallet Integer | AddTokens Wallet Wallet Integer
| Withdraw Wallet Integer Integer | Withdraw Wallet Wallet Integer Integer
| BuyTokens Wallet Wallet Integer | BuyTokens Wallet Wallet Integer
deriving (Show, Eq) deriving (Show, Eq)
data ContractInstanceKey TSModel w s e where data ContractInstanceKey TSModel w s e where
OperateKey :: Wallet -> ContractInstanceKey TSModel (Last TokenSale) TSOperateSchema' Text StartKey :: Wallet -> ContractInstanceKey TSModel (Last TokenSale) TSStartSchema' Text
UseKey :: Wallet -> Wallet -> ContractInstanceKey TSModel () TSUseSchema Text UseKey :: Wallet -> Wallet -> ContractInstanceKey TSModel () TSUseSchema Text
instanceTag key _ = fromString $ "instance tag for: " ++ show key
arbitraryAction _ = oneof $ arbitraryAction _ = oneof $
(Start <$> genSeller) : (Start <$> genWallet) :
[ SetPrice <$> genSeller <*> genNonNeg ] ++ [ SetPrice <$> genWallet <*> genWallet <*> genNonNeg ] ++
[ AddTokens <$> genSeller <*> genNonNeg ] ++ [ AddTokens <$> genWallet <*> genWallet <*> genNonNeg ] ++
[ Withdraw <$> genSeller <*> genNonNeg <*> genNonNeg ] ++ [ BuyTokens <$> genWallet <*> genWallet <*> genNonNeg ] ++
[ BuyTokens <$> genSeller <*> genUser <*> genNonNeg ] [ Withdraw <$> genWallet <*> genWallet <*> genNonNeg <*> genNonNeg ]
initialState = TSModel Map.empty initialState = TSModel Map.empty
@ -74,18 +77,19 @@ instance ContractModel TSModel where
(tsModel . at w) $= Just (TSState 0 0 0) (tsModel . at w) $= Just (TSState 0 0 0)
wait 1 wait 1
nextState (SetPrice w p) = do nextState (SetPrice v w p) = do
(tsModel . ix w . tssPrice) $= p when (v == w) $
(tsModel . ix v . tssPrice) $= p
wait 1 wait 1
nextState (AddTokens w n) = do nextState (AddTokens v w n) = do
started <- hasStarted w -- has the token sale started? started <- hasStarted v -- has the token sale started?
when (n > 0 && started) $ do when (n > 0 && started) $ do
bc <- askModelState $ view $ balanceChange w 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? when (tokenAmt + assetClassValueOf bc token >= n) $ do -- does the wallet have the tokens to give?
withdraw w $ assetClassValue token n withdraw w $ assetClassValue token n
(tsModel . ix w . tssToken) $~ (+ n) (tsModel . ix v . tssToken) $~ (+ n)
wait 1 wait 1
nextState (BuyTokens v w n) = do nextState (BuyTokens v w n) = do
@ -103,23 +107,24 @@ instance ContractModel TSModel where
_ -> return () _ -> return ()
wait 1 wait 1
nextState (Withdraw w n l) = do nextState (Withdraw v w n l) = do
m <- getTSState w when (v == w) $ do
case m of m <- getTSState v
Just t case m of
| t ^. tssToken >= n && t ^. tssLovelace >= l -> do Just t
deposit w $ lovelaceValueOf l <> assetClassValue (tokens Map.! w) n | t ^. tssToken >= n && t ^. tssLovelace >= l -> do
(tsModel . ix w . tssLovelace) $~ (+ (- l)) deposit w $ lovelaceValueOf l <> assetClassValue (tokens Map.! w) n
(tsModel . ix w . tssToken) $~ (+ (- n)) (tsModel . ix v . tssLovelace) $~ (+ (- l))
_ -> return () (tsModel . ix v . tssToken) $~ (+ (- n))
_ -> return ()
wait 1 wait 1
perform h _ cmd = case cmd of perform h _ cmd = case cmd of
(Start w) -> callEndpoint @"start" (h $ OperateKey w) (css Map.! w, tokenCurrency, tokenNames Map.! w) >> delay 1 (Start w) -> callEndpoint @"start" (h $ StartKey w) (nftCurrencies Map.! w, tokenCurrencies Map.! w, tokenNames Map.! w) >> delay 1
(SetPrice w p) -> callEndpoint @"set price" (h $ OperateKey w) p >> delay 1 (SetPrice v w p) -> callEndpoint @"set price" (h $ UseKey v w) p >> delay 1
(AddTokens w n) -> callEndpoint @"add tokens" (h $ OperateKey w) n >> delay 1 (AddTokens v w n) -> callEndpoint @"add tokens" (h $ UseKey v 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
(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 s (Start w) = isNothing $ getTSState' s w
precondition _ _ = True precondition _ _ = True
@ -138,34 +143,36 @@ getTSState v = do
hasStarted :: Wallet -> Spec TSModel Bool hasStarted :: Wallet -> Spec TSModel Bool
hasStarted v = isJust <$> getTSState v hasStarted v = isJust <$> getTSState v
w1, w2, w3, w4 :: Wallet w1, w2 :: Wallet
w1 = Wallet 1 w1 = Wallet 1
w2 = Wallet 2 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 :: [Wallet]
wallets = [w1, w2, w3, w4] wallets = [w1, w2]
css :: Map Wallet CurrencySymbol tokenCurrencies, nftCurrencies :: Map Wallet CurrencySymbol
css = Map.fromList [(w1, "01"), (w2, "02")] 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 :: 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 Wallet TokenSale
tss = Map.fromList tss = Map.fromList
[ (w, TokenSale (pubKeyHash $ walletPubKey w) (tokens Map.! w) $ AssetClass (css Map.! w, nftName)) [ (w, TokenSale { tsSeller = pubKeyHash $ walletPubKey w
| w <- [w1, w2] , tsToken = tokens Map.! w
, tsNFT = nftAssets Map.! w
})
| w <- wallets
] ]
delay :: Int -> EmulatorTrace () delay :: Int -> EmulatorTrace ()
@ -173,12 +180,11 @@ delay = void . waitNSlots . fromIntegral
instanceSpec :: [ContractInstanceSpec TSModel] instanceSpec :: [ContractInstanceSpec TSModel]
instanceSpec = instanceSpec =
[ContractInstanceSpec (OperateKey w) w $ operateTS'' | w <- [w1, w2]] ++ [ContractInstanceSpec (StartKey w) w startEndpoint' | w <- wallets] ++
[ContractInstanceSpec (UseKey v w) w $ useTS $ tss Map.! v | v <- [w1, w2], w <- [w3, w4]] [ContractInstanceSpec (UseKey v w) w $ useEndpoints $ tss Map.! v | v <- wallets, w <- wallets]
genSeller, genUser :: Gen Wallet genWallet :: Gen Wallet
genSeller = elements [w1, w2] genWallet = elements wallets
genUser = elements [w3, w4]
genNonNeg :: Gen Integer genNonNeg :: Gen Integer
genNonNeg = getNonNegative <$> arbitrary genNonNeg = getNonNegative <$> arbitrary
@ -197,21 +203,8 @@ prop_TS = withMaxSuccess 1000 . propRunActionsWithOptions
, lovelaceValueOf 1000_000_000 <> , lovelaceValueOf 1000_000_000 <>
(nfts Map.! w) <> (nfts Map.! w) <>
mconcat [assetClassValue t tokenAmt | t <- Map.elems tokens]) mconcat [assetClassValue t tokenAmt | t <- Map.elems tokens])
| w <- [w1, w2] | w <- wallets
] ++ ]
[(w, lovelaceValueOf 1000_000_000) | w <- [w3, w4]]
test :: IO () test :: IO ()
test = quickCheck prop_TS 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
]

60
code/week08/src/Week08/TokenSale.hs
View file

@ -15,12 +15,12 @@ module Week08.TokenSale
( TokenSale (..) ( TokenSale (..)
, TSRedeemer (..) , TSRedeemer (..)
, nftName , nftName
, TSOperateSchema , TSStartSchema
, TSOperateSchema' , TSStartSchema'
, TSUseSchema , TSUseSchema
, operateTS' , startEndpoint
, operateTS'' , startEndpoint'
, useTS , useEndpoints
) where ) where
import Control.Monad hiding (fmap) 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 :: HasBlockchainActions s => TokenSale -> Integer -> Integer -> Contract w s Text ()
withdraw ts n l = void $ mapErrorSM $ runStep (tsClient ts) $ Withdraw n l withdraw ts n l = void $ mapErrorSM $ runStep (tsClient ts) $ Withdraw n l
type TSOperateSchema = BlockchainActions type TSStartSchema = BlockchainActions
.\/ Endpoint "start" (CurrencySymbol, TokenName) .\/ Endpoint "start" (CurrencySymbol, TokenName)
type TSStartSchema' = BlockchainActions
.\/ Endpoint "start" (CurrencySymbol, CurrencySymbol, TokenName)
type TSUseSchema = BlockchainActions
.\/ Endpoint "set price" Integer .\/ Endpoint "set price" Integer
.\/ Endpoint "add tokens" Integer .\/ Endpoint "add tokens" Integer
.\/ Endpoint "buy tokens" Integer
.\/ Endpoint "withdraw" (Integer, 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. startEndpoint :: Contract (Last TokenSale) TSStartSchema Text ()
( HasBlockchainActions s startEndpoint = startTS' >> startEndpoint
, 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
where where
go :: TokenSale -> Contract (Last TokenSale) s Text () startTS' = handleError logError $ endpoint @"start" >>= void . startTS Nothing . AssetClass
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)
operateTS' :: Contract (Last TokenSale) TSOperateSchema Text () startEndpoint' :: Contract (Last TokenSale) TSStartSchema' Text ()
operateTS' = endpoint @"start" >>= uncurry (operateTS Nothing) startEndpoint' = startTS' >> startEndpoint'
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
where 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 buyTokens' = handleError logError $ endpoint @"buy tokens" >>= buyTokens ts
withdraw' = handleError logError $ endpoint @"withdraw" >>= uncurry (withdraw ts)

30
code/week08/src/Week08/TraceTokenSale.hs
View file

@ -39,35 +39,31 @@ test = runEmulatorTraceIO' def emCfg myTrace
] ]
v :: Value v :: Value
v = Ada.lovelaceValueOf 1000_000_000 v = Ada.lovelaceValueOf 1000_000_000 <> assetClassValue token 1000
<> assetClassValue token1 1000
<> assetClassValue token2 1000
currency1, currency2 :: CurrencySymbol currency :: CurrencySymbol
currency1 = "aa" currency = "aa"
currency2 = "bb"
name1, name2 :: TokenName name :: TokenName
name1 = "A" name = "A"
name2 = "B"
token1, token2 :: AssetClass token :: AssetClass
token1 = AssetClass (currency1, name1) token = AssetClass (currency, name)
token2 = AssetClass (currency2, name2)
myTrace :: EmulatorTrace () myTrace :: EmulatorTrace ()
myTrace = do myTrace = do
h1 <- activateContractWallet (Wallet 1) operateTS' h <- activateContractWallet (Wallet 1) startEndpoint
callEndpoint @"start" h1 (currency1, name1) callEndpoint @"start" h (currency, name)
void $ Emulator.waitNSlots 5 void $ Emulator.waitNSlots 5
Last m <- observableState h1 Last m <- observableState h
case m of case m of
Nothing -> Extras.logError @String "error starting token sale" Nothing -> Extras.logError @String "error starting token sale"
Just ts -> do Just ts -> do
Extras.logInfo $ "started token sale " ++ show ts Extras.logInfo $ "started token sale " ++ show ts
h2 <- activateContractWallet (Wallet 2) $ useTS ts h1 <- activateContractWallet (Wallet 1) $ useEndpoints ts
h3 <- activateContractWallet (Wallet 3) $ useTS ts h2 <- activateContractWallet (Wallet 2) $ useEndpoints ts
h3 <- activateContractWallet (Wallet 3) $ useEndpoints ts
callEndpoint @"set price" h1 1_000_000 callEndpoint @"set price" h1 1_000_000
void $ Emulator.waitNSlots 5 void $ Emulator.waitNSlots 5