diff --git a/code/week08/src/Week08/TokenSaleWithClose.hs b/code/week08/src/Week08/TokenSaleWithClose.hs index 893a684..c118da2 100644 --- a/code/week08/src/Week08/TokenSaleWithClose.hs +++ b/code/week08/src/Week08/TokenSaleWithClose.hs @@ -54,6 +54,7 @@ data TSRedeemer = | AddTokens Integer | BuyTokens Integer | Withdraw Integer Integer + | Close deriving (Show, Prelude.Eq) PlutusTx.unstableMakeIsData ''TSRedeemer @@ -63,54 +64,58 @@ lovelaces :: Value -> Integer lovelaces = Ada.getLovelace . Ada.fromValue {-# INLINABLE transition #-} -transition :: TokenSale -> State Integer -> TSRedeemer -> Maybe (TxConstraints Void Void, State Integer) +transition :: TokenSale -> State (Maybe Integer) -> TSRedeemer -> Maybe (TxConstraints Void Void, State (Maybe Integer)) transition ts s r = case (stateValue s, stateData s, r) of - (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 + (v, Just _, SetPrice p) | p >= 0 -> Just ( Constraints.mustBeSignedBy (tsSeller ts) + , State (Just p) $ + v <> + nft (negate 1) + ) + (v, Just p, AddTokens n) | n > 0 -> Just ( mempty + , State (Just p) $ + v <> + nft (negate 1) <> + assetClassValue (tsToken ts) n + ) + (v, Just p, BuyTokens n) | n > 0 -> Just ( mempty + , State (Just p) $ + v <> + nft (negate 1) <> + assetClassValue (tsToken ts) (negate n) <> + lovelaceValueOf (n * p) + ) + (v, Just p, Withdraw n l) | n >= 0 && l >= 0 -> Just ( Constraints.mustBeSignedBy (tsSeller ts) + , State (Just p) $ + v <> + nft (negate 1) <> + assetClassValue (tsToken ts) (negate n) <> + lovelaceValueOf (negate l) + ) + (_, Just _, Close) -> Just ( Constraints.mustBeSignedBy (tsSeller ts) + , State Nothing $ + mempty + ) + _ -> Nothing where nft :: Integer -> Value nft = assetClassValue (tsNFT ts) {-# INLINABLE tsStateMachine #-} -tsStateMachine :: TokenSale -> StateMachine Integer TSRedeemer -tsStateMachine ts = mkStateMachine (Just $ tsNFT ts) (transition ts) (const False) +tsStateMachine :: TokenSale -> StateMachine (Maybe Integer) TSRedeemer +tsStateMachine ts = mkStateMachine (Just $ tsNFT ts) (transition ts) isNothing {-# INLINABLE mkTSValidator #-} -mkTSValidator :: TokenSale -> Integer -> TSRedeemer -> ScriptContext -> Bool +mkTSValidator :: TokenSale -> Maybe Integer -> TSRedeemer -> ScriptContext -> Bool mkTSValidator = mkValidator . tsStateMachine -type TS = StateMachine Integer TSRedeemer +type TS = StateMachine (Maybe Integer) TSRedeemer tsInst :: TokenSale -> Scripts.ScriptInstance TS tsInst ts = Scripts.validator @TS ($$(PlutusTx.compile [|| mkTSValidator ||]) `PlutusTx.applyCode` PlutusTx.liftCode ts) $$(PlutusTx.compile [|| wrap ||]) where - wrap = Scripts.wrapValidator @Integer @TSRedeemer + wrap = Scripts.wrapValidator @(Maybe Integer) @TSRedeemer tsValidator :: TokenSale -> Validator tsValidator = Scripts.validatorScript . tsInst @@ -118,7 +123,7 @@ tsValidator = Scripts.validatorScript . tsInst tsAddress :: TokenSale -> Ledger.Address tsAddress = scriptAddress . tsValidator -tsClient :: TokenSale -> StateMachineClient Integer TSRedeemer +tsClient :: TokenSale -> StateMachineClient (Maybe Integer) TSRedeemer tsClient ts = mkStateMachineClient $ StateMachineInstance (tsStateMachine ts) (tsInst ts) mapErrorC :: Contract w s C.CurrencyError a -> Contract w s Text a @@ -142,7 +147,7 @@ startTS mcs token = do , tsNFT = AssetClass (cs, nftName) } client = tsClient ts - void $ mapErrorSM $ runInitialise client 0 mempty + void $ mapErrorSM $ runInitialise client (Just 0) mempty tell $ Last $ Just ts logInfo $ "started token sale " ++ show ts return ts @@ -159,6 +164,9 @@ 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 +close :: HasBlockchainActions s => TokenSale -> Contract w s Text () +close ts = void $ mapErrorSM $ runStep (tsClient ts) Close + type TSStartSchema = BlockchainActions .\/ Endpoint "start" (CurrencySymbol, TokenName) type TSStartSchema' = BlockchainActions @@ -168,6 +176,7 @@ type TSUseSchema = BlockchainActions .\/ Endpoint "add tokens" Integer .\/ Endpoint "buy tokens" Integer .\/ Endpoint "withdraw" (Integer, Integer) + .\/ Endpoint "close" () startEndpoint :: Contract (Last TokenSale) TSStartSchema Text () startEndpoint = startTS' >> startEndpoint @@ -180,9 +189,10 @@ startEndpoint' = startTS' >> startEndpoint' 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 +useEndpoints ts = (setPrice' `select` addTokens' `select` buyTokens' `select` withdraw' `select` close') >> useEndpoints 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) + close' = handleError logError $ endpoint @"close" >> close ts diff --git a/code/week08/test/Spec/ModelWithClose.hs b/code/week08/test/Spec/ModelWithClose.hs index f1af77c..4dcea71 100644 --- a/code/week08/test/Spec/ModelWithClose.hs +++ b/code/week08/test/Spec/ModelWithClose.hs @@ -64,6 +64,7 @@ instance ContractModel TSModel where | 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 @@ -77,7 +78,8 @@ instance ContractModel TSModel where [ SetPrice <$> genWallet <*> genWallet <*> genNonNeg ] ++ [ AddTokens <$> genWallet <*> genWallet <*> genNonNeg ] ++ [ BuyTokens <$> genWallet <*> genWallet <*> genNonNeg ] ++ - [ Withdraw <$> genWallet <*> genWallet <*> genNonNeg <*> genNonNeg ] + [ Withdraw <$> genWallet <*> genWallet <*> genNonNeg <*> genNonNeg ] ++ + [ Close <$> genWallet <*> genWallet ] initialState = TSModel Map.empty @@ -128,18 +130,32 @@ instance ContractModel TSModel where _ -> 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) diff --git a/code/week08/test/Spec/TraceWithClose.hs b/code/week08/test/Spec/TraceWithClose.hs index cd68c0e..263554a 100644 --- a/code/week08/test/Spec/TraceWithClose.hs +++ b/code/week08/test/Spec/TraceWithClose.hs @@ -38,7 +38,7 @@ tests :: TestTree tests = checkPredicateOptions (defaultCheckOptions & emulatorConfig .~ emCfg) "token sale trace" - ( walletFundsChange (Wallet 1) (Ada.lovelaceValueOf 10_000_000 <> assetClassValue token (-60)) + ( walletFundsChange (Wallet 1) (Ada.lovelaceValueOf 25_000_000 <> assetClassValue token (-25)) .&&. walletFundsChange (Wallet 2) (Ada.lovelaceValueOf (-20_000_000) <> assetClassValue token 20) .&&. walletFundsChange (Wallet 3) (Ada.lovelaceValueOf (- 5_000_000) <> assetClassValue token 5) ) @@ -48,24 +48,31 @@ runMyTrace :: IO () runMyTrace = runEmulatorTraceIO' def emCfg myTrace emCfg :: EmulatorConfig -emCfg = EmulatorConfig $ Left $ Map.fromList [(Wallet w, v) | w <- [1 .. 3]] +emCfg = EmulatorConfig $ Left $ Map.fromList [(Wallet w, v' w) | w <- [1 .. 3]] where v :: Value v = Ada.lovelaceValueOf 1000_000_000 <> assetClassValue token 1000 -currency :: CurrencySymbol -currency = "aa" + v' :: Integer -> Value + v' w + | w == 1 = v <> assetClassValue nft 1 + | otherwise = v -name :: TokenName -name = "A" +tokenCurrency, nftCurrency :: CurrencySymbol +tokenCurrency = "aa" +nftCurrency = "01" -token :: AssetClass -token = AssetClass (currency, name) +tokenName' :: TokenName +tokenName' = "A" + +token, nft :: AssetClass +token = AssetClass (tokenCurrency, tokenName') +nft = AssetClass (nftCurrency, nftName) myTrace :: EmulatorTrace () myTrace = do - h <- activateContractWallet (Wallet 1) startEndpoint - callEndpoint @"start" h (currency, name) + h <- activateContractWallet (Wallet 1) startEndpoint' + callEndpoint @"start" h (nftCurrency, tokenCurrency, tokenName') void $ Emulator.waitNSlots 5 Last m <- observableState h case m of @@ -89,5 +96,6 @@ myTrace = do callEndpoint @"buy tokens" h3 5 void $ Emulator.waitNSlots 5 - callEndpoint @"withdraw" h1 (40, 10_000_000) + callEndpoint @"close" h1 () +-- callEndpoint @"withdraw" h1 (40, 10_000_000) void $ Emulator.waitNSlots 5