first working version

This commit is contained in:
Lars Brünjes 2021-05-24 22:21:05 +02:00
parent 0e622f33c6
commit b4e6f8886a
No known key found for this signature in database
GPG key ID: B488B9045DC1A087
3 changed files with 194 additions and 25 deletions

View file

@ -18,6 +18,7 @@ library
, containers
, data-default
, freer-extras
, lens
, playground-common
, plutus-contract
, plutus-ledger
@ -26,6 +27,7 @@ library
, plutus-tx
, plutus-use-cases
, prettyprinter
, QuickCheck
, text
default-language: Haskell2010
ghc-options: -Wall -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fno-strictness -fno-spec-constr -fno-specialise

View file

@ -2,10 +2,13 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
@ -13,23 +16,175 @@
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 Control.Lens hiding (elements)
import Control.Monad (void, when)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (isJust, isNothing)
import Data.Monoid (Last (..))
import Data.Text (Text)
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 Plutus.Contract.Test.ContractModel
import Plutus.Trace.Emulator
import Ledger hiding (singleton)
import Ledger.Ada as Ada
import Ledger.Value
import Prelude (Semigroup (..))
import qualified Prelude
import Test.QuickCheck
import Week08.TokenSale
data TSState = TSState
{ _tssPrice :: !Integer
, _tssLovelace :: !Integer
, _tssToken :: !Integer
} deriving Show
makeLenses ''TSState
newtype TSModel = TSModel {_tsModel :: Map Wallet TSState}
deriving Show
makeLenses ''TSModel
instance ContractModel TSModel where
data Action TSModel = Start Wallet | TSAction Wallet Wallet TSRedeemer
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
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 ]
initialState = TSModel Map.empty
nextState (Start w) = do
withdraw w $ nfts Map.! w
(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
wait 1
nextState (TSAction v w (AddTokens n)) = do
started <- hasStarted v -- 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?
withdraw w $ assetClassValue token n
(tsModel . ix v . tssToken) $~ (+ n)
wait 1
nextState (TSAction v w (BuyTokens n)) = do
when (n > 0) $ do
m <- getTSState v
case m of
Just t
| t ^. tssToken >= n -> do
let p = t ^. tssPrice
l = p * n
withdraw w $ lovelaceValueOf l
deposit w $ assetClassValue (tokens Map.! v) n
(tsModel . ix v . tssLovelace) $~ (+ l)
(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))
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
precondition s (Start w) = isNothing $ getTSState' s w
precondition _ _ = True
deriving instance Eq (ContractInstanceKey TSModel w s e)
deriving instance Show (ContractInstanceKey TSModel w s e)
getTSState' :: ModelState TSModel -> Wallet -> Maybe TSState
getTSState' s v = s ^. contractState . tsModel . at v
getTSState :: Wallet -> Spec TSModel (Maybe TSState)
getTSState v = do
s <- getModelState
return $ getTSState' s v
hasStarted :: Wallet -> Spec TSModel Bool
hasStarted v = isJust <$> getTSState v
w1, w2, w3, w4 :: Wallet
w1 = Wallet 1
w2 = Wallet 2
w3 = Wallet 3
w4 = Wallet 4
tokenCurrency :: CurrencySymbol
tokenCurrency = "ff"
tokenNames :: Map Wallet TokenName
tokenNames = Map.fromList [(w1, "A"), (w2, "B")]
tokens :: Map Wallet AssetClass
tokens = (\tn -> AssetClass (tokenCurrency, tn)) <$> tokenNames
wallets :: [Wallet]
wallets = [w1, w2, w3, w4]
css :: Map Wallet CurrencySymbol
css = Map.fromList [(w1, "01"), (w2, "02")]
nfts :: Map Wallet Value
nfts = (\cs -> assetClassValue (AssetClass (cs, nftName)) 1) <$> css
tss :: Map Wallet TokenSale
tss = Map.fromList
[ (w, TokenSale (pubKeyHash $ walletPubKey w) (tokens Map.! w) $ AssetClass (css Map.! w, nftName))
| w <- [w1, w2]
]
delay :: Int -> EmulatorTrace ()
delay = void . waitNSlots . fromIntegral
instanceSpec :: [ContractInstanceSpec TSModel]
instanceSpec =
[ContractInstanceSpec (StartKey w) w $ startTS'' | 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]
prop_TS :: Actions TSModel -> Property
prop_TS = propRunActionsWithOptions
(defaultCheckOptions & emulatorConfig .~ EmulatorConfig (Left d))
instanceSpec
(const $ pure True)
where
d :: InitialDistribution
d = Map.fromList $ [ ( w
, lovelaceValueOf 1000_000_000 <>
(nfts Map.! w) <>
mconcat [assetClassValue t 1000 | t <- Map.elems tokens])
| w <- [w1, w2]
] ++
[(w, lovelaceValueOf 1000_000_000) | w <- [w3, w4]]
test :: IO ()
test = quickCheck prop_TS

