-- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE DeriveLift #-} {-# LANGUAGE TypeFamilyDependencies #-} -- We want to make sure 'failUsingArg' is used with sane argument. {-# OPTIONS_GHC -Wno-redundant-constraints #-} module Lorentz.Errors ( -- * Haskell to 'Value' conversion IsError (..) , ErrorScope , ConstantScope , isoErrorToVal , isoErrorFromVal , simpleFailUsing , ErrorHasDoc (..) , typeDocMdDescriptionReferToError , isInternalErrorClass , UnspecifiedError (..) , Impossible (..) , SomeError (..) -- * General instructions , failUnexpected -- * Custom errors , NoErrorArg , UnitErrorArg , ErrorArg , CustomError (..) , CustomErrorRep , IsCustomErrorArgRep (..) , MustHaveErrorArg , failCustom , failCustom_ , failCustomNoArg -- * Documentation , ErrorClass (..) , CustomErrorHasDoc (..) , DError (..) , DThrows (..) -- * Internals , errorTagToText , errorTagToMText ) where import Data.Char qualified as C import Data.List qualified as L import Fmt (Buildable, build, fmt, pretty, (+|), (|+)) import Language.Haskell.TH.Syntax (Lift) import Lorentz.Base import Lorentz.Doc import Lorentz.Ext import Lorentz.Instr hiding (cast) import Lorentz.Value import Morley.Michelson.Text import Morley.Michelson.Typed.Convert (untypeValue) import Morley.Michelson.Typed.Haskell import Morley.Michelson.Typed.Instr import Morley.Michelson.Typed.Scope import Morley.Michelson.Typed.Sing (castM, castSingE) import Morley.Util.Markdown import Morley.Util.MismatchError import Morley.Util.Type import Morley.Util.TypeLits import Morley.Util.Typeable ---------------------------------------------------------------------------- -- IsError ---------------------------------------------------------------------------- -- | Since 008 it's prohibited to fail with non-packable values and with the -- 'Contract t' type values, which is equivalent to our @ConstantScope@ constraint. -- See https://gitlab.com/tezos/tezos/-/issues/1093#note_496066354 for more information. type ErrorScope t = ConstantScope t type KnownError a = ErrorScope (ToT a) -- | Haskell type representing error. class (ErrorHasDoc e) => IsError e where -- | Converts a Haskell error into @Value@ representation. errorToVal :: e -> (forall t. ErrorScope t => Value t -> r) -> r -- | Converts a @Value@ into Haskell error. errorFromVal :: (SingI t) => Value t -> Either Text e -- | Fail with the given Haskell value. failUsing :: (IsError e) => e -> s :-> t failUsing = simpleFailUsing -- | Implementation of 'errorToVal' via 'IsoValue'. isoErrorToVal :: (KnownError e, IsoValue e) => e -> (forall t. ErrorScope t => Value t -> r) -> r isoErrorToVal e cont = cont $ toVal e -- | Implementation of 'errorFromVal' via 'IsoValue'. isoErrorFromVal :: (SingI t, KnownIsoT e, IsoValue e) => Value t -> Either Text e isoErrorFromVal e = fromVal <$> castSingE e -- | Basic implementation for 'failUsing'. simpleFailUsing :: forall e s t. (IsError e) => e -> s :-> t simpleFailUsing err = errorToVal err $ \eval -> doc (DThrows (Proxy @e)) # (FI $ PUSH eval `Seq` FAILWITH) class Typeable e => ErrorHasDoc (e :: Type) where -- | Name of error as it appears in the corresponding section title. errorDocName :: Text -- | What should happen for this error to be raised. errorDocMdCause :: Markdown -- | Brief version of 'errorDocMdCause'. -- -- This will appear along with the error when mentioned in entrypoint description. -- By default, the first sentence of the full description is used. errorDocMdCauseInEntrypoint :: Markdown errorDocMdCauseInEntrypoint = pickFirstSentence $ errorDocMdCause @e -- | How this error is represented in Haskell. errorDocHaskellRep :: Markdown -- | Error class. errorDocClass :: ErrorClass errorDocClass = ErrClassUnknown -- | Which definitions documentation for this error mentions. errorDocDependencies :: [SomeDocDefinitionItem] -- | Constraints which we require in a particular instance. -- You are not oblidged to often instantiate this correctly, it is only useful -- for some utilities. type ErrorRequirements e :: Constraint type ErrorRequirements _ = () -- | Captured constraints which we require in a particular instance. -- This is a way to encode a bidirectional instance in the nowaday Haskell, -- for @class MyConstraint => ErrorHasDoc MyType@ instance it lets deducing -- @MyConstraint@ by @ErrorHasDoc MyType@. -- -- You are not oblidged to always instantiate, it is only useful for some -- utilities which otherwise would not compile. errorDocRequirements :: Dict (ErrorRequirements e) default errorDocRequirements :: ErrorRequirements e => Dict (ErrorRequirements e) errorDocRequirements = Dict -- | Helper for managing descriptions. pickFirstSentence :: Markdown -> Markdown pickFirstSentence = build . toText . go . fmt where go :: String -> String go = \case '.' : c : _ | C.isSpace c -> "." c : s -> c : go s "" -> "" ---------------------------------------------------------------------------- -- Instances ---------------------------------------------------------------------------- -- | Use this for internal errors only. -- -- \"Normal\" error scenarios should use the mechanism of custom errors, see below. instance IsError MText where errorToVal = isoErrorToVal errorFromVal = isoErrorFromVal instance ErrorHasDoc MText where errorDocName = "InternalError" errorDocMdCause = "Some internal error occurred." errorDocHaskellRep = "Textual error message, see " <> typeDocMdReference (Proxy @MText) (WithinParens False) <> "." errorDocClass = ErrClassContractInternal errorDocDependencies = [SomeDocDefinitionItem (DType $ Proxy @MText)] instance TypeError ('Text "Use representative error messages") => IsError () where errorToVal _ _ = error "impossible" errorFromVal = error "impossible" instance TypeError ('Text "Use representative error messages") => ErrorHasDoc () where errorDocName = error "impossible" errorDocMdCause = error "impossible" errorDocHaskellRep = error "impossible" errorDocDependencies = error "impossible" -- | Use this type as replacement for @()@ when you __really__ want to leave -- error cause unspecified. data UnspecifiedError = UnspecifiedError deriving stock Generic deriving anyclass IsoValue instance IsError UnspecifiedError where errorToVal = isoErrorToVal errorFromVal = isoErrorFromVal instance ErrorHasDoc UnspecifiedError where errorDocName = "Unspecified error" errorDocMdCause = "Some error occurred." errorDocHaskellRep = typeDocMdReference (Proxy @()) (WithinParens False) <> "." errorDocDependencies = typeDocDependencies (Proxy @()) -- | Use this error when sure that failing at the current position is possible -- in no curcumstances (including invalid user input or misconfigured storage). -- -- To use this as error, you have to briefly specify the reason why the error -- scenario is impossible (experimental feature). data Impossible (reason :: Symbol) = HasCallStack => Impossible instance KnownSymbol reason => IsError (Impossible reason) where errorToVal Impossible cont = cont $ toVal () errorFromVal = error "Extracting impossible error" failUsing err@Impossible = justComment codeComment # testAssert testDescription "" (push False) # simpleFailUsing err where codeComment = fromString $ "Failure from " <> prettyCallStack callStack testDescription = "Impossible happened: unexpected " <> symbolValT' @reason <> "\n\ \At: " <> fromString (prettyCallStack callStack) instance KnownSymbol reason => ErrorHasDoc (Impossible reason) where errorDocName = "Impossible error" errorDocMdCause = "An impossible error happened.\n\n\ \If this error occured, contact the contract authors." errorDocHaskellRep = typeDocMdReference (Proxy @()) (WithinParens False) <> "." errorDocDependencies = typeDocDependencies (Proxy @()) -- | Type wrapper for an @IsError@. data SomeError = forall e. (IsError e, Eq e) => SomeError e instance Eq SomeError where SomeError e1 == SomeError e2 = eqExt e1 e2 instance Buildable SomeError where build (SomeError e) = errorToVal e (build . untypeValue) ---------------------------------------------------------------------------- -- General instructions ---------------------------------------------------------------------------- -- | Fail, providing a reference to the place in the code where -- this function is called. -- -- Like 'error' in Haskell code, this instruction is for internal errors only. failUnexpected :: MText -> s :-> t failUnexpected msg = failUsing $ [mt|Unexpected: |] <> msg ---------------------------------------------------------------------------- -- Custom errors ---------------------------------------------------------------------------- {- | Declares a custom error, defining @error name - error argument@ relation. If your error is supposed to carry no argument, then provide @()@. Note that this relation is defined globally rather than on per-contract basis, so define errors accordingly. If your error has argument specific to your contract, call it such that error name reflects its belonging to this contract. This is the basic [error format]. -} {- About global registry of errors: Pros: this allows defining pieces of code which can be reused among the contracts. Cons: possible name collisions. Example of worst case: two libraries define different errors for the same tag, attempt to use both of these libraries would cause compile-time error. But such infrastructure will barely take place in practice. -} {- For future work: * Assosiating unique numeric error codes to tags, and put codes into the contract instead of tags. This allows getting rid of overhead related to often long tag literals. * Allow using arbitrary type instead of tag (and 'KnownSymbol' constraint will be replaced with a more generic one). Some users may prefer using datatypes as tags rather than type-level strings as tags because * there will be no orphan instances then * no problem with name collisions * compiler will prompt a hint in case of typo in tag name * in some cases autocomplete handles declarations in code better than strings (and cons here is that each such tag will need to be declared first). -} type family ErrorArg (tag :: Symbol) :: Type -- | Material custom error. -- -- Use this in pattern matches against error (e.g. in tests). data CustomError (tag :: Symbol) = CustomError { ceTag :: Label tag , ceArg :: CustomErrorRep tag } deriving stock instance Eq (CustomErrorRep tag) => Eq (CustomError tag) deriving stock instance Show (CustomErrorRep tag) => Show (CustomError tag) instance Buildable (CustomError tag) where build (CustomError tg _err) = "CustomError #" +| build tg -- | To be used as @ErrorArg@ instance when failing with just -- a @string@ instead of @pair string x@ data NoErrorArg -- | To be used as @ErrorArg@ instances. This is equivalent to using -- @()@ but using @UnitErrorArg@ is preferred since @()@ behavior could -- be changed in the future. data UnitErrorArg -- | How 'CustomError' is actually represented in Michelson. type CustomErrorRep tag = CustomErrorArgRep (ErrorArg tag) type family CustomErrorArgRep (errArg :: Type) where CustomErrorArgRep NoErrorArg = MText CustomErrorArgRep UnitErrorArg = (MText, ()) CustomErrorArgRep errArg = (MText, errArg) -- | Typeclass implements various method that work with `CustomErrorArgRep`. class IsCustomErrorArgRep a where verifyErrorTag :: MText -> a -> Either Text a customErrorRepDocDeps :: [SomeDocDefinitionItem] customErrorHaskellRep :: (KnownSymbol tag, CustomErrorHasDoc tag) => Proxy tag -> Markdown instance IsCustomErrorArgRep MText where verifyErrorTag expectedTag tag = if tag == expectedTag then Right tag else Left $ "Bad tag, expected " +| expectedTag |+ ", got " +| tag |+ "" customErrorRepDocDeps = [] customErrorHaskellRep (_ :: Proxy tag) = mdTicked $ build (errorTagToText @tag) instance (TypeHasDoc errArg) => IsCustomErrorArgRep (MText, errArg) where verifyErrorTag expectedTag (tag, arg) = if tag == expectedTag then Right (tag, arg) else Left $ "Bad tag, expected " +| expectedTag |+ ", got " +| tag |+ "" customErrorRepDocDeps = [ SomeDocDefinitionItem $ DType $ Proxy @errArg ] customErrorHaskellRep (_ :: Proxy tag) = mconcat [ mdTicked ("(" <> build (errorTagToText @tag) <> ", " <> "" <> ")") , ("\n\nProvided error argument will be of type " <> typeDocMdReference (Proxy @(MText, errArg)) (WithinParens False) <> (maybe "" (\txt -> " and stand for " <> txt) (customErrArgumentSemantics @tag)) <> "." ) ] -- | This instance cannot be implemented, use 'IsError' instance instead. instance (WellTypedToT (CustomErrorRep tag), TypeError ('Text "CustomError has no IsoValue instance")) => IsoValue (CustomError tag) where -- Originally we had a `TypeError` here, but that had to be changed when -- `WellTyped (ToT a)` was added as a superclass of `IsoValue`, because it -- resulted in the type error being triggerred from the evaluation of `ToT` -- typefamily in the super class clause. type ToT (CustomError tag) = (ToT (CustomErrorRep tag)) toVal = error "impossible" fromVal = error "impossible" instance ( CustomErrorHasDoc tag , KnownError (CustomErrorRep tag) , IsoValue (CustomErrorRep tag) , IsCustomErrorArgRep (CustomErrorRep tag) ) => IsError (CustomError tag) where errorToVal (CustomError _ arg) cont = cont $ toVal @(CustomErrorRep tag) arg errorFromVal v = do let expectedTag = errorTagToMText (fromLabel @tag) v' <- castM v \MkMismatchError{..} -> Left $ "Wrong type for custom error: " <> pretty meActual errArg <- verifyErrorTag @(CustomErrorRep tag) expectedTag $ fromVal @(CustomErrorRep tag) v' pure $ CustomError fromLabel errArg instance ( CustomErrorHasDoc tag , IsCustomErrorArgRep (CustomErrorRep tag) ) => ErrorHasDoc (CustomError tag) where errorDocName = errorTagToText @tag errorDocDependencies = customErrorRepDocDeps @(CustomErrorRep tag) errorDocMdCause = customErrDocMdCause @tag errorDocMdCauseInEntrypoint = customErrDocMdCauseInEntrypoint @tag errorDocClass = customErrClass @tag errorDocHaskellRep = customErrorHaskellRep @(CustomErrorRep tag) (Proxy @tag) type ErrorRequirements (CustomError tag) = (CustomErrorHasDoc tag, IsCustomErrorArgRep (CustomErrorRep tag)) errorDocRequirements = Dict -- | Demote error tag to term level. errorTagToMText :: Label tag -> MText errorTagToMText l = -- Now tags come not from constructor names, but from labels, -- we have to lead the first letter to upper case to preserve -- compatibility with FA1.2 interface. mtextHeadToUpper $ labelToMText l errorTagToText :: forall tag. KnownSymbol tag => Text errorTagToText = toText $ errorTagToMText (fromLabel @tag) -- | Fail with given custom error. failCustom :: forall tag err s any. ( MustHaveErrorArg tag (MText, err) , CustomErrorHasDoc tag , KnownError err ) => Label tag -> err : s :-> any failCustom l = doc (DThrows (Proxy @(CustomError tag))) # push (errorTagToMText l) # pair @MText @err # FI (FAILWITH @(ToT (MText, err))) -- | Fail with given custom error. failCustomNoArg :: forall tag s any. ( MustHaveErrorArg tag MText , CustomErrorHasDoc tag ) => Label tag -> s :-> any failCustomNoArg l = doc (DThrows (Proxy @(CustomError tag))) # push (errorTagToMText l) # FI (FAILWITH @(ToT (MText))) type MustHaveErrorArg errorTag expectedArgRep = FailUnlessEqual (CustomErrorRep errorTag) expectedArgRep ('Text "Error argument type is " ':<>: 'ShowType (expectedArgRep) ':<>: 'Text " but given error requires argument of type " ':<>: 'ShowType (CustomErrorRep errorTag) ) -- | Specialization of 'failCustom' for unit-arg errors. failCustom_ :: forall tag s any. ( MustHaveErrorArg tag (MText, ()) , CustomErrorHasDoc tag ) => Label tag -> s :-> any failCustom_ l = doc (DThrows (Proxy @(CustomError tag))) # unit # push (errorTagToMText l) # pair @MText @() # FI (FAILWITH @(ToT (MText, ()))) -- Special treatment of no-arg errors ---------------------------------------------------------------------------- -- | If 'CustomError' constructor is not provided its argument, we assume -- that this is unit-arg error and interpret the passed value as complete. instance ( Typeable arg , IsError (CustomError tag) , arg ~ ErrorArg tag , FailUnlessEqual arg () ('Text "This error requires argument of type " ':<>: 'ShowType (ErrorArg tag) ) ) => IsError (arg -> CustomError tag) where errorToVal mkCustomError cont = errorToVal (mkCustomError ()) cont errorFromVal v = errorFromVal v <&> \(CustomError l a) b -> CustomError l (fst a, b) instance (Typeable arg, ErrorHasDoc (CustomError tag)) => ErrorHasDoc (arg -> CustomError tag) where errorDocName = errorDocName @(CustomError tag) errorDocMdCauseInEntrypoint = errorDocMdCauseInEntrypoint @(CustomError tag) errorDocMdCause = errorDocMdCause @(CustomError tag) errorDocHaskellRep = errorDocHaskellRep @(CustomError tag) errorDocDependencies = errorDocDependencies @(CustomError tag) ---------------------------------------------------------------------------- -- Errors documentation injection into contracts ---------------------------------------------------------------------------- -- | Error class on how the error should be handled by the client. data ErrorClass = ErrClassActionException -- ^ Normal expected error. -- Examples: "insufficient balance", "wallet does not exist". | ErrClassBadArgument -- ^ Invalid argument passed to entrypoint. -- Examples: your entrypoint accepts an enum represented as @nat@, and -- unknown value is provided. -- This includes more complex cases which involve multiple entrypoints. -- E.g. API provides iterator interface, middleware should care about using it -- hiding complex details and exposing a simpler API to user; then an attempt to -- request non-existing element would also correspond to an error from this class. | ErrClassContractInternal -- ^ Unexpected error. Most likely it means that there is a bug in -- the contract or the contract has been deployed incorrectly. | ErrClassUnknown -- ^ It's possible to leave error class unspecified. deriving stock (Lift) instance Buildable ErrorClass where build = \case ErrClassActionException -> "Action exception" ErrClassBadArgument -> "Bad argument" ErrClassContractInternal -> "Internal" ErrClassUnknown -> "-" -- | Whether given error class is about internal errors. -- -- Internal errors are not enlisted on per-entrypoint basis, only once for -- the entire contract. isInternalErrorClass :: ErrorClass -> Bool isInternalErrorClass = \case ErrClassActionException -> False ErrClassBadArgument -> False ErrClassContractInternal -> True ErrClassUnknown -> False class (KnownSymbol tag, TypeHasDoc (CustomErrorRep tag), IsError (CustomError tag)) => CustomErrorHasDoc tag where -- | What should happen for this error to be raised. customErrDocMdCause :: Markdown -- | Brief version of 'customErrDocMdCause'. -- This will appear along with the error when mentioned in entrypoint description. -- -- By default, the first sentence of the full description is used. customErrDocMdCauseInEntrypoint :: Markdown customErrDocMdCauseInEntrypoint = pickFirstSentence $ customErrDocMdCause @tag -- | Error class. -- -- By default this returns "unknown error" class; though you should provide -- explicit implementation in order to avoid a warning. customErrClass :: ErrorClass customErrClass = ErrClassUnknown -- | Clarification of error argument meaning. -- -- Provide when it's not obvious, e.g. argument is not named with t'Lorentz.ADT.:!'. -- -- NOTE: This should /not/ be an entire sentence, rather just the semantic -- backbone. -- -- Bad: -- * @Error argument stands for the previous value of approval.@ -- -- Good: -- * @the previous value of approval@ -- * @pair, first argument of which is one thing, and the second is another@ customErrArgumentSemantics :: Maybe Markdown customErrArgumentSemantics = Nothing {-# MINIMAL customErrDocMdCause, customErrClass #-} -- | Mentions that contract uses given error. data DError where DError :: ErrorHasDoc e => Proxy e -> DError instance Eq DError where DError e1 == DError e2 = e1 `eqParam1` e2 instance Ord DError where DError e1 `compare` DError e2 = e1 `compareExt` e2 instance DocItem DError where type DocItemPlacement DError = 'DocItemInDefinitions type DocItemReferenced DError = 'True docItemPos = 5010 docItemSectionName = Just "Errors" docItemSectionDescription = Just errorsDocumentation docItemRef (DError (_ :: Proxy e)) = DocItemRef $ DocItemId ("errors-" <> errorDocName @e) docItemToMarkdown lvl (DError (_ :: Proxy e)) = mconcat [ mdSeparator , mdHeader lvl (mdTicked . build $ errorDocName @e) , mdSubsection "Class" (build $ errorDocClass @e) , "\n\n" , mdSubsection "Fires if" $ errorDocMdCause @e , "\n\n" , mdSubsection "Representation" $ errorDocHaskellRep @e ] docItemToToc lvl d@(DError (_ :: Proxy e)) = mdTocFromRef lvl (build $ errorDocName @e) d docItemDependencies (DError (_ :: Proxy e)) = errorDocDependencies @e errorDocMdReference :: forall e. ErrorHasDoc e => Markdown errorDocMdReference = let DocItemRef docItemId = docItemRef $ DError (Proxy @e) in mdLocalRef (mdTicked . build $ errorDocName @e) docItemId -- | Documentation for custom errors. -- | Mentions that entrypoint throws given error. data DThrows where DThrows :: ErrorHasDoc e => Proxy e -> DThrows instance Eq DThrows where DThrows e1 == DThrows e2 = eqParam1 e1 e2 instance DocItem DThrows where docItemPos = 5011 docItemSectionName = Just "Possible errors" docItemSectionNameStyle = DocSectionNameSmall docItemDependencies (DThrows ds) = [SomeDocDefinitionItem (DError ds)] docItemToMarkdown _ (DThrows (_ :: Proxy e)) = "* " <> errorDocMdReference @e <> " — " <> errorDocMdCauseInEntrypoint @e docItemsOrder = let errType (DThrows (_ :: Proxy e)) = errorDocClass @e in L.nub . filter (Prelude.not . isInternalErrorClass . errType) -- | Implementation of 'typeDocMdDescription' (of 'TypeHasDoc' typeclass) -- for Haskell types which sole purpose is to be error. typeDocMdDescriptionReferToError :: forall e. IsError e => Markdown typeDocMdDescriptionReferToError = "This type is primarily used as error, see " <> docDefinitionRef "description in section with errors" (DError (Proxy @e)) -- | This is to be included on top of @Errors@ section of the generated -- documentation. errorsDocumentation :: Markdown errorsDocumentation = -- Note: this description should remain general enough to fit into all our -- error formats, seek for [error format] to find all the relevant -- declarations. [md| Our contract implies the possibility of error scenarios, this section enlists all values which the contract can produce via calling `FAILWITH` instruction on them. In case of error, no changes to contract state will be applied. Each entrypoint also contains a list of errors which can be raised during its execution; only for no-throw entrypoints this list will be omitted. Errors in these lists are placed in the order in which the corresponding properties are checked unless the opposite is specified. I.e., if for a given entrypoint call two different errors may take place, the one which appears in the list first will be thrown. The errors are represented either as a string `error tag` or a pair `(error tag, error argument)`. See the list of errors below for details. We distinquish several error classes: + #{errClassActionException}: given action cannot be performed with regard to the current contract state. Examples: "insufficient balance", "wallet does not exist". If you are implementing a middleware, such errors should be propagated to the client. + #{errClassBadArgument}: invalid argument supplied to the entrypoint. Examples: entrypoint accepts a natural number from `0-3` range, and you supply `5`. If you are implementing a middleware, you should care about not letting such errors happen. + #{errClassContractInternal}: contract-internal error. In ideal case, such errors should not take place, but still, make sure that you are ready to handle them. They can signal either invalid contract deployment or a bug in contract implementation. If an internal error is thrown, please report it to the author of this contract. |] where errClassActionException = mdBold $ build ErrClassActionException errClassBadArgument = mdBold $ build ErrClassBadArgument errClassContractInternal = mdBold $ build ErrClassContractInternal