diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,26 @@ For latest version of this document see [`ChangeLog.md on GitHub`](https://github.com/trskop/http-rfc7807/blob/main/ChangeLog.md). + +### 0.2.0.0 + +* (**breaking change**) Function `rfc7807ServerError` sets the value of `title` + field is set to HTTP reason from Servant's `ServerError` by default. User can + still override it as before, but this is a breaking change as it changes the + expected output. + +* (**breaking change**) Type variable `body` is now first in the definition of + `rfc7807ServerError`. If you've used `TypeApplications` when calling + `rfc7807ServerError` function then this may be a breaking change for you. + +* (**change**) Support `servant-server-0.15` in addition to currently supported + versions. We are planning to drop the support once again in next major + release. See [@servant-server-1.16 ChangeLog + ](https://hackage.haskell.org/package/servant-server-0.16/changelog) to see + what it entails. + +* Documentation updates + + ### 0.1.0.0 Initial release diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -23,6 +23,88 @@ } ``` + +## Table of Contents + +(Links work on GitHub, but not on Hackage.) + +* [What does this package do?](#what-does-this-package-do) +* [Why would I want to use this?](#why-would-i-want-to-use-this) +* [When would I want to use something else?](#when-would-i-want-to-use-something-else) +* [Usage examples](#usage-examples) + + +## What does this package do? + 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. +representation of user defined fields. See module `Network.HTTP.RFC7807` for +documentation. + +In addition the package provides basic support for [`servant-server` package +](https://hackage.haskell.org/package/servant-server). See +[`Servant.Server.RFC7807` module documentation +](https://hackage.haskell.org/package/http-rfc7807/docs/Servant-Server-RFC7807.html) +for more information and usage examples. + + +## Why would I want to use this? + +[![Oh my](https://raw.githubusercontent.com/trskop/http-rfc7807/f9d81307fff768ebe55eff7b009310aefc9af233/doc/nixcraft-tweet-with-obscure-error-response.png) +](https://twitter.com/nixcraft/status/1321898390209273856) + +There are many ways common ways how API error responses are structured in HTTP +APIs. Using this one has few advantages: + +* It is standardised in [RFC7807 — Problem Details for HTTP APIs + ](https://tools.ietf.org/html/rfc7807). This can be leveraged in terms of + documentation, libraries built with it in mind, and not heaving to reinvent + something that people have put a lot of thought into. + +* Gives you a nice template that is still flexible and extensible. This is + important if we are retrofitting it into an existing API. + +* Documented by default. The `type` field is a URL, used correctly can allow us + to prevent a lot of issues by linking errors with their documentation. + +* Increasing level of detail. We have `type`, `title`, then `detail`, and + finally custom fields. This way we can progressively add more information + allowing users to easily debug issues. + +* Proxy friendly. When proxies are involved, so called layering, it is quite + easy to loose the original status code. This can also happen with some HTTP + libraries that do not retain the status code. + +* Probably more... + +There's an interesting article "[REST API Error Handling - Problem Details +Response by Guy Levin published on 23rd of May, 2018 +](https://blog.restcase.com/rest-api-error-handling-problem-details-response/)" +that compares various stiles of error responses AKA problem details responses. + + +## When would I want to use something else? + +This response structure may not serve your needs if it's clashing with your +needs. Some examples of that: + +* Your needs are in direct conflict with the [RFC7807 — Problem Details for + HTTP APIs](https://tools.ietf.org/html/rfc7807) standard. For example, fields + that are defined by the standard are reserved in your system or protocol + you're using. + +* When RFC7807 messages cannot easily be retrofitted into your API and you need + to preserve backward compatibility. + +* Probably more... + + +## Usage examples + +General usage (not tied to Servant) is documented in [module +`Network.HTTP.RFC7807` in section Usage Examples +](https://hackage.haskell.org/package/http-rfc7807/docs/Network-HTTP-RFC7807.html#usage-examples). + +Basic usage with Servant (actually `servant-server`) is documented in +[module `Servant.Server.RFC7807` in section Usage Examples +](https://hackage.haskell.org/package/http-rfc7807/docs/Servant-Server-RFC7807.html#usage-examples). diff --git a/http-rfc7807.cabal b/http-rfc7807.cabal --- a/http-rfc7807.cabal +++ b/http-rfc7807.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 31ff663e1db6eb5ce1c51bdec4504de59a9d87225c9a4052382cec7633c603db +-- hash: 81f1ad1976b7e75902fd442b0e1b09b0e6295bb53eba518d35aaddff3a0ec408 name: http-rfc7807 -version: 0.1.0.0 +version: 0.2.0.0 synopsis: RFC7807 style response messages description: [RFC7807 — Problem Details for HTTP APIs](https://tools.ietf.org/html/rfc7807) @@ -47,8 +47,8 @@ , 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 + , servant >=0.15 && <1 + , servant-server >=0.15 && <1 , text >=1.2.3.0 && <2 default-language: Haskell2010 @@ -62,11 +62,15 @@ 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 + HUnit >=1.6.0.0 && <1.7 + , 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 + , http-types >=0.12.2 && <1 + , servant >=0.15 && <1 + , servant-server >=0.15 && <1 , tasty >=1.2.3 && <2 , tasty-hunit >=0.10.0.2 && <1 , text >=1.2.3.0 && <2 diff --git a/src/Servant/Server/RFC7807.hs b/src/Servant/Server/RFC7807.hs --- a/src/Servant/Server/RFC7807.hs +++ b/src/Servant/Server/RFC7807.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- | -- Module: Servant.Server.RFC7807 -- Description: Servant support for RFC7807 style error response messages @@ -18,6 +19,14 @@ -- * Mime Type @application\/problem+json@ , ProblemJSON + -- * Usage Examples + -- + -- $usageExamples + + -- ** Direct Use Example + -- + -- $directUseExample + -- * Re-exported -- -- | When using 'Rfc7807Error' in more complex way, please, depend on @@ -25,13 +34,27 @@ -- detailed usage examples can be found in "Network.HTTP.RFC7807" module -- documentation. , Rfc7807Error(..) + +#if !MIN_VERSION_servant_server(0,16,0) + -- * Servant 0.15 Compatibility + -- + -- | In @servant-server@ version 0.16 'ServantErr' was renamed to + -- 'ServerError'. This package provides compatiblity for that version, but + -- it may be dropped in the near future. + -- + -- For more information see [@servant-server-1.16 ChangeLog + -- ](https://hackage.haskell.org/package/servant-server-0.16/changelog). + , ServerError +#endif ) where +import Data.Function (($)) import Data.List.NonEmpty (NonEmpty((:|))) import Data.Maybe (Maybe(Just)) import Data.Proxy (Proxy) import Data.Semigroup ((<>)) +import Data.String (fromString) import qualified Data.Aeson as Aeson (FromJSON, ToJSON, encode) import Network.HTTP.Media ((//), (/:), renderHeader) @@ -72,6 +95,12 @@ instance Aeson.FromJSON a => MimeUnrender ProblemJSON a where mimeUnrender _ = eitherDecodeLenient +#if !MIN_VERSION_servant_server(0,16,0) +-- | Compatibility with newer @servant-server@ versions as 'ServantErr' was +-- renamed to 'ServerError' in version 0.16. +type ServerError = ServantErr +#endif + -- | Construct Servant 'ServerError' with RFC7807 style response body. -- -- By using Servant abstractions (like 'MimeRender' and 'Accept') we are able @@ -85,7 +114,7 @@ -- -- ... -- -- instance 'Aeson.ToJSON' ErrorType where --- 'Aeson.toJSON' = \\case +-- toJSON = \\case -- ValidationError -> -- 'Aeson.String' \"/errors#validation-error\" -- @@ -98,7 +127,8 @@ -- } -- @ rfc7807ServerError - :: (MimeRender ctype body) + :: forall body ctype errorType errorInfo context + . (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' @@ -111,16 +141,32 @@ -> (Rfc7807Error errorType errorInfo context -> body) -- ^ Modify the 'Rfc7807Error' type to your hearts desire. -- + -- The @'Rfc7807Error' errorType errorInfo context@ given to this function + -- will have @type@, @title@, and @status@ set. Values for @title@ and + -- @status@ are taken from Servant's 'ServerError'. It is highly advised + -- to modify the @title@ to something more useful. + -- -- 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. + -- into JSON. In other words, 'Data.Function.id' is a valid fit. -> ServerError -rfc7807ServerError ctype serverError@ServerError{errHTTPCode, errHeaders} t f = +rfc7807ServerError + ctype +#if MIN_VERSION_servant_server(0,16,0) + serverError@ServerError{errHTTPCode, errHeaders, errReasonPhrase} +#else + serverError@ServantErr{errHTTPCode, errHeaders, errReasonPhrase} +#endif + errorType' + f = serverError { errBody = - mimeRender ctype (f (rfc7807Error t){status = Just errHTTPCode}) + mimeRender ctype $ f (rfc7807Error errorType') + { status = Just errHTTPCode + , title = Just (fromString errReasonPhrase) + } , errHeaders = errHeaders <> [ (hContentType, renderHeader (contentType ctype)) @@ -136,3 +182,92 @@ -- 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. +-- +-- If you're interested in using this module right away then jump straight to +-- [Usage Examples section](#usage-examples). + +-- $usageExamples +-- +-- #usage-examples# +-- +-- These examples focus on usage of 'rfc7807ServerError', to see examples more +-- related to the 'Rfc7807Error' messages go to "Network.HTTP.RFC7807" module. +-- +-- 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). +-- +-- * @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. + +-- $directUseExample +-- +-- This example is intended to illustrate how we can start producing RFC7807 +-- style responses without too much fuss. No complex abstractions, no custom +-- wrappers for 'Rfc7807Error', no custom serialisation, and no extra @context@. +-- +-- @ +-- -- | Servant definition of an endpoint. +-- type SomeEndpoint = {- ... -} +-- +-- -- | This code is not complex enough to actually need to be in a function, +-- -- but it makes some things more obious and easier to change. +-- badRequest +-- :: ( MonadError 'ServerError' m +-- , 'Aeson.ToJSON' errorType +-- , 'Aeson.ToJSON' errorInfo +-- ) +-- => errorType +-- -> ( 'Rfc7807Error' errorType errorInfo () +-- -> 'Rfc7807Error' errorType errorInfo () +-- ) +-- -> m a +-- badRequest errorType = +-- throwError . 'rfc7807ServerError' (Proxy \@'ProblemJSON') 'err400' errorType +-- +-- -- | See "Network.HTTP.RFC7807" module for more information and examples on +-- -- how to use and define data types to be used for @errorType@. +-- data ErrorType +-- = ValidationError +-- -- ... +-- +-- instance 'Aeson.ToJSON' ErrorType where +-- toJSON = \\case +-- ValidationError -> +-- 'Data.Aeson.String' \"/errors#some-endpoint-validation-error\" +-- +-- someHandler :: 'ServerT' SomeEndpoint m +-- someHandler request = do +-- response <- doTheEndpointStuffBasedOn request +-- +-- case response of +-- Success r -> +-- pure r +-- +-- InvalidRequest error_@DataValidationFailed -> +-- badRequest ValidationError \\e -> e +-- { title = \"Request data validation failed\" +-- , detail = \"One or more members of request's 'data' field\\ +-- \\ failed validation, see 'error' field\" +-- +-- -- If we've used something like \@{\"error\": TheError}\@ +-- -- before switching to RFC7807 then this will be backward +-- -- compatible. We can also play with the serialisation if we +-- -- need to preserve backward compatibility. It won't work +-- -- all the time though. +-- -- +-- -- Huge downside of this approach is that the error is +-- -- directly serialised into JSON. API contract can easily be +-- -- affected by changes that seem unrelated. Please, consider +-- -- having a separate data type for this purpose or use JSON +-- -- combinators. +-- , error_ +-- } +-- +-- {- ... -} +-- @ diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,6 +1,6 @@ -- | -- Module: Main --- Description: TODO: Module synopsis +-- Description: Unit tests for Haskell implementation of RFC7807 style responses -- Copyright: (c) 2020 Peter Trško -- License: BSD3 -- @@ -8,7 +8,7 @@ -- Stability: experimental -- Portability: GHC specific language extensions. -- --- TODO: Module description. +-- Unit tests for Haskell implementation of RFC7807 style responses. module Main ( main ) @@ -16,18 +16,35 @@ import Prelude +import Control.Exception (handle, throwIO) import Data.Maybe (isJust) +import Data.Proxy (Proxy(Proxy)) import Data.Aeson ((.=)) import qualified Data.Aeson as Aeson import Data.Text (Text) -import Test.Hspec.Expectations.Json (shouldBeJson) +import Network.HTTP.Types (hContentType) +import Servant.API as Servant (JSON) +import Servant.Server as Servant +import qualified Test.HUnit.Lang as HUnit + ( HUnitFailure(HUnitFailure) + , formatFailureReason + ) +import qualified Test.Hspec.Expectations.Json as Json (shouldBeJson) --import Test.QuickCheck.Instances () import Test.Tasty (TestName, TestTree, defaultMain, testGroup) -import Test.Tasty.HUnit ({-(@?=),-} testCase{-, assertEqual-}) +import Test.Tasty.HUnit + ( Assertion + , HasCallStack + , assertEqual + , assertFailure + , testCase + , HUnitFailure(..) + ) --import Test.Tasty.QuickCheck (testProperty) -import Network.HTTP.RFC7807 +import Network.HTTP.RFC7807 (Rfc7807Error(..)) +import Servant.Server.RFC7807 (ProblemJSON, rfc7807ServerError) main :: IO () @@ -35,6 +52,68 @@ [ testGroup "Network.HTTP.RFC7807" [ testDefaultSerialisation ] + + , testGroup "Servant.Server.RFC7807" + [ testCase "err400, JSON" do + let actual = + rfc7807ServerError @(Rfc7807Error Text () ()) + (Proxy @Servant.JSON) Servant.err400 "/errors#400" id + + assertEqual "HTTP status code hasn't changed" + (Servant.errHTTPCode Servant.err400) + (Servant.errHTTPCode actual) + assertEqual "HTTP reason phrase hasn't changed" + (Servant.errReasonPhrase Servant.err400) + (Servant.errReasonPhrase actual) + assertEqual "Content-Type is present and is\ + \ application/json;charset=utf-8" + (Just "application/json;charset=utf-8") + (hContentType `lookup` Servant.errHeaders actual) + + case Aeson.eitherDecode (Servant.errBody actual) of + Left err -> + assertFailure + ( "HTTP response body is valid JSON, but we got:\n" + <> err + ) + + Right actualJson -> + actualJson `shouldBeJson` Aeson.object + [ "type" .= Aeson.String "/errors#400" + , "status" .= Servant.errHTTPCode Servant.err400 + , "title" .= Servant.errReasonPhrase Servant.err400 + ] + + , testCase "err500, ProblemJSON" do + let actual = + rfc7807ServerError @(Rfc7807Error Text () ()) + (Proxy @ProblemJSON) Servant.err500 "/errors#500" id + + assertEqual "HTTP status code hasn't changed" + (Servant.errHTTPCode Servant.err500) + (Servant.errHTTPCode actual) + assertEqual "HTTP reason phrase hasn't changed" + (Servant.errReasonPhrase Servant.err500) + (Servant.errReasonPhrase actual) + assertEqual "Content-Type is present and is\ + \ application/json;charset=utf8" + (Just "application/problem+json;charset=utf-8") + (hContentType `lookup` Servant.errHeaders actual) + + case Aeson.eitherDecode (Servant.errBody actual) of + Left err -> + assertFailure + ( "HTTP response body is valid JSON, but we got:\n" + <> err + ) + + Right actualJson -> + actualJson `shouldBeJson` Aeson.object + [ "type" .= Aeson.String "/errors#500" + , "status" .= Servant.errHTTPCode Servant.err500 + , "title" .= Servant.errReasonPhrase Servant.err500 + ] + ] ] testDefaultSerialisation :: TestTree @@ -74,10 +153,9 @@ ] } - -- 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. + -- Missing values were strategically chosen 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" @@ -109,3 +187,12 @@ , ["context" .= context | isJust context] ] ) + +shouldBeJson :: HasCallStack => Aeson.Value -> Aeson.Value -> Assertion +shouldBeJson actual expected = hUnitToTasty (Json.shouldBeJson actual expected) + +-- | Converts @HUnit@ exception to @tasty-hunit@ exception so that formatting +-- is preserved. +hUnitToTasty :: Assertion -> Assertion +hUnitToTasty = handle \(HUnit.HUnitFailure src reason) -> + throwIO $ HUnitFailure src (HUnit.formatFailureReason reason)