claudiomaradonna/plutus-pioneer-program
1
0
Fork 0
mirror of https://github.com/FiloSpaTeam/plutus-pioneer-program.git synced 2024-11-22 06:42:00 +01:00
Code Issues Projects Releases Packages Wiki Activity

sample solution for homework from week 8

Browse source
This commit is contained in:
Lars Brünjes 2021-05-27 19:34:11 +02:00
parent 99cbc0b8ca
commit 9c86f2370b
No known key found for this signature in database
GPG key ID: B488B9045DC1A087
3 changed files with 81 additions and 47 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

80
code/week08/src/Week08/TokenSaleWithClose.hs
View file

@ -54,6 +54,7 @@ data TSRedeemer =
| AddTokens Integer | AddTokens Integer
| BuyTokens Integer | BuyTokens Integer
| Withdraw Integer Integer | Withdraw Integer Integer
| Close
deriving (Show, Prelude.Eq) deriving (Show, Prelude.Eq)
PlutusTx.unstableMakeIsData ''TSRedeemer PlutusTx.unstableMakeIsData ''TSRedeemer
@ -63,54 +64,58 @@ lovelaces :: Value -> Integer
lovelaces = Ada.getLovelace . Ada.fromValue lovelaces = Ada.getLovelace . Ada.fromValue
{-# INLINABLE transition #-} {-# 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 transition ts s r = case (stateValue s, stateData s, r) of
(v, _, SetPrice p) | p >= 0 -> Just ( Constraints.mustBeSignedBy (tsSeller ts) (v, Just _, SetPrice p) | p >= 0 -> Just ( Constraints.mustBeSignedBy (tsSeller ts)
, State p $ , State (Just p) $
v <> v <>
nft (negate 1) nft (negate 1)
) )
(v, p, AddTokens n) | n > 0 -> Just ( mempty (v, Just p, AddTokens n) | n > 0 -> Just ( mempty
, State p $ , State (Just p) $
v <> v <>
nft (negate 1) <> nft (negate 1) <>
assetClassValue (tsToken ts) n assetClassValue (tsToken ts) n
) )
(v, p, BuyTokens n) | n > 0 -> Just ( mempty (v, Just p, BuyTokens n) | n > 0 -> Just ( mempty
, State p $ , State (Just p) $
v <> v <>
nft (negate 1) <> nft (negate 1) <>
assetClassValue (tsToken ts) (negate n) <> assetClassValue (tsToken ts) (negate n) <>
lovelaceValueOf (n * p) lovelaceValueOf (n * p)
) )
(v, p, Withdraw n l) | n >= 0 && l >= 0 -> Just ( Constraints.mustBeSignedBy (tsSeller ts) (v, Just p, Withdraw n l) | n >= 0 && l >= 0 -> Just ( Constraints.mustBeSignedBy (tsSeller ts)
, State p $ , State (Just p) $
v <> v <>
nft (negate 1) <> nft (negate 1) <>
assetClassValue (tsToken ts) (negate n) <> assetClassValue (tsToken ts) (negate n) <>
lovelaceValueOf (negate l) lovelaceValueOf (negate l)
) )
_ -> Nothing (_, Just _, Close) -> Just ( Constraints.mustBeSignedBy (tsSeller ts)
, State Nothing $
mempty
)
_ -> Nothing
where where
nft :: Integer -> Value nft :: Integer -> Value
nft = assetClassValue (tsNFT ts) nft = assetClassValue (tsNFT ts)
{-# INLINABLE tsStateMachine #-} {-# INLINABLE tsStateMachine #-}
tsStateMachine :: TokenSale -> StateMachine Integer TSRedeemer tsStateMachine :: TokenSale -> StateMachine (Maybe Integer) TSRedeemer
tsStateMachine ts = mkStateMachine (Just $ tsNFT ts) (transition ts) (const False) tsStateMachine ts = mkStateMachine (Just $ tsNFT ts) (transition ts) isNothing
{-# INLINABLE mkTSValidator #-} {-# INLINABLE mkTSValidator #-}
mkTSValidator :: TokenSale -> Integer -> TSRedeemer -> ScriptContext -> Bool mkTSValidator :: TokenSale -> Maybe Integer -> TSRedeemer -> ScriptContext -> Bool
mkTSValidator = mkValidator . tsStateMachine mkTSValidator = mkValidator . tsStateMachine
type TS = StateMachine Integer TSRedeemer type TS = StateMachine (Maybe Integer) TSRedeemer
tsInst :: TokenSale -> Scripts.ScriptInstance TS tsInst :: TokenSale -> Scripts.ScriptInstance TS
tsInst ts = Scripts.validator @TS tsInst ts = Scripts.validator @TS
($$(PlutusTx.compile [|| mkTSValidator ||]) `PlutusTx.applyCode` PlutusTx.liftCode ts) ($$(PlutusTx.compile [|| mkTSValidator ||]) `PlutusTx.applyCode` PlutusTx.liftCode ts)
$$(PlutusTx.compile [|| wrap ||]) $$(PlutusTx.compile [|| wrap ||])
where where
wrap = Scripts.wrapValidator @Integer @TSRedeemer wrap = Scripts.wrapValidator @(Maybe Integer) @TSRedeemer
tsValidator :: TokenSale -> Validator tsValidator :: TokenSale -> Validator
tsValidator = Scripts.validatorScript . tsInst tsValidator = Scripts.validatorScript . tsInst
@ -118,7 +123,7 @@ tsValidator = Scripts.validatorScript . tsInst
tsAddress :: TokenSale -> Ledger.Address tsAddress :: TokenSale -> Ledger.Address
tsAddress = scriptAddress . tsValidator tsAddress = scriptAddress . tsValidator
tsClient :: TokenSale -> StateMachineClient Integer TSRedeemer tsClient :: TokenSale -> StateMachineClient (Maybe Integer) TSRedeemer
tsClient ts = mkStateMachineClient $ StateMachineInstance (tsStateMachine ts) (tsInst ts) tsClient ts = mkStateMachineClient $ StateMachineInstance (tsStateMachine ts) (tsInst ts)
mapErrorC :: Contract w s C.CurrencyError a -> Contract w s Text a mapErrorC :: Contract w s C.CurrencyError a -> Contract w s Text a
@ -142,7 +147,7 @@ startTS mcs token = do
, tsNFT = AssetClass (cs, nftName) , tsNFT = AssetClass (cs, nftName)
} }
client = tsClient ts client = tsClient ts
void $ mapErrorSM $ runInitialise client 0 mempty void $ mapErrorSM $ runInitialise client (Just 0) mempty
tell $ Last $ Just ts tell $ Last $ Just ts
logInfo $ "started token sale " ++ show ts logInfo $ "started token sale " ++ show ts
return 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 :: HasBlockchainActions s => TokenSale -> Integer -> Integer -> Contract w s Text ()
withdraw ts n l = void $ mapErrorSM $ runStep (tsClient ts) $ Withdraw n l 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 type TSStartSchema = BlockchainActions
.\/ Endpoint "start" (CurrencySymbol, TokenName) .\/ Endpoint "start" (CurrencySymbol, TokenName)
type TSStartSchema' = BlockchainActions type TSStartSchema' = BlockchainActions
@ -168,6 +176,7 @@ type TSUseSchema = BlockchainActions
.\/ Endpoint "add tokens" Integer .\/ Endpoint "add tokens" Integer
.\/ Endpoint "buy tokens" Integer .\/ Endpoint "buy tokens" Integer
.\/ Endpoint "withdraw" (Integer, Integer) .\/ Endpoint "withdraw" (Integer, Integer)
.\/ Endpoint "close" ()
startEndpoint :: Contract (Last TokenSale) TSStartSchema Text () startEndpoint :: Contract (Last TokenSale) TSStartSchema Text ()
startEndpoint = startTS' >> startEndpoint 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) startTS' = handleError logError $ endpoint @"start" >>= \(cs1, cs2, tn) -> void $ startTS (Just cs1) $ AssetClass (cs2, tn)
useEndpoints :: TokenSale -> Contract () TSUseSchema Text () 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 where
setPrice' = handleError logError $ endpoint @"set price" >>= setPrice ts setPrice' = handleError logError $ endpoint @"set price" >>= setPrice ts
addTokens' = handleError logError $ endpoint @"add tokens" >>= addTokens ts addTokens' = handleError logError $ endpoint @"add tokens" >>= addTokens ts
buyTokens' = handleError logError $ endpoint @"buy tokens" >>= buyTokens ts buyTokens' = handleError logError $ endpoint @"buy tokens" >>= buyTokens ts
withdraw' = handleError logError $ endpoint @"withdraw" >>= uncurry (withdraw ts) withdraw' = handleError logError $ endpoint @"withdraw" >>= uncurry (withdraw ts)
close' = handleError logError $ endpoint @"close" >> close ts

18
code/week08/test/Spec/ModelWithClose.hs
View file

@ -64,6 +64,7 @@ instance ContractModel TSModel where
| AddTokens Wallet Wallet Integer | AddTokens Wallet Wallet Integer
| Withdraw Wallet Wallet Integer Integer | Withdraw Wallet Wallet Integer Integer
| BuyTokens Wallet Wallet Integer | BuyTokens Wallet Wallet Integer
| Close Wallet Wallet
deriving (Show, Eq) deriving (Show, Eq)
data ContractInstanceKey TSModel w s e where data ContractInstanceKey TSModel w s e where
@ -77,7 +78,8 @@ instance ContractModel TSModel where
[ SetPrice <$> genWallet <*> genWallet <*> genNonNeg ] ++ [ SetPrice <$> genWallet <*> genWallet <*> genNonNeg ] ++
[ AddTokens <$> genWallet <*> genWallet <*> genNonNeg ] ++ [ AddTokens <$> genWallet <*> genWallet <*> genNonNeg ] ++
[ BuyTokens <$> genWallet <*> genWallet <*> genNonNeg ] ++ [ BuyTokens <$> genWallet <*> genWallet <*> genNonNeg ] ++
[ Withdraw <$> genWallet <*> genWallet <*> genNonNeg <*> genNonNeg ] [ Withdraw <$> genWallet <*> genWallet <*> genNonNeg <*> genNonNeg ] ++
[ Close <$> genWallet <*> genWallet ]
initialState = TSModel Map.empty initialState = TSModel Map.empty
@ -128,18 +130,32 @@ instance ContractModel TSModel where
_ -> return () _ -> return ()
wait 1 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 perform h _ cmd = case cmd of
(Start w) -> callEndpoint @"start" (h $ StartKey w) (nftCurrencies Map.! w, tokenCurrencies Map.! w, tokenNames Map.! w) >> delay 1 (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 (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 (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 (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 (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 (Start w) = isNothing $ getTSState' s w
precondition s (SetPrice v _ _) = isJust $ getTSState' s v precondition s (SetPrice v _ _) = isJust $ getTSState' s v
precondition s (AddTokens v _ _) = isJust $ getTSState' s v precondition s (AddTokens v _ _) = isJust $ getTSState' s v
precondition s (BuyTokens v _ _) = isJust $ getTSState' s v precondition s (BuyTokens v _ _) = isJust $ getTSState' s v
precondition s (Withdraw 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 Eq (ContractInstanceKey TSModel w s e)
deriving instance Show (ContractInstanceKey TSModel w s e) deriving instance Show (ContractInstanceKey TSModel w s e)

30
code/week08/test/Spec/TraceWithClose.hs
View file

@ -38,7 +38,7 @@ tests :: TestTree
tests = checkPredicateOptions tests = checkPredicateOptions
(defaultCheckOptions & emulatorConfig .~ emCfg) (defaultCheckOptions & emulatorConfig .~ emCfg)
"token sale trace" "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 2) (Ada.lovelaceValueOf (-20_000_000) <> assetClassValue token 20)
.&&. walletFundsChange (Wallet 3) (Ada.lovelaceValueOf (- 5_000_000) <> assetClassValue token 5) .&&. walletFundsChange (Wallet 3) (Ada.lovelaceValueOf (- 5_000_000) <> assetClassValue token 5)
) )
@ -48,24 +48,31 @@ runMyTrace :: IO ()
runMyTrace = runEmulatorTraceIO' def emCfg myTrace runMyTrace = runEmulatorTraceIO' def emCfg myTrace
emCfg :: EmulatorConfig 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 where
v :: Value v :: Value
v = Ada.lovelaceValueOf 1000_000_000 <> assetClassValue token 1000 v = Ada.lovelaceValueOf 1000_000_000 <> assetClassValue token 1000
currency :: CurrencySymbol v' :: Integer -> Value
currency = "aa" v' w
| w == 1 = v <> assetClassValue nft 1
| otherwise = v
name :: TokenName tokenCurrency, nftCurrency :: CurrencySymbol
name = "A" tokenCurrency = "aa"
nftCurrency = "01"
token :: AssetClass tokenName' :: TokenName
token = AssetClass (currency, name) tokenName' = "A"
token, nft :: AssetClass
token = AssetClass (tokenCurrency, tokenName')
nft = AssetClass (nftCurrency, nftName)
myTrace :: EmulatorTrace () myTrace :: EmulatorTrace ()
myTrace = do myTrace = do
h <- activateContractWallet (Wallet 1) startEndpoint h <- activateContractWallet (Wallet 1) startEndpoint'
callEndpoint @"start" h (currency, name) callEndpoint @"start" h (nftCurrency, tokenCurrency, tokenName')
void $ Emulator.waitNSlots 5 void $ Emulator.waitNSlots 5
Last m <- observableState h Last m <- observableState h
case m of case m of
@ -89,5 +96,6 @@ myTrace = do
callEndpoint @"buy tokens" h3 5 callEndpoint @"buy tokens" h3 5
void $ Emulator.waitNSlots 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 void $ Emulator.waitNSlots 5