gift example

This commit is contained in:
Lars Brünjes 2021-04-09 23:13:08 +02:00
parent ae07c00ad7
commit ba7dc9d479
No known key found for this signature in database
GPG key ID: B488B9045DC1A087
3 changed files with 86 additions and 369 deletions

View file

@ -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

View file

@ -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 []

View file

@ -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]