feat(bidder_deposit): implement ReclaimDepositLoser sub-validator

Author: errfrom

src/HydraAuctionOnchain/Errors/Validators/BidderDeposit.hs

@@ -18,6 +18,14 @@ data PBidderDepositError (s :: S)
   | BidderDeposit'UseDepositWinner'Error'MissingAuctionEscrowInput
   | BidderDeposit'UseDepositWinner'Error'AuctionEscrowInputMissingToken
   | BidderDeposit'UseDepositWinner'Error'InvalidAuctionEscrowRedeemer
+  | -- ReclaimDepositLoser errors
+    BidderDeposit'ReclaimDepositLoser'Error'MissingStandingBidInput
+  | BidderDeposit'ReclaimDepositLoser'Error'StandingBidInputMissingToken
+  | BidderDeposit'ReclaimDepositLoser'Error'FailedToDecodeStandingBidState
+  | BidderDeposit'ReclaimDepositLoser'Error'BidderNotLoser
+  | BidderDeposit'ReclaimDepositLoser'Error'IncorrectValidityInterval
+  | BidderDeposit'ReclaimDepositLoser'Error'InvalidBidderAddress
+  | BidderDeposit'ReclaimDepositLoser'Error'NoBidderConsent
   deriving stock (Generic, Eq)
   deriving anyclass (PlutusType)
 

src/HydraAuctionOnchain/Helpers.hs

@@ -9,6 +9,7 @@ module HydraAuctionOnchain.Helpers
   , pfindUniqueInputWithToken
   , pfindUniqueOutputWithAddress
   , pfindUniqueOutputWithScriptHash
+  , pfindUniqueRefInputWithScriptHash
   , pgetOwnInput
   , pintervalFiniteClosedOpen
   , ponlyOneInputFromAddress
@@ -88,6 +89,18 @@ pfindUniqueInputWithScriptHash = phoistAcyclic $
       #$ pfield @"inputs"
       # txInfo
 
+pfindUniqueRefInputWithScriptHash :: Term s (PScriptHash :--> PTxInfo :--> PMaybe PTxInInfo)
+pfindUniqueRefInputWithScriptHash = phoistAcyclic $
+  plam $ \sh txInfo ->
+    pfindUnique
+      # plam
+        ( \utxo -> P.do
+            addr <- plet $ pfield @"address" #$ pfield @"resolved" # utxo
+            paddressHasScriptHash # addr # sh
+        )
+      #$ pfield @"referenceInputs"
+      # txInfo
+
 pfindUniqueInputWithToken
   :: Term
       s

src/HydraAuctionOnchain/Types/AuctionTerms.hs

@@ -5,6 +5,7 @@ module HydraAuctionOnchain.Types.AuctionTerms
   , pbiddingPeriod
   , pcleanupPeriod
   , ppenaltyPeriod
+  , ppostBiddingPeriod
   , ppurchasePeriod
   , ptotalAuctionFees
   , pvalidateAuctionTerms
@@ -162,3 +163,8 @@ pcleanupPeriod :: Term s (PAuctionTerms :--> PPOSIXTimeRange)
 pcleanupPeriod = phoistAcyclic $
   plam $ \auctionTerms ->
     Interval.pfrom #$ pfield @"cleanup" # auctionTerms
+
+ppostBiddingPeriod :: Term s (PAuctionTerms :--> PPOSIXTimeRange)
+ppostBiddingPeriod = phoistAcyclic $
+  plam $ \auctionTerms ->
+    Interval.pfrom #$ pfield @"biddingEnd" # auctionTerms

src/HydraAuctionOnchain/Types/StandingBidState.hs

@@ -27,15 +27,15 @@ instance PTryFrom PData PStandingBidState
 pbidderLost :: Term s (PStandingBidState :--> PBidderInfo :--> PBool)
 pbidderLost = phoistAcyclic $
   plam $ \bidState bidderInfo ->
