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