http-rfc7807 (empty) → 0.1.0.0

raw patch · 7 files changed

+1077/−0 lines, 7 filesdep +aesondep +basedep +call-stack

Dependencies added: aeson, base, call-stack, hspec-expectations-json, http-media, http-rfc7807, http-types, servant, servant-server, tasty, tasty-hunit, text

Files

• ChangeLog.md +5/−0
• LICENSE +30/−0
• README.md +28/−0
• http-rfc7807.cabal +73/−0
• src/Network/HTTP/RFC7807.hs +692/−0
• src/Servant/Server/RFC7807.hs +138/−0
• test/Main.hs +111/−0

@@ -0,0 +1,5 @@+For latest version of this document see [`ChangeLog.md on GitHub`](https://github.com/trskop/http-rfc7807/blob/main/ChangeLog.md).++### 0.1.0.0++Initial release

@@ -0,0 +1,30 @@+Copyright (c) 2020 Peter Trško++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Peter Trško nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,28 @@+# Problem Details for HTTP APIs (RFC7807)++Extensible implementation of [RFC7807 — Problem Details for HTTP APIs+](https://tools.ietf.org/html/rfc7807) in Haskell.++RFC7807 defines HTTP API error responses that are quite informative. Very basic+example of such message could look like:++```+HTTP/1.1 404 Not Found+Transfer-Encoding: chunked+Date: Sun, 01 Nov 2020 22:28:42 GMT+Server: Warp/3.3.13+Content-Type: application/problem+json;charset=utf-8+Content-Length: 251++{+  "type": "https://example.com/docs/error#upload-to-missing-file",+  "title": "File resource doesn't exist",+  "status": 404,+  "detail": "Cannot upload file content to a non-existent file.",+  "documentId": "ae095978-2f7c-47aa-84dd-220be55195a5"+}+```++This library provides a data type `Rfc7807Error` that represents such error+responses. It is designed to be extensible and to allow alternative+representation of user defined fields.

@@ -0,0 +1,73 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 31ff663e1db6eb5ce1c51bdec4504de59a9d87225c9a4052382cec7633c603db++name:           http-rfc7807+version:        0.1.0.0+synopsis:       RFC7807 style response messages++description:    [RFC7807 — Problem Details for HTTP APIs](https://tools.ietf.org/html/rfc7807)+                style response messages.+                .+                See [GitHub README](https://github.com/trskop/http-rfc7807#readme) for more+                information.+category:       Web, Servant+homepage:       https://github.com/trskop/http-rfc7807#readme+bug-reports:    https://github.com/trskop/http-rfc7807/issues+author:         Peter Trško+maintainer:     peter.trsko@gmail.com+copyright:      (c) 2020 Peter Trško+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/trskop/http-rfc7807++library+  exposed-modules:+      Network.HTTP.RFC7807+      Servant.Server.RFC7807+  other-modules:+      Paths_http_rfc7807+  hs-source-dirs:+      src+  default-extensions: BlockArguments DeriveGeneric DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances InstanceSigs LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings RecordWildCards ScopedTypeVariables TypeApplications+  ghc-options: -Wall -Wcompat+  build-depends:+      aeson >=1.4.1.0 && <2+    , base >=4.12 && <5+    , http-media >=0.7.1.3 && <1+    , http-types >=0.12.2 && <1+    , servant >=0.16 && <1+    , servant-server >=0.16 && <1+    , text >=1.2.3.0 && <2+  default-language: Haskell2010++test-suite command-wrapper-tests+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Paths_http_rfc7807+  hs-source-dirs:+      test+  default-extensions: BlockArguments DeriveGeneric DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances InstanceSigs LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings RecordWildCards ScopedTypeVariables TypeApplications+  ghc-options: -Wall -Wcompat -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson >=1.4.1.0 && <2+    , base >=4.12 && <5+    , call-stack >=0.2.0 && <1+    , hspec-expectations-json >=1.0.0.0 && <2+    , http-rfc7807+    , tasty >=1.2.3 && <2+    , tasty-hunit >=0.10.0.2 && <1+    , text >=1.2.3.0 && <2+  default-language: Haskell2010

@@ -0,0 +1,692 @@+-- |+-- Module:      Network.HTTP.RFC7807+-- Description: RFC7807 style response messages+-- Copyright:   (c) 2020 Peter Trško+-- License:     BSD3+--+-- Maintainer:  peter.trsko@gmail.com+-- Stability:   experimental+-- Portability: GHC specific language extensions.+--+-- [RFC7807 — Problem Details for HTTP APIs](https://tools.ietf.org/html/rfc7807)+-- style response messages.+module Network.HTTP.RFC7807+    (+    -- $intro+      Rfc7807Error(..)+    , rfc7807Error++    -- * Encoding and Decoding+    --+    -- | #encoding-and-decoding# Definitions in this section are useful for+    -- defining your own JSON encoding\/decoding. See [Usage Examples section+    -- ](#usage-examples) for ideas on how to use them.+    --+    -- What's provided in here are:+    --+    -- * Function 'toKeyValue' for generic serialisation of 'Rfc7807Error' into+    --   JSON object representation.+    --+    -- * Function 'parseObject' for parsing JSON 'Aeson.Object' (key-value map)+    --   into 'Rfc7807Error'.+    --+    -- * Parameters that modify behaviour of 'toKeyValue' and 'parseObject:+    --   'EncodingOptions', 'defaultEncodingOptions', and 'ExtensionField'.+    , toKeyValue+    , parseObject+    , EncodingOptions(..)+    , defaultEncodingOptions+    , ExtensionField(..)++    -- * Usage Examples+    --+    -- $usageExamples++    -- ** Type Alias+    --+    -- $usageExamplesTypeAlias++    -- ** Newtype+    --+    -- $usageExamplesNewtype++    -- ** Extra Fields Example+    --+    -- $usageExamplesExtraFieldsExample+    )+  where++import Control.Applicative (pure)+import Data.Bool (Bool(False, True), (||), not, otherwise)+import Data.Eq (Eq)+import Data.Function (($), const)+import Data.Int (Int)+import Data.Maybe (Maybe(Nothing), isJust)+import Data.Monoid (Monoid, mconcat, mempty)+import Data.Proxy (Proxy(Proxy))+import Data.String (String)+import Data.Typeable (Typeable, typeRep)+import GHC.Generics (Generic)+import Text.Show (Show, show)++import Data.Aeson ((.:), (.:?), (.=))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Aeson (Parser)+import Data.Text (Text)+++-- | Based on [RFC7807](https://tools.ietf.org/html/rfc7807) with few+-- additional fields @'error_' :: errorInfo@ and @'context' :: context@.+--+-- Meaning of individual type parameters:+--+-- [@errorType@]: Represents an URI reference. Easiest to start with is just+--   using 'Text' type; simplest and most extensible is defining an enum with a+--   'Aeson.ToJSON', see [Usage Examples section](#usage-examples) for an enum+--   example.+--+-- [@errorInfo@]: Not defined by RFC7807. This type is intended to provide a+--   different representation of the error. This is very useful when you're+--   retrofitting RFC7807 style messages into an existing error reporting.+--   Another common use case is when client needs to understand the error+--   response. For example, form validation errors that need to be displayed in+--   context of the element that failed validation. If you're not using this+--   you can set the type to @()@.+--+-- [@context@]: Not defined by RFC3986. This type is intended to provide more+--   details\/context to what has happened. For example, IDs of entities that+--   were involved. If you're not using this you can set the type to @()@.+data Rfc7807Error errorType errorInfo context = Rfc7807Error+    { type_ :: errorType+    -- ^ (__required__) A URI reference+    -- (see [RFC3986](https://tools.ietf.org/html/rfc3986)) that identifies the+    -- problem type.  This specification encourages that, when dereferenced, it+    -- provide human-readable documentation for the problem type (e.g., using+    -- HTML [W3C.REC-html5-20141028+    -- ](https://tools.ietf.org/html/rfc7807#ref-W3C.REC-html5-20141028)).+    -- When this member is not present, its value is assumed to be+    -- @\"about:blank\"@.+    --+    -- Consumers MUST use the @\"type\"@ string as the primary identifier for+    -- the problem type; the @\"title\"@ string is advisory and included only+    -- for users who are not aware of the semantics of the URI and do not+    -- have the ability to discover them (e.g., offline log analysis).+    -- Consumers SHOULD NOT automatically dereference the type URI.+    --+    -- Relative URIs are accepted; this means that they must be resolved+    -- relative to the document's base URI, as per [RFC3986, Section 5+    -- ](https://tools.ietf.org/html/rfc3986#section-5).+    --+    -- === Notes:+    --+    -- In JSON this filed is named only @\"type\"@.++    , title :: Maybe Text+    -- ^ (__optional__) A short, human-readable summary of the problem type. It+    -- SHOULD NOT change from occurrence to occurrence of the problem, except+    -- for purposes of localization (e.g., using proactive content negotiation;+    -- see [RFC7231, Section 3.4+    -- ](https://tools.ietf.org/html/rfc7231#section-3.4).+    --+    -- Consumers MUST use the @\"type\"@ string as the primary identifier for+    -- the problem type; the @\"title\"@ string is advisory and included only+    -- for users who are not aware of the semantics of the URI and do not+    -- have the ability to discover them (e.g., offline log analysis).+    -- Consumers SHOULD NOT automatically dereference the type URI.+    --+    -- === Notes:+    --+    -- In JSON this filed is named @\"title\"@.++    , status :: Maybe Int+    -- ^ (__optional__) The HTTP status code (see [RFC7231, Section 6+    -- ](https://tools.ietf.org/html/rfc7231#section-6)) generated by the+    -- origin server for this occurrence of the problem.+    --+    -- If present, is only advisory; it conveys the HTTP status code used for+    -- the convenience of the consumer.  Generators MUST use the same status+    -- code in the actual HTTP response, to assure that generic HTTP software+    -- that does not understand this format still behaves correctly.  See+    -- [RFC7807, Section 5](https://tools.ietf.org/html/rfc7807#section-5) for+    -- further caveats regarding its use.+    --+    -- Consumers can use the status member to determine what the original+    -- status code used by the generator was, in cases where it has been+    -- changed (e.g., by an intermediary or cache), and when message bodies+    -- persist without HTTP information.  Generic HTTP software will still use+    -- the HTTP status code.+    --+    -- === Notes:+    --+    -- In JSON this filed is named @\"status\"@.++    , detail :: Maybe Text+    -- ^ (__optional__) A human-readable explanation specific to this+    -- occurrence of the problem.+    --+    -- If present, ought to focus on helping the client correct the problem,+    -- rather than giving debugging information.  Consumers SHOULD NOT parse+    -- the "detail" member for information; extensions are more suitable and+    -- less error-prone ways to obtain such information.+    --+    -- === Notes:+    --+    -- In JSON this filed is named @\"detail\"@.++    , instance_ :: Maybe Text+    -- ^ (__optional__) A URI reference that identifies the specific occurrence+    -- of the problem.  It may or may not yield further information if+    -- dereferenced.+    --+    -- Relative URIs are accepted; this means that they must be resolved+    -- relative to the document's base URI, as per [RFC3986, Section 5+    -- ](https://tools.ietf.org/html/rfc3986#section-5).+    --+    -- === Notes:+    --+    -- In JSON this filed ins named only @\"instance\"@.++    , error_ :: Maybe errorInfo+    -- ^ (__optional__, __extension__) An additional representation of the+    -- error.  Lots of clients detect that the response is an error using+    -- simple algorithm of checking presence of the field @\"error\"@ that has+    -- non-@null@ value.+    --+    -- === Notes:+    --+    -- How the field is named in the resulting JSON object is controlled by+    -- 'extensionFieldName', but by default it is @\"error\"@.++    , context :: Maybe context+    -- ^ (__optional__, __extension__) Extra information for the purposes of+    -- debugging.+    --+    -- === Notes:+    --+    -- How the field is named in the resulting JSON object is controlled by+    -- 'extensionFieldName', but by default it is @\"context\"@.+    }+  deriving stock (Eq, Generic, Show)++-- | Constructor for 'Rfc7807Error' that set's only 'type_' and everything else+-- is set to 'Nothing'.+--+-- === Usage Example+--+-- This example illustrates how the function is used, not necessarily the best+-- error response you can provide to your client:+--+-- @+-- ('rfc7807Error' \"/errors#not-found\"){'status' = 404}+-- @+rfc7807Error :: errorType -> Rfc7807Error errorType errorInfo context+rfc7807Error type_ = Rfc7807Error+    { type_+    , title = Nothing+    , status = Nothing+    , detail = Nothing+    , instance_ = Nothing+    , error_ = Nothing+    , context = Nothing+    }++-- | Enum representing the extension fields 'error_' and 'context' that are not+-- defined by RFC7807.+--+-- This allows us to reference the field in 'EncodingOptions' and later in+-- 'toKeyValue' and 'parseObject' without resolving to using 'Text'.+data ExtensionField+    = ErrorField+    -- ^ Represents the name of the 'error_' field of 'Rfc7807Error' data type.+    | ContextField+    -- ^ Represents the name of the 'context' field of 'Rfc7807Error' data type.+  deriving stock (Eq, Generic, Show)++-- {{{ JSON Encoding ----------------------------------------------------------++-- | Encode using @'toKeyValue' 'defaultEncodingOptions'@.+instance+    ( Aeson.ToJSON errorType+    , Aeson.ToJSON errorInfo+    , Aeson.ToJSON context+    ) => Aeson.ToJSON (Rfc7807Error errorType errorInfo context)+  where+    toJSON :: Rfc7807Error errorType errorInfo context -> Aeson.Value+    toJSON v = Aeson.Object (toKeyValue defaultEncodingOptions v)++    toEncoding :: Rfc7807Error errorType errorInfo context -> Aeson.Encoding+    toEncoding v = Aeson.pairs (toKeyValue defaultEncodingOptions v)++-- | Parameters that allow us to control certain aspects of how 'Rfc7807Error'+-- is encoded\/decoded to\/from JSON.+data EncodingOptions = EncodingOptions+    { omitNothingFields :: Bool+    -- ^ Should empty fields be omitted in the JSON representation?+    --+    -- [If set to @True@ (default)]: then record fields of 'Rfc7807Error' with+    -- a 'Nothing' value will be omitted from the resulting object instead of+    -- being represented as @null@.+    --+    -- [If set to @False@]: then the resulting JSON object will include those+    -- fields and the 'Nothing' value will be mapped to @null@ JSON value.+    --+    -- === Notes:+    --+    -- This setting is ignored by 'parseObject' function as respecting it would+    -- mean that even valid RFC7807 messages would fail to parse.++    , omitExtensionField :: ExtensionField -> Bool+    -- ^ Should specified extension field be omitted in the JSON+    -- representation?+    --+    -- [If the function returns @True@]: then the specified record field of+    -- 'Rfc7807Error' will be omitted entirely even if it contains+    -- 'Data.Maybe.Just' value.+    --+    -- [If the function returns @False@]: then the specified record field is+    -- included in the serialised output. However, if the value of that field+    -- is 'Nothing' and 'omitNothingFields' is set to @True@ then the field+    -- will once again be omitted from the resulting JSON object.+    --+    -- === Notes:+    --+    -- This setting can be used in a similar fashion as verbosity level. For+    -- example, we can omit these fields on production and have them enabled+    -- in testing or dev environments.+    --+    -- This setting is respected by 'parseObject' function, which will ignore+    -- extension fields for which the function returns @True@. Ignored+    -- extension fields will always be set to 'Nothing'.++    , extensionFieldName :: ExtensionField -> Text+    -- ^ How should the extension fields be named?+    --+    -- Fields 'error_' and 'context' are not defined by RFC7807 and as such+    -- their names may be adjusted depending on our particular needs and+    -- conventions. This function allows exactly that.+    --+    -- === Notes:+    --+    -- This setting is respected by 'parseObject' function, which will use this+    -- function when searching for extension fields in a JSON object.+    }+  deriving stock (Generic)++-- | Default 'EncodingOptions':+--+-- @+-- defaultEncodingOptions = 'EncodingOptions'+--     { 'omitNothingFields' = True+--     , 'omitExtensionField' = const False+--     }+-- @+defaultEncodingOptions :: EncodingOptions+defaultEncodingOptions = EncodingOptions+    { omitNothingFields = True+    , omitExtensionField = const False+    , extensionFieldName = \case+        ErrorField -> "error"+        ContextField -> "context"+    }++-- | Serialise 'Rfc7807Error' into a key-value pairs. It's abstract to support+-- both types of Aeson encodings ('Aeson.Object' and 'Aeson.Encoding') at once.+--+-- === Usage Examples+--+-- @+-- 'Aeson.Object' . 'toKeyValue' 'defaultEncodingOptions'+--     ::  ( 'Aeson.ToJSON' errorType+--         , 'Aeson.ToJSON' errorInfo+--         , 'Aeson.ToJSON' context+--         )+--     => 'Rfc7807Error' errorType errorInfo context+--     -> 'Aeson.Value'+-- @+--+-- @+-- 'Aeson.pairs' . 'toKeyValue' 'defaultEncodingOptions'+--     ::  ( 'Aeson.ToJSON' errorType+--         , 'Aeson.ToJSON' errorInfo+--         , 'Aeson.ToJSON' context+--         )+--     => 'Rfc7807Error' errorType errorInfo context+--     -> 'Aeson.Encoding'+-- @+toKeyValue+    :: forall kv errorType errorInfo context+    .   ( Aeson.ToJSON errorType+        , Aeson.ToJSON errorInfo+        , Aeson.ToJSON context+        , Aeson.KeyValue kv+        , Monoid kv+        )+    => EncodingOptions+    -> Rfc7807Error errorType errorInfo context+    -> kv+toKeyValue EncodingOptions{..} Rfc7807Error{..} = mconcat+    [ "type" .= type_+    , field "title" title+    , field "status" status+    , field "detail" detail+    , field "instance" instance_+    , extField ErrorField error_+    , extField ContextField context+    ]+  where+    field :: Aeson.ToJSON a => Text -> Maybe a -> kv+    field name value =+        mwhen (not omitNothingFields || isJust value)+            (name .= value)++    extField :: Aeson.ToJSON a => ExtensionField -> Maybe a -> kv+    extField name value =+        mwhen (not (omitExtensionField name))+            $ field (extensionFieldName name) value++    mwhen :: Bool -> kv -> kv+    mwhen p kv = if p then kv else mempty++-- }}} JSON Encoding ----------------------------------------------------------++-- {{{ JSON Decoding ----------------------------------------------------------++-- | Decode using @'parseObject' 'defaultEncodingOptions'@.+instance+    ( Aeson.FromJSON errorType+    , Aeson.FromJSON errorInfo+    , Aeson.FromJSON context+    , Typeable errorType+    , Typeable errorInfo+    , Typeable context+    )+    => Aeson.FromJSON (Rfc7807Error errorType errorInfo context)+  where+    parseJSON+        :: Aeson.Value+        -> Aeson.Parser (Rfc7807Error errorType errorInfo context)+    parseJSON = Aeson.withObject typeName (parseObject defaultEncodingOptions)+      where+        typeName :: String+        typeName =+            show (typeRep (Proxy @(Rfc7807Error errorType errorInfo context)))++-- | Parse JSON value into 'Rfc7807Error'. Reason for taking 'Aeson.Object'+-- instead of 'Aeson.Value' is that it allows us to define serialisation for+-- our own data types with extra fields while preserving RFC7807 message+-- structure.+--+-- === Usage example+--+-- @+-- 'Aeson.withObject' \"ErrorResponse\" \\o ->+--     'parseObject' 'defaultEncodingOptions' o+-- @+parseObject+    :: forall errorType errorInfo context+    .   ( Aeson.FromJSON errorType+        , Aeson.FromJSON errorInfo+        , Aeson.FromJSON context+        )+    => EncodingOptions+    -> Aeson.Object+    -> Aeson.Parser (Rfc7807Error errorType errorInfo context)+parseObject EncodingOptions{omitExtensionField, extensionFieldName} o = do+    type_ <- o .: "type"+    title <- o .:? "title"+    status <- o .:? "status"+    detail <- o .:? "detail"+    instance_ <- o .:? "instance"+    error_ <- extField ErrorField+    context <- extField ContextField++    pure Rfc7807Error+        { type_+        , title+        , status+        , detail+        , instance_+        , error_+        , context+        }+  where+    extField+        :: Aeson.FromJSON a+        => ExtensionField+        -> Aeson.Parser (Maybe a)+    extField name+      | omitExtensionField name = pure Nothing+      | otherwise               = o .:? extensionFieldName name++-- }}} JSON Decoding ----------------------------------------------------------++-- $intro+--+-- This module defines 'Rfc7807Error' data type that represents+-- [RFC7807](https://tools.ietf.org/html/rfc7807) style response message along+-- with few extensions that are not defined by the standard, but allowed by it.+--+-- The sandard specifies two serialisation formats:+--+-- 1. JSON (@application\/problem+json@) and+--+-- 2. XML (@application\/problem+xml@)+--+-- This package supports only JSON serialisation, but it should not be hard to+-- build XML serialisation yourself, if required. We also expose few low-level+-- definitions for cases when you want to build your own JSON serialisation+-- that is compatible with the standard. If you're interested in that then best+-- to look at [Usage Examples](#usage-examples) and [Encoding and Decoding+-- ](#encoding-and-decoding) sections.+--+-- This package also provides Servant integration that is defined in a separate+-- module "Servant.Server.RFC7807".+--+-- If you want to jump straight to using this then go directly to+-- [Usage Examples section](#usage-examples).++-- $usageExamples+--+-- #usage-examples#+--+-- We start with a simple use case in [Type Alias section+-- ](#usage-examples-type-alias) and we get progressively more complicated.+-- Which one is best for you depends on many factors. There's a little guidance+-- that we can give you in that regard, but maybe consider following:+--+-- * If you are just exploring or evaluating multiple options then maybe start+--   with the simple example first.+--+-- * If you want to integrate RFC7807 style messages into existing system,+--   while requiring backward compatibility, then go with the more complicated+--   example. It will allow you to merge existing error responses with RFC7807+--   style ones more easily.+--+-- Haskell\/GHC language extensions being used in the examples:+--+-- * @RecordWildCards@ and @NamedFieldPuns@ — please read this great article+--   if you're not familiar with these extensions: [The Power of RecordWildCards+--   by Dmitrii Kovanikov](https://kodimensional.dev/recordwildcards).+--+-- * @LambdaCase@ — allows us to use @\\case@ as a short hand for+--   @\\x -> case x of@. See [GHC User's Guide — Lambda-case+--   ](https://downloads.haskell.org/ghc/latest/docs/html/users_guide/glasgow_exts.html#lambda-case)+--   for more information.+--+-- * @OverloadedStrings@ — allows us to define string literals for types like+--   'Text' without needing to manually pack\/convert 'String' values. See+--   [GHC User's Guide — Overloaded string literals+--   ](https://downloads.haskell.org/ghc/latest/docs/html/users_guide/glasgow_exts.html#overloaded-string-literals)+--   for more information.++-- $usageExamplesTypeAlias+--+-- #usage-examples-type-alias#+--+-- The easiest way how to use 'Rfc7807Error' data type without always needing+-- to pass all the type arguments is by creating a type alias like this:+--+-- @+-- type ErrorResponse = 'Rfc7807Error' ErrorType () ()+--+-- data ErrorType+--     = DocumentNotFound+--     {- ... -}+--+-- instance 'Aeson.ToJSON' ErrorType where+--     toJSON = \\case+--         DocumentNotFound ->+--             'Aeson.String' \"https:\/\/example.com\/docs\/error#document-not-found\"+--         {- ... -}+-- @+--+-- If you want custom value in @\"error\"@ field then you can either specify+-- the type to the one you're using or leave @errorInfo@ type variable+-- polymorphic. The later has the advantage that different types can be used+-- for different REST API resources\/endpoints:+--+-- @+-- type ErrorResponse errorInfo = 'Rfc7807Error' ErrorType errorInfo ()+--+-- data ErrorType+--     = DocumentNotFound+--     {- ... -}+--+-- instance 'Aeson.ToJSON' ErrorType where+--     toJSON = \\case+--         DocumentNotFound ->+--             -- The URL doesn't have to be absolute. See description of+--             -- 'type_' field of 'Rfc7807Error' for more information.+--             'Aeson.String' \"https:\/\/example.com\/docs\/error#document-not-found\"+--         {- ... -}+-- @++-- $usageExamplesNewtype+--+-- While it is possible to use 'Rfc7807Error' directly, using newtype allows to+-- be more flexible with how things are encoded. If you're expecting your use+-- cases to evolve over time it is good to start with something like this:+--+-- @+-- -- | See [\"Type Alias\"](#usage-examples-type-alias) section for \@ErrorType\@ example.+-- data ErrorType+--   = {- ... -}+--+-- newtype ErrorResponse = ErrorResponse+--     { errorResponse :: 'Rfc7807Error' ErrorType () ()+--     }+--+-- -- Following encoding example is very simple, basicaly the same thing as the+-- -- default 'Rfc7807Error' encoding. However, it's a template that when+-- -- copied allows us to adjust bits that we want different.+--+-- errorResponseEncodingOptions :: 'EncodingOptions'+-- errorResponseEncodingOptions = 'defaultEncodingOptions'+--     { 'omitExtensionField' = const True+--     }+--+-- instance 'Aeson.ToJSON' ErrorResponse where+--     'Aeson.toJSON' :: ErrorResponse -> 'Aeson.Value'+--     'Aeson.toJSON' ErrorResponse{..} =+--          'Aeson.object' . 'toKeyValue' errorResponseEncodingOptions+--     {- ... -}+--+-- instance 'Aeson.FromJSON' ErrorResponse where+--     'Aeson.parseJSON' :: ErrorResponse -> 'Aeson.Value'+--     'Aeson.parseJSON' = 'Aeson.withObject' \"ErrorResponse\" \\o ->+--          ErrorResponse <$> 'parseObject' errorResponseEncodingOptions o+-- @++-- $usageExamplesExtraFieldsExample+--+-- This is an elaboration of the previous \"Newtype\" example. We will use+-- @errorInfo@ and @context@ type arguments of 'Rfc7807Error' to include more+-- information. The @errorInfo@ will be kept polymorphic so that each HTTP+-- response can use a different one, depending on its needs.+--+-- @+-- -- | See \"Type Alias\" section for \@ErrorType\@ example.+-- data ErrorType+--   = {- ... -}+--+-- -- | We can use a concrete data type or we can use something flexible like+-- -- 'Aeson.Object' (actually a \@HashMap Text 'Aeson.Value'\@) allowing us to+-- -- include any kind of metadata.+-- --+-- -- This approach intentionally resembles structured logging approach like+-- -- the one used by [katip](https://hackage.haskell.org/package/katip) library.+-- type ErrorContext = 'Aeson.Object'+--+-- newtype ErrorResponse e = ErrorResponse+--     { errorResponse :: 'Rfc7807Error' ErrorType e ErrorContext+--     }+--+-- -- Following serialisation example is just one of many possibilities. What+-- -- it illustrates is how much flexibility we have. Not only we can rename+-- -- fields through 'extensionFieldName', we can also play with the encoding+-- -- to get something that is more suitable for our system.+--+-- -- | What we'll do is serialise the \@ErrorContext\@ manually. To be able to+-- -- do that we need to tell 'toKeyValue' and 'parseObject' to ignore the+-- -- extension field.+-- --+-- -- Another thing that we'll do is that we'll rename the @\"error\"@ field to+-- -- @\"error_message\"@. This is one of those things that are useful when+-- -- we are changing existing error responses.+-- errorResponseEncodingOptions :: 'EncodingOptions'+-- errorResponseEncodingOptions = 'defaultEncodingOptions'+--     { 'omitExtensionField' = \\case+--         'ErrorField' -> False+--         'ContextField' -> True+--+--     , 'extensionFieldName' = \\case+--         'ErrorField' -> \"error_message\"+--         name -> 'extensionFieldName' 'defaultEncodingOptions' name+--     }+--+-- instance 'Aeson.ToJSON' => 'Aeson.ToJSON' (ErrorResponse e) where+--     'Aeson.toJSON' :: ErrorResponse -> 'Aeson.Value'+--     'Aeson.toJSON' ErrorResponse{errorResponse} = 'Aeson.Object'+--         ( 'toKeyValue' errorResponseEncodingOptions errorResponse+--         -- We'll take everything that's in context and put it directly into+--         -- the top-level JSON object.+--         --+--         -- The downside of this approach is that we need to be careful not+--         -- to redefine already existing fields. What we could do is change+--         -- the field names. It is quite common to use \"@fieldName\" or+--         -- similar convention for metadata.+--         --+--         -- If we go with custom data type we can then examine if it's JSON+--         -- object or not. If not we can instead put it into the \"context\"+--         -- field as a kind of a default.+--         <> context errorResponse+--         )+--     {- ... -}+--+-- instance 'Aeson.FromJSON' e => 'Aeson.FromJSON' (ErrorResponse e) where+--     'Aeson.parseJSON' :: ErrorResponse -> 'Aeson.Value'+--     'Aeson.parseJSON' = 'Aeson.withObject' \"ErrorResponse\" \\o ->+--          errorResponse <- 'parseObject' errorResponseEncodingOptions o+--+--          -- Now we'll take all the fields that are not part of RFC7807 or+--          -- \"error\" and put them into context.+--          let context = flip filterWithKey o \\k _v ->+--                  k `notElem` parsedFields+--+--          pure ErrorResponse+--              { errorResponse = errorResponse{context}+--              }+--        where+--          parsedFields =+--              -- These hardcoded values are okay since RFC7807 defines the+--              -- names and we cannot change them.+--              [ \"type\", \"title\", \"status\", \"detail\", \"instance\"+--              , 'extensionFieldName' 'ErrorField'+--              ]+-- @+--+-- At this point we may want to provide few helper functions for constructing+-- @ErrorResponse@ (also known as smart constructors) to fit in nicely with the+-- rest of our code base and HTTP framework we are using. You may want to look+-- at "Servant.Server.RFC7807" module, even if you're using a different+-- framework. It should give you few ideas on how to proceed.

@@ -0,0 +1,138 @@+-- |+-- Module:      Servant.Server.RFC7807+-- Description: Servant support for RFC7807 style error response messages+-- Copyright:   (c) 2020 Peter Trško+-- License:     BSD3+--+-- Maintainer:  peter.trsko@gmail.com+-- Stability:   experimental+-- Portability: GHC specific language extensions.+--+-- Servant support for [RFC7807 — Problem Details for HTTP APIs+-- ](https://tools.ietf.org/html/rfc7807) style response messages.+module Servant.Server.RFC7807+    (+    -- $intro+      rfc7807ServerError++    -- * Mime Type @application\/problem+json@+    , ProblemJSON++    -- * Re-exported+    --+    -- | When using 'Rfc7807Error' in more complex way, please, depend on+    -- "Network.HTTP.RFC7807" module directly. More information and more+    -- detailed usage examples can be found in "Network.HTTP.RFC7807" module+    -- documentation.+    , Rfc7807Error(..)+    )+  where++import Data.List.NonEmpty (NonEmpty((:|)))+import Data.Maybe (Maybe(Just))+import Data.Proxy (Proxy)+import Data.Semigroup ((<>))++import qualified Data.Aeson as Aeson (FromJSON, ToJSON, encode)+import Network.HTTP.Media ((//), (/:), renderHeader)+import Network.HTTP.Types (hContentType)+import Servant.API.ContentTypes+  ( Accept(contentTypes)+  , MimeRender(mimeRender)+  , MimeUnrender(mimeUnrender)+  , contentType+  , eitherDecodeLenient+  )+import Servant.Server++import Network.HTTP.RFC7807 (Rfc7807Error(..), rfc7807Error)++-- | Media type defined by+-- <https://tools.ietf.org/html/rfc7807#section-6.1 RFC7807>:+-- @application/problem+json@+--+-- The way how this mime type is handled is the same as+-- 'Servant.API.ContentTypes.JSON'.+data ProblemJSON++-- TODO: This mime type is specifically designed for RFC7807 representation.+-- Should we enforce that in the encoding and decoding?++-- | @application/problem+json; charset=utf-8@+instance Accept ProblemJSON where+    contentTypes _ = ct /: ("charset", "utf-8") :| [ct]+      where+        ct = "application" // "problem+json"++-- | 'Aeson.encode'+instance Aeson.ToJSON a => MimeRender ProblemJSON a where+    mimeRender _ = Aeson.encode++-- | 'eitherDecodeLenient'+instance Aeson.FromJSON a => MimeUnrender ProblemJSON a where+    mimeUnrender _ = eitherDecodeLenient++-- | Construct Servant 'ServerError' with RFC7807 style response body.+--+-- By using Servant abstractions (like 'MimeRender' and 'Accept') we are able+-- to easily integrate with existing code bases.+--+-- === Usage Example+--+-- @+-- data ErrorType+--     = ValidationError+--     -- ...+--+-- instance 'Aeson.ToJSON' ErrorType where+--     'Aeson.toJSON' = \\case+--         ValidationError ->+--              'Aeson.String' \"/errors#validation-error\"+--+-- {- ... -} = do+--     {- ... -}+--     unless validationSuccessful do+--         throwError $ 'rfc7807ServerError' (Proxy \@'ProblemJSON') 'err400' ValidationError \\e ->+--             e  { 'title' = \"Request failed to pass data validation\"+--                -- ...+--                }+-- @+rfc7807ServerError+    :: (MimeRender ctype body)+    => Proxy ctype+    -- ^ Media type to use when encoding the error response body. This allows+    -- us to select appropriate mime type, e.g. 'Servant.API.ContentTypes.JSON'+    -- or 'ProblemJSON'.+    -> ServerError+    -- ^ One of Servant error values e.g. 'err400'.+    -> errorType+    -- ^ Value of the 'type_' field (@\"type\"@ in JSON), the only mandatory+    -- parameter for RFC7807 content.+    -> (Rfc7807Error errorType errorInfo context -> body)+    -- ^ Modify the 'Rfc7807Error' type to your hearts desire.+    --+    -- Reason for the return type to be polymorphic (i.e. @body@) is that we+    -- may want to use a newtype to use a different encoding. This still allows+    -- us to use the @'Rfc7807Error' errorType errorInfo context@ type as a+    -- return type if @errorType@, @errorInfo@, and @context@ can be encoded+    -- into JSON.+    -> ServerError+rfc7807ServerError ctype serverError@ServerError{errHTTPCode, errHeaders} t f =+    serverError+        { errBody =+            mimeRender ctype (f (rfc7807Error t){status = Just errHTTPCode})++        , errHeaders = errHeaders+            <>  [ (hContentType, renderHeader (contentType ctype))+                ]+        }++-- $intro+--+-- The main functionality of this module is 'rfc7807ServerError', which allows+-- us to create Servant's 'ServerError' values with RFC7807 style body.+-- Implementation is more abstract than strictly necessary to account for the+-- fact that @application/problem+json@ may not always be the best mime type to+-- use. This is especially true if we are migrating existing error responses.+-- Another benefit of the abstract way it's defined is that we can potentially+-- use different encoding or serialisation libraries.

@@ -0,0 +1,111 @@+-- |+-- Module:      Main+-- Description: TODO: Module synopsis+-- Copyright:   (c) 2020 Peter Trško+-- License:     BSD3+--+-- Maintainer:  peter.trsko@gmail.com+-- Stability:   experimental+-- Portability: GHC specific language extensions.+--+-- TODO: Module description.+module Main+    ( main+    )+  where++import Prelude++import Data.Maybe (isJust)++import Data.Aeson ((.=))+import qualified Data.Aeson as Aeson+import Data.Text (Text)+import Test.Hspec.Expectations.Json (shouldBeJson)+--import Test.QuickCheck.Instances ()+import Test.Tasty (TestName, TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit ({-(@?=),-} testCase{-, assertEqual-})+--import Test.Tasty.QuickCheck (testProperty)++import Network.HTTP.RFC7807+++main :: IO ()+main = defaultMain $ testGroup "Tests"+    [ testGroup "Network.HTTP.RFC7807"+        [ testDefaultSerialisation+        ]+    ]++testDefaultSerialisation :: TestTree+testDefaultSerialisation = testGroup "Default serialisation"+    -- Reason why samples are enough is that the way the serialisation works is+    -- mostly uniform. Testing it deeper just reimplements the logic and+    -- doesn't test anything useful.+    --+    -- Optional data values do not matter either as 'ToJSON' instances are+    -- used, therefore, we cannot guarantee anything beyond it being+    -- serialisable.+    --+    -- While testing that toJSON and toEncoding correspond would be useful to+    -- catch some errors, it won't test 'toKeyValue'.  Polymorphism guarantees+    -- that the representations cannot diverge beyond ordering.+    [ testDefaultSerialisationCase "Minimal sample" Rfc7807Error+        { type_ = "https://example.com/docs/error" :: Text+        , title = Nothing+        , status = Nothing+        , detail = Nothing+        , instance_ = Nothing+        , error_ = Nothing @()+        , context = Nothing @()+        }++    , testDefaultSerialisationCase "Full sample" Rfc7807Error+        { type_ = "https://example.com/docs/error" :: Text+        , title = Just "Not so detailed error"+        , status = Just 500+        , detail = Just "Very detailed error message"+        , instance_ = Just "https://example.com/error/instance/123"+        , error_ = Just $ Aeson.object+            [ "foo" .= Aeson.String "bar"+            ]+        , context = Just $ Aeson.object+            [ "id" .= Aeson.String "1234"+            ]+        }++    -- Missing values were strategically chosen to belong to have one among+    -- fields defined by the standard and one among the extension fields.  As+    -- the logic is uniform we are able to verify both classes at the same+    -- time.+    , testDefaultSerialisationCase "Few empty values sample" Rfc7807Error+        { type_ = "https://example.com/docs/error" :: Text+        , title = Just "Not so detailed error"+        , status = Just 500+        , detail = Just "Very detailed error message"+        , instance_ = Nothing  -- Check that field is omitted.+        , error_ = Nothing @() -- Check that field is omitted.+        , context = Just ()+        }+    ]++testDefaultSerialisationCase+    ::  ( Aeson.ToJSON errorType+        , Aeson.ToJSON errorInfo+        , Aeson.ToJSON context+        )+    => TestName+    -> Rfc7807Error errorType errorInfo context+    -> TestTree+testDefaultSerialisationCase name v@Rfc7807Error{..} = testCase name do+    Aeson.toJSON v `shouldBeJson` Aeson.object+        ( mconcat+            [ ["type" .= type_]+            , ["title" .= title | isJust title]+            , ["status" .= status | isJust status]+            , ["detail" .= detail | isJust detail]+            , ["instance" .= instance_ | isJust instance_]+            , ["error" .= error_ | isJust error_]+            , ["context" .= context | isJust context]+            ]+        )