feat(standing_bid): implement ConcludeAuction sub-validator

Author: errfrom

hydra-auction-onchain.cabal

@@ -111,6 +111,7 @@ library
     HydraAuctionOnchain.Types.BidTerms
     HydraAuctionOnchain.Types.Error
     HydraAuctionOnchain.Types.StandingBidState
+    HydraAuctionOnchain.Validators.AuctionEscrow
     HydraAuctionOnchain.Validators.AuctionMetadata
     HydraAuctionOnchain.Validators.StandingBid
 

src/HydraAuctionOnchain/Helpers.hs

@@ -3,18 +3,22 @@
 module HydraAuctionOnchain.Helpers
   ( pdecodeInlineDatum
   , pfindUnique
+  , pfindUniqueInputWithToken
   , pfindUniqueOutputWithAddress
   , pintervalFiniteClosedOpen
   , pserialise
   , putxoAddress
   ) where
 
+import Plutarch.Api.V1.Value (pvalueOf)
 import Plutarch.Api.V2
   ( PAddress
+  , PCurrencySymbol
   , PExtended (PFinite)
   , PInterval (PInterval)
   , PLowerBound (PLowerBound)
   , POutputDatum (POutputDatum)
+  , PTokenName
   , PTxInInfo
   , PTxInfo
   , PTxOut
@@ -40,6 +44,24 @@ pfindUnique = phoistAcyclic $
   plam $ \predicate list ->
     pfromSingleton #$ pfilter # predicate # list
 
+pfindUniqueInputWithToken
+  :: Term
+      s
+      ( PCurrencySymbol
+          :--> PTokenName
+          :--> PTxInfo
+          :--> PMaybe PTxInInfo
+      )
+pfindUniqueInputWithToken = phoistAcyclic $
+  plam $ \cs tn txInfo ->
+    pfindUnique
+      # plam
+        ( \utxo ->
+            pvalueOf # (pfield @"value" #$ pfield @"resolved" # utxo) # cs # tn #== 1
+        )
+      #$ pfield @"inputs"
+      # txInfo
+
 pfindUniqueOutputWithAddress :: Term s (PAddress :--> PTxInfo :--> PMaybe PTxOut)
 pfindUniqueOutputWithAddress = phoistAcyclic $
   plam $ \addr txInfo ->

src/HydraAuctionOnchain/Validators/AuctionEscrow.hs

@@ -0,0 +1,27 @@
+module HydraAuctionOnchain.Validators.AuctionEscrow
+  ( pisConcluding
+  ) where
+
+--------------------------------------------------------------------------------
+-- Redeemers
+--------------------------------------------------------------------------------
+
+data PAuctionEscrowRedeemer (s :: S)
+  = StartBiddingRedeemer (Term s (PDataRecord '[]))
+  | BidderBuysRedeemer (Term s (PDataRecord '[]))
+  | SellerReclaimsRedeemer (Term s (PDataRecord '[]))
+  | CleanupAuctionRedeemer (Term s (PDataRecord '[]))
+  deriving stock (Generic)
+  deriving anyclass (PlutusType, PIsData, PShow, PEq)
+
+instance DerivePlutusType PAuctionEscrowRedeemer where
+  type DPTStrat _ = PlutusTypeData
+
+instance PTryFrom PData (PAsData PAuctionEscrowRedeemer)
+
+pisConcluding :: Term s (PAuctionEscrowRedeemer :--> PBool)
+pisConcluding = phoistAcyclic $
+  plam $ \redeemer -> pmatch redeemer $ \case
+    BidderBuysRedeemer _ -> pcon PTrue
+    SellerReclaimsRedeemer _ -> pcon PTrue
+    _ -> pcon PFalse

src/HydraAuctionOnchain/Validators/StandingBid.hs

@@ -4,17 +4,30 @@ module HydraAuctionOnchain.Validators.StandingBid
 
 import HydraAuctionOnchain.Helpers
   ( pdecodeInlineDatum
+  , pfindUniqueInputWithToken
   , pfindUniqueOutputWithAddress
   , putxoAddress
   )
-import HydraAuctionOnchain.MintingPolicies.Auction (standingBidTokenName)
+import HydraAuctionOnchain.MintingPolicies.Auction
+  ( auctionEscrowTokenName
+  , standingBidTokenName
+  )
 import HydraAuctionOnchain.Types.AuctionTerms (PAuctionTerms, pbiddingPeriod)
 import HydraAuctionOnchain.Types.Error (ToErrorCode (toErrorCode), err, perrMaybe)
 import HydraAuctionOnchain.Types.StandingBidState (PStandingBidState, pvalidateNewBid)
+import HydraAuctionOnchain.Validators.AuctionEscrow (pisConcluding)
 import Plutarch.Api.V1.Value (pvalueOf)
-import Plutarch.Api.V2 (PCurrencySymbol, PScriptContext, PTxInInfo, PTxInfo, PTxOut)
+import Plutarch.Api.V2
+  ( PCurrencySymbol
+  , PScriptContext
+  , PScriptPurpose (PSpending)
+  , PTxInInfo
+  , PTxInfo
+  , PTxOut
+  )
 import Plutarch.Extra.Interval (pcontains)
-import Plutarch.Extra.ScriptContext (ptryOwnInput, ptxSignedBy)
+import Plutarch.Extra.Maybe (pmaybe)
+import Plutarch.Extra.ScriptContext (ptryFromRedeemer, ptryOwnInput, ptxSignedBy)
 import Plutarch.Monadic qualified as P
 
 --------------------------------------------------------------------------------
@@ -97,6 +110,24 @@ instance ToErrorCode PStandingBid'MoveToHydra'Error where
       StandingBid'MoveToHydra'Error'IncorrectValidityInterval ->
         pconstant "StandingBid_MoveToHydra_02"
 
+-- ConcludeAuction -------------------------------------------------------------
+data PStandingBid'ConcludeAuction'Error (s :: S)
+  = StandingBid'ConcludeAuction'Error'MissingAuctionEscrowInput
+  | StandingBid'ConcludeAuction'Error'InvalidAuctionEscrowRedeemer
+  deriving stock (Generic)
+  deriving anyclass (PlutusType)
+
+instance DerivePlutusType PStandingBid'ConcludeAuction'Error where
+  type DPTStrat _ = PlutusTypeScott
+
+instance ToErrorCode PStandingBid'ConcludeAuction'Error where
+  toErrorCode = phoistAcyclic $
+    plam $ \err -> pmatch err $ \case
+      StandingBid'ConcludeAuction'Error'MissingAuctionEscrowInput ->
+        pconstant "StandingBid_ConcludeAuction_01"
+      StandingBid'ConcludeAuction'Error'InvalidAuctionEscrowRedeemer ->
+        pconstant "StandingBid_ConcludeAuction_02"
+
 --------------------------------------------------------------------------------
 -- Validator
 --------------------------------------------------------------------------------
@@ -133,7 +164,7 @@ standingBidValidator = phoistAcyclic $
       MoveToHydraRedeemer _ ->
         pcheckMoveToHydra # txInfo # auctionTerms
       ConcludeAuctionRedeemer _ ->
-        pcheckConcludeAuction
+        pcheckConcludeAuction # txInfo # auctionCs
 
 --------------------------------------------------------------------------------
 -- NewBid
@@ -213,8 +244,33 @@ pcheckMoveToHydra = phoistAcyclic $
 -- ConcludeAuction
 --------------------------------------------------------------------------------
 
-pcheckConcludeAuction :: Term s PUnit
-pcheckConcludeAuction = undefined
+pcheckConcludeAuction :: Term s (PTxInfo :--> PCurrencySymbol :--> PUnit)
+pcheckConcludeAuction = phoistAcyclic $
+  plam $ \txInfo auctionCs -> P.do
+    -- (StandingBid_ConcludeAuction_01)
+    -- There is an input that contains the auction escrow token.
+    auctionEscrowUtxo <-
+      plet $
+        perrMaybe
+          # pcon StandingBid'ConcludeAuction'Error'MissingAuctionEscrowInput
+          # (pfindUniqueInputWithToken # auctionCs # auctionEscrowTokenName # txInfo)
+
+    -- (StandingBid_ConcludeAuction_02)
+    -- The auction escrow input is being spent with the `BidderBuys` or
+    -- `SellerReclaims` redeemer. Implicitly, this means that the auction is
+    -- concluding with either the winning bidder buying the auction lot or the
+    -- seller reclaiming it.
+    redeemers <- plet $ pfield @"redeemers" # txInfo
+    auctionEscrowOref <- plet $ pfield @"outRef" # auctionEscrowUtxo
+    spendsAuctionEscrow <- plet $ pcon $ PSpending $ pdcons @"_0" # auctionEscrowOref # pdnil
+    auctionEscrowRedeemer <- plet $ ptryFromRedeemer # spendsAuctionEscrow # redeemers
+    err StandingBid'ConcludeAuction'Error'InvalidAuctionEscrowRedeemer $
+      pmaybe
+        # pcon PFalse
+        # plam (\redeemer -> pisConcluding # pfromData redeemer)
+        # auctionEscrowRedeemer
+
+    pcon PUnit
 
 --------------------------------------------------------------------------------
 -- Helpers