diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/http-rfc7807.cabal b/http-rfc7807.cabal new file mode 100644 --- /dev/null +++ b/http-rfc7807.cabal @@ -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 diff --git a/src/Network/HTTP/RFC7807.hs b/src/Network/HTTP/RFC7807.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/RFC7807.hs @@ -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. diff --git a/src/Servant/Server/RFC7807.hs b/src/Servant/Server/RFC7807.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/RFC7807.hs @@ -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 +-- : +-- @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. diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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] + ] + )