bid validation

This commit is contained in:
Lars Brünjes 2021-04-01 18:43:33 +02:00
parent d0e24919eb
commit 55a6783edc
No known key found for this signature in database
GPG key ID: B488B9045DC1A087

View file

@ -38,6 +38,7 @@ 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
@ -55,8 +56,18 @@ 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
@ -65,10 +76,15 @@ data Bid = Bid
, 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 = Start Auction | MkBid Bid | Close
data AuctionAction = MkBid Bid | Close
deriving Show
PlutusTx.unstableMakeIsData ''AuctionAction
@ -95,7 +111,82 @@ minBid AuctionDatum{..} = case adHighestBid of
{-# INLINABLE mkAuctionValidator #-}
mkAuctionValidator :: AuctionDatum -> AuctionAction -> ValidatorCtx -> Bool
mkAuctionValidator _ _ _ = True
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" (correctOutputDatum b) &&
traceIfFalse "wrong output value" (correctOutputValue bBid) &&
traceIfFalse "wrong refund" correctRefund
Close -> True
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"
correctOutputDatum :: Bid -> Bool
correctOutputDatum b = (adAuction outputDatum == auction) &&
(adHighestBid outputDatum == Just b)
correctOutputValue :: Integer -> Bool
correctOutputValue amount =
txOutValue ownOutput == tokenValue Plutus.<> Ada.lovelaceValueOf amount
correctRefund :: Bool
correctRefund = 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"
auctionInstance :: Scripts.ScriptInstance Auctioning
auctionInstance = Scripts.validator @Auctioning
@ -144,6 +235,8 @@ start StartParams{..} = do
{ aSeller = pkh
, aDeadline = spDeadline
, aMinBid = spMinBid
, aCurrency = spCurrency
, aToken = spToken
}
d = AuctionDatum
{ adAuction = a
@ -231,7 +324,9 @@ findAuction cs tn = do
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)
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 ()