-    pmaybeData
-      # pcon PTrue
-      # plam (\bidTerms -> pbidderMadeBid # bidTerms # bidderInfo)
-      # pto bidState
+    pnot #$ pbidderWon # bidState # bidderInfo
 
 pbidderWon :: Term s (PStandingBidState :--> PBidderInfo :--> PBool)
 pbidderWon = phoistAcyclic $
   plam $ \bidState bidderInfo ->
-    pnot #$ pbidderLost # bidState # bidderInfo
+    pmaybeData
+      # pcon PFalse
+      # plam (\bidTerms -> pbidderMadeBid # bidTerms # bidderInfo)
+      # pto bidState
 
 ----------------------------------------------------------------------
 -- Standing bid state transition validation

src/HydraAuctionOnchain/Validators/BidderDeposit.hs

@@ -3,7 +3,7 @@
 module HydraAuctionOnchain.Validators.BidderDeposit
   ( PBidderDepositRedeemer
       ( UseDepositWinnerRedeemer
-      , DepositReclaimedByLoserRedeemer
+      , ReclaimDepositLoserRedeemer
       , DepositReclaimedAuctionConcludedRedeemer
       , DepositCleanupRedeemer
       )
@@ -14,14 +14,17 @@ import HydraAuctionOnchain.Errors.Validators.BidderDeposit (PBidderDepositError
 import HydraAuctionOnchain.Helpers
   ( pdecodeInlineDatum
   , pfindUniqueInputWithScriptHash
+  , pfindUniqueRefInputWithScriptHash
   , pgetOwnInput
   , ponlyOneInputFromAddress
   , putxoAddress
   )
+import HydraAuctionOnchain.Lib.Address (paddrPaymentKeyHash)
 import HydraAuctionOnchain.Lib.ScriptContext (pinputSpentWithRedeemer)
+import HydraAuctionOnchain.Types.AuctionTerms (PAuctionTerms, ppostBiddingPeriod)
 import HydraAuctionOnchain.Types.BidderInfo (PBidderInfo)
 import HydraAuctionOnchain.Types.Error (errCode, passert, passertMaybe)
-import HydraAuctionOnchain.Types.StandingBidState (PStandingBidState, pbidderWon)
+import HydraAuctionOnchain.Types.StandingBidState (PStandingBidState, pbidderLost, pbidderWon)
 import HydraAuctionOnchain.Types.Tokens
   ( ptxOutContainsAuctionEscrowToken
   , ptxOutContainsStandingBidToken
@@ -30,14 +33,16 @@ import HydraAuctionOnchain.Validators.AuctionEscrow
   ( PAuctionEscrowRedeemer (BidderBuysRedeemer)
   )
 import Plutarch.Api.V2 (PCurrencySymbol, PScriptContext, PScriptHash, PTxInfo)
+import Plutarch.Extra.Interval (pcontains)
+import Plutarch.Extra.ScriptContext (ptxSignedBy)
 import Plutarch.Monadic qualified as P
 
 ----------------------------------------------------------------------
 -- Redeemers
 
 data PBidderDepositRedeemer (s :: S)
   = UseDepositWinnerRedeemer (Term s (PDataRecord '[]))
-  | DepositReclaimedByLoserRedeemer (Term s (PDataRecord '[]))
+  | ReclaimDepositLoserRedeemer (Term s (PDataRecord '[]))
   | DepositReclaimedAuctionConcludedRedeemer (Term s (PDataRecord '[]))
   | DepositCleanupRedeemer (Term s (PDataRecord '[]))
   deriving stock (Generic)
@@ -57,13 +62,14 @@ bidderDepositValidator
       ( PScriptHash
           :--> PScriptHash
           :--> PCurrencySymbol
+          :--> PAuctionTerms
           :--> PBidderInfo
           :--> PBidderDepositRedeemer
           :--> PScriptContext
           :--> PUnit
       )
 bidderDepositValidator = phoistAcyclic $
-  plam $ \standingBidSh auctionEscrowSh auctionCs bidderInfo redeemer ctx -> P.do
+  plam $ \standingBidSh auctionEscrowSh auctionCs auctionTerms bidderInfo redeemer ctx -> P.do
     txInfo <- plet $ pfield @"txInfo" # ctx
 
     -- The validator's own input should exist.
@@ -91,8 +97,21 @@ bidderDepositValidator = phoistAcyclic $
           # auctionEscrowSh
           # auctionCs
           # bidderInfo
+      ReclaimDepositLoserRedeemer _ ->
+        pcheckReclaimDepositLoser
+          # txInfo
+          # standingBidSh
+          # auctionCs
+          # auctionTerms
+          # bidderInfo
       _ -> undefined
 
+----------------------------------------------------------------------
+-- UseDepositWinner
+--
+-- Deposit is used by the bidder who won the auction to buy
+-- the auction lot.
+
 pcheckUseDepositWinner
   :: Term
       s
@@ -152,3 +171,65 @@ pcheckUseDepositWinner = phoistAcyclic $
         # auctionEscrowInput
 
     pcon PUnit
+
+----------------------------------------------------------------------
+-- ReclaimDepositLoser
+--
+-- The bidder deposit is reclaimed by a bidder that did not win
+-- the auction.
+
+pcheckReclaimDepositLoser
+  :: Term
+      s
+      ( PTxInfo
+          :--> PScriptHash
+          :--> PCurrencySymbol
+          :--> PAuctionTerms
+          :--> PBidderInfo
+          :--> PUnit
+      )
+pcheckReclaimDepositLoser = phoistAcyclic $
+  plam $ \txInfo standingBidSh auctionCs auctionTerms bidderInfo -> P.do
+    txInfoFields <- pletFields @["signatories", "validRange"] txInfo
+
+    -- There should be exactly one standing bid reference input.
+    standingBidInput <-
+      plet $
+        passertMaybe
+          $(errCode BidderDeposit'ReclaimDepositLoser'Error'MissingStandingBidInput)
+          (pfindUniqueRefInputWithScriptHash # standingBidSh # txInfo)
+
+    -- The standing bid reference input should contain the standing
+    -- bid token.
+    standingBidInputResolved <- plet $ pfield @"resolved" # standingBidInput
+    passert $(errCode BidderDeposit'ReclaimDepositLoser'Error'StandingBidInputMissingToken) $
+      ptxOutContainsStandingBidToken # auctionCs # standingBidInputResolved
+
+    -- The standing bid input contains a datum that can be decoded
+    -- as a standing bid state.
+    bidState <-
+      plet $
+        passertMaybe
+          $(errCode BidderDeposit'ReclaimDepositLoser'Error'FailedToDecodeStandingBidState)
+          (pdecodeInlineDatum @PStandingBidState # standingBidInputResolved)
+
+    -- The bidder deposit's bidder lost the auction.
+    passert $(errCode BidderDeposit'ReclaimDepositLoser'Error'BidderNotLoser) $
+      pbidderLost # bidState # bidderInfo
+
+    -- This redeemer can only be used after the bidding period.
+    passert $(errCode BidderDeposit'ReclaimDepositLoser'Error'IncorrectValidityInterval) $
+      pcontains # (ppostBiddingPeriod # auctionTerms) # txInfoFields.validRange
+
+    -- The payment part of the bidder address should be pkh.
+    bidderPkh <-
+      plet $
+        passertMaybe
+          $(errCode BidderDeposit'ReclaimDepositLoser'Error'InvalidBidderAddress)
+          (paddrPaymentKeyHash #$ pfield @"biBidderAddress" # bidderInfo)
+
+    -- The bidder deposit's bidder signed the transaction.
+    passert $(errCode BidderDeposit'ReclaimDepositLoser'Error'NoBidderConsent) $
+      ptxSignedBy # txInfoFields.signatories # pdata bidderPkh
+
+    pcon PUnit