servant-errors (empty) → 0.1.0.0

raw patch · 6 files changed

+587/−0 lines, 6 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, http-api-data, http-media, http-types, scientific, servant, servant-errors, servant-server, string-conversions, text, unordered-containers, wai, warp

Files

CHANGELOG.md +11/−0
LICENSE +21/−0
README.lhs +138/−0
README.md +138/−0
servant-errors.cabal +64/−0
src/Network/Wai/Middleware/Servant/Errors.hs +215/−0

+ CHANGELOG.md view

@@ -0,0 +1,11 @@+# Changelog++`servant-errors` uses [PVP Versioning][1].+The changelog is available [on GitHub][2].++## 0.0.0.0++* Initially created.++[1]: https://pvp.haskell.org+[2]: https://github.com/epicallan/servant-errors/releases

+ LICENSE view

@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2019 Lukwago Allan++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

+ README.lhs view

@@ -0,0 +1,138 @@+# servant-errors++[![Hackage](https://img.shields.io/hackage/v/servant-errors.svg?logo=haskell)](https://hackage.haskell.org/package/servant-errors)+[![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](LICENSE)+[![Build status](https://img.shields.io/travis/epicallan/servant-errors.svg?logo=travis)](https://travis-ci.org/epicallan/servant-errors)++## Intro++This package implements a wai-middleware targeting servant-server applications with a goal of make it easier to generate custom server error responses.++## Motivation++By default, when your servant server application experiences an internal exception during endpoint route resolution, e.g. request body decode errors. The server response is just plain text with a status code in the HTTP headers.++At the same time, if you don't write custom code to customise error responses for errors thrown within servant route handlers the default response is plain text with an HTTP content-type if set within `ServerError`.++With `servant-errors`  library, you get a single interface to structure and encode your error responses in one place as `JSON` error response or any other preferred form.++```haskell ignore+-- | A typical servant application is usually of this form++main :: IO ()+main = run 8001 (serve proxyApi handlers)++-- | With servant-errors as error processing middleware+main :: IO ()+main = run 8001+     $ errorMw @JSON @'["error", "status"]+     -- ^ Structures error response as JSON objects+     -- with 'error' and 'status' strings as error object field keys+     -- note they can be changed to any other preferred strings.+     $ serve proxyApi handlers++-- | The implementation above can also be written as below+-- if you want to output JSON error responses with 'error'+-- and 'status' as the JSON Object keys+main :: IO ()+main = run 8001+     $ errorMwDefJson+     -- ^ Default implementation of structuring error responses as JSON+     -- with no customisation option for JSON error object field keys+     $ serve proxyApi handlers+```++This [blog post](https://lukwagoallan.com/posts/unifying-servant-server-error-responses) explains in more details.++## Complete Usage Example++```haskell+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE TypeOperators     #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DerivingVia #-}++module Main where++import           Data.Aeson (FromJSON, ToJSON)+import           Data.Proxy (Proxy(..))+import           Data.Text (Text)+import           GHC.Generics (Generic)+import           Network.Wai (Application)+import           Network.Wai.Handler.Warp (run)+import           Network.Wai.Middleware.Servant.Errors (errorMw, HasErrorBody(..))+import           Servant (ReqBody, (:>), Post, JSON, Accept(..), serve)++-- | A greet message data type for use as Request Body+newtype Greet = Greet { msg :: Text }+  deriving (Generic, Show, FromJSON, ToJSON)++-- servant application+main' :: IO ()+main' = run 8001+  $ errorMw @JSON @'["error", "status"]+  -- ^ @JSON specifies content type encoding of errors+  -- @["error", "status"] specifies error and code text label in resulting JSON error response+  -- when an empty type level list parameter for 'errorMw' is specified+  -- the 'HasErrorBody' instance defaults it to '@["error", "status"]' for JSON and PlainText instances+  -- hence; errorMw @JSON @'[] == @JSON @["error", "status"]+  $ serve api handler+  where+    handler = return . id+    api = Proxy @(ReqBody '[JSON] Greet :> Post '[JSON] Greet)++-- | Example Below shows the derivation of an alternative 'HasErrorBody' instance+-- for JSON error responses if you want to implement more customisation+----------------------------------------------------------------------------------------+----------------------------------------------------------------------------------------++-- | We need a newtype like data type to avoid orphan instances, 'Ctyp' satisfy's that+-- We also make use of deriving via to get an Accept instance easily.+-- Note: 'HasErrorBody' instance requires an Accept instance for a content-type++data Ctyp a+  deriving Accept via JSON++instance HasErrorBody (Ctyp JSON) '[] where+  encodeError = undefined -- write your custom implementation++-- | Example Middleware with a different 'HasErrorBody' instance for JSON+errorMwJson :: Application -> Application+errorMwJson =  errorMw @(Ctyp JSON) @'[]+```++If a user submits a wrong request body during an HTTP request the HTTP error response is of the formats below;++Error response body while using this package's error Middleware .+_________________________________________++``` JSON+{+    "status": 400,+    "error": "Error in $: key \"msg\" not present"+}+# The response is JSON encoded and contains an HTTP content-type header plus a status code.+```++Default error response without middleware;+_________________________________________++```+ "Error in $: key \"msg\" not present"++# The response is plain text, contains an HTTP status code but lacks an HTTP content-type header.+```++### Documentation++This README is tested by `markdown-unlit` to make sure the code builds. To keep _that_ happy, we do need a `main` in this file, so ignore the following :)++```haskell+main :: IO ()+main = pure ()+```

