changed endpoints

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
+        OperateKey :: Wallet           -> ContractInstanceKey TSModel (Last TokenSale) TSOperateSchema' Text
-        UseKey   :: Wallet -> Wallet -> ContractInstanceKey TSModel () TSUseSchema Text
+        UseKey     :: Wallet -> Wallet -> ContractInstanceKey TSModel ()               TSUseSchema      Text
 
     arbitraryAction _ = oneof $
         (Start <$> genSeller) :
-        [ (\v w p   -> TSAction v w $ SetPrice p)   <$> genSeller <*> genUser <*> arbitrary ] ++
+        [ SetPrice  <$> genSeller <*> genNonNeg ]               ++
-        [ (\v w n   -> TSAction v w $ AddTokens n)  <$> genSeller <*> genUser <*> arbitrary ] ++
+        [ AddTokens <$> genSeller <*> genNonNeg ]               ++
-        [ (\v w n   -> TSAction v w $ BuyTokens n)  <$> genSeller <*> genUser <*> arbitrary ] ++
+        [ Withdraw  <$> genSeller <*> genNonNeg <*> genNonNeg ] ++
-        [ (\v w n l -> TSAction v w $ Withdraw n l) <$> genSeller <*> genUser <*> arbitrary <*> arbitrary ]
+        [ 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
+    nextState (SetPrice w p) = do
-        (tsModel . ix v . tssPrice) $= p
+        (tsModel . ix w . tssPrice) $= p
         wait 1
 
-    nextState (TSAction v w (AddTokens n)) = do
+    nextState (AddTokens w n) = do
-        started <- hasStarted v                          -- has the token sale started?
+        started <- hasStarted w                                     -- has the token sale started?
         when (n > 0 && started) $ do
             bc <- askModelState $ view $ balanceChange w
-            let token = tokens Map.! v
+            let token = tokens Map.! w
-            when (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
-                (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
+    nextState (Withdraw w n l) = do
-        withdraw w $ lovelaceValueOf l <> assetClassValue (tokens Map.! v) n
+        m <- getTSState w
-        (tsModel . ix v . tssLovelace) $~ (+ (- l))
+        case m of
-        (tsModel . ix v . tssToken) $~ (+ (- n))
+            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
+        (Start w)         -> callEndpoint @"start"      (h $ OperateKey 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
+        (SetPrice w p)    -> callEndpoint @"set price"  (h $ OperateKey w) p                                                >> delay 1
-        (TSAction v w (AddTokens n))  -> callEndpoint @"add tokens" (h $ UseKey v w) n                                                >> delay 1
+        (AddTokens w n)   -> callEndpoint @"add tokens" (h $ OperateKey w) n                                                >> delay 1
-        (TSAction v w (BuyTokens n))  -> callEndpoint @"buy tokens" (h $ UseKey v w) n                                                >> delay 1
+        (Withdraw w n l)  -> callEndpoint @"withdraw"   (h $ OperateKey w) (n, l)                                           >> delay 1
-        (TSAction v w (Withdraw n l)) -> callEndpoint @"withdraw"   (h $ UseKey v 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
+    ]
+

code/week08/src/Week08/TokenSale.hs

@@ -15,11 +15,11 @@ module Week08.TokenSale
     ( TokenSale (..)
     , TSRedeemer (..)
     , nftName
-    , TSStartSchema
+    , TSOperateSchema
-    , TSStartSchema'
+    , TSOperateSchema'
     , TSUseSchema
-    , startTS'
+    , operateTS'
-    , startTS''
+    , 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)
+    (v, _, SetPrice p)   | p >= 0           -> Just ( Constraints.mustBeSignedBy (tsSeller ts)
-                                 , State p (v <> nft (negate 1))
+                                                    , State p (v <> nft (negate 1))
-                                 )
+                                                    )
-    (v, p, AddTokens n)  -> Just ( mempty
+    (v, p, AddTokens n)  | n > 0            -> Just ( mempty
-                                 , State p $ v <> nft (negate 1) <> assetClassValue (tsToken ts) n
+                                                    , State p $ v <> nft (negate 1) <> assetClassValue (tsToken ts) n
-                                 )
+                                                    )
-    (v, p, BuyTokens n)  -> Just ( mempty
+    (v, p, BuyTokens n)  | n > 0            -> Just ( mempty
-                                 , State p $ v <> nft (negate 1) <> assetClassValue (tsToken ts) (negate n) <> lovelaceValueOf (n * p)
+                                                    , State p $ v <> nft (negate 1) <> assetClassValue (tsToken ts) (negate n) <> lovelaceValueOf (n * p)
-                                 )
+                                                    )
-    (v, p, Withdraw n l) -> Just ( Constraints.mustBeSignedBy (tsSeller ts)
+    (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)
+                                                    , 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 TSOperateSchema  = BlockchainActions
-type TSStartSchema' = BlockchainActions .\/ Endpoint "start" (CurrencySymbol, CurrencySymbol, TokenName)
+    .\/ Endpoint "start"      (CurrencySymbol, TokenName)
-type TSUseSchema    = BlockchainActions
     .\/ 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 ()
+operateTS :: forall s.
-startTS' = start >> startTS'
+             ( 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 ()
+operateTS' :: Contract (Last TokenSale) TSOperateSchema Text ()
-startTS'' = start >> startTS''
+operateTS' = endpoint @"start" >>= uncurry (operateTS Nothing)
-  where
+
-    start  = endpoint @"start"  >>= \(cs1, cs2, tn) -> startTS (Just cs1) $ AssetClass (cs2, tn)
+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)

code/week08/src/Week08/TraceTokenSale.hs

@@ -56,31 +56,24 @@ token2 = AssetClass (currency2, name2)
 
 myTrace :: EmulatorTrace ()
 myTrace = do
-    h <- activateContractWallet (Wallet 1) startTS'
+    h1 <- activateContractWallet (Wallet 1) operateTS'
-    callEndpoint @"start" h (currency1, name1)
+    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