View file

@ -13,9 +13,13 @@
module Week08.TokenSale
( TokenSale (..)
, TSRedeemer (..)
, nftName
, TSStartSchema
, TSStartSchema'
, TSUseSchema
, startTS'
, startTS''
, useTS
) where
@ -50,7 +54,7 @@ data TSRedeemer =
| AddTokens Integer
| BuyTokens Integer
| Withdraw Integer Integer
deriving Show
deriving (Show, Prelude.Eq)
PlutusTx.unstableMakeIsData ''TSRedeemer
@ -113,14 +117,16 @@ mapErrorSM = mapError $ pack . show
nftName :: TokenName
nftName = "NFT"
startTS :: HasBlockchainActions s => AssetClass -> Contract (Last TokenSale) s Text ()
startTS token = do
startTS :: HasBlockchainActions s => Maybe CurrencySymbol -> AssetClass -> Contract (Last TokenSale) s Text ()
startTS mcs token = do
pkh <- pubKeyHash <$> Contract.ownPubKey
osc <- mapErrorC $ C.forgeContract pkh [(nftName, 1)]
cs <- case mcs of
Nothing -> C.currencySymbol <$> mapErrorC (C.forgeContract pkh [(nftName, 1)])
Just cs' -> return cs'
let ts = TokenSale
{ tsSeller = pkh
, tsToken = token
, tsNFT = AssetClass (C.currencySymbol osc, nftName)
, tsNFT = AssetClass (cs, nftName)
}
client = tsClient ts
void $ mapErrorSM $ runInitialise client 0 mempty
@ -139,8 +145,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
type TSStartSchema = BlockchainActions .\/ Endpoint "start" (CurrencySymbol, TokenName)
type TSUseSchema = BlockchainActions
type TSStartSchema = BlockchainActions .\/ Endpoint "start" (CurrencySymbol, TokenName)
type TSStartSchema' = BlockchainActions .\/ Endpoint "start" (CurrencySymbol, CurrencySymbol, TokenName)
type TSUseSchema = BlockchainActions
.\/ Endpoint "set price" Integer
.\/ Endpoint "add tokens" Integer
.\/ Endpoint "buy tokens" Integer
@ -149,7 +156,12 @@ type TSUseSchema = BlockchainActions
startTS' :: Contract (Last TokenSale) TSStartSchema Text ()
startTS' = start >> startTS'
where
start = endpoint @"start" >>= startTS . AssetClass
start = endpoint @"start" >>= startTS Nothing . AssetClass
startTS'' :: Contract (Last TokenSale) TSStartSchema' Text ()
startTS'' = start >> startTS''
where
start = endpoint @"start" >>= \(cs1, cs2, tn) -> startTS (Just cs1) $ AssetClass (cs2, tn)
useTS :: TokenSale -> Contract () TSUseSchema Text ()
useTS ts = (setPrice' `select` addTokens' `select` buyTokens' `select` withdraw') >> useTS ts