diff --git a/code/week02/plutus-pioneer-program-week02.cabal b/code/week02/plutus-pioneer-program-week02.cabal index 762e041..acd6f4f 100644 --- a/code/week02/plutus-pioneer-program-week02.cabal +++ b/code/week02/plutus-pioneer-program-week02.cabal @@ -10,7 +10,7 @@ License-files: LICENSE library hs-source-dirs: src - exposed-modules: Week02.Validators + exposed-modules: Week02.Gift build-depends: aeson , base ^>=4.14.1.0 , containers diff --git a/code/week02/src/Week02/Gift.hs b/code/week02/src/Week02/Gift.hs new file mode 100644 index 0000000..fc79dc4 --- /dev/null +++ b/code/week02/src/Week02/Gift.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week02.Gift + ( give + , grab + , endpoints + , schemas + , registeredKnownCurrencies + , printJson + , printSchemas + , ensureKnownCurrencies + , stage + ) where + +import Control.Monad hiding (fmap) +import Data.Map as Map +import Data.Text (Text) +import Data.Void (Void) +import Plutus.Contract hiding (when) +import PlutusTx (Data (..)) +import qualified PlutusTx +import PlutusTx.Prelude hiding (Semigroup(..), unless) +import Ledger hiding (singleton) +import Ledger.Constraints as Constraints +import qualified Ledger.Scripts as Scripts +import Ledger.Ada as Ada +import Playground.Contract (printJson, printSchemas, ensureKnownCurrencies, stage) +import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions) +import Playground.Types (KnownCurrency (..)) +import Prelude (Semigroup (..)) +import Text.Printf (printf) + +{-# INLINABLE mkGiftValidator #-} +mkGiftValidator :: Data -> Data -> Data -> () +mkGiftValidator _ _ _ = () + +giftValidator :: Validator +giftValidator = mkValidatorScript $$(PlutusTx.compile [|| mkGiftValidator ||]) + +giftHash :: Ledger.ValidatorHash +giftHash = Scripts.validatorHash giftValidator + +giftAddress :: Ledger.Address +giftAddress = ScriptAddress giftHash + +type GiftSchema = + BlockchainActions + .\/ Endpoint "give" Integer + .\/ Endpoint "grab" () + +give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e () +give amount = do + let tx = mustPayToOtherScript giftHash (Datum $ I 42) $ Ada.lovelaceValueOf amount + ledgerTx <- submitTx tx + void $ awaitTxConfirmed $ txId ledgerTx + logInfo @String $ printf "made a gift of %d lovelace" amount + +grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => Contract w s e () +grab = do + utxos <- utxoAt $ ScriptAddress giftHash + let orefs = fst <$> Map.toList utxos + lookups = Constraints.unspentOutputs utxos <> + Constraints.otherScript giftValidator + tx :: TxConstraints Void Void + tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ I 17 | oref <- orefs] + ledgerTx <- submitTxConstraintsWith @Void lookups tx + void $ awaitTxConfirmed $ txId ledgerTx + logInfo @String $ "collected gifts" + +endpoints :: Contract () GiftSchema Text () +endpoints = (give' `select` grab') >> endpoints + where + give' = endpoint @"give" >>= give + grab' = endpoint @"grab" >> grab + +mkSchemaDefinitions ''GiftSchema + +mkKnownCurrencies [] diff --git a/code/week02/src/Week02/Validators.hs b/code/week02/src/Week02/Validators.hs deleted file mode 100644 index 36e2297..0000000 --- a/code/week02/src/Week02/Validators.hs +++ /dev/null @@ -1,368 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -module Week02.Validators - ( Auction (..) - , StartParams (..), BidParams (..), CloseParams (..) - , AuctionSchema - , start, bid, close - , endpoints - , schemas - , ensureKnownCurrencies - , printJson - , printSchemas - , registeredKnownCurrencies - , stage - ) where - -import Control.Monad hiding (fmap) -import Data.Aeson (ToJSON, FromJSON) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Map as Map -import Data.Text (pack, Text) -import GHC.Generics (Generic) -import Plutus.Contract hiding (when) -import qualified PlutusTx as PlutusTx -import PlutusTx.Prelude hiding (Semigroup(..), unless) -import qualified PlutusTx.Prelude as Plutus -import Ledger hiding (singleton) -import Ledger.Constraints as Constraints -import qualified Ledger.Scripts as Scripts -import qualified Ledger.Typed.Scripts as Scripts -import Ledger.Value as Value -import Ledger.Ada as Ada -import Playground.Contract (ensureKnownCurrencies, printSchemas, stage, printJson) -import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions) -import Playground.Types (KnownCurrency (..)) -import Prelude (Semigroup (..)) -import Schema (ToSchema) -import Text.Printf (printf) - -data Auction = Auction - { aSeller :: !PubKeyHash - , aDeadline :: !Slot - , aMinBid :: !Integer - , aCurrency :: !CurrencySymbol - , aToken :: !TokenName - } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) - -instance Eq Auction where - {-# INLINABLE (==) #-} - a == b = (aSeller a == aSeller b) && - (aDeadline a == aDeadline b) && - (aMinBid a == aMinBid b) && - (aCurrency a == aCurrency b) && - (aToken a == aToken b) - -PlutusTx.unstableMakeIsData ''Auction -PlutusTx.makeLift ''Auction - -data Bid = Bid - { bBidder :: !PubKeyHash - , bBid :: !Integer - } deriving Show - -instance Eq Bid where - {-# INLINABLE (==) #-} - b == c = (bBidder b == bBidder c) && - (bBid b == bBid c) - -PlutusTx.unstableMakeIsData ''Bid -PlutusTx.makeLift ''Bid - -data AuctionAction = MkBid Bid | Close - deriving Show - -PlutusTx.unstableMakeIsData ''AuctionAction -PlutusTx.makeLift ''AuctionAction - -data AuctionDatum = AuctionDatum - { adAuction :: !Auction - , adHighestBid :: !(Maybe Bid) - } deriving Show - -PlutusTx.unstableMakeIsData ''AuctionDatum -PlutusTx.makeLift ''AuctionDatum - -data Auctioning -instance Scripts.ScriptType Auctioning where - type instance RedeemerType Auctioning = AuctionAction - type instance DatumType Auctioning = AuctionDatum - -{-# INLINABLE minBid #-} -minBid :: AuctionDatum -> Integer -minBid AuctionDatum{..} = case adHighestBid of - Nothing -> aMinBid adAuction - Just Bid{..} -> bBid + 1 - -{-# INLINABLE mkAuctionValidator #-} -mkAuctionValidator :: AuctionDatum -> AuctionAction -> ValidatorCtx -> Bool -mkAuctionValidator ad redeemer ctx = - traceIfFalse "wrong input value" correctInputValue && - case redeemer of - MkBid b@Bid{..} -> - traceIfFalse "bid too low" (sufficientBid bBid) && - traceIfFalse "wrong output datum" (correctBidOutputDatum b) && - traceIfFalse "wrong output value" (correctBidOutputValue bBid) && - traceIfFalse "wrong refund" correctBidRefund && - traceIfFalse "too late" correctBidSlotRange - Close -> - traceIfFalse "too early" correctCloseSlotRange && - case adHighestBid ad of - Nothing -> - traceIfFalse "expected seller to get token" (getsValue (aSeller auction) tokenValue) - Just Bid{..} -> - traceIfFalse "expected highest bidder to get token" (getsValue bBidder tokenValue) && - traceIfFalse "expected seller to get highest bid" (getsValue (aSeller auction) $ Ada.lovelaceValueOf bBid) - - where - info :: TxInfo - info = valCtxTxInfo ctx - - input :: TxInInfo - input = - let - isScriptInput i = case txInInfoWitness i of - Nothing -> False - Just _ -> True - xs = [i | i <- txInfoInputs info, isScriptInput i] - in - case xs of - [i] -> i - _ -> traceError "expected exactly one script input" - - inVal :: Value - inVal = txInInfoValue input - - auction :: Auction - auction = adAuction ad - - tokenValue :: Value - tokenValue = Value.singleton (aCurrency auction) (aToken auction) 1 - - correctInputValue :: Bool - correctInputValue = inVal == case adHighestBid ad of - Nothing -> tokenValue - Just Bid{..} -> tokenValue Plutus.<> Ada.lovelaceValueOf bBid - - sufficientBid :: Integer -> Bool - sufficientBid amount = amount >= minBid ad - - ownOutput :: TxOutInfo - outputDatum :: AuctionDatum - (ownOutput, outputDatum) = case getContinuingOutputs ctx of - [o] -> case txOutType o of - PayToPubKey -> traceError "wrong output type" - PayToScript h -> case findDatum h info of - Nothing -> traceError "datum not found" - Just (Datum d) -> case PlutusTx.fromData d of - Just ad' -> (o, ad') - Nothing -> traceError "error decoding data" - _ -> traceError "expected exactly one continuing output" - - correctBidOutputDatum :: Bid -> Bool - correctBidOutputDatum b = (adAuction outputDatum == auction) && - (adHighestBid outputDatum == Just b) - - correctBidOutputValue :: Integer -> Bool - correctBidOutputValue amount = - txOutValue ownOutput == tokenValue Plutus.<> Ada.lovelaceValueOf amount - - correctBidRefund :: Bool - correctBidRefund = case adHighestBid ad of - Nothing -> True - Just Bid{..} -> - let - os = [ o - | o <- txInfoOutputs info - , txOutAddress o == PubKeyAddress bBidder - ] - in - case os of - [o] -> txOutValue o == Ada.lovelaceValueOf bBid - _ -> traceError "expected exactly one refund output" - - correctBidSlotRange :: Bool - correctBidSlotRange = to (aDeadline auction) `contains` txInfoValidRange info - - correctCloseSlotRange :: Bool - correctCloseSlotRange = from (aDeadline auction) `contains` txInfoValidRange info - - getsValue :: PubKeyHash -> Value -> Bool - getsValue h v = - let - [o] = [ o' - | o' <- txInfoOutputs info - , txOutValue o' == v - ] - in - txOutAddress o == PubKeyAddress h - -auctionInstance :: Scripts.ScriptInstance Auctioning -auctionInstance = Scripts.validator @Auctioning - $$(PlutusTx.compile [|| mkAuctionValidator ||]) - $$(PlutusTx.compile [|| wrap ||]) - where - wrap = Scripts.wrapValidator @AuctionDatum @AuctionAction - -auctionValidator :: Validator -auctionValidator = Scripts.validatorScript auctionInstance - -auctionHash :: Ledger.ValidatorHash -auctionHash = Scripts.validatorHash auctionValidator - -auctionAddress :: Ledger.Address -auctionAddress = ScriptAddress auctionHash - -data StartParams = StartParams - { spDeadline :: !Slot - , spMinBid :: !Integer - , spCurrency :: !CurrencySymbol - , spToken :: !TokenName - } deriving (Generic, ToJSON, FromJSON, ToSchema) - -data BidParams = BidParams - { bpCurrency :: !CurrencySymbol - , bpToken :: !TokenName - , bpBid :: !Integer - } deriving (Generic, ToJSON, FromJSON, ToSchema) - -data CloseParams = CloseParams - { cpCurrency :: !CurrencySymbol - , cpToken :: !TokenName - } deriving (Generic, ToJSON, FromJSON, ToSchema) - -type AuctionSchema = - BlockchainActions - .\/ Endpoint "start" StartParams - .\/ Endpoint "bid" BidParams - .\/ Endpoint "close" CloseParams - -start :: (HasBlockchainActions s, AsContractError e) => StartParams -> Contract w s e () -start StartParams{..} = do - pkh <- pubKeyHash <$> ownPubKey - let a = Auction - { aSeller = pkh - , aDeadline = spDeadline - , aMinBid = spMinBid - , aCurrency = spCurrency - , aToken = spToken - } - d = AuctionDatum - { adAuction = a - , adHighestBid = Nothing - } - v = Value.singleton spCurrency spToken 1 - tx = mustPayToTheScript d v - ledgerTx <- submitTxConstraints auctionInstance tx - void $ awaitTxConfirmed $ txId ledgerTx - logInfo @String $ printf "started auction %s for token %s" (show a) (show v) - -bid :: forall w s. HasBlockchainActions s => BidParams -> Contract w s Text () -bid BidParams{..} = do - (oref, o, d@AuctionDatum{..}) <- findAuction bpCurrency bpToken - logInfo @String $ printf "found auction utxo with datum %s" (show d) - - when (bpBid < minBid d) $ - throwError $ pack $ printf "bid lower than minimal bid %d" (minBid d) - pkh <- pubKeyHash <$> ownPubKey - let b = Bid {bBidder = pkh, bBid = bpBid} - d' = d {adHighestBid = Just b} - v = Value.singleton bpCurrency bpToken 1 <> Ada.lovelaceValueOf bpBid - r = Redeemer $ PlutusTx.toData $ MkBid b - - lookups = Constraints.scriptInstanceLookups auctionInstance <> - Constraints.otherScript auctionValidator <> - Constraints.unspentOutputs (Map.singleton oref o) - tx = case adHighestBid of - Nothing -> mustPayToTheScript d' v <> - mustValidateIn (to $ aDeadline adAuction) <> - mustSpendScriptOutput oref r - Just Bid{..} -> mustPayToTheScript d' v <> - mustPayToPubKey bBidder (Ada.lovelaceValueOf bBid) <> - mustValidateIn (to $ aDeadline adAuction) <> - mustSpendScriptOutput oref r - ledgerTx <- submitTxConstraintsWith lookups tx - void $ awaitTxConfirmed $ txId ledgerTx - logInfo @String $ printf "made bid of %d lovelace in auction %s for token (%s, %s)" - bpBid - (show adAuction) - (show bpCurrency) - (show bpToken) - -close :: forall w s. HasBlockchainActions s => CloseParams -> Contract w s Text () -close CloseParams{..} = do - (oref, o, d@AuctionDatum{..}) <- findAuction cpCurrency cpToken - logInfo @String $ printf "found auction utxo with datum %s" (show d) - - let t = Value.singleton cpCurrency cpToken 1 - r = Redeemer $ PlutusTx.toData Close - seller = aSeller adAuction - - lookups = Constraints.scriptInstanceLookups auctionInstance <> - Constraints.otherScript auctionValidator <> - Constraints.unspentOutputs (Map.singleton oref o) - tx = case adHighestBid of - Nothing -> mustPayToPubKey seller t <> - mustValidateIn (from $ aDeadline adAuction) <> - mustSpendScriptOutput oref r - Just Bid{..} -> mustPayToPubKey bBidder t <> - mustPayToPubKey seller (Ada.lovelaceValueOf bBid) <> - mustValidateIn (from $ aDeadline adAuction) <> - mustSpendScriptOutput oref r - ledgerTx <- submitTxConstraintsWith lookups tx - void $ awaitTxConfirmed $ txId ledgerTx - logInfo @String $ printf "closed auction %s for token (%s, %s)" - (show adAuction) - (show cpCurrency) - (show cpToken) - -findAuction :: HasBlockchainActions s - => CurrencySymbol - -> TokenName - -> Contract w s Text (TxOutRef, TxOutTx, AuctionDatum) -findAuction cs tn = do - utxos <- utxoAt $ ScriptAddress auctionHash - let xs = [ (oref, o) - | (oref, o) <- Map.toList utxos - , Value.valueOf (txOutValue $ txOutTxOut o) cs tn == 1 - ] - case xs of - [(oref, o)] -> case txOutType $ txOutTxOut o of - PayToPubKey -> throwError "unexpected out type" - PayToScript h -> case Map.lookup h $ txData $ txOutTxTx o of - Nothing -> throwError "datum not found" - Just (Datum e) -> case PlutusTx.fromData e of - Nothing -> throwError "datum has wrong type" - Just d@AuctionDatum{..} - | aCurrency adAuction == cs && aToken adAuction == tn -> return (oref, o, d) - | otherwise -> throwError "auction token missmatch" - _ -> throwError "auction utxo not found" - -endpoints :: Contract () AuctionSchema Text () -endpoints = (start' `select` bid' `select` close') >> endpoints - where - start' = endpoint @"start" >>= start - bid' = endpoint @"bid" >>= bid - close' = endpoint @"close" >>= close - -mkSchemaDefinitions ''AuctionSchema - -myToken :: KnownCurrency -myToken = KnownCurrency (ValidatorHash "f") "Token" (TokenName "T" :| []) - -mkKnownCurrencies ['myToken]