feat: wip: implement standing bid validator

Author: errfrom

Makefile

@@ -7,7 +7,7 @@ build:
 	cabal v2-build all
 
 repl:
-	cabal v2-repl hydra-auction-onchain 
+	cabal v2-repl hydra-auction-onchain --ghc-options '-Wno-missing-import-lists'
 
 format:
 	fourmolu -m inplace ${hs-sources} && cabal-fmt -i ${cabal-sources} && nix run '.#nixFormat'

hydra-auction-onchain.cabal

@@ -107,7 +107,12 @@ library
     HydraAuctionOnchain.Scripts
     HydraAuctionOnchain.Types.AuctionInfo
     HydraAuctionOnchain.Types.AuctionTerms
+    HydraAuctionOnchain.Types.BidderInfo
+    HydraAuctionOnchain.Types.BidTerms
+    HydraAuctionOnchain.Types.Error
+    HydraAuctionOnchain.Types.StandingBidState
     HydraAuctionOnchain.Validators.AuctionMetadata
+    HydraAuctionOnchain.Validators.StandingBid
 
   build-depends:
     , bytestring

src/HydraAuctionOnchain/Helpers.hs

@@ -1 +1,28 @@
-module HydraAuctionOnchain.Helpers () where
+{-# LANGUAGE PackageImports #-}
+
+module HydraAuctionOnchain.Helpers
+  ( pfindUnique
+  , pfindUniqueOutputWithAddress
+  , putxoAddress
+  ) where
+
+import Plutarch.Api.V2 (PAddress, PTxInInfo, PTxInfo, PTxOut)
+import "liqwid-plutarch-extra" Plutarch.Extra.List (pfromSingleton)
+
+pfindUnique :: PIsListLike l a => Term s ((a :--> PBool) :--> l a :--> PMaybe a)
+pfindUnique = phoistAcyclic $
+  plam $ \predicate list ->
+    pfromSingleton #$ pfilter # predicate # list
+
+pfindUniqueOutputWithAddress :: Term s (PAddress :--> PTxInfo :--> PMaybe PTxOut)
+pfindUniqueOutputWithAddress = phoistAcyclic $
+  plam $ \addr txInfo ->
+    pfindUnique
+      # plam (\out -> (pfield @"address" # out) #== addr)
+      #$ pfield @"outputs"
+      # txInfo
+
+putxoAddress :: Term s (PTxInInfo :--> PAddress)
+putxoAddress = phoistAcyclic $
+  plam $ \utxo ->
+    pfield @"address" #$ pfield @"resolved" # utxo

src/HydraAuctionOnchain/Scripts.hs

@@ -1,17 +1,25 @@
 module HydraAuctionOnchain.Scripts
   ( auctionMetadataValidatorScript
   , auctionMetadataValidatorUntyped
+  , standingBidValidatorScript
+  , standingBidValidatorUntyped
   , writeScript
   ) where
 
 import Data.Text (Text)
 import Data.Text qualified as T (unpack)
+import HydraAuctionOnchain.Types.AuctionTerms (PAuctionTerms)
 import HydraAuctionOnchain.Validators.AuctionMetadata (auctionMetadataValidator)
+import HydraAuctionOnchain.Validators.StandingBid (standingBidValidator)
 import Plutarch (Config (Config), Script, TracingMode (DoTracingAndBinds), compile)
-import Plutarch.Api.V2 (PValidator)
+import Plutarch.Api.V2 (PCurrencySymbol, PValidator)
 import Plutarch.Unsafe (punsafeCoerce)
 import Ply.Plutarch.TypedWriter (TypedWriter, writeTypedScript)
 
+--------------------------------------------------------------------------------
+-- AuctionMetadata
+--------------------------------------------------------------------------------
+
 auctionMetadataValidatorUntyped :: ClosedTerm PValidator
 auctionMetadataValidatorUntyped =
   phoistAcyclic $ plam $ \datum redeemer ctx ->
@@ -24,6 +32,24 @@ auctionMetadataValidatorUntyped =
 auctionMetadataValidatorScript :: Script
 auctionMetadataValidatorScript = compileScript auctionMetadataValidatorUntyped
 
+--------------------------------------------------------------------------------
+-- StandingBid
+--------------------------------------------------------------------------------
+
+standingBidValidatorUntyped :: ClosedTerm (PCurrencySymbol :--> PAuctionTerms :--> PValidator)
+standingBidValidatorUntyped =
+  phoistAcyclic $ plam $ \auctionCs auctionTerms datum redeemer ctx ->
+    popaque $
+      standingBidValidator
+        # auctionCs
+        # auctionTerms
+        # punsafeCoerce datum
+        # punsafeCoerce redeemer
+        # ctx
+
+standingBidValidatorScript :: Script
+standingBidValidatorScript = compileScript standingBidValidatorUntyped
+
 config :: Config
 config = Config DoTracingAndBinds
 

src/HydraAuctionOnchain/Types/AuctionTerms.hs

@@ -10,6 +10,7 @@ import Plutarch.Api.V2
   , PValue
   )
 import Plutarch.DataRepr (PDataFields)
