├── .gitignore ├── .stylish-haskell.yaml ├── .travis.yml ├── CHANGELOG.md ├── LICENSE ├── README.lhs ├── README.md ├── servant-errors.cabal └── src └── Network └── Wai └── Middleware └── Servant └── Errors.hs /.gitignore: -------------------------------------------------------------------------------- 1 | ### Haskell 2 | dist 3 | dist-* 4 | cabal-dev 5 | *.o 6 | *.hi 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | *.prof 12 | *.aux 13 | *.hp 14 | *.eventlog 15 | .virtualenv 16 | .hsenv 17 | .hpc 18 | .cabal-sandbox/ 19 | cabal.sandbox.config 20 | cabal.config 21 | 22 | # only needed for building with cabal new-build locally 23 | cabal.project.local 24 | cabal.project 25 | hackage-deploy 26 | 27 | cabal.project.freeze 28 | .ghc.environment.* 29 | .HTF/ 30 | docs.sh 31 | # Stack 32 | stack.yaml.lock 33 | stack.yaml 34 | .stack-work/ 35 | 36 | ### IDE/support 37 | # Vim 38 | [._]*.s[a-v][a-z] 39 | [._]*.sw[a-p] 40 | [._]s[a-v][a-z] 41 | [._]sw[a-p] 42 | *~ 43 | tags 44 | 45 | # IntellijIDEA 46 | .idea/ 47 | .ideaHaskellLib/ 48 | *.iml 49 | 50 | # Atom 51 | .haskell-ghc-mod.json 52 | 53 | # VS 54 | .vscode/ 55 | 56 | # Emacs 57 | *# 58 | .dir-locals.el 59 | TAGS 60 | 61 | # other 62 | .DS_Store 63 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | steps: 2 | - simple_align: 3 | cases: true 4 | top_level_patterns: true 5 | records: true 6 | 7 | # Import cleanup 8 | - imports: 9 | align: none 10 | list_align: after_alias 11 | pad_module_names: false 12 | long_list_align: inline 13 | empty_list_align: inherit 14 | list_padding: 2 15 | separate_lists: true 16 | space_surround: false 17 | 18 | - language_pragmas: 19 | style: vertical 20 | remove_redundant: true 21 | 22 | # Remove trailing whitespace 23 | - trailing_whitespace: {} 24 | 25 | columns: 100 26 | 27 | newline: native 28 | 29 | language_extensions: 30 | - BangPatterns 31 | - ConstraintKinds 32 | - DataKinds 33 | - DefaultSignatures 34 | - DeriveAnyClass 35 | - DeriveDataTypeable 36 | - DeriveGeneric 37 | - DerivingVia 38 | - DerivingStrategies 39 | - ExplicitNamespaces 40 | - FlexibleContexts 41 | - FlexibleInstances 42 | - FunctionalDependencies 43 | - GADTs 44 | - GeneralizedNewtypeDeriving 45 | - InstanceSigs 46 | - KindSignatures 47 | - LambdaCase 48 | - MultiParamTypeClasses 49 | - OverloadedStrings 50 | - QuasiQuotes 51 | - RecordWildCards 52 | - ScopedTypeVariables 53 | - StandaloneDeriving 54 | - TemplateHaskell 55 | - TupleSections 56 | - TypeApplications 57 | - TypeFamilies 58 | - ViewPatterns 59 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: true 2 | language: haskell 3 | 4 | git: 5 | depth: 1 6 | 7 | cabal: "3.0" 8 | 9 | cache: 10 | directories: 11 | - "$HOME/.cabal/store" 12 | 13 | matrix: 14 | include: 15 | - ghc: 8.4.4 16 | - ghc: 8.6.5 17 | - ghc: 8.8.3 18 | - ghc: 9.2.5 19 | 20 | 21 | install: 22 | - | 23 | ghc --version 24 | cabal --version 25 | cabal new-update 26 | cabal new-configure 27 | cabal new-build --enable-tests 28 | 29 | script: 30 | - cabal new-test 31 | # HLint check 32 | - curl -sSL https://raw.github.com/ndmitchell/neil/master/misc/travis.sh | sh -s -- hlint . 33 | 34 | notifications: 35 | email: false 36 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | `servant-errors` uses [PVP Versioning][1]. 4 | The changelog is available [on GitHub][2]. 5 | 6 | ## 0.1.0.0 7 | 8 | * Initially created. 9 | 10 | [1]: https://pvp.haskell.org 11 | [2]: https://github.com/epicallan/servant-errors/releases 12 | 13 | ## 0.1.0.1 14 | 15 | * Add package dependence bounds 16 | 17 | [1]: https://pvp.haskell.org 18 | [2]: https://github.com/epicallan/servant-errors/releases 19 | 20 | ## 0.1.1.0 21 | 22 | * support more GHC versions (8.2 - 8.6) 23 | 24 | ## 0.1.2.0 25 | 26 | * fix reversed object key fields in errors 27 | 28 | ## 0.1.3.0 29 | 30 | * fixes PlainText HasErrorBody instance 31 | * couple of code refactors 32 | 33 | ## 0.1.3.1 34 | 35 | * export encoding helper functions 36 | 37 | ## 0.1.5.0 38 | 39 | * add GHC 8.8 support 40 | 41 | ## 0.1.6.0 42 | 43 | * Fix: use provided content-type 44 | 45 | 46 | ## 0.1.7.0 47 | 48 | * Pass old headers to new response when contentType header be added in `newResponse`. 49 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2019 Lukwago Allan 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.lhs: -------------------------------------------------------------------------------- 1 | README.md -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # servant-errors 2 | 3 | [![Hackage](https://img.shields.io/hackage/v/servant-errors.svg?logo=haskell)](https://hackage.haskell.org/package/servant-errors) 4 | [![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](LICENSE) 5 | [![Build status](https://img.shields.io/travis/epicallan/servant-errors.svg?logo=travis)](https://travis-ci.org/epicallan/servant-errors) 6 | 7 | ## Intro 8 | 9 | This package implements a wai-middleware targeting servant-server applications with a goal of make it easier to generate custom server error responses. 10 | 11 | ### Checkout accompanying blogpost for more details. 12 | 13 | * [Unifying Servant server error responses](https://lukwagoallan.com/posts/unifying-servant-server-error-responses) 14 | 15 | ## Motivation 16 | 17 | 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. 18 | 19 | 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 when provided within `ServerError`. 20 | 21 | 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. 22 | 23 | ```haskell ignore 24 | -- | A typical servant application is usually of this form 25 | 26 | main :: IO () 27 | main = run 8001 (serve proxyApi handlers) 28 | 29 | -- | With 'errorMw' from servant-errors library as an error processing middleware 30 | main :: IO () 31 | main = run 8001 32 | $ errorMw @JSON @'["error", "status"] 33 | -- ^ Structures error response as JSON objects 34 | -- with 'error' and 'status' strings as error object field keys 35 | -- note they can be changed to any other preferred strings. 36 | $ serve proxyApi handlers 37 | 38 | -- | The implementation above can also be written as below 39 | -- if you want to output JSON error responses with 'error' 40 | -- and 'status' as the JSON Object keys 41 | main :: IO () 42 | main = run 8001 43 | $ errorMwDefJson 44 | -- ^ Default implementation of structuring error responses as JSON 45 | -- with no customisation option for JSON error object field keys 46 | $ serve proxyApi handlers 47 | ``` 48 | 49 | 50 | 51 | ## Complete Usage Example 52 | 53 | ```haskell 54 | {-# LANGUAGE DataKinds #-} 55 | {-# LANGUAGE DeriveGeneric #-} 56 | {-# LANGUAGE TypeFamilies #-} 57 | {-# LANGUAGE TypeOperators #-} 58 | {-# LANGUAGE TypeApplications #-} 59 | {-# LANGUAGE FlexibleInstances #-} 60 | {-# LANGUAGE DeriveAnyClass #-} 61 | {-# LANGUAGE MultiParamTypeClasses #-} 62 | 63 | module Main where 64 | 65 | import Data.Aeson (FromJSON, ToJSON) 66 | import Data.Proxy (Proxy(..)) 67 | import Data.Text (Text) 68 | import GHC.Generics (Generic) 69 | import Network.Wai (Application) 70 | import Network.Wai.Handler.Warp (run) 71 | import Network.Wai.Middleware.Servant.Errors (errorMw, HasErrorBody(..)) 72 | import Servant (ReqBody, (:>), Post, JSON, Accept(..), serve) 73 | 74 | -- | A greet message data type for use as Request Body 75 | newtype Greet = Greet { msg :: Text } 76 | deriving (Generic, Show, FromJSON, ToJSON) 77 | 78 | -- servant application 79 | main' :: IO () 80 | main' = run 8001 81 | $ errorMw @JSON @'["error", "status"] 82 | -- ^ @JSON specifies content type encoding of errors 83 | -- @["error", "status"] specifies error and code text label in resulting JSON error response 84 | -- when an empty type level list parameter for 'errorMw' is specified 85 | -- the 'HasErrorBody' instance defaults it to '@["error", "status"]' for JSON and PlainText instances 86 | -- hence; errorMw @JSON @'[] == @JSON @["error", "status"] 87 | $ serve api handler 88 | where 89 | handler = return . id 90 | api = Proxy @(ReqBody '[JSON] Greet :> Post '[JSON] Greet) 91 | 92 | -- | Example Below shows the derivation of an alternative 'HasErrorBody' instance 93 | -- for JSON error responses if you want to implement more customisation 94 | ---------------------------------------------------------------------------------------- 95 | ---------------------------------------------------------------------------------------- 96 | 97 | -- | We need a newtype like data type to avoid orphan instances, 'Ctyp' satisfy's that 98 | -- Also note that 'HasErrorBody' instance requires an Accept instance for a content-type 99 | 100 | data Ctyp a 101 | 102 | {- 103 | if you are using GHC 8.6 and above you can make use of deriving Via 104 | for creating the Accept Instance 105 | 106 | >> data Ctyp a 107 | >> deriving Accept via JSON 108 | -} 109 | 110 | instance Accept (Ctyp JSON) where 111 | contentType _ = contentType (Proxy @JSON) 112 | 113 | instance HasErrorBody (Ctyp JSON) '[] where 114 | encodeError = undefined -- write your custom implementation 115 | 116 | -- | Example Middleware with a different 'HasErrorBody' instance for JSON 117 | errorMwJson :: Application -> Application 118 | errorMwJson = errorMw @(Ctyp JSON) @'[] 119 | ``` 120 | 121 | If a user submits a wrong request body during an HTTP request the HTTP error response is of the formats below; 122 | 123 | Error response body while using this package's error Middleware . 124 | _________________________________________ 125 | 126 | ``` JSON 127 | { 128 | "status": 400, 129 | "error": "Error in $: key \"msg\" not present" 130 | } 131 | # The response is JSON encoded and contains an HTTP content-type header plus a status code. 132 | ``` 133 | 134 | Default error response without middleware; 135 | _________________________________________ 136 | 137 | ``` 138 | "Error in $: key \"msg\" not present" 139 | 140 | # The response is plain text, contains an HTTP status code but lacks an HTTP content-type header. 141 | ``` 142 | 143 | ### Documentation 144 | 145 | 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 :) 146 | 147 | ```haskell 148 | main :: IO () 149 | main = pure () 150 | ``` 151 | -------------------------------------------------------------------------------- /servant-errors.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: servant-errors 3 | version: 0.1.7.0 4 | synopsis: Servant Errors wai-middlware 5 | description: 6 | 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. 7 | 8 | homepage: https://github.com/epicallan/servant-errors 9 | bug-reports: https://github.com/epicallan/servant-errors/issues 10 | license: MIT 11 | license-file: LICENSE 12 | author: Lukwago Allan 13 | maintainer: epicallan.al@gmail.com 14 | copyright: 2019 Lukwago Allan 15 | category: Network, Servant 16 | build-type: Simple 17 | extra-doc-files: 18 | CHANGELOG.md 19 | README.md 20 | 21 | tested-with: 22 | GHC ==8.4.4 || ==8.6.5 || ==8.8.3 || ==8.8.4 || ==9.0.2 || ==9.2.5 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/epicallan/servant-errors.git 27 | 28 | common common-options 29 | build-depends: 30 | , aeson >=1.3 && <2.2 31 | , base >=4.10.0.0 && <5 32 | , base-compat >=0.9.0 33 | , text >=1.2 34 | , wai >=3.2 35 | 36 | ghc-options: 37 | -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates 38 | -Wcompat -Widentities -Wredundant-constraints -fhide-source-paths 39 | -freverse-errors -Wpartial-fields 40 | 41 | default-language: Haskell2010 42 | 43 | library 44 | import: common-options 45 | hs-source-dirs: src 46 | exposed-modules: Network.Wai.Middleware.Servant.Errors 47 | build-depends: 48 | , bytestring >=0.10.8.2 49 | , http-api-data >=0.3 50 | , http-media >=0.7 51 | , http-types >=0.12 52 | , scientific >=0.3 53 | , servant >=0.13 54 | , string-conversions >=0.4 55 | , unordered-containers >=0.2 56 | 57 | test-suite readme 58 | import: common-options 59 | build-depends: 60 | , servant-errors 61 | , servant-server >=0.13 62 | , warp >=3.2.26 63 | 64 | main-is: README.lhs 65 | type: exitcode-stdio-1.0 66 | ghc-options: -pgmL markdown-unlit 67 | build-tool-depends: markdown-unlit:markdown-unlit 68 | -------------------------------------------------------------------------------- /src/Network/Wai/Middleware/Servant/Errors.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | A Wai middleware that uniformly structures errors within a servant application. 3 | The library assumes all HTTP responses with status codes between @4xx@ and @5xx@ while 4 | lacking an @HTTP content-type@ are error responses. This assumption is derived 5 | from servant server error handling implementation. 6 | 7 | The formatting and structuring of errors rest on the implementation of 'HasErrorBody' class instances. 8 | It's class parameters are a content-type eg @JSON@ or @PlainText@ and a type-level list of 9 | @options@ e.g @'["error", "status"]@. The library offers instances for 'JSON' and 'PlainText' content-types. 10 | 11 | ==Sample usage with servant 12 | 13 | ===A typical servant application is usually of this form: 14 | 15 | @ 16 | main :: IO () 17 | main = run 8001 (serve proxyApi handlers) 18 | @ 19 | 20 | ===With servant-errors as an error processing middleware: 21 | 22 | @ 23 | main :: IO () 24 | main = run 8001 25 | $ errorMw \@JSON \@\'["error", "status"] 26 | -- ^ Structures error response as JSON objects 27 | -- with @error@ and @status@ strings as error object field keys 28 | -- note they can be changed to any other preferred strings. 29 | $ serve proxyApi handlers 30 | @ 31 | -} 32 | {-# LANGUAGE AllowAmbiguousTypes #-} 33 | {-# LANGUAGE ConstraintKinds #-} 34 | {-# LANGUAGE DataKinds #-} 35 | {-# LANGUAGE FlexibleInstances #-} 36 | {-# LANGUAGE KindSignatures #-} 37 | {-# LANGUAGE MultiParamTypeClasses #-} 38 | {-# LANGUAGE NoImplicitPrelude #-} 39 | {-# LANGUAGE PackageImports #-} 40 | {-# LANGUAGE RankNTypes #-} 41 | {-# LANGUAGE RecordWildCards #-} 42 | {-# LANGUAGE ScopedTypeVariables #-} 43 | {-# LANGUAGE TypeApplications #-} 44 | module Network.Wai.Middleware.Servant.Errors 45 | ( -- * Error Middleware 46 | errorMw 47 | , errorMwDefJson 48 | 49 | -- * HasErrorBody class 50 | , HasErrorBody (..) 51 | 52 | -- * Helper functions and data types 53 | , ErrorMsg (..) 54 | , StatusCode (..) 55 | , ErrorLabels (..) 56 | , getErrorLabels 57 | , encodeAsJsonError 58 | , encodeAsPlainText 59 | )where 60 | 61 | import "base-compat" Prelude.Compat 62 | import Data.Aeson (encode, toJSON) 63 | import qualified Data.ByteString as B 64 | import Data.ByteString.Builder (toLazyByteString) 65 | import qualified Data.ByteString.Lazy as LB 66 | import qualified Data.HashMap.Strict as H 67 | import Data.IORef (modifyIORef', newIORef, readIORef) 68 | import Data.Kind (Type) 69 | import Data.List (find) 70 | import Data.Proxy (Proxy (..)) 71 | import Data.Scientific (Scientific) 72 | import Data.String.Conversions (cs) 73 | import qualified Data.Text as T 74 | import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) 75 | import qualified Network.HTTP.Media as M 76 | import Network.HTTP.Types (Header, Status (..), hContentType) 77 | import Network.Wai (Middleware, Response, responseHeaders, responseLBS, responseStatus, 78 | responseToStream) 79 | import Servant.API.ContentTypes (Accept (..), JSON, PlainText) 80 | 81 | -- | 'StatusCode' holds HTTP error status code 82 | newtype StatusCode = StatusCode { unStatusCode :: Int } 83 | deriving (Eq, Ord, Show) 84 | 85 | -- | 'ErrorMsg' holds HTTP error response body message 86 | newtype ErrorMsg = ErrorMsg { unErrorMsg :: T.Text } 87 | deriving Show 88 | 89 | -- | 'ErrorLabels' is a configuration for holding error response labels 90 | data ErrorLabels = ErrorLabels 91 | { errName :: T.Text 92 | , errStatusName :: T.Text 93 | } 94 | 95 | -- | The 'HasErrorBody' class is used for structuring servant error responses. 96 | -- 97 | -- @ctyp@ is an HTTP content-type with an 'Accept' class instance. eg @JSON@ 98 | -- 99 | -- @opts@ is a type level list for customising error and status labels. 100 | -- 101 | -- For example: 102 | -- @'["error-message", "status-code"]@ 103 | -- 104 | -- When @opts@ is left as an Empty type level list, it default's to a type list of these values: 105 | -- @'["error", "status"]@ for the library provided 'JSON' and 'PlainText' instances. 106 | -- 107 | class Accept ctyp => HasErrorBody (ctyp :: Type) (opts :: [Symbol]) where 108 | -- | 'encodeError' formats error response. 109 | -- The @opts@ type level list in the class definition is used by the 'getErrorLabels' function 110 | -- to obtain error labels which are subsequently used in implementing @encodeError@ for class instances 111 | encodeError :: StatusCode -> ErrorMsg -> LB.ByteString 112 | 113 | instance (KnownSymbol errLabel, KnownSymbol statusLabel) 114 | => HasErrorBody JSON '[errLabel, statusLabel] where 115 | encodeError = encodeAsJsonError (getErrorLabels @errLabel @statusLabel) 116 | 117 | instance HasErrorBody JSON '[] where 118 | encodeError = encodeError @JSON @["error", "status"] 119 | 120 | instance (KnownSymbol errLabel, KnownSymbol statusLabel) 121 | => HasErrorBody PlainText '[errLabel, statusLabel] where 122 | encodeError = encodeAsPlainText (getErrorLabels @errLabel @statusLabel) 123 | 124 | instance HasErrorBody PlainText '[] where 125 | encodeError = encodeError @PlainText @["error", "status"] 126 | 127 | -- | 'errorMwDefJson' is a convenience pre-configured function for middleware 128 | -- that encodes error responses as @JSON@ objects using @error@ and @status@ 129 | -- for a @JSON object@ key fields 130 | -- 131 | -- A resulting response may look like this: 132 | -- @\{ error: \"failed to decode request body\", status: 400 \}@ 133 | -- 134 | errorMwDefJson :: Middleware 135 | errorMwDefJson = errorMw @JSON @'[] 136 | 137 | -- | 'errorMw' functions provides "Network.Wai" middleware for formatting error responses 138 | -- within a servant application. 139 | -- Note that this function expects you to have @TypeApplications@ extension enabled 140 | -- 141 | -- > errorMw @JSON @'[ "error", "status"] 142 | -- 143 | errorMw :: forall ctyp opts. HasErrorBody ctyp opts => Middleware 144 | errorMw baseApp req respond = 145 | baseApp req $ \ response -> do 146 | let status = responseStatus response 147 | mcontentType = getContentTypeHeader response 148 | case (status, mcontentType) of 149 | (Status code _, Nothing) | code >= 400 && code < 600 -> 150 | newResponse @ctyp @opts status response >>= respond 151 | _ -> respond response 152 | where 153 | getContentTypeHeader :: Response -> Maybe Header 154 | getContentTypeHeader = find ((hContentType ==) . fst) . responseHeaders 155 | 156 | 157 | -- | 'newResponse' creates new API route 'Response' content based on a 'HasErrorBody' instance 158 | -- 159 | -- In the event that the original error response has an empty error message body e.g. a 404 error. 160 | -- The error status message is used as the error message. 161 | newResponse 162 | :: forall ctyp opts . HasErrorBody ctyp opts 163 | => Status 164 | -> Response 165 | -> IO Response 166 | newResponse status@(Status code statusMsg) response = do 167 | body <- responseBody response 168 | let oldHeaders = responseHeaders response 169 | let newHeaders = (hContentType, M.renderHeader $ contentType (Proxy @ctyp)) : oldHeaders 170 | content = ErrorMsg . cs $ if body == mempty then statusMsg else body 171 | newContent = encodeError @ctyp @opts (StatusCode code) content 172 | return $ responseLBS status newHeaders newContent 173 | 174 | -- | 'responseBody' extracts response body from the servant server response. 175 | responseBody :: Response -> IO B.ByteString 176 | responseBody res = 177 | let (_status, _headers, streamBody) = responseToStream res in 178 | streamBody $ \f -> do 179 | content <- newIORef mempty 180 | f (\chunk -> modifyIORef' content (<> chunk)) (return ()) 181 | cs . toLazyByteString <$> readIORef content 182 | 183 | {------------------------------------------------------------------------------- 184 | Helper functions for defining instances 185 | -------------------------------------------------------------------------------} 186 | 187 | -- | 'encodeAsJsonError' formats error response into 'JSON' encoded string. 188 | -- Its used in the library provided 'HasErrorBody' /JSON/ instance 189 | encodeAsJsonError :: ErrorLabels -> StatusCode -> ErrorMsg -> LB.ByteString 190 | encodeAsJsonError ErrorLabels {..} code content = 191 | encode $ toJSON $ H.fromList 192 | [ (errName, toJSON (unErrorMsg content)) 193 | , (errStatusName, toJSON (toScientific code)) 194 | ] 195 | where 196 | toScientific :: StatusCode -> Scientific 197 | toScientific = fromInteger . fromIntegral @_ @Integer . unStatusCode 198 | 199 | -- | 'encodeAsPlainText' formats error response into 'PlainText' string. 200 | -- its used in the library provided 'HasErrorBody' /PlainText/ class instance 201 | encodeAsPlainText :: ErrorLabels -> StatusCode -> ErrorMsg -> LB.ByteString 202 | encodeAsPlainText ErrorLabels {..} code content = 203 | cs $ errName 204 | <> unErrorMsg content 205 | <> errStatusName 206 | <> cs (show $ unStatusCode code) 207 | 208 | -- | 'getErrorLabels' is used to tranform type level list options provided via the 209 | -- 'HasErrorBody' class into an 'ErrorLabels' data type. 210 | -- 211 | -- 'ErrorLabels' is used with the error formatting and encoding 212 | -- functions used in \HasErrorBody\ class. 213 | getErrorLabels 214 | :: forall errLabel statusLabel .(KnownSymbol errLabel, KnownSymbol statusLabel) 215 | => ErrorLabels 216 | getErrorLabels = ErrorLabels (label (Proxy @errLabel)) (label (Proxy @statusLabel)) 217 | where 218 | label :: KnownSymbol t => Proxy t -> T.Text 219 | label proxy = cs $ symbolVal proxy 220 | --------------------------------------------------------------------------------