diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for hedgehog-servant + +## 0.0.0.1 -- 2019-11-04 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright 2019 Felix Mulder + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. 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. + +3. Neither the name of the copyright holder nor the names of its 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 HOLDER 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hedgehog-servant.cabal b/hedgehog-servant.cabal new file mode 100644 --- /dev/null +++ b/hedgehog-servant.cabal @@ -0,0 +1,129 @@ +name: + hedgehog-servant +version: + 0.0.0.1 +synopsis: + Hedgehog property testing for Servant APIs +description: + An adapter for using Hedgehog to create requests against Servant APIs. +bug-reports: + https://github.com/felixmulder/hedgehog-servant +cabal-version: + 1.24 +license: + BSD3 +license-file: + LICENSE +author: + Felix Mulder +maintainer: + felix.mulder@gmail.com +copyright: + Felix Mulder +category: + testing +build-type: + Simple +extra-source-files: + CHANGELOG.md + +source-repository head + type: git + location: git://github.com/felixmulder/hedgehog-servant.git + +library + default-extensions: + DataKinds + DeriveGeneric + FlexibleContexts + FlexibleInstances + GADTs + KindSignatures + MultiParamTypeClasses + OverloadedStrings + PolyKinds + RankNTypes + ScopedTypeVariables + TypeApplications + TypeOperators + ViewPatterns + + ghc-options: + -Wall -Wredundant-constraints -fhide-source-paths + + exposed-modules: + Hedgehog.Servant + + build-depends: + base >= 4.9 && < 5 + , bytestring >= 0.10 && < 0.11 + , case-insensitive >= 1.2 && < 1.3 + , hedgehog >= 0.6 && < 1.1 + , http-client >= 0.6 && < 0.7 + , http-media >= 0.8 && < 0.9 + , http-types >= 0.12 && < 0.13 + , servant >= 0.16 && < 0.17 + , servant-client >= 0.16 && < 0.17 + , servant-server >= 0.16 && < 0.17 + , string-conversions >= 0.4 && < 0.5 + , text >= 1.2 && < 1.3 + + hs-source-dirs: + src + + default-language: + Haskell2010 + +test-suite hedgehog-servant-tests + type: + exitcode-stdio-1.0 + + default-language: + Haskell2010 + + main-is: + Main.hs + + ghc-options: + -Wall -Wredundant-constraints -fhide-source-paths -threaded + + hs-source-dirs: + test + + other-modules: + Test.Hedgehog.Servant + + default-extensions: + DataKinds + DeriveGeneric + DerivingStrategies + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + KindSignatures + MultiParamTypeClasses + OverloadedStrings + PolyKinds + RankNTypes + ScopedTypeVariables + TypeApplications + TypeOperators + ViewPatterns + + build-depends: + hedgehog-servant + + , aeson >= 1.4 && < 1.5 + , base >= 4.9 && < 5 + , bytestring >= 0.10 && < 0.11 + , case-insensitive >= 1.2 && < 1.3 + , hedgehog >= 0.6 && < 1.1 + , http-client >= 0.6 && < 0.7 + , http-media >= 0.8 && < 0.9 + , http-types >= 0.12 && < 0.13 + , servant >= 0.16 && < 0.17 + , servant-client >= 0.16 && < 0.17 + , servant-server >= 0.16 && < 0.17 + , string-conversions >= 0.4 && < 0.5 + , text >= 1.2 && < 1.3 diff --git a/src/Hedgehog/Servant.hs b/src/Hedgehog/Servant.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Servant.hs @@ -0,0 +1,318 @@ +module Hedgehog.Servant + ( GList(..) + , HasGen(..) + , GenRequest(..) + ) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Internal as BS (c2w) +import qualified Data.CaseInsensitive as CI +import Data.Proxy (Proxy(..)) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import qualified Data.Text as Text +import Data.String.Conversions (ConvertibleStrings, cs) +import GHC.TypeLits (KnownSymbol, symbolVal) +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Network.HTTP.Media (renderHeader) +import Network.HTTP.Client (Request(..), RequestBody(..)) +import Network.HTTP.Client (defaultRequest) +import Network.HTTP.Types (HeaderName) +import Servant.API (ToHttpApiData(..)) +import Servant.API (Capture', CaptureAll, Header', Description, Summary) +import Servant.API (QueryParam', QueryParams, QueryFlag) +import Servant.API (ReqBody', Verb, ReflectMethod) +import Servant.API (BasicAuth, HttpVersion, IsSecure, RemoteHost, Vault) +import Servant.API (WithNamedContext) +import Servant.API ((:>), (:<|>)) +import Servant.API (reflectMethod) +import Servant.API.ContentTypes (AllMimeRender(..)) +import Servant.Client (BaseUrl(..), Scheme(..)) + +-- | Data structure used in order to specify generators for API +-- +-- Example usage: +-- +-- @ +-- type Api = "cats" :> ReqBody '[JSON] Cat :> Post '[JSON] () +-- +-- catGen :: Gen Cat +-- catGen = _ +-- +-- genApi :: Gen (BaseUrl -> Request) +-- genApi = genRequest (Proxy @Api) (catGen :*: GNil) +-- @ +data GList (a :: [*]) where + GNil :: GList '[] + (:*:) :: Gen x -> GList xs -> GList (Gen x ': xs) + +infixr 6 :*: + +-- | Simple getter from a GList of possible generators +class HasGen (g :: *) (gens :: [*]) where + getGen :: GList gens -> Gen g + +instance {-# OVERLAPPING #-} HasGen h (Gen h ': rest) where + getGen (ha :*: _) = ha + +instance {-# OVERLAPPABLE #-} (HasGen h rest) => HasGen h (first ': rest) where + getGen (_ :*: hs) = getGen hs + +-- | Type class used to generate requests from a 'GList gens' for API @api@ +class GenRequest (api :: *) (gens :: [*]) where + genRequest :: Proxy api -> GList gens -> Gen (BaseUrl -> Request) + +-- | Instance for composite APIs +instance + ( GenRequest a reqs + , GenRequest b reqs + ) => GenRequest (a :<|> b) reqs where + genRequest _ gens = + Gen.choice + [ genRequest (Proxy @a) gens + , genRequest (Proxy @b) gens + ] + +-- | Instance for description +instance + ( GenRequest api reqs + ) => GenRequest (Description d :> api) reqs where + genRequest _ = genRequest (Proxy @api) + +-- | Instance for summary +instance + ( GenRequest api reqs + ) => GenRequest (Summary s :> api) reqs where + genRequest _ = genRequest (Proxy @api) + +-- | Instance for path part of API +instance + ( KnownSymbol path + , GenRequest api reqs + ) => GenRequest (path :> api) reqs where + genRequest _ gens = do + makeRequest <- genRequest (Proxy @api) gens + pure $ prependPath (symbolVal $ Proxy @path) . makeRequest + +-- | Instance for path capture +instance + ( ToHttpApiData a + , HasGen a gens + , GenRequest api gens + ) => GenRequest (Capture' modifiers sym a :> api) gens where + genRequest _ gens = do + capture <- toUrlPiece <$> getGen @a @gens gens + makeRequest <- genRequest (Proxy @api) gens + pure $ prependPath capture . makeRequest + +-- | Instance for capture rest of path, e.g: +-- +-- @ +-- type Api = "cats" :> CaptureAll "rest" Text :> Get '[JSON] [Cat] +-- @ +-- +-- For simplicity this will generate a number of paths from 0 to 10 linearly +-- +instance + ( ToHttpApiData a + , HasGen a gens + , GenRequest api gens + ) => GenRequest (CaptureAll sym a :> api) gens where + genRequest _ gens = do + captures <- Gen.list (Range.linear 0 10) (getGen @a @gens gens) + makeRequest <- genRequest (Proxy @api) gens + pure $ \baseUrl -> + foldr (prependPath . toUrlPiece) (makeRequest baseUrl) captures + +-- | Instance for headers +-- +-- /Note: this instance currently makes all headers mandatory/ +instance + ( HasGen header gens + , KnownSymbol headerName + , ToHttpApiData header + , GenRequest api gens + ) => GenRequest (Header' mods headerName header :> api) gens where + genRequest _ gens = do + let headerName = CI.mk . cs . symbolVal $ Proxy @headerName + header <- getGen @header @gens gens + makeRequest <- genRequest (Proxy @api) gens + pure $ addHeader headerName (toHeader header) . makeRequest + +-- | Instance for setting query flag +-- +-- /Note: this instance currently makes all query flags mandatory/ +instance + ( KnownSymbol name + , GenRequest api gens + ) => GenRequest (QueryFlag name :> api) gens where + genRequest _ gens = do + let paramName = toUrlPiece . symbolVal $ Proxy @name + makeRequest <- genRequest (Proxy @api) gens + pure $ \baseUrl -> + let + partialReq = makeRequest baseUrl + oldQuery = decodeUtf8 $ queryString partialReq + newQuery = + if Text.null oldQuery then paramName + else paramName <> "&" <> oldQuery + in + partialReq { queryString = encodeUtf8 newQuery } + +-- | Instance for setting query parameters +-- +-- /Note: this instance currently makes all query params mandatory/ +instance + ( KnownSymbol paramName + , ToHttpApiData param + , HasGen param gens + , GenRequest api gens + ) => GenRequest (QueryParam' mods paramName param :> api) gens where + genRequest _ gens = do + queryParam <- toUrlPiece <$> getGen @param @gens gens + + let + paramName = toUrlPiece . symbolVal $ Proxy @paramName + query = paramName <> "=" <> queryParam + + makeRequest <- genRequest (Proxy @api) gens + pure $ \baseUrl -> + let + partialReq = makeRequest baseUrl + oldQuery = decodeUtf8 $ queryString partialReq + newQuery = + if Text.null oldQuery then query + else query <> "&" <> oldQuery + in + partialReq { queryString = encodeUtf8 newQuery } + +-- | Instance for generating query parameters for arrays of values +instance + ( KnownSymbol paramName + , HasGen param gens + , ToHttpApiData param + , GenRequest api gens + ) => GenRequest (QueryParams paramName param :> api) gens where + genRequest _ gens = do + params <- Gen.list (Range.linear 1 20) (getGen @param @gens gens) + + let + paramName = toUrlPiece . symbolVal $ Proxy @paramName + params' = fmap (((paramName <> "[]=") <>) . toUrlPiece) params + queryParams = Text.intercalate "&" params' + + makeRequest <- genRequest (Proxy @api) gens + pure $ \baseUrl -> + let + partialReq = makeRequest baseUrl + oldQuery = decodeUtf8 $ queryString partialReq + newQuery = + if Text.null oldQuery then queryParams + else queryParams <> "&" <> oldQuery + in + partialReq { queryString = encodeUtf8 newQuery } + +-- | Instance for request body +instance + ( AllMimeRender contentTypes body + , HasGen body gens + , GenRequest api gens + ) => GenRequest (ReqBody' mods contentTypes body :> api) gens where + genRequest _ gens = do + newBody <- getGen @body @gens gens + + (contentType, body) <- + Gen.element $ allMimeRender (Proxy @contentTypes) newBody + + makeRequest <- genRequest (Proxy @api) gens + + pure $ setBody body + . addHeader "Content-Type" (renderHeader contentType) + . makeRequest + +-- | Instnace for capturing verb e.g. @POST@ or @GET@ +instance + ( ReflectMethod method + ) => GenRequest (Verb method status contentTypes body) gens where + genRequest _ _ = + pure $ \baseUrl -> defaultRequest + { host = cs . baseUrlHost $ baseUrl + , port = baseUrlPort baseUrl + , secure = baseUrlScheme baseUrl == Https + , method = reflectMethod (Proxy @method) + } + +-- | This instance doees not do anything right now +-- +-- /Note:/ in order to use features provided by this type in the API, you'll +-- need to manually adjust the generated request. +instance + ( GenRequest api gens + ) => GenRequest (BasicAuth x y :> api) gens where + genRequest _ gens = genRequest (Proxy @api) gens + +-- | This instance doees not do anything right now +-- +-- /Note:/ in order to use features provided by this type in the API, you'll +-- need to manually adjust the generated request. +instance + ( GenRequest api gens + ) => GenRequest (HttpVersion :> api) gens where + genRequest _ gens = genRequest (Proxy @api) gens + +-- | This instance doees not do anything right now +-- +-- /Note:/ in order to use features provided by this type in the API, you'll +-- need to manually adjust the generated request. +instance + ( GenRequest api gens + ) => GenRequest (IsSecure :> api) gens where + genRequest _ gens = genRequest (Proxy @api) gens + +-- | This instance doees not do anything right now +-- +-- /Note:/ in order to use features provided by this type in the API, you'll +-- need to manually adjust the generated request. +instance + ( GenRequest api gens + ) => GenRequest (RemoteHost :> api) gens where + genRequest _ gens = genRequest (Proxy @api) gens + +-- | This instance doees not do anything right now +-- +-- /Note:/ in order to use features provided by this type in the API, you'll +-- need to manually adjust the generated request. +instance + ( GenRequest api gens + ) => GenRequest (Vault :> api) gens where + genRequest _ gens = genRequest (Proxy @api) gens + +-- | This instance doees not do anything right now +-- +-- /Note:/ in order to use features provided by this type in the API, you'll +-- need to manually adjust the generated request. +instance + ( GenRequest api gens + ) => GenRequest (WithNamedContext x y api) gens where + genRequest _ gens = genRequest (Proxy @api) gens + +setBody :: LBS.ByteString -> Request -> Request +setBody body oldReq = oldReq { requestBody = RequestBodyLBS body } + +addHeader :: HeaderName -> BS.ByteString -> Request -> Request +addHeader name value oldReq = + let + headers = (name, value) : requestHeaders oldReq + in + oldReq { requestHeaders = headers } + +-- | Helper function for prepending a new URL piece +prependPath :: ConvertibleStrings s BS.ByteString => s -> Request -> Request +prependPath new oldReq = + let + partialUrl = BS.dropWhile (== BS.c2w '/') . path $ oldReq + urlPieces = filter (not . BS.null) [cs new, partialUrl] + in + oldReq { path = "/" <> BS.intercalate "/" urlPieces } diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,10 @@ +module Main (main) where + +import Hedgehog.Main (defaultMain) + +import qualified Test.Hedgehog.Servant as Hedgehog.Servant + +main :: IO () +main = defaultMain + [ Hedgehog.Servant.tests + ] diff --git a/test/Test/Hedgehog/Servant.hs b/test/Test/Hedgehog/Servant.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hedgehog/Servant.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE TemplateHaskell #-} +module Test.Hedgehog.Servant + ( tests + ) where + +import Control.Monad (forM_) +import Data.Aeson (FromJSON, ToJSON, eitherDecode) +import Data.String (IsString) +import Data.Proxy (Proxy(..)) +import Data.Text (Text, splitOn) +import Data.Text.Encoding (decodeUtf8) +import Data.Functor ((<&>)) +import Data.Foldable (find) +import GHC.Generics (Generic) +import Servant.API (Capture, ReqBody, Header, JSON) +import Servant.API (QueryFlag, QueryParam, QueryParams) +import Servant.API (Post) +import Servant.API ((:>), (:<|>)) +import Servant.Client (BaseUrl(..), Scheme(..)) +import Network.HTTP.Client (Request(..), RequestBody(..)) +import Network.HTTP.Types (methodPost) + +import Hedgehog (Gen, Property, PropertyT) +import Hedgehog (annotate, annotateShow, checkParallel, discover, forAll) +import Hedgehog (failure, property, success) +import Hedgehog ((===)) +import qualified Hedgehog.Gen as Gen + +import Hedgehog.Servant (GenRequest(..), GList(..)) + +-- A typical cat: +data Cat = Cat + { name :: Text + , color :: Text + } + deriving stock (Generic) + +-- With ability to go back and forth to JSON: +instance ToJSON Cat +instance FromJSON Cat + +-- And a simple generator to get random values of Cat: +genCat :: Gen Cat +genCat = Cat + <$> Gen.element [ "Kitty", "Misty" ] + <*> Gen.element [ "Red", "Green", "Blue" ] + +-- Here's a simple API that allows posting a Cat in JSON to +-- +-- POST /cats +type SimplestApi = + "my" :> "cats" :> ReqBody '[JSON] Cat :> Post '[JSON] () + +-- Generate a request to the Cat API from a base URL +catRequestGen :: BaseUrl -> Gen Request +catRequestGen baseUrl = + genRequest (Proxy @SimplestApi) (genCat :*: GNil) <&> + \makeReq -> makeReq baseUrl + +defaultBaseUrl :: BaseUrl +defaultBaseUrl = BaseUrl + { baseUrlScheme = Https + , baseUrlHost = "localhost" + , baseUrlPort = 8080 + , baseUrlPath = "" + } + +prop_check_cat_request :: Property +prop_check_cat_request = property $ do + forAll (catRequestGen defaultBaseUrl) >>= propCat + +type CaptureApi = + "cats" :> Capture "pathParam" Text :> Capture "path2" Text :> Post '[JSON] () + +captureGen :: Gen Text -> BaseUrl -> Gen Request +captureGen txt baseUrl = + genRequest (Proxy @CaptureApi) (txt :*: GNil) <&> + \makeReq -> makeReq baseUrl + +prop_check_capture_req :: Property +prop_check_capture_req = + let + pathParam :: IsString a => a + pathParam = "myPathParam" + in + property $ do + req <- forAll $ captureGen (pure pathParam) defaultBaseUrl + propBaseUrl req + method req === methodPost + path req === "/cats/" <> pathParam <> "/" <> pathParam + +-- A typical dog: +data Dog = Dog + { dogName :: Text + , dogHappy :: Bool + } + deriving stock (Generic) + +-- With ability to go back and forth to JSON: +instance ToJSON Dog +instance FromJSON Dog + +-- And a simple generator to get random values of Cat: +genDog :: Gen Dog +genDog = Dog + <$> Gen.element [ "Pluto", "Rowdy" ] + <*> Gen.bool + +type AltApi = + "my" :> "cats" :> ReqBody '[JSON] Cat :> Post '[JSON] () + :<|> "dogs" :> ReqBody '[JSON] Dog :> Post '[JSON] () + +-- Generate a request to the Cat API from a base URL +altRequestGen :: BaseUrl -> Gen Request +altRequestGen baseUrl = + genRequest (Proxy @AltApi) (genCat :*: genDog :*: GNil) <&> + \makeReq -> makeReq baseUrl + +prop_check_alt_api :: Property +prop_check_alt_api = property $ do + req <- forAll (altRequestGen defaultBaseUrl) + case path req of + "/my/cats" -> propCat req + "/dogs" -> propDog req + badPath -> annotate "Bad path" >> annotateShow badPath >> failure + +type HeaderApi = "cats" :> Header "Correlation-Id" Text :> Post '[JSON] () + +headerRequestGen :: BaseUrl -> Gen Request +headerRequestGen baseUrl = + let + textGen :: Gen Text + textGen = pure "some-corr-id" + in + genRequest (Proxy @HeaderApi) (textGen :*: GNil) <&> + \makeReq -> makeReq baseUrl + +prop_has_correlation_id :: Property +prop_has_correlation_id = property $ do + req <- forAll (headerRequestGen defaultBaseUrl) + case find ((== "Correlation-Id") . fst) (requestHeaders req) of + Just _ -> success + Nothing -> failure + +type QueryFlagApi = + "my" :> "cats" :> QueryFlag "foo" :> QueryFlag "fi" :> Post '[JSON] () + +queryFlagGen :: BaseUrl -> Gen Request +queryFlagGen baseUrl = + genRequest (Proxy @QueryFlagApi) GNil <&> + \makeReq -> makeReq baseUrl + +prop_has_query_Flag :: Property +prop_has_query_Flag = property $ do + req <- forAll (queryFlagGen defaultBaseUrl) + queryString req === "foo&fi" + +type QueryParamApi = + "my" :> "cats" :> QueryParam "foo" Text :> QueryParam "fi" Text :> Post '[JSON] () + +queryParamGen :: BaseUrl -> Gen Request +queryParamGen baseUrl = + let + paramGen :: Gen Text + paramGen = pure "bar" + in + genRequest (Proxy @QueryParamApi) (paramGen :*: GNil) <&> + \makeReq -> makeReq baseUrl + +prop_has_query_param :: Property +prop_has_query_param = property $ do + req <- forAll (queryParamGen defaultBaseUrl) + queryString req === "foo=bar&fi=bar" + +type QueryParamsApi = + "my" :> "cats" :> QueryParams "foo" Text :> Post '[JSON] () + +queryParamsGen :: BaseUrl -> Gen Request +queryParamsGen baseUrl = + let + paramGen :: Gen Text + paramGen = pure "bar" + in + genRequest (Proxy @QueryParamsApi) (paramGen :*: GNil) <&> + \makeReq -> makeReq baseUrl + +prop_has_query_params :: Property +prop_has_query_params = property $ do + queryParams <- + decodeUtf8 . queryString <$> + forAll (queryParamsGen defaultBaseUrl) + + forM_ (splitOn "&" queryParams) (=== "foo[]=bar") + +propCat :: Request -> PropertyT IO () +propCat req = do + propBaseUrl req + propContentTypeJson req + propDecodeJson (Proxy @Cat) req + method req === methodPost + path req === "/my/cats" + +propDog :: Request -> PropertyT IO () +propDog req = do + propBaseUrl req + propContentTypeJson req + propDecodeJson (Proxy @Dog) req + method req === methodPost + path req === "/dogs" + + +propBaseUrl :: Request -> PropertyT IO () +propBaseUrl req = do + method req === methodPost + secure req === True + host req === "localhost" + port req === 8080 + +propContentTypeJson :: Request -> PropertyT IO () +propContentTypeJson req = + let + headers = requestHeaders req + in + case find ((== "Content-Type"). fst) headers of + Just _ -> success + Nothing -> do + annotate "Couldn't find \"Content-Type\" header" + annotateShow headers + failure + +propDecodeJson :: forall a. FromJSON a => Proxy a -> Request -> PropertyT IO () +propDecodeJson _ req = + case requestBody req of + RequestBodyLBS (eitherDecode @a -> Right _) -> + success + RequestBodyLBS (eitherDecode @a -> Left err) -> + annotateShow err >> failure + _ -> failure + +tests :: IO Bool +tests = checkParallel $$discover