From d62d0572ddf47e0cb56dbd3b5a43b7d45dc94d39 Mon Sep 17 00:00:00 2001 From: Ashesh Ambasta Date: Sun, 10 Jul 2022 12:15:30 +0200 Subject: [PATCH] Add error modes to detect and output errors in the correct mode. This will let us start servers with the correct mode and respond with errors in HTML or in JSON, depending on the use case. A future improvement would be to do this via a middleware: and detect the mode based off the the client's "Accept" header. --- core/commence-core.cabal | 4 +- core/src/Commence/Runtime/Errors.hs | 75 +++++++++++++------ core/src/Commence/Runtime/Errors/Code.hs | 32 ++++++++ core/src/Commence/Runtime/Errors/Mode.hs | 21 ++++++ .../commence-interactive-state.cabal | 2 +- 5 files changed, 108 insertions(+), 26 deletions(-) create mode 100644 core/src/Commence/Runtime/Errors/Code.hs create mode 100644 core/src/Commence/Runtime/Errors/Mode.hs diff --git a/core/commence-core.cabal b/core/commence-core.cabal index 8c825c5..8458012 100644 --- a/core/commence-core.cabal +++ b/core/commence-core.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: commence-core -version: 0.1.0.0 +version: 0.2.0.0 extra-source-files: CHANGELOG.md common common-extensions @@ -82,6 +82,8 @@ library , Commence.Multilogging , Commence.Util.Module , Commence.Runtime.Errors + , Commence.Runtime.Errors.Mode + , Commence.Runtime.Errors.Code , Commence.Runtime.Storage , Commence.ACL , Commence.ACL.Types diff --git a/core/src/Commence/Runtime/Errors.hs b/core/src/Commence/Runtime/Errors.hs index c356ffe..1de6e67 100644 --- a/core/src/Commence/Runtime/Errors.hs +++ b/core/src/Commence/Runtime/Errors.hs @@ -32,33 +32,30 @@ instance IsRuntimeErr AuthErr where module Commence.Runtime.Errors ( RuntimeErr(..) , IsRuntimeErr(..) - , ErrCode(..) , asServantError + , defaultErrHtml + -- * Exceptional re-exports for backwards compatibility in dependant packages. + , module Mode + , module Code ) where -import Commence.Logging +import Commence.Runtime.Errors.Code as Code +import Commence.Runtime.Errors.Mode as Mode import Control.Lens as L -import qualified Data.ByteString.Lazy as BSL -import qualified Data.String -- Required from the handrolled IsString instance. + hiding ( (.=) ) +import qualified Data.Aeson as Aeson +import Data.Aeson ( (.=) + , Value(String) + ) -- for convenience, where qualified imports are overkill. import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified GHC.Show as Show import Network.HTTP.Types import qualified Network.HTTP.Types as HTTP import Servant.Server ( ServerError(..) ) - -newtype ErrCode = ErrCode [Text] - deriving (Eq, Show, Monoid, Semigroup) via [Text] - -instance TextShow ErrCode where - showb = showb . showErrCode - --- | Reverse of the IsString instance (below) -showErrCode (ErrCode envs) = T.toUpper . T.intercalate "." $ envs - --- | Take any string; split at @/@; and use it as the ErrCode. -instance IsString ErrCode where - fromString = ErrCode . T.splitOn "." . T.toUpper . T.pack +import qualified Text.Blaze.Html as B +import Text.Blaze.Html.Renderer.Utf8 ( renderHtml ) +import qualified Text.Blaze.Html5 as H -- brittany-disable-next-binding -- | A generalised error @@ -73,7 +70,7 @@ deriving anyclass instance Exception RuntimeErr -- | TODO: add common properties of errors. class IsRuntimeErr e where - errCode :: e -> ErrCode + errCode :: e -> Code.ErrCode -- | Construct a `RuntimeErr` from an instance value knownErr :: e -> RuntimeErr @@ -98,7 +95,20 @@ class IsRuntimeErr e where -- | Header information to supply for returning errors over HTTP. httpHeaders :: e -> [Header] - httpHeaders e = [("x-err-code", errCode e ^. coerced . L.to showErrCode . L.to TE.encodeUtf8)] + httpHeaders e = [("x-err-code", errCode e ^. coerced . L.to Code.showErrCode . L.to TE.encodeUtf8)] + + -- | Error specific HTML markup generation. Uses the crude `defaultErrHtml` by default. + htmlErr :: e -> B.Html + htmlErr = defaultErrHtml + +-- | Generate an HTML error: TODO improve the default implementation to have a proper design. +-- For errors with very custom designs, this method may be overriden. +defaultErrHtml :: forall e . IsRuntimeErr e => e -> B.Html +defaultErrHtml e = H.body $ do + H.text "Sorry, we've encountered an error." + H.hr + maybe mempty addMessage (userMessage e) + where addMessage txt = H.text txt *> H.hr instance Show RuntimeErr where show = T.unpack . displayErr @@ -127,17 +137,34 @@ instance IsRuntimeErr RuntimeErr where T.unwords ["RuntimeException", show e, T.pack $ displayException e] -- | Map out a known error to a `ServerError` (from Servant) -asServantError :: IsRuntimeErr e => e -> ServerError -asServantError e = ServerError +asServantError :: IsRuntimeErr e => Mode.ErrMode -> e -> ServerError +asServantError mode e = ServerError { errReasonPhrase = T.unpack . TE.decodeUtf8 $ statusMessage - , errHeaders = httpHeaders e + , errHeaders = httpHeaders e <> Mode.modeContentType mode , .. } where Status errHTTPCode statusMessage = httpStatus e - errBody = - maybe "No known reason." (BSL.fromStrict . TE.encodeUtf8) $ userMessage e + -- depending on the mode, we'd like to output the right respose body. + -- this in combination of the call to `Mode.modeContentType` above will ensure we're outputting the correct response type. + errBody = case mode of + Mode.JsonErr -> Aeson.encode . knownErr $ e + Mode.HtmlErr -> renderHtml $ htmlErr e instance MonadError RuntimeErr (Either RuntimeErr) where throwError = Left catchError op' handler = either handler Right op' + +instance Aeson.ToJSON RuntimeErr where + toJSON = \case + KnownErr e -> Aeson.object + [ "errorCode" .= errCode e + , "userMessage" .= userMessage e + , "errorType" .= String "KNOWN_ERR" -- indicates that we know how to handle this error, and it is a user-defined error. + ] + + RuntimeException ex -> Aeson.object + [ "errorType" .= String "RUNTIME_EXCEPTION" + , "exception" .= String (show ex) + ] + diff --git a/core/src/Commence/Runtime/Errors/Code.hs b/core/src/Commence/Runtime/Errors/Code.hs new file mode 100644 index 0000000..9502b7d --- /dev/null +++ b/core/src/Commence/Runtime/Errors/Code.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} +module Commence.Runtime.Errors.Code + ( ErrCode(..) + , showErrCode + ) where + +import Commence.Logging +import qualified Data.Aeson as Aeson +import qualified Data.String -- Required from the handrolled IsString instance. +import qualified Data.Text as T +import qualified Text.Blaze.Html5 as H + +newtype ErrCode = ErrCode [Text] + deriving (Eq, Show, Monoid, Semigroup) via [Text] + +instance TextShow ErrCode where + showb = showb . showErrCode + +-- | Reverse of the IsString instance (below) +showErrCode (ErrCode envs) = T.toUpper . T.intercalate "." $ envs + +-- | Take any string; split at @/@; and use it as the ErrCode. +instance IsString ErrCode where + fromString = ErrCode . T.splitOn "." . T.toUpper . T.pack + +instance Aeson.ToJSON ErrCode where + toJSON = Aeson.String . showErrCode + {-# INLINE toJSON #-} + +instance H.ToMarkup ErrCode where + toMarkup = H.text . showErrCode + {-# INLINE toMarkup #-} diff --git a/core/src/Commence/Runtime/Errors/Mode.hs b/core/src/Commence/Runtime/Errors/Mode.hs new file mode 100644 index 0000000..eaf69c0 --- /dev/null +++ b/core/src/Commence/Runtime/Errors/Mode.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} +module Commence.Runtime.Errors.Mode + ( ErrMode(..) + , modeContentType + ) where + +import Network.HTTP.Types.Header + +{- | An error mode indicates how we'd like to have a failure. + +In some cases, we'd like to respond with JSON values in case of errors: eg. in a REST API response. Whereas for hosted HTML +interfaces, we'd like to respond with HTML. +-} +data ErrMode = JsonErr | HtmlErr + deriving (Eq, Show) + +-- | Get the content-type header value +modeContentType :: ErrMode -> [Header] +modeContentType = pure . (hContentType, ) . \case + JsonErr -> "application/json" + HtmlErr -> "text/html" diff --git a/interactive-state/commence-interactive-state.cabal b/interactive-state/commence-interactive-state.cabal index e7697c2..e18b41b 100644 --- a/interactive-state/commence-interactive-state.cabal +++ b/interactive-state/commence-interactive-state.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: commence-interactive-state -version: 0.1.0.0 +version: 0.2.0.0 common common-extensions default-language: Haskell2010