refactor(standing_bid): improve errors

Author: errfrom

hydra-auction-onchain.cabal

@@ -102,6 +102,7 @@ common common-lang
 library
   import:          common-lang
   exposed-modules:
+    HydraAuctionOnchain.Errors.StandingBid
     HydraAuctionOnchain.Helpers
     HydraAuctionOnchain.MintingPolicies.Auction
     HydraAuctionOnchain.Scripts
@@ -127,7 +128,10 @@ library
     , ply-core
     , ply-plutarch
     , pretty-simple
+    , safe
+    , template-haskell
     , text
+    , universe
 
   hs-source-dirs:  src
 

src/HydraAuctionOnchain/Errors/StandingBid.hs

@@ -0,0 +1,34 @@
+module HydraAuctionOnchain.Errors.StandingBid
+  ( PStandingBidError (..)
+  ) where
+
+import Data.Universe (Universe (universe), universeGeneric)
+import HydraAuctionOnchain.Types.Error (ErrorCodePrefix (errorCodePrefix))
+
+data PStandingBidError (s :: S)
+  = -- Common errors
+    StandingBid'Error'OwnInputMissingToken
+  | StandingBid'Error'UnexpectedTokensMintedBurned
+  | -- NewBid errors
+    StandingBid'NewBid'Error'MissingOwnOutput
+  | StandingBid'NewBid'Error'OwnOutputMissingToken
+  | StandingBid'NewBid'Error'FailedToDecodeNewBid
+  | StandingBid'NewBid'Error'InvalidNewBidState
+  | StandingBid'NewBid'Error'IncorrectValidityInterval
+  | -- MoveToHydra errors
+    StandingBid'MoveToHydra'Error'MissingDelegateSignatures
+  | StandingBid'MoveToHydra'Error'IncorrectValidityInterval
+  | -- ConcludeAuction errors
+    StandingBid'ConcludeAuction'Error'MissingAuctionEscrowInput
+  | StandingBid'ConcludeAuction'Error'InvalidAuctionEscrowRedeemer
+  deriving stock (Generic, Eq)
+  deriving anyclass (PlutusType)
+
+instance DerivePlutusType PStandingBidError where
+  type DPTStrat _ = PlutusTypeScott
+
+instance Universe (PStandingBidError s) where
+  universe = universeGeneric
+
+instance ErrorCodePrefix (PStandingBidError s) where
+  errorCodePrefix = "STBD"

src/HydraAuctionOnchain/Types/Error.hs

@@ -1,19 +1,63 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE UndecidableInstances #-}
+
 module HydraAuctionOnchain.Types.Error