+ README.md view

@@ -0,0 +1,138 @@+# servant-errors++[![Hackage](https://img.shields.io/hackage/v/servant-errors.svg?logo=haskell)](https://hackage.haskell.org/package/servant-errors)+[![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](LICENSE)+[![Build status](https://img.shields.io/travis/epicallan/servant-errors.svg?logo=travis)](https://travis-ci.org/epicallan/servant-errors)++## Intro++This package implements a wai-middleware targeting servant-server applications with a goal of make it easier to generate custom server error responses.++## Motivation++By default, when your servant server application experiences an internal exception during endpoint route resolution, e.g. request body decode errors. The server response is just plain text with a status code in the HTTP headers.++At the same time, if you don't write custom code to customise error responses for errors thrown within servant route handlers the default response is plain text with an HTTP content-type if set within `ServerError`.++With `servant-errors`  library, you get a single interface to structure and encode your error responses in one place as `JSON` error response or any other preferred form.++```haskell ignore+-- | A typical servant application is usually of this form++main :: IO ()+main = run 8001 (serve proxyApi handlers)++-- | With servant-errors as error processing middleware+main :: IO ()+main = run 8001+     $ errorMw @JSON @'["error", "status"]+     -- ^ Structures error response as JSON objects+     -- with 'error' and 'status' strings as error object field keys+     -- note they can be changed to any other preferred strings.+     $ serve proxyApi handlers++-- | The implementation above can also be written as below+-- if you want to output JSON error responses with 'error'+-- and 'status' as the JSON Object keys+main :: IO ()+main = run 8001+     $ errorMwDefJson+     -- ^ Default implementation of structuring error responses as JSON+     -- with no customisation option for JSON error object field keys+     $ serve proxyApi handlers+```++This [blog post](https://lukwagoallan.com/posts/unifying-servant-server-error-responses) explains in more details.++## Complete Usage Example++```haskell+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE TypeOperators     #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DerivingVia #-}++module Main where++import           Data.Aeson (FromJSON, ToJSON)+import           Data.Proxy (Proxy(..))+import           Data.Text (Text)+import           GHC.Generics (Generic)+import           Network.Wai (Application)+import           Network.Wai.Handler.Warp (run)+import           Network.Wai.Middleware.Servant.Errors (errorMw, HasErrorBody(..))+import           Servant (ReqBody, (:>), Post, JSON, Accept(..), serve)++-- | A greet message data type for use as Request Body+newtype Greet = Greet { msg :: Text }+  deriving (Generic, Show, FromJSON, ToJSON)++-- servant application+main' :: IO ()+main' = run 8001+  $ errorMw @JSON @'["error", "status"]+  -- ^ @JSON specifies content type encoding of errors+  -- @["error", "status"] specifies error and code text label in resulting JSON error response+  -- when an empty type level list parameter for 'errorMw' is specified+  -- the 'HasErrorBody' instance defaults it to '@["error", "status"]' for JSON and PlainText instances+  -- hence; errorMw @JSON @'[] == @JSON @["error", "status"]+  $ serve api handler+  where+    handler = return . id+    api = Proxy @(ReqBody '[JSON] Greet :> Post '[JSON] Greet)++-- | Example Below shows the derivation of an alternative 'HasErrorBody' instance+-- for JSON error responses if you want to implement more customisation+----------------------------------------------------------------------------------------+----------------------------------------------------------------------------------------++-- | We need a newtype like data type to avoid orphan instances, 'Ctyp' satisfy's that+-- We also make use of deriving via to get an Accept instance easily.+-- Note: 'HasErrorBody' instance requires an Accept instance for a content-type++data Ctyp a+  deriving Accept via JSON++instance HasErrorBody (Ctyp JSON) '[] where+  encodeError = undefined -- write your custom implementation++-- | Example Middleware with a different 'HasErrorBody' instance for JSON+errorMwJson :: Application -> Application+errorMwJson =  errorMw @(Ctyp JSON) @'[]+```++If a user submits a wrong request body during an HTTP request the HTTP error response is of the formats below;++Error response body while using this package's error Middleware .+_________________________________________++``` JSON+{+    "status": 400,+    "error": "Error in $: key \"msg\" not present"+}+# The response is JSON encoded and contains an HTTP content-type header plus a status code.+```++Default error response without middleware;+_________________________________________++```+ "Error in $: key \"msg\" not present"++# The response is plain text, contains an HTTP status code but lacks an HTTP content-type header.+```++### Documentation++This README is tested by `markdown-unlit` to make sure the code builds. To keep _that_ happy, we do need a `main` in this file, so ignore the following :)++```haskell+main :: IO ()+main = pure ()+```

