mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-11-22 06:42:00 +01:00
sample solution for homework from week 8
This commit is contained in:
Lars Brünjes
parent
99cbc0b8ca
commit
9c86f2370b
3 changed files with 81 additions and 47 deletions
|
|
@ -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, Just _, SetPrice p) | p >= 0 -> Just ( Constraints.mustBeSignedBy (tsSeller ts)
|
||||
, State (Just p) $
|
||||
v <>
|
||||
nft (negate 1)
|
||||
)
|
||||
(v, p, AddTokens n) | n > 0 -> Just ( mempty
|
||||
, State p $
|
||||
(v, Just p, AddTokens n) | n > 0 -> Just ( mempty
|
||||
, State (Just p) $
|
||||
v <>
|
||||
nft (negate 1) <>
|
||||
assetClassValue (tsToken ts) n
|
||||
)
|
||||
(v, p, BuyTokens n) | n > 0 -> Just ( mempty
|
||||
, State p $
|
||||
(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, p, Withdraw n l) | n >= 0 && l >= 0 -> Just ( Constraints.mustBeSignedBy (tsSeller ts)
|
||||
, State 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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue