mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-12-22 21:42:11 +01:00
bidding
This commit is contained in:
Lars Brünjes
parent
dd3104ea77
commit
7d256947d7
2 changed files with 73 additions and 9 deletions
|
|
@ -13,6 +13,7 @@ library
|
|||
exposed-modules: EnglishAuction
|
||||
build-depends: aeson
|
||||
, base ^>=4.14.1.0
|
||||
, containers
|
||||
, playground-common
|
||||
, plutus-contract
|
||||
, plutus-ledger
|
||||
|
|
|
|||
|
|
@ -32,19 +32,22 @@ module EnglishAuction
|
|||
import Control.Monad hiding (fmap)
|
||||
import Data.Aeson (ToJSON, FromJSON)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Text (Text)
|
||||
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 (unless)
|
||||
import PlutusTx.Prelude hiding (Semigroup(..), unless)
|
||||
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)
|
||||
|
||||
|
|
@ -57,13 +60,15 @@ data Auction = Auction
|
|||
PlutusTx.unstableMakeIsData ''Auction
|
||||
PlutusTx.makeLift ''Auction
|
||||
|
||||
data Bid = MkBid !PubKeyHash !Integer
|
||||
deriving Show
|
||||
data Bid = Bid
|
||||
{ bBidder :: !PubKeyHash
|
||||
, bBid :: !Integer
|
||||
} deriving Show
|
||||
|
||||
PlutusTx.unstableMakeIsData ''Bid
|
||||
PlutusTx.makeLift ''Bid
|
||||
|
||||
data AuctionAction = Start Auction | Bid Bid | Success | Failure
|
||||
data AuctionAction = Start Auction | MkBid Bid | Close
|
||||
deriving Show
|
||||
|
||||
PlutusTx.unstableMakeIsData ''AuctionAction
|
||||
|
|
@ -82,6 +87,12 @@ 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 _ _ _ = True
|
||||
|
|
@ -109,15 +120,22 @@ data StartParams = StartParams
|
|||
, spToken :: !TokenName
|
||||
} deriving (Generic, ToJSON, FromJSON, ToSchema)
|
||||
|
||||
data BidParams = BidParams
|
||||
{ bpCurrency :: !CurrencySymbol
|
||||
, bpToken :: !TokenName
|
||||
, bpBid :: !Integer
|
||||
} deriving (Generic, ToJSON, FromJSON, ToSchema)
|
||||
|
||||
type AuctionSchema =
|
||||
BlockchainActions
|
||||
.\/ Endpoint "start" StartParams
|
||||
.\/ Endpoint "bid" BidParams
|
||||
|
||||
start :: HasBlockchainActions s => StartParams -> Contract w s Text ()
|
||||
start :: (HasBlockchainActions s, AsContractError e) => StartParams -> Contract w s e ()
|
||||
start StartParams{..} = do
|
||||
pkh <- pubKeyHash <$> ownPubKey
|
||||
let a = Auction
|
||||
{ aSeller = pkh
|
||||
{ aSeller = pkh
|
||||
, aDeadline = spDeadline
|
||||
, aMinBid = spMinBid
|
||||
}
|
||||
|
|
@ -131,14 +149,59 @@ start StartParams{..} = do
|
|||
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
|
||||
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 ""
|
||||
where
|
||||
findAuction :: Contract w s Text (TxOutRef, TxOutTx, AuctionDatum)
|
||||
findAuction = do
|
||||
utxos <- utxoAt $ ScriptAddress auctionHash
|
||||
let xs = [ (oref, o)
|
||||
| (oref, o) <- Map.toList utxos
|
||||
, Value.valueOf (txOutValue $ txOutTxOut o) bpCurrency bpToken == 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 -> return (oref, o, d)
|
||||
_ -> throwError "auction utxo not found"
|
||||
|
||||
endpoints :: Contract () AuctionSchema Text ()
|
||||
endpoints = start' >> endpoints
|
||||
endpoints = (start' `select` bid') >> endpoints
|
||||
where
|
||||
start' = endpoint @"start" >>= start
|
||||
bid' = endpoint @"bid" >>= bid
|
||||
|
||||
mkSchemaDefinitions ''AuctionSchema
|
||||
|
||||
myToken :: KnownCurrency
|
||||
myToken = KnownCurrency (ValidatorHash "ffff") "Token" (TokenName "T" :| [])
|
||||
myToken = KnownCurrency (ValidatorHash "f") "Token" (TokenName "T" :| [])
|
||||
|
||||
mkKnownCurrencies ['myToken]
|
||||
|
|
|
|||
Loading…
Reference in a new issue