+ servant-errors.cabal view

@@ -0,0 +1,64 @@+cabal-version:       2.0+name:                servant-errors+version:             0.1.0.0+synopsis:            Servant Errors wai-middlware+description:         A Wai middleware that uniformly structures errors with in a servant application. The library assumes all HTTP responses with status code greater than 200 and without an HTTP content type are error responses. This assumption is derived from servant server error handling implementation.++homepage:            https://github.com/epicallan/servant-errors+bug-reports:         https://github.com/epicallan/servant-errors/issues+license:             MIT+license-file:        LICENSE+author:              Lukwago Allan+maintainer:          epicallan.al@gmail.com+copyright:           2019 Lukwago Allan+category:            Network, Servant+build-type:          Simple+extra-doc-files:     README.md+                   , CHANGELOG.md+tested-with:         GHC == 8.6.4++source-repository head+  type:                git+  location:            https://github.com/epicallan/servant-errors.git+library+  hs-source-dirs:      src+  exposed-modules:     Network.Wai.Middleware.Servant.Errors++  build-depends:       base ^>= 4.12.0.0+                     , aeson+                     , bytestring+                     , http-types+                     , http-api-data+                     , http-media+                     , scientific+                     , servant+                     , string-conversions+                     , text+                     , unordered-containers+                     , wai++  ghc-options:         -Wall+                       -Wincomplete-uni-patterns+                       -Wincomplete-record-updates+                       -Wcompat+                       -Widentities+                       -Wredundant-constraints+                       -fhide-source-paths+                       -Wpartial-fields++  default-language:    Haskell2010++test-suite readme+  build-depends:       base+                     , aeson+                     , text+                     , servant-errors+                     , servant-server+                     , wai+                     , warp++  main-is:             README.lhs+  type:                exitcode-stdio-1.0+  default-language:    Haskell2010+  ghc-options:         -pgmL markdown-unlit -Wall+  build-tool-depends:  markdown-unlit:markdown-unlit

+ src/Network/Wai/Middleware/Servant/Errors.hs view

