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

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

@ -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
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
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 w . tssLovelace) $~ (+ (- l))
(tsModel . ix w . tssToken) $~ (+ (- 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
(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
]

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

@ -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)
.\/ Endpoint "set price" Integer
.\/ Endpoint "add tokens" Integer
.\/ Endpoint "withdraw" (Integer, Integer)
type TSOperateSchema' = BlockchainActions
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 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
startTS' = handleError logError $ endpoint @"start" >>= void . startTS Nothing . AssetClass
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
withdraw' = handleError logError $ endpoint @"withdraw" >>= uncurry (withdraw ts)
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
where
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 = 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