mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-12-22 21:42:11 +01:00
complete version of the token sales contract
This commit is contained in:
Lars Brünjes
parent
b1eed7b358
commit
0e622f33c6
5 changed files with 292 additions and 205 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
-}
|
||||
35
code/week08/src/Week08/TestTokenSale.hs
Normal file
35
code/week08/src/Week08/TestTokenSale.hs
Normal file
|
|
@ -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
|
||||
160
code/week08/src/Week08/TokenSale.hs
Normal file
160
code/week08/src/Week08/TokenSale.hs
Normal file
|
|
@ -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)
|
||||
94
code/week08/src/Week08/TraceTokenSale.hs
Normal file
94
code/week08/src/Week08/TraceTokenSale.hs
Normal file
|
|
@ -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
|
||||
Loading…
Reference in a new issue