forked from chris-moreton/plutus-pioneer-program
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathModelWithClose.hs
238 lines (197 loc) · 9.07 KB
/
ModelWithClose.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Spec.ModelWithClose
( tests
, test
, TSModel (..)
) where
import Control.Lens hiding (elements)
import Control.Monad (void, when)
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
import Plutus.Trace.Emulator
import Ledger hiding (singleton)
import Ledger.Ada as Ada
import Ledger.Value
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck
import Week08.TokenSaleWithClose (TokenSale (..), TSStartSchema', TSUseSchema, startEndpoint', useEndpoints, nftName)
data TSState = TSState
{ _tssPrice :: !Integer
, _tssLovelace :: !Integer
, _tssToken :: !Integer
} deriving Show
makeLenses ''TSState
newtype TSModel = TSModel {_tsModel :: Map Wallet TSState}
deriving Show
makeLenses ''TSModel
tests :: TestTree
tests = testProperty "token sale model" prop_TS
instance ContractModel TSModel where
data Action TSModel =
Start Wallet
| SetPrice Wallet Wallet Integer
| AddTokens Wallet Wallet Integer
| Withdraw Wallet Wallet Integer Integer
| BuyTokens Wallet Wallet Integer
| Close Wallet Wallet
deriving (Show, Eq)
data ContractInstanceKey TSModel w s e where
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 <$> genWallet) :
[ SetPrice <$> genWallet <*> genWallet <*> genNonNeg ] ++
[ AddTokens <$> genWallet <*> genWallet <*> genNonNeg ] ++
[ BuyTokens <$> genWallet <*> genWallet <*> genNonNeg ] ++
[ Withdraw <$> genWallet <*> genWallet <*> genNonNeg <*> genNonNeg ] ++
[ Close <$> genWallet <*> genWallet ]
initialState = TSModel Map.empty
nextState (Start w) = do
withdraw w $ nfts Map.! w
(tsModel . at w) $= Just (TSState 0 0 0)
wait 1
nextState (SetPrice v w p) = do
when (v == w) $
(tsModel . ix v . tssPrice) $= p
wait 1
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.! v
when (tokenAmt + assetClassValueOf bc token >= n) $ do -- does the wallet have the tokens to give?
withdraw w $ assetClassValue token n
(tsModel . ix v . tssToken) $~ (+ n)
wait 1
nextState (BuyTokens v w n) = do
when (n > 0) $ do
m <- getTSState v
case m of
Just t
| t ^. tssToken >= n -> do
let p = t ^. tssPrice
l = p * n
withdraw w $ lovelaceValueOf l
deposit w $ assetClassValue (tokens Map.! v) n
(tsModel . ix v . tssLovelace) $~ (+ l)
(tsModel . ix v . tssToken) $~ (+ (- n))
_ -> return ()
wait 1
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
nextState (Close v w) = do
when (v == w) $ do
m <- getTSState v
case m of
Just t -> do
deposit w $ lovelaceValueOf (t ^. tssLovelace) <>
assetClassValue (tokens Map.! w) (t ^. tssToken) <>
(nfts Map.! w)
(tsModel . at v) $= Nothing
_ -> return ()
wait 1
perform h _ cmd = case cmd of
(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
(Close v w) -> callEndpoint @"close" (h $ UseKey v w) () >> delay 1
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
precondition s (Close v _) = isJust $ getTSState' s v
deriving instance Eq (ContractInstanceKey TSModel w s e)
deriving instance Show (ContractInstanceKey TSModel w s e)
getTSState' :: ModelState TSModel -> Wallet -> Maybe TSState
getTSState' s v = s ^. contractState . tsModel . at v
getTSState :: Wallet -> Spec TSModel (Maybe TSState)
getTSState v = do
s <- getModelState
return $ getTSState' s v
hasStarted :: Wallet -> Spec TSModel Bool
hasStarted v = isJust <$> getTSState v
w1, w2 :: Wallet
w1 = Wallet 1
w2 = Wallet 2
wallets :: [Wallet]
wallets = [w1, w2]
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 = Map.fromList [(w, assetClassValue (nftAssets Map.! w) 1) | w <- wallets]
tss :: Map Wallet TokenSale
tss = Map.fromList
[ (w, TokenSale { tsSeller = pubKeyHash $ walletPubKey w
, tsToken = tokens Map.! w
, tsNFT = nftAssets Map.! w
})
| w <- wallets
]
delay :: Int -> EmulatorTrace ()
delay = void . waitNSlots . fromIntegral
instanceSpec :: [ContractInstanceSpec TSModel]
instanceSpec =
[ContractInstanceSpec (StartKey w) w startEndpoint' | w <- wallets] ++
[ContractInstanceSpec (UseKey v w) w $ useEndpoints $ tss Map.! v | v <- wallets, w <- wallets]
genWallet :: Gen Wallet
genWallet = elements wallets
genNonNeg :: Gen Integer
genNonNeg = getNonNegative <$> arbitrary
tokenAmt :: Integer
tokenAmt = 1_000
prop_TS :: Actions TSModel -> Property
prop_TS = withMaxSuccess 100 . propRunActionsWithOptions
(defaultCheckOptions & emulatorConfig .~ EmulatorConfig (Left d))
instanceSpec
(const $ pure True)
where
d :: InitialDistribution
d = Map.fromList $ [ ( w
, lovelaceValueOf 1000_000_000 <>
(nfts Map.! w) <>
mconcat [assetClassValue t tokenAmt | t <- Map.elems tokens])
| w <- wallets
]
test :: IO ()
test = quickCheck prop_TS