From 0e622f33c66fd28b1213f4515c90b844f470bab7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Sun, 23 May 2021 16:37:21 +0200 Subject: [PATCH] complete version of the token sales contract --- .../plutus-pioneer-program-week08.cabal | 4 +- code/week08/src/Week08/StateMachine.hs | 204 ------------------ code/week08/src/Week08/TestTokenSale.hs | 35 +++ code/week08/src/Week08/TokenSale.hs | 160 ++++++++++++++ code/week08/src/Week08/TraceTokenSale.hs | 94 ++++++++ 5 files changed, 292 insertions(+), 205 deletions(-) delete mode 100644 code/week08/src/Week08/StateMachine.hs create mode 100644 code/week08/src/Week08/TestTokenSale.hs create mode 100644 code/week08/src/Week08/TokenSale.hs create mode 100644 code/week08/src/Week08/TraceTokenSale.hs diff --git a/code/week08/plutus-pioneer-program-week08.cabal b/code/week08/plutus-pioneer-program-week08.cabal index 7a8748e..fbd4ca5 100644 --- a/code/week08/plutus-pioneer-program-week08.cabal +++ b/code/week08/plutus-pioneer-program-week08.cabal @@ -10,7 +10,9 @@ License-files: LICENSE library hs-source-dirs: src - exposed-modules: Week08.StateMachine + exposed-modules: Week08.TokenSale + , Week08.TestTokenSale + , Week08.TraceTokenSale build-depends: aeson , base ^>=4.14.1.0 , containers diff --git a/code/week08/src/Week08/StateMachine.hs b/code/week08/src/Week08/StateMachine.hs deleted file mode 100644 index 6676f2d..0000000 --- a/code/week08/src/Week08/StateMachine.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -module Week08.StateMachine where - -import Control.Monad hiding (fmap) -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text, pack) -import GHC.Generics (Generic) -import Plutus.Contract as Contract hiding (when) -import Plutus.Contract.StateMachine -import Plutus.Contract.Test -import qualified PlutusTx -import PlutusTx.Prelude hiding (Semigroup(..), check, unless) -import Ledger hiding (singleton) -import Ledger.Ada as Ada -import Ledger.Constraints as Constraints -import Ledger.Typed.Tx -import qualified Ledger.Typed.Scripts as Scripts -import Ledger.Value -import Playground.Contract (ToSchema) -import Prelude (Semigroup (..)) -import qualified Prelude - -data TokenSale = TokenSale - { tsSeller :: !PubKeyHash - , tsToken :: !AssetClass - , tsNFT :: !AssetClass - } deriving (Show, Generic, FromJSON, ToJSON, Prelude.Eq, Prelude.Ord) - -PlutusTx.makeLift ''TokenSale - -data TSRedeemer = - SetPrice Integer - | AddTokens Integer - | BuyTokens Integer - | Withdraw Integer Integer - deriving Show - -PlutusTx.unstableMakeIsData ''TSRedeemer - -{-# INLINABLE lovelaces #-} -lovelaces :: Value -> Integer -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 - ) - (v, p, AddTokens n) -> Just ( mempty - , State p $ v <> assetClassValue (tsToken ts) n - ) - (v, p, BuyTokens n) -> Just ( mempty - , State p $ v <> assetClassValue (tsToken ts) (negate n) <> lovelaceValueOf (n * p) - ) - (v, p, Withdraw n l) -> Just ( Constraints.mustBeSignedBy (tsSeller ts) - , State p $ v <> assetClassValue (tsToken ts) (negate n) <> lovelaceValueOf (negate l) - ) - -{-# INLINABLE tsStateMachine #-} -tsStateMachine :: TokenSale -> StateMachine Integer TSRedeemer -tsStateMachine ts = mkStateMachine (Just $ tsNFT ts) (transition ts) (const False) - -{-# INLINABLE mkTSValidator #-} -mkTSValidator :: TokenSale -> Integer -> TSRedeemer -> ScriptContext -> Bool -mkTSValidator = mkValidator . tsStateMachine - -type TS = StateMachine 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 - -tsValidator :: TokenSale -> Validator -tsValidator = Scripts.validatorScript . tsInst - -tsAddress :: TokenSale -> Ledger.Address -tsAddress = scriptAddress . tsValidator - -tsClient :: TokenSale -> StateMachineClient Integer TSRedeemer -tsClient ts = mkStateMachineClient $ StateMachineInstance (tsStateMachine ts) (tsInst ts) - -{- - - - - -data FirstParams = FirstParams - { fpSecond :: !PubKeyHash - , fpStake :: !Integer - , fpPlayDeadline :: !Slot - , fpRevealDeadline :: !Slot - , fpNonce :: !ByteString - , fpCurrency :: !CurrencySymbol - , fpTokenName :: !TokenName - , fpChoice :: !GameChoice - } deriving (Show, Generic, FromJSON, ToJSON, ToSchema) - -mapError' :: Contract w s SMContractError a -> Contract w s Text a -mapError' = mapError $ pack . show - -firstGame :: forall w s. HasBlockchainActions s => FirstParams -> Contract w s Text () -firstGame fp = do - pkh <- pubKeyHash <$> Contract.ownPubKey - let game = Game - { gFirst = pkh - , gSecond = fpSecond fp - , gStake = fpStake fp - , gPlayDeadline = fpPlayDeadline fp - , gRevealDeadline = fpRevealDeadline fp - , gToken = AssetClass (fpCurrency fp, fpTokenName fp) - } - client = gameClient game - v = lovelaceValueOf (fpStake fp) - c = fpChoice fp - bs = sha2_256 $ fpNonce fp `concatenate` if c == Zero then bsZero else bsOne - void $ mapError' $ runInitialise client (GameDatum bs Nothing) v - logInfo @String $ "made first move: " ++ show (fpChoice fp) - - void $ awaitSlot $ 1 + fpPlayDeadline fp - - m <- mapError' $ getOnChainState client - case m of - Nothing -> throwError "game output not found" - Just ((o, _), _) -> case tyTxOutData o of - - GameDatum _ Nothing -> do - logInfo @String "second player did not play" - void $ mapError' $ runStep client ClaimFirst - logInfo @String "first player reclaimed stake" - - GameDatum _ (Just c') | c' == c -> do - logInfo @String "second player played and lost" - void $ mapError' $ runStep client $ Reveal $ fpNonce fp - logInfo @String "first player revealed and won" - - _ -> logInfo @String "second player played and won" - -data SecondParams = SecondParams - { spFirst :: !PubKeyHash - , spStake :: !Integer - , spPlayDeadline :: !Slot - , spRevealDeadline :: !Slot - , spCurrency :: !CurrencySymbol - , spTokenName :: !TokenName - , spChoice :: !GameChoice - } deriving (Show, Generic, FromJSON, ToJSON, ToSchema) - -secondGame :: forall w s. HasBlockchainActions s => SecondParams -> Contract w s Text () -secondGame sp = do - pkh <- pubKeyHash <$> Contract.ownPubKey - let game = Game - { gFirst = spFirst sp - , gSecond = pkh - , gStake = spStake sp - , gPlayDeadline = spPlayDeadline sp - , gRevealDeadline = spRevealDeadline sp - , gToken = AssetClass (spCurrency sp, spTokenName sp) - } - client = gameClient game - m <- mapError' $ getOnChainState client - case m of - Nothing -> logInfo @String "no running game found" - Just ((o, _), _) -> case tyTxOutData o of - GameDatum _ Nothing -> do - logInfo @String "running game found" - void $ mapError' $ runStep client $ Play $ spChoice sp - logInfo @String $ "made second move: " ++ show (spChoice sp) - - void $ awaitSlot $ 1 + spRevealDeadline sp - - m' <- mapError' $ getOnChainState client - case m' of - Nothing -> logInfo @String "first player won" - Just _ -> do - logInfo @String "first player didn't reveal" - void $ mapError' $ runStep client ClaimSecond - logInfo @String "second player won" - - _ -> throwError "unexpected datum" - -type GameSchema = BlockchainActions .\/ Endpoint "first" FirstParams .\/ Endpoint "second" SecondParams - -endpoints :: Contract () GameSchema Text () -endpoints = (first `select` second) >> endpoints - where - first = endpoint @"first" >>= firstGame - second = endpoint @"second" >>= secondGame --} diff --git a/code/week08/src/Week08/TestTokenSale.hs b/code/week08/src/Week08/TestTokenSale.hs new file mode 100644 index 0000000..57fc75e --- /dev/null +++ b/code/week08/src/Week08/TestTokenSale.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week08.TestTokenSale where + +import Control.Monad hiding (fmap) +import Data.Aeson (FromJSON, ToJSON) +import Data.Monoid (Last (..)) +import Data.Text (Text, pack) +import GHC.Generics (Generic) +import Plutus.Contract as Contract hiding (when) +import Plutus.Contract.StateMachine +import Plutus.Contract.Test +import qualified Plutus.Contracts.Currency as C +import qualified PlutusTx +import PlutusTx.Prelude hiding (Semigroup(..), check, unless) +import Ledger hiding (singleton) +import Ledger.Ada as Ada +import Ledger.Constraints as Constraints +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Value +import Prelude (Semigroup (..)) +import qualified Prelude + +import Week08.TokenSale diff --git a/code/week08/src/Week08/TokenSale.hs b/code/week08/src/Week08/TokenSale.hs new file mode 100644 index 0000000..e7c34ca --- /dev/null +++ b/code/week08/src/Week08/TokenSale.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week08.TokenSale + ( TokenSale (..) + , TSStartSchema + , TSUseSchema + , startTS' + , useTS + ) where + +import Control.Monad hiding (fmap) +import Data.Aeson (FromJSON, ToJSON) +import Data.Monoid (Last (..)) +import Data.Text (Text, pack) +import GHC.Generics (Generic) +import Plutus.Contract as Contract hiding (when) +import Plutus.Contract.StateMachine +import qualified Plutus.Contracts.Currency as C +import qualified PlutusTx +import PlutusTx.Prelude hiding (Semigroup(..), check, unless) +import Ledger hiding (singleton) +import Ledger.Ada as Ada +import Ledger.Constraints as Constraints +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Value +import Prelude (Semigroup (..)) +import qualified Prelude + +data TokenSale = TokenSale + { tsSeller :: !PubKeyHash + , tsToken :: !AssetClass + , tsNFT :: !AssetClass + } deriving (Show, Generic, FromJSON, ToJSON, Prelude.Eq, Prelude.Ord) + +PlutusTx.makeLift ''TokenSale + +data TSRedeemer = + SetPrice Integer + | AddTokens Integer + | BuyTokens Integer + | Withdraw Integer Integer + deriving Show + +PlutusTx.unstableMakeIsData ''TSRedeemer + +{-# INLINABLE lovelaces #-} +lovelaces :: Value -> Integer +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) + ) + 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) + +{-# INLINABLE mkTSValidator #-} +mkTSValidator :: TokenSale -> Integer -> TSRedeemer -> ScriptContext -> Bool +mkTSValidator = mkValidator . tsStateMachine + +type TS = StateMachine 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 + +tsValidator :: TokenSale -> Validator +tsValidator = Scripts.validatorScript . tsInst + +tsAddress :: TokenSale -> Ledger.Address +tsAddress = scriptAddress . tsValidator + +tsClient :: TokenSale -> StateMachineClient Integer TSRedeemer +tsClient ts = mkStateMachineClient $ StateMachineInstance (tsStateMachine ts) (tsInst ts) + +mapErrorC :: Contract w s C.CurrencyError a -> Contract w s Text a +mapErrorC = mapError $ pack . show + +mapErrorSM :: Contract w s SMContractError a -> Contract w s Text a +mapErrorSM = mapError $ pack . show + + +nftName :: TokenName +nftName = "NFT" + +startTS :: HasBlockchainActions s => AssetClass -> Contract (Last TokenSale) s Text () +startTS token = do + pkh <- pubKeyHash <$> Contract.ownPubKey + osc <- mapErrorC $ C.forgeContract pkh [(nftName, 1)] + let ts = TokenSale + { tsSeller = pkh + , tsToken = token + , tsNFT = AssetClass (C.currencySymbol osc, nftName) + } + client = tsClient ts + void $ mapErrorSM $ runInitialise client 0 mempty + tell $ Last $ Just ts + logInfo $ "started token sale " ++ show 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 + +buyTokens :: HasBlockchainActions s => TokenSale -> Integer -> Contract w s Text () +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 TSUseSchema = BlockchainActions + .\/ Endpoint "set price" Integer + .\/ Endpoint "add tokens" Integer + .\/ Endpoint "buy tokens" Integer + .\/ Endpoint "withdraw" (Integer, Integer) + +startTS' :: Contract (Last TokenSale) TSStartSchema Text () +startTS' = start >> startTS' + where + start = endpoint @"start" >>= startTS . AssetClass + +useTS :: TokenSale -> Contract () TSUseSchema Text () +useTS ts = (setPrice' `select` addTokens' `select` buyTokens' `select` withdraw') >> 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 new file mode 100644 index 0000000..6616282 --- /dev/null +++ b/code/week08/src/Week08/TraceTokenSale.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week08.TraceTokenSale where + +import Control.Monad hiding (fmap) +import Control.Monad.Freer.Extras as Extras +import Data.Default (Default (..)) +import qualified Data.Map as Map +import Data.Monoid (Last (..)) +import Ledger +import Ledger.Value +import Ledger.Ada as Ada +import Plutus.Trace.Emulator as Emulator +import PlutusTx.Prelude +import Wallet.Emulator.Wallet + +import Week08.TokenSale + +test :: IO () +test = runEmulatorTraceIO' def emCfg myTrace + where + emCfg :: EmulatorConfig + emCfg = EmulatorConfig $ Left $ Map.fromList + [ (Wallet w, v) + | w <- [1 .. 3] + ] + + v :: Value + v = Ada.lovelaceValueOf 1000_000_000 + <> assetClassValue token1 1000 + <> assetClassValue token2 1000 + +currency1, currency2 :: CurrencySymbol +currency1 = "aa" +currency2 = "bb" + +name1, name2 :: TokenName +name1 = "A" +name2 = "B" + +token1, token2 :: AssetClass +token1 = AssetClass (currency1, name1) +token2 = AssetClass (currency2, name2) + +myTrace :: EmulatorTrace () +myTrace = do + h <- activateContractWallet (Wallet 1) startTS' + callEndpoint @"start" h (currency1, name1) + void $ Emulator.waitNSlots 5 + Last m <- observableState h + 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 + + callEndpoint @"buy tokens" h3 5 + void $ Emulator.waitNSlots 5 + + callEndpoint @"withdraw" h1 (40, 10_000_000) + void $ Emulator.waitNSlots 5 + + callEndpoint @"withdraw" h2 (40, 10_000_000) + void $ Emulator.waitNSlots 5