mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-12-22 13:31:59 +01:00
changed endpoints
This commit is contained in:
Lars Brünjes
parent
b4e6f8886a
commit
d3af622a71
3 changed files with 110 additions and 75 deletions
|
|
@ -31,7 +31,7 @@ import Ledger.Ada as Ada
|
|||
import Ledger.Value
|
||||
import Test.QuickCheck
|
||||
|
||||
import Week08.TokenSale
|
||||
import Week08.TokenSale (TokenSale (..), TSOperateSchema', TSUseSchema, useTS, operateTS'', nftName)
|
||||
|
||||
data TSState = TSState
|
||||
{ _tssPrice :: !Integer
|
||||
|
|
@ -48,19 +48,24 @@ makeLenses ''TSModel
|
|||
|
||||
instance ContractModel TSModel where
|
||||
|
||||
data Action TSModel = Start Wallet | TSAction Wallet Wallet TSRedeemer
|
||||
data Action TSModel =
|
||||
Start Wallet
|
||||
| SetPrice Wallet Integer
|
||||
| AddTokens Wallet Integer
|
||||
| Withdraw Wallet Integer Integer
|
||||
| BuyTokens Wallet Wallet Integer
|
||||
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
|
||||
OperateKey :: Wallet -> ContractInstanceKey TSModel (Last TokenSale) TSOperateSchema' Text
|
||||
UseKey :: Wallet -> Wallet -> ContractInstanceKey TSModel () TSUseSchema Text
|
||||
|
||||
arbitraryAction _ = oneof $
|
||||
(Start <$> genSeller) :
|
||||
[ (\v w p -> TSAction v w $ SetPrice p) <$> genSeller <*> genUser <*> arbitrary ] ++
|
||||
[ (\v w n -> TSAction v w $ AddTokens n) <$> genSeller <*> genUser <*> arbitrary ] ++
|
||||
[ (\v w n -> TSAction v w $ BuyTokens n) <$> genSeller <*> genUser <*> arbitrary ] ++
|
||||
[ (\v w n l -> TSAction v w $ Withdraw n l) <$> genSeller <*> genUser <*> arbitrary <*> arbitrary ]
|
||||
[ SetPrice <$> genSeller <*> genNonNeg ] ++
|
||||
[ AddTokens <$> genSeller <*> genNonNeg ] ++
|
||||
[ Withdraw <$> genSeller <*> genNonNeg <*> genNonNeg ] ++
|
||||
[ BuyTokens <$> genSeller <*> genUser <*> genNonNeg ]
|
||||
|
||||
initialState = TSModel Map.empty
|
||||
|
||||
|
|
@ -69,21 +74,21 @@ instance ContractModel TSModel where
|
|||
(tsModel . at w) $= Just (TSState 0 0 0)
|
||||
wait 1
|
||||
|
||||
nextState (TSAction v w (SetPrice p)) = when (v == w) $ do
|
||||
(tsModel . ix v . tssPrice) $= p
|
||||
nextState (SetPrice w p) = do
|
||||
(tsModel . ix w . tssPrice) $= p
|
||||
wait 1
|
||||
|
||||
nextState (TSAction v w (AddTokens n)) = do
|
||||
started <- hasStarted v -- has the token sale started?
|
||||
nextState (AddTokens w n) = do
|
||||
started <- hasStarted w -- has the token sale started?
|
||||
when (n > 0 && started) $ do
|
||||
bc <- askModelState $ view $ balanceChange w
|
||||
let token = tokens Map.! v
|
||||
when (assetClassValueOf bc token >= n) $ do -- does the wallet have the tokens to give?
|
||||
let token = tokens Map.! w
|
||||
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)
|
||||
(tsModel . ix w . tssToken) $~ (+ n)
|
||||
wait 1
|
||||
|
||||
nextState (TSAction v w (BuyTokens n)) = do
|
||||
nextState (BuyTokens v w n) = do
|
||||
when (n > 0) $ do
|
||||
m <- getTSState v
|
||||
case m of
|
||||
|
|
@ -94,22 +99,27 @@ instance ContractModel TSModel where
|
|||
withdraw w $ lovelaceValueOf l
|
||||
deposit w $ assetClassValue (tokens Map.! v) n
|
||||
(tsModel . ix v . tssLovelace) $~ (+ l)
|
||||
(tsModel . ix v . tssToken) $~ (+ (- n))
|
||||
(tsModel . ix v . tssToken) $~ (+ (- n))
|
||||
_ -> return ()
|
||||
wait 1
|
||||
|
||||
nextState (TSAction v w (Withdraw n l)) = when (v == w) $ do
|
||||
withdraw w $ lovelaceValueOf l <> assetClassValue (tokens Map.! v) n
|
||||
(tsModel . ix v . tssLovelace) $~ (+ (- l))
|
||||
(tsModel . ix v . tssToken) $~ (+ (- n))
|
||||
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 ()
|
||||
wait 1
|
||||
|
||||
perform h _ cmd = case cmd of
|
||||
(Start w) -> callEndpoint @"start" (h $ StartKey w) (css Map.! w, tokenCurrency, tokenNames Map.! w) >> delay 1
|
||||
(TSAction v w (SetPrice p)) -> callEndpoint @"set price" (h $ UseKey v w) p >> delay 1
|
||||
(TSAction v w (AddTokens n)) -> callEndpoint @"add tokens" (h $ UseKey v w) n >> delay 1
|
||||
(TSAction v w (BuyTokens n)) -> callEndpoint @"buy tokens" (h $ UseKey v w) n >> delay 1
|
||||
(TSAction v w (Withdraw n l)) -> callEndpoint @"withdraw" (h $ UseKey v w) (n, l) >> delay 1
|
||||
(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
|
||||
|
||||
precondition s (Start w) = isNothing $ getTSState' s w
|
||||
precondition _ _ = True
|
||||
|
|
@ -163,15 +173,21 @@ delay = void . waitNSlots . fromIntegral
|
|||
|
||||
instanceSpec :: [ContractInstanceSpec TSModel]
|
||||
instanceSpec =
|
||||
[ContractInstanceSpec (StartKey w) w $ startTS'' | w <- [w1, w2]] ++
|
||||
[ContractInstanceSpec (OperateKey w) w $ operateTS'' | w <- [w1, w2]] ++
|
||||
[ContractInstanceSpec (UseKey v w) w $ useTS $ tss Map.! v | v <- [w1, w2], w <- [w3, w4]]
|
||||
|
||||
genSeller, genUser :: Gen Wallet
|
||||
genSeller = elements [w1, w2]
|
||||
genUser = elements [w3, w4]
|
||||
|
||||
genNonNeg :: Gen Integer
|
||||
genNonNeg = getNonNegative <$> arbitrary
|
||||
|
||||
tokenAmt :: Integer
|
||||
tokenAmt = 1_000
|
||||
|
||||
prop_TS :: Actions TSModel -> Property
|
||||
prop_TS = propRunActionsWithOptions
|
||||
prop_TS = withMaxSuccess 1000 . propRunActionsWithOptions
|
||||
(defaultCheckOptions & emulatorConfig .~ EmulatorConfig (Left d))
|
||||
instanceSpec
|
||||
(const $ pure True)
|
||||
|
|
@ -180,7 +196,7 @@ prop_TS = propRunActionsWithOptions
|
|||
d = Map.fromList $ [ ( w
|
||||
, lovelaceValueOf 1000_000_000 <>
|
||||
(nfts Map.! w) <>
|
||||
mconcat [assetClassValue t 1000 | t <- Map.elems tokens])
|
||||
mconcat [assetClassValue t tokenAmt | t <- Map.elems tokens])
|
||||
| w <- [w1, w2]
|
||||
] ++
|
||||
[(w, lovelaceValueOf 1000_000_000) | w <- [w3, w4]]
|
||||
|
|
@ -188,3 +204,14 @@ prop_TS = propRunActionsWithOptions
|
|||
|
||||
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,11 +15,11 @@ module Week08.TokenSale
|
|||
( TokenSale (..)
|
||||
, TSRedeemer (..)
|
||||
, nftName
|
||||
, TSStartSchema
|
||||
, TSStartSchema'
|
||||
, TSOperateSchema
|
||||
, TSOperateSchema'
|
||||
, TSUseSchema
|
||||
, startTS'
|
||||
, startTS''
|
||||
, operateTS'
|
||||
, operateTS''
|
||||
, useTS
|
||||
) where
|
||||
|
||||
|
|
@ -65,18 +65,19 @@ lovelaces = Ada.getLovelace . Ada.fromValue
|
|||
{-# INLINABLE transition #-}
|
||||
transition :: TokenSale -> State Integer -> TSRedeemer -> Maybe (TxConstraints Void Void, State Integer)
|
||||
transition ts s r = case (stateValue s, stateData s, r) of
|
||||
(v, _, SetPrice p) -> Just ( Constraints.mustBeSignedBy (tsSeller ts)
|
||||
, State p (v <> nft (negate 1))
|
||||
)
|
||||
(v, p, AddTokens n) -> Just ( mempty
|
||||
, State p $ v <> nft (negate 1) <> assetClassValue (tsToken ts) n
|
||||
)
|
||||
(v, p, BuyTokens n) -> Just ( mempty
|
||||
, State p $ v <> nft (negate 1) <> assetClassValue (tsToken ts) (negate n) <> lovelaceValueOf (n * p)
|
||||
)
|
||||
(v, p, Withdraw n l) -> Just ( Constraints.mustBeSignedBy (tsSeller ts)
|
||||
, State p $ v <> nft (negate 1) <> assetClassValue (tsToken ts) (negate n) <> lovelaceValueOf (negate l)
|
||||
)
|
||||
(v, _, SetPrice p) | p >= 0 -> Just ( Constraints.mustBeSignedBy (tsSeller ts)
|
||||
, State p (v <> nft (negate 1))
|
||||
)
|
||||
(v, p, AddTokens n) | n > 0 -> Just ( mempty
|
||||
, State p $ v <> nft (negate 1) <> assetClassValue (tsToken ts) n
|
||||
)
|
||||
(v, p, BuyTokens n) | n > 0 -> Just ( mempty
|
||||
, State p $ v <> nft (negate 1) <> assetClassValue (tsToken ts) (negate n) <> lovelaceValueOf (n * p)
|
||||
)
|
||||
(v, p, Withdraw n l) | n >= 0 && l >= 0 -> Just ( Constraints.mustBeSignedBy (tsSeller ts)
|
||||
, State p $ v <> nft (negate 1) <> assetClassValue (tsToken ts) (negate n) <> lovelaceValueOf (negate l)
|
||||
)
|
||||
_ -> Nothing
|
||||
where
|
||||
nft :: Integer -> Value
|
||||
nft = assetClassValue (tsNFT ts)
|
||||
|
|
@ -117,7 +118,7 @@ mapErrorSM = mapError $ pack . show
|
|||
nftName :: TokenName
|
||||
nftName = "NFT"
|
||||
|
||||
startTS :: HasBlockchainActions s => Maybe CurrencySymbol -> AssetClass -> Contract (Last TokenSale) s Text ()
|
||||
startTS :: HasBlockchainActions s => Maybe CurrencySymbol -> AssetClass -> Contract (Last TokenSale) s Text TokenSale
|
||||
startTS mcs token = do
|
||||
pkh <- pubKeyHash <$> Contract.ownPubKey
|
||||
cs <- case mcs of
|
||||
|
|
@ -132,12 +133,13 @@ startTS mcs token = do
|
|||
void $ mapErrorSM $ runInitialise client 0 mempty
|
||||
tell $ Last $ Just ts
|
||||
logInfo $ "started token sale " ++ show ts
|
||||
return ts
|
||||
|
||||
setPrice :: HasBlockchainActions s => TokenSale -> Integer -> Contract w s Text ()
|
||||
setPrice ts p = void $ mapErrorSM $ runStep (tsClient ts) $ SetPrice p
|
||||
|
||||
addTokens :: HasBlockchainActions s => TokenSale -> Integer -> Contract w s Text ()
|
||||
addTokens ts n = void $ mapErrorSM $ runStep (tsClient ts) $ AddTokens n
|
||||
addTokens ts n = void (mapErrorSM $ runStep (tsClient ts) $ AddTokens n)
|
||||
|
||||
buyTokens :: HasBlockchainActions s => TokenSale -> Integer -> Contract w s Text ()
|
||||
buyTokens ts n = void $ mapErrorSM $ runStep (tsClient ts) $ BuyTokens n
|
||||
|
|
@ -145,28 +147,44 @@ 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 TSStartSchema = BlockchainActions .\/ Endpoint "start" (CurrencySymbol, TokenName)
|
||||
type TSStartSchema' = BlockchainActions .\/ Endpoint "start" (CurrencySymbol, CurrencySymbol, TokenName)
|
||||
type TSUseSchema = BlockchainActions
|
||||
type TSOperateSchema = BlockchainActions
|
||||
.\/ Endpoint "start" (CurrencySymbol, TokenName)
|
||||
.\/ 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
|
||||
|
||||
startTS' :: Contract (Last TokenSale) TSStartSchema Text ()
|
||||
startTS' = start >> startTS'
|
||||
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
|
||||
where
|
||||
start = endpoint @"start" >>= startTS Nothing . AssetClass
|
||||
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'' :: Contract (Last TokenSale) TSStartSchema' Text ()
|
||||
startTS'' = start >> startTS''
|
||||
where
|
||||
start = endpoint @"start" >>= \(cs1, cs2, tn) -> startTS (Just cs1) $ AssetClass (cs2, tn)
|
||||
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 = (setPrice' `select` addTokens' `select` buyTokens' `select` withdraw') >> useTS ts
|
||||
useTS ts = buyTokens' >> useTS 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)
|
||||
|
|
|
|||
|
|
@ -56,31 +56,24 @@ token2 = AssetClass (currency2, name2)
|
|||
|
||||
myTrace :: EmulatorTrace ()
|
||||
myTrace = do
|
||||
h <- activateContractWallet (Wallet 1) startTS'
|
||||
callEndpoint @"start" h (currency1, name1)
|
||||
h1 <- activateContractWallet (Wallet 1) operateTS'
|
||||
callEndpoint @"start" h1 (currency1, name1)
|
||||
void $ Emulator.waitNSlots 5
|
||||
Last m <- observableState h
|
||||
Last m <- observableState h1
|
||||
case m of
|
||||
Nothing -> Extras.logError @String "error starting token sale"
|
||||
Just ts -> do
|
||||
Extras.logInfo $ "started token sale " ++ show ts
|
||||
|
||||
h1 <- activateContractWallet (Wallet 1) $ useTS ts
|
||||
h2 <- activateContractWallet (Wallet 2) $ useTS ts
|
||||
h3 <- activateContractWallet (Wallet 3) $ useTS ts
|
||||
|
||||
callEndpoint @"set price" h1 1_000_000
|
||||
void $ Emulator.waitNSlots 5
|
||||
|
||||
callEndpoint @"set price" h2 2_000_000
|
||||
void $ Emulator.waitNSlots 5
|
||||
|
||||
callEndpoint @"add tokens" h1 100
|
||||
void $ Emulator.waitNSlots 5
|
||||
|
||||
callEndpoint @"add tokens" h2 10
|
||||
void $ Emulator.waitNSlots 5
|
||||
|
||||
callEndpoint @"buy tokens" h2 20
|
||||
void $ Emulator.waitNSlots 5
|
||||
|
||||
|
|
@ -89,6 +82,3 @@ myTrace = do
|
|||
|
||||
callEndpoint @"withdraw" h1 (40, 10_000_000)
|
||||
void $ Emulator.waitNSlots 5
|
||||
|
||||
callEndpoint @"withdraw" h2 (40, 10_000_000)
|
||||
void $ Emulator.waitNSlots 5
|
||||
|
|
|
|||
Loading…
Reference in a new issue