diff --git a/code/week08/src/Week08/TestTokenSale.hs b/code/week08/src/Week08/TestTokenSale.hs index 3e2f73a..036cc05 100644 --- a/code/week08/src/Week08/TestTokenSale.hs +++ b/code/week08/src/Week08/TestTokenSale.hs @@ -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 + ] + diff --git a/code/week08/src/Week08/TokenSale.hs b/code/week08/src/Week08/TokenSale.hs index 4ec5fef..5ad60f9 100644 --- a/code/week08/src/Week08/TokenSale.hs +++ b/code/week08/src/Week08/TokenSale.hs @@ -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) diff --git a/code/week08/src/Week08/TraceTokenSale.hs b/code/week08/src/Week08/TraceTokenSale.hs index 6616282..c7e1a68 100644 --- a/code/week08/src/Week08/TraceTokenSale.hs +++ b/code/week08/src/Week08/TraceTokenSale.hs @@ -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