This commit is contained in:
Lars Brünjes 2021-03-31 03:13:36 +02:00
parent dd3104ea77
commit 7d256947d7
No known key found for this signature in database
GPG key ID: B488B9045DC1A087
2 changed files with 73 additions and 9 deletions

View file

@ -13,6 +13,7 @@ library
exposed-modules: EnglishAuction
build-depends: aeson
, base ^>=4.14.1.0
, containers
, playground-common
, plutus-contract
, plutus-ledger

View file

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