+import Ply.Plutarch (PlyArgOf)
 
 newtype PAuctionTerms (s :: S)
   = PAuctionTerms
@@ -36,3 +37,7 @@ newtype PAuctionTerms (s :: S)
 
 instance DerivePlutusType PAuctionTerms where
   type DPTStrat _ = PlutusTypeData
+
+data AuctionTerms
+
+type instance PlyArgOf PAuctionTerms = AuctionTerms

src/HydraAuctionOnchain/Types/BidTerms.hs

@@ -0,0 +1,24 @@
+module HydraAuctionOnchain.Types.BidTerms
+  ( PBidTerms (PBidTerms)
+  ) where
+
+import HydraAuctionOnchain.Types.BidderInfo (PBidderInfo)
+import Plutarch.DataRepr (PDataFields)
+
+data PBidTerms (s :: S)
+  = PBidTerms
+      ( Term
+          s
+          ( PDataRecord
+              '[ "btBidder" ':= PBidderInfo
+               , "btPrice" ':= PInteger
+               , "btBidderSignature" ':= PByteString
+               , "btSellerSignature" ':= PByteString
+               ]
+          )
+      )
+  deriving stock (Generic)
+  deriving anyclass (PlutusType, PIsData, PDataFields, PShow, PEq)
+
+instance DerivePlutusType PBidTerms where
+  type DPTStrat _ = PlutusTypeData

src/HydraAuctionOnchain/Types/BidderInfo.hs

@@ -0,0 +1,22 @@
+module HydraAuctionOnchain.Types.BidderInfo
+  ( PBidderInfo (PBidderInfo)
+  ) where
+
+import Plutarch.Api.V2 (PPubKeyHash)
+import Plutarch.DataRepr (PDataFields)
+
+data PBidderInfo (s :: S)
+  = PBidderInfo
+      ( Term
+          s
+          ( PDataRecord
+              '[ "biBidderPkh" ':= PPubKeyHash
+               , "biBidderVk" ':= PByteString
+               ]
+          )
+      )
+  deriving stock (Generic)
+  deriving anyclass (PlutusType, PIsData, PDataFields, PShow, PEq)
+
+instance DerivePlutusType PBidderInfo where
+  type DPTStrat _ = PlutusTypeData

src/HydraAuctionOnchain/Types/Error.hs

@@ -0,0 +1,19 @@
+module HydraAuctionOnchain.Types.Error
+  ( ToErrorCode (toErrorCode)
+  , err
+  , perrMaybe
+  ) where
+
+import Plutarch.Extra.Bool (passert)
+
+class ToErrorCode a where
+  toErrorCode :: Term s (a :--> PString)
+
+err :: (PlutusType e, ToErrorCode e) => e s -> Term s PBool -> Term s a -> Term s a
+err e = passert (toErrorCode # pcon e)
+
+perrMaybe :: ToErrorCode e => Term s (e :--> PMaybe a :--> a)
+perrMaybe = phoistAcyclic $
+  plam $ \err mval -> pmatch mval $ \case
+    PJust val -> val
+    PNothing -> ptraceError $ toErrorCode # err

src/HydraAuctionOnchain/Types/StandingBidState.hs

@@ -0,0 +1,13 @@
+module HydraAuctionOnchain.Types.StandingBidState
+  ( PStandingBidState (PStandingBidState)
+  ) where
+
+import HydraAuctionOnchain.Types.BidTerms (PBidTerms)
+import Plutarch.Api.V2 (PMaybeData)
+
+newtype PStandingBidState (s :: S) = PStandingBidState (Term s (PMaybeData PBidTerms))
+  deriving stock (Generic)
+  deriving anyclass (PlutusType, PIsData, PShow, PEq)
+
+instance DerivePlutusType PStandingBidState where
+  type DPTStrat _ = PlutusTypeNewtype

src/HydraAuctionOnchain/Validators/AuctionMetadata.hs

@@ -23,14 +23,15 @@ instance DerivePlutusType PAuctionMetadataRedeemer where
   type DPTStrat _ = PlutusTypeData
 
 auctionMetadataValidator
-  :: ClosedTerm
+  :: Term
+      s
       ( PAuctionInfo
           :--> PAuctionMetadataRedeemer
           :--> PScriptContext
           :--> PUnit
       )
-auctionMetadataValidator =
-  phoistAcyclic $ plam $ \auctionInfo redeemer ctx ->
+auctionMetadataValidator = phoistAcyclic $
+  plam $ \auctionInfo redeemer ctx ->
     pmatch redeemer $ \case
       RemoveAuctionRedeemer _ -> P.do
         auctionCurrencySymbol <- plet $ pfield @"auctionId" # auctionInfo