-  ( ToErrorCode (toErrorCode)
-  , err
-  , perrMaybe
+  ( ErrorCode (fromErrorCode, toErrorCode)
+  , ErrorCodePrefix (errorCodePrefix)
+  , errCode
+  , passert
+  , passertMaybe
   ) where
 
+import Data.List (elemIndex)
+import Data.Maybe (fromJust)
+import Data.Text (Text)
+import Data.Text qualified as Text (pack, stripPrefix, unpack)
+import Data.Universe (Universe (universe))
+import Language.Haskell.TH (Exp (LitE), Lit (StringL), Q)
 import Plutarch.Extra.Bool (passert)
+import Plutarch.Extra.Maybe (passertPJust)
+import Safe (atMay)
+
+-- | Prefix an error code with a short text tag.
+-- Typically, this should be defined like this:
+--   errorCodePrefix = const "ABCD"
+--
+-- Make sure that error code prefixes are unique per error type.
+class ErrorCodePrefix a where
+  errorCodePrefix :: Text
+
+-- | Types which are used to describe errors as short error codes in scripts.
+-- Laws:
+--   1. fromErrorCode . toErrorCode = Just
+--   2. (toErrorCode <$> fromErrorCode x) == (const x <$> fromErrorCode x)
+class (ErrorCodePrefix a, Eq a, Universe a) => ErrorCode a where
+  -- | Get the short error code used in a script for given error type.
+  toErrorCode :: a -> Text
+
+  -- | Get the error type from an error code,
+  -- assuming that the error code produced from that error type.
+  fromErrorCode :: Text -> Maybe a
+
+-- | Sequentially ordered types have sequentially ordered error codes.
+-- Assuming that Universe implementation is correct, this instance should
+-- satisfy the ErrorCode laws.
+instance (Universe a, Eq a, ErrorCodePrefix a) => ErrorCode a where
+  toErrorCode x = prefix <> numericCode
+    where
+      -- fromJust should not result in an error here if Universe is correct.
+      numericCode = Text.pack $ show $ fromJust $ elemIndex x universe
+      prefix = errorCodePrefix @a
 
-class ToErrorCode a where
-  toErrorCode :: Term s (a :--> PString)
+  fromErrorCode x = atMay universe =<< numericCode
+    where
+      numericCode = read . Text.unpack <$> Text.stripPrefix prefix x
+      prefix = errorCodePrefix @a
 
-err :: (PlutusType e, ToErrorCode e) => e s -> Term s PBool -> Term s a -> Term s a
-err e = passert (toErrorCode # pcon e)
+-- | Get the string literal from given error 'e'.
+-- Use this with template haskell splices, e.g. $(errCode MyError)
+errCode :: ErrorCode e => e -> Q Exp
+errCode e = pure (LitE (StringL (Text.unpack (toErrorCode 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
+passertMaybe :: Text -> Term s (PMaybe a) -> Term s a
+passertMaybe err mval = passertPJust # pconstant err # mval

src/HydraAuctionOnchain/Validators/StandingBid.hs

@@ -1,7 +1,10 @@
+{-# LANGUAGE TemplateHaskell #-}
+
 module HydraAuctionOnchain.Validators.StandingBid
   ( standingBidValidator
   ) where
 
+import HydraAuctionOnchain.Errors.StandingBid (PStandingBidError (..))
 import HydraAuctionOnchain.Helpers
   ( pdecodeInlineDatum
   , pfindUniqueInputWithToken
@@ -13,7 +16,7 @@ import HydraAuctionOnchain.MintingPolicies.Auction
   , standingBidTokenName
   )
 import HydraAuctionOnchain.Types.AuctionTerms (PAuctionTerms, pbiddingPeriod)
-import HydraAuctionOnchain.Types.Error (ToErrorCode (toErrorCode), err, perrMaybe)
+import HydraAuctionOnchain.Types.Error (errCode, passert, passertMaybe)
 import HydraAuctionOnchain.Types.StandingBidState (PStandingBidState, pvalidateNewBid)
 import HydraAuctionOnchain.Validators.AuctionEscrow (pisConcluding)
 import Plutarch.Api.V1.Value (pvalueOf)
@@ -44,90 +47,6 @@ data PStandingBidRedeemer (s :: S)
 instance DerivePlutusType PStandingBidRedeemer where
   type DPTStrat _ = PlutusTypeData
 
---------------------------------------------------------------------------------
--- Errors
---------------------------------------------------------------------------------
-
-data PStandingBidError (s :: S)
-  = StandingBid'Error'OwnInputMissingToken
-  | StandingBid'Error'UnexpectedTokensMintedBurned
-  deriving stock (Generic)
-  deriving anyclass (PlutusType)
-
-instance DerivePlutusType PStandingBidError where
-  type DPTStrat _ = PlutusTypeScott
-
-instance ToErrorCode PStandingBidError where
-  toErrorCode = phoistAcyclic $
-    plam $ \err -> pmatch err $ \case
-      StandingBid'Error'OwnInputMissingToken ->
-        pconstant "StandingBid01"
-      StandingBid'Error'UnexpectedTokensMintedBurned ->
-        pconstant "StandingBid02"
-
--- NewBid ----------------------------------------------------------------------
-data PStandingBid'NewBid'Error (s :: S)
-  = StandingBid'NewBid'Error'MissingOwnOutput
-  | StandingBid'NewBid'Error'OwnOutputMissingToken
-  | StandingBid'NewBid'Error'FailedToDecodeNewBid
-  | StandingBid'NewBid'Error'InvalidNewBidState
-  | StandingBid'NewBid'Error'IncorrectValidityInterval
-  deriving stock (Generic)
-  deriving anyclass (PlutusType)
-
-instance DerivePlutusType PStandingBid'NewBid'Error where
-  type DPTStrat _ = PlutusTypeScott
-
-instance ToErrorCode PStandingBid'NewBid'Error where
-  toErrorCode = phoistAcyclic $
-    plam $ \err -> pmatch err $ \case
-      StandingBid'NewBid'Error'MissingOwnOutput ->
-        pconstant "StandingBid_NewBid_01"
-      StandingBid'NewBid'Error'OwnOutputMissingToken ->
-        pconstant "StandingBid_NewBid_02"
-      StandingBid'NewBid'Error'FailedToDecodeNewBid ->
-        pconstant "StandingBid_NewBid_03"
-      StandingBid'NewBid'Error'InvalidNewBidState ->
-        pconstant "StandingBid_NewBid_04"
-      StandingBid'NewBid'Error'IncorrectValidityInterval ->
-        pconstant "StandingBid_NewBid_05"
-
--- MoveToHydra -----------------------------------------------------------------
-data PStandingBid'MoveToHydra'Error (s :: S)
-  = StandingBid'MoveToHydra'Error'MissingDelegateSignatures
-  | StandingBid'MoveToHydra'Error'IncorrectValidityInterval
-  deriving stock (Generic)
-  deriving anyclass (PlutusType)
-
-instance DerivePlutusType PStandingBid'MoveToHydra'Error where
-  type DPTStrat _ = PlutusTypeScott
-
-instance ToErrorCode PStandingBid'MoveToHydra'Error where
-  toErrorCode = phoistAcyclic $
-    plam $ \err -> pmatch err $ \case
-      StandingBid'MoveToHydra'Error'MissingDelegateSignatures ->
-        pconstant "StandingBid_MoveToHydra_01"
-      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
 --------------------------------------------------------------------------------
@@ -147,15 +66,14 @@ standingBidValidator = phoistAcyclic $
     ownInput <- plet $ ptryOwnInput # ctx
     txInfo <- plet $ pfield @"txInfo" # ctx
 
-    -- (StandingBid01)
-    -- The standing bid input should contain the standing bid token.
-    err StandingBid'Error'OwnInputMissingToken $
+    -- (STBD0) The standing bid input should contain the standing
+    -- bid token.
+    passert $(errCode StandingBid'Error'OwnInputMissingToken) $
       ptxOutContainsStandingBidToken # auctionCs #$ pfield @"resolved" # ownInput
 
-    -- (StandingBid02)
-    -- There should be no tokens minted or burned.
+    -- (STBD1) There should be no tokens minted or burned.
     mintValue <- plet $ pfield @"mint" # txInfo
-    err StandingBid'Error'UnexpectedTokensMintedBurned $
+    passert $(errCode StandingBid'Error'UnexpectedTokensMintedBurned) $
       pfromData mintValue #== mempty
 
     pmatch redeemer $ \case
@@ -182,38 +100,35 @@ pcheckNewBid
       )
 pcheckNewBid = phoistAcyclic $
   plam $ \txInfo auctionCs auctionTerms ownInput oldBidState -> P.do
-    -- (StandingBid_NewBid_01)
-    -- The standing bid output should exist.
+    -- (STBD2) The standing bid output should exist.
     ownOutput <-
       plet $
-        perrMaybe
-          # pcon StandingBid'NewBid'Error'MissingOwnOutput
-          # (pfindUniqueOutputWithAddress # (putxoAddress # ownInput) # txInfo)
+        passertMaybe
+          $(errCode StandingBid'NewBid'Error'MissingOwnOutput)
+          (pfindUniqueOutputWithAddress # (putxoAddress # ownInput) # txInfo)
 
-    -- (StandingBid_NewBid_02)
-    -- The standing bid output should contain the standing bid token.
-    err StandingBid'NewBid'Error'OwnOutputMissingToken $
+    -- (STBD3) The standing bid output should contain the standing
+    -- bid token.
+    passert $(errCode StandingBid'NewBid'Error'OwnOutputMissingToken) $
       ptxOutContainsStandingBidToken # auctionCs # ownOutput
 
-    -- (StandingBid_NewBid_03)
-    -- The standing bid output's datum should be decodable
+    -- (STBD4) The standing bid output's datum should be decodable
     -- as a standing bid state.
     newBidState <-
       plet $
-        perrMaybe
-          # pcon StandingBid'NewBid'Error'FailedToDecodeNewBid
-          # (pdecodeInlineDatum # ownOutput)
+        passertMaybe
+          $(errCode StandingBid'NewBid'Error'FailedToDecodeNewBid)
+          (pdecodeInlineDatum # ownOutput)
 
-    -- (StandingBid_NewBid_04)
-    -- The transition from the old bid state to the new bid state
-    -- should be valid.
-    err StandingBid'NewBid'Error'InvalidNewBidState $
+    -- (STBD5) The transition from the old bid state to the new
+    -- bid state should be valid.
+    passert $(errCode StandingBid'NewBid'Error'InvalidNewBidState) $
       pvalidateNewBid # auctionCs # auctionTerms # oldBidState # newBidState
 
-    -- (StandingBid_NewBid_05)
-    -- The transaction validity should end before the bidding end time.
+    -- (STBD6) The transaction validity should end before the
+    -- bidding end time.
     txInfoValidRange <- plet $ pfield @"validRange" # txInfo
-    err StandingBid'NewBid'Error'IncorrectValidityInterval $
+    passert $(errCode StandingBid'NewBid'Error'IncorrectValidityInterval) $
       pcontains # (pbiddingPeriod # auctionTerms) # txInfoValidRange
 
     pcon PUnit
@@ -227,15 +142,14 @@ pcheckMoveToHydra = phoistAcyclic $
   plam $ \txInfo auctionTerms -> P.do
     txInfoFields <- pletFields @["signatories", "validRange"] txInfo
 
-    -- (StandingBid_MoveToHydra_01)
-    -- The transaction should be signed by all the delegates.
+    -- (STBD7) The transaction should be signed by all the delegates.
     delegates <- plet $ pfield @"delegates" # auctionTerms
-    err StandingBid'MoveToHydra'Error'MissingDelegateSignatures $
+    passert $(errCode StandingBid'MoveToHydra'Error'MissingDelegateSignatures) $
       pall # plam (\sig -> ptxSignedBy # txInfoFields.signatories # sig) # delegates
 
-    -- (StandingBid_MoveToHydra_02)
-    -- The transaction validity should end before the bidding end time.
-    err StandingBid'MoveToHydra'Error'IncorrectValidityInterval $
+    -- (STBD8) The transaction validity should end before the
+    -- bidding end time.
+    passert $(errCode StandingBid'MoveToHydra'Error'IncorrectValidityInterval) $
       pcontains # (pbiddingPeriod # auctionTerms) # txInfoFields.validRange
 
     pcon PUnit
@@ -247,24 +161,23 @@ pcheckMoveToHydra = phoistAcyclic $
 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.
+    -- (STBD9) 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.
+        passertMaybe
+          $(errCode StandingBid'ConcludeAuction'Error'MissingAuctionEscrowInput)
+          (pfindUniqueInputWithToken # auctionCs # auctionEscrowTokenName # txInfo)
+
+    -- (STBD10) 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 $
+    passert $(errCode StandingBid'ConcludeAuction'Error'InvalidAuctionEscrowRedeemer) $
       pmaybe
         # pcon PFalse
         # plam (\redeemer -> pisConcluding # pfromData redeemer)