@@ -0,0 +1,215 @@+{- |+  A Wai middleware that uniformly structures errors within a servant application.+  The library assumes all HTTP responses with status codes greater than @200@ and+  lacking an @HTTP content-type@ are error responses. This assumption is derived+  from servant server error handling implementation.++  The formatting and structuring of errors rest on the implementation of 'HasErrorBody' class instances.+  It's class parameters are a content-type eg @JSON@ or @PlainText@ and a type-level list of+  @options@ e.g @'["error", "status"]@. The library offers instances for 'JSON' and 'PlainText' content-types.++  ==Sample usage with servant++  ===A typical servant application is usually of this form:++  @+  main :: IO ()+  main = run 8001 (serve proxyApi handlers)+  @++  ===With servant-errors as an error processing middleware:++  @+  main :: IO ()+  main = run 8001+     $ errorMw \@JSON \@\'["error", "status"]+     -- ^ Structures error response as JSON objects+     -- with @error@ and @status@ strings as error object field keys+     -- note they can be changed to any other preferred strings.+     $ serve proxyApi handlers+  @+-}+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+module Network.Wai.Middleware.Servant.Errors+  ( -- * Error Middleware+    errorMw+  , errorMwDefJson++  -- * HasErrorBody class+  , HasErrorBody (..)++  -- * Helper functions and data types+  , ErrorMsg (..)+  , StatusCode (..)+  , ErrorLabels (..)+  , getErrorLabels+  )where++import Data.Aeson (Value (..), encode)+import qualified Data.ByteString as B+import Data.ByteString.Builder (toLazyByteString)+import qualified Data.ByteString.Lazy as LB+import qualified Data.HashMap.Strict as H+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.Kind (Type)+import Data.List (find)+import Data.Proxy (Proxy (..))+import Data.Scientific (Scientific)+import Data.String.Conversions (cs)+import qualified Data.Text as T+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import qualified Network.HTTP.Media as M+import Network.HTTP.Types (Header, Status (..), hContentType)+import Network.Wai (Application, Response, responseHeaders, responseLBS, responseStatus,+                    responseToStream)+import Servant.API.ContentTypes (Accept (..), JSON, PlainText)++-- | 'StatusCode' holds HTTP error status code+newtype StatusCode = StatusCode { unStatusCode :: Int }+  deriving (Eq, Ord, Show)++-- | 'ErrorMsg' holds HTTP error response body message+newtype ErrorMsg = ErrorMsg { unErrorMsg :: T.Text }+  deriving Show++-- | 'ErrorLabels' is a configuration for holding error response labels+data ErrorLabels = ErrorLabels+  { errName       :: T.Text+  , errStatusName :: T.Text+  }++-- | The 'HasErrorBody' class is used for structuring servant error responses.+--+-- @ctyp@ is an HTTP content-type with an 'Accept' class instance. eg @JSON@+--+-- @opts@ is a type level list for customising error and status labels.+--+-- For example:+-- @'["error-message", "status-code"]@+--+-- When @opts@ is left as an Empty type level list, it default's to a type list of these values:+-- @'["error", "status"]@ for the library provided 'JSON' and 'PlainText' instances.+--+class Accept ctyp => HasErrorBody (ctyp :: Type) (opts :: [Symbol]) where+  -- | 'encodeError' formats error response.+  -- The @opts@ type level list in the class definition is used by the 'getErrorLabels' function+  -- to obtain error labels which are subsequently used in implementing @encodeError@ for class instances+  encodeError :: StatusCode -> ErrorMsg -> LB.ByteString++instance  (KnownSymbol errLabel, KnownSymbol statusLabel)+  => HasErrorBody JSON '[errLabel, statusLabel] where+    encodeError = encodeAsJsonError (getErrorLabels @statusLabel @errLabel)++instance HasErrorBody JSON '[] where+  encodeError = encodeError @JSON @["error", "status"]++instance  (KnownSymbol errLabel, KnownSymbol statusLabel)+  => HasErrorBody PlainText '[errLabel, statusLabel] where+    encodeError = encodeAsPlainText (getErrorLabels @statusLabel @errLabel)++instance HasErrorBody PlainText '[] where+  encodeError = encodeError @JSON @["error", "status"]++-- | 'errorMwDefJson' is a convenience pre-configured function for middleware+-- that encodes error responses as @JSON@ objects using @error@ and @status@+-- for a @JSON object@ key fields+--+-- A resulting response may look like this:+-- @\{ error: \"failed to decode request body\", status: 400 \}@+--+errorMwDefJson :: Application -> Application+errorMwDefJson = errorMw @JSON @'[]++-- | 'errorMw' functions provides "Network.Wai" middleware for formatting error responses+-- within a servant application.+-- Note that this function expects you to have @TypeApplications@ extension enabled+--+-- > errorMw @JSON @'[ "error", "status"]+--+errorMw :: forall ctyp opts. HasErrorBody ctyp opts => Application -> Application+errorMw baseApp req respond =+  baseApp req $ \ response -> do+     let status      = responseStatus response+         mcontentType = getContentTypeHeader response+     case (status, mcontentType) of+       (Status 200 _, _)                     -> respond response+       (Status code _, Nothing) | code > 200 ->+         newResponse @ctyp @opts status response >>= respond+       _                                     -> respond response+  where+    getContentTypeHeader :: Response -> Maybe Header+    getContentTypeHeader = find ((hContentType ==) . fst) . responseHeaders+++-- | 'newResponse' creates new API route 'Response' content based on a 'HasErrorBody' instance+--+-- In the event that the original error response has an empty error message body e.g. a 404 error.+-- The error status message is used as the error message.+newResponse+  :: forall ctyp opts . HasErrorBody ctyp opts+  => Status+  -> Response+  -> IO Response+newResponse status@(Status code statusMsg) response = do+  body <- responseBody response+  let header = (hContentType,  M.renderHeader $ contentType (Proxy @JSON) )+      content = ErrorMsg . cs $ if body == mempty then statusMsg else body+      newContent = encodeError @ctyp @opts (StatusCode code) content+  return $ responseLBS status [header] newContent++-- | 'responseBody' extracts response body from the servant server response.+responseBody :: Response -> IO B.ByteString+responseBody res =+  let (_status, _headers, streamBody) = responseToStream res in+  streamBody $ \f -> do+    content <- newIORef mempty+    f (\chunk -> modifyIORef' content (<> chunk)) (return ())+    cs . toLazyByteString <$> readIORef content++{-------------------------------------------------------------------------------+  Helper functions for defining instances+-------------------------------------------------------------------------------}++-- | 'encodeAsJsonError' formats error response into 'JSON' encoded string.+-- Its used in the library provided 'HasErrorBody' /JSON/ instance+encodeAsJsonError :: ErrorLabels -> StatusCode -> ErrorMsg -> LB.ByteString+encodeAsJsonError ErrorLabels {..} code content =+  encode $ Object+         $ H.fromList+           [ (errName, String $ unErrorMsg content)+           , (errStatusName, Number $ toScientific code )+           ]+   where+     toScientific :: StatusCode -> Scientific+     toScientific = fromInteger . fromIntegral @_ @Integer . unStatusCode++-- | 'encodeAsPlainText' formats error response into 'PlainText' string.+-- its used in the library provided 'HasErrorBody' /PlainText/ class instance+encodeAsPlainText :: ErrorLabels -> StatusCode -> ErrorMsg -> LB.ByteString+encodeAsPlainText ErrorLabels {..} code content =+  cs $  errName+     <> unErrorMsg content+     <> errStatusName+     <> cs (show $ unStatusCode code)++-- | 'getErrorLabels' is used to tranform type level list options provided via the+-- 'HasErrorBody' class into an 'ErrorLabels' data type.+--+-- 'ErrorLabels' is used with the error formatting and encoding+-- functions used in \HasErrorBody\ class.+getErrorLabels+  :: forall errLabel statusLabel .(KnownSymbol errLabel, KnownSymbol statusLabel)+  => ErrorLabels+getErrorLabels = ErrorLabels (label (Proxy @errLabel)) (label (Proxy @statusLabel))+  where+    label :: KnownSymbol t => Proxy t -> T.Text+    label proxy = cs $ symbolVal proxy