wai-middleware-openapi (empty) → 0.1.0.0
raw patch · 13 files changed
+1024/−0 lines, 13 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, filepath, hspec, http-media, http-types, insert-ordered-containers, lens, mtl, openapi3, text, wai, wai-extra, wai-middleware-openapi
Files
- CHANGELOG.md +1/−0
- LICENSE +21/−0
- README.md +128/−0
- src/Network/Wai/Middleware/OpenApi.hs +184/−0
- src/Network/Wai/Middleware/OpenApi/PathMap.hs +83/−0
- src/Network/Wai/Middleware/OpenApi/Schema.hs +140/−0
- src/Network/Wai/Middleware/OpenApi/Validate.hs +28/−0
- src/Network/Wai/Middleware/OpenApi/ValidationError.hs +46/−0
- tests/Network/Wai/Middleware/OpenApi/PathMapSpec.hs +90/−0
- tests/Network/Wai/Middleware/OpenApiSpec.hs +70/−0
- tests/Spec.hs +1/−0
- tests/TestApp.hs +131/−0
- wai-middleware-openapi.cabal +101/−0
+ CHANGELOG.md view
@@ -0,0 +1,1 @@+See https://github.com/freckle/wai-middleware-openapi/releases
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2024 Renaissance Learning Inc++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,128 @@+# WAI OpenAPI Middleware++Validates request and response bodies against your service's OpenAPI spec.++This is useful in a non-Servant web application, where OpenAPI specs cannot be+generated from the API implementation itself, and so must be maintained+manually.++## Usage++```hs+import Network.Wai (Middleware)+import Network.Wai.Middleware.OpenApi qualified as OpenApi++middleware :: Middleware+middleware =+ thisMiddleware+ . thatMiddleware+ . OpenApi.validate openApi+ . theOtherMiddleware++-- Defined in your /docs or /openapi.json Handler+openApi :: OpenApi+openApi = undefined+```++Default behavior:++- If a request body is invalid, a 400 is returned+- If a response body is invalid, a 500 is returned+- In both cases, the validation errors are included in the response body++This is useful if you,++1. Are confident your server is currently complying with spec+2. Trust your spec enough to reject all invalid-according-to-it requests+3. Trust your observability to catch the 5xx increase any future+ response-validity bug would cause++If all or some of these are not true, see the next section.++## Configuring++The `validate` function is equivalent to,++```hs+validateRequests defaultOnRequestErrors+ . validateResponses defaultOnResponseErrors+```++Where those "on" functions take the appropriate error type and return a+`Middleware`. The reason it returns a middleware is so that it can decide if it+should take over the response or let it run normally:++```hs+defaultOnRequestErrors :: RequestErrors -> Middleware+defaultOnRequestErrors = \case+ RequestSchemaNotFound {} -> id -- respond normally+ RequestIsNotJson {} -> id+ RequestInvalid _ errs -> \_ _ respond ->+ respond $ clientErrorResponse errs -- respond with an error+```++Implementing and using a function like this would be how you:++1. Decide to error on missing schema, etc+2. Change the shape of of the JSON errors+3. Emit non-JSON errors++## Evaluation++When first implementing this, you probably want to log invalid cases but still+respond normally. To support this use-case, the library ships replacements for+`defaultOn*` that are named `evaluateOn*`. These functions take an action to+apply to the errors (presumably to log them) and then responds normally.++```hs+validateRequests (evaluateOnRequestErrors logIt)+ . validateResponses (evaluateOnResponseErrors logIt)++logIt :: Show e => e -> IO ()+logIt = undefined+```++The action is necessarily `IO` because we're in a WAI middleware context.++## Performance & Sampling++This middleware may add a performance tax depending on the size of your typical+requests, responses, and OpenAPI spec itself. If you are concerned, we recommend+enabling this middleware on a sampling of requests.++For example,++```hs+openApiMiddleware :: OpenApi.Settings -> Middleware+openApiMiddleware settings =+ -- Only validate 20% of requests+ sampledMiddleware 20 $ OpenApi.validate spec++sampledMiddleware :: Int -> Middleware -> Middleware+sampledMiddleware percent m app request respond = do+ roll <- randomRIO (0, 100)+ if percent <= roll+ then m app request respond+ else app request respond+```++> [!NOTE]+> We will likely upstream `sampledMiddleware` to `wai-extra` at some point.++## Release++To trigger a release, merge a commit to `main` that follows [Conventional+Commits][]. In short,++- `fix:` to trigger a patch release+- `feat:` to trigger a minor release+- `<type>!:` or use a `BREAKING CHANGE:` footer to trigger a major release++We don't enforce conventional commits generally (though you are free do so),+it's only required if you want to trigger release.++[conventional commits]: https://www.conventionalcommits.org/en/v1.0.0/#summary++---++[CHANGELOG](./CHANGELOG.md) | [LICENSE](./LICENSE)
+ src/Network/Wai/Middleware/OpenApi.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE CPP #-}++module Network.Wai.Middleware.OpenApi+ ( validate+ , RequestErrors (..)+ , ResponseErrors (..)+ , SchemaNotFound (..)+ , ValidationErrors (..)+ , validateRequests+ , defaultOnRequestErrors+ , evaluateOnRequestErrors+ , validateResponses+ , defaultOnResponseErrors+ , evaluateOnResponseErrors+ ) where++import Prelude++import Control.Lens ((^.))+import Control.Monad.Except+import Control.Monad.State+import Data.Aeson (Value, eitherDecode)+import Data.ByteString.Builder (toLazyByteString)+import Data.ByteString.Lazy qualified as BSL+import Data.IORef (atomicModifyIORef, newIORef, readIORef)+import Data.List.NonEmpty qualified as NE+import Data.OpenApi (Definitions, OpenApi, Schema)+import Data.OpenApi qualified as OpenApi+import Network.Wai (Middleware, Request, Response)+import Network.Wai qualified as Wai+import Network.Wai.Middleware.OpenApi.PathMap qualified as PathMap+import Network.Wai.Middleware.OpenApi.Schema+import Network.Wai.Middleware.OpenApi.Validate+import Network.Wai.Middleware.OpenApi.ValidationError++#if !MIN_VERSION_mtl(2, 3, 1)+-- <https://hackage-content.haskell.org/package/mtl-2.3.2/docs/src/Control.Monad.Error.Class.html#modifyError>+modifyError :: MonadError e' m => (e -> e') -> ExceptT e m a -> m a+modifyError f m = runExceptT m >>= either (throwError . f) pure+#endif++-- | Validate using 'defaultOnRequestErrors' and 'defaultOnResponseErrors'+validate :: OpenApi -> Middleware+validate spec =+ validateRequests spec defaultOnRequestErrors+ . validateResponses spec defaultOnResponseErrors++data RequestErrors+ = -- | The OpenAPI spec doesn't contain a schema for this request+ --+ -- The 'SchemaNotFound' component will attempt to describe what about the+ -- request and/or spec prevented finding schema.+ RequestSchemaNotFound SchemaNotFound+ | -- | The request was not JSON+ --+ -- Components are the raw body and error.+ RequestIsNotJson BSL.ByteString String+ | -- | The request was considered invalid+ --+ -- Components are parsed body and errors.+ RequestInvalid Value ValidationErrors+ deriving stock (Show)++defaultOnRequestErrors :: RequestErrors -> Middleware+defaultOnRequestErrors = \case+ RequestSchemaNotFound {} -> id+ RequestIsNotJson {} -> id+ RequestInvalid _ errs -> \_ _ respond ->+ respond $ clientErrorResponse errs++-- | Run the given action and proceed normally+evaluateOnRequestErrors+ :: (RequestErrors -> IO ()) -> RequestErrors -> Middleware+evaluateOnRequestErrors f errs app request respond = do+ f errs+ app request respond++data ResponseErrors+ = -- | The OpenAPI spec doesn't contain a schema for this response+ ResponseSchemaNotFound SchemaNotFound+ | -- | The response was not JSON+ --+ -- Components are the raw body and error.+ ResponseIsNotJson BSL.ByteString String+ | -- | The response was considered invalid+ --+ -- Components are parsed body and errors.+ ResponseInvalid Value ValidationErrors+ deriving stock (Show)++defaultOnResponseErrors :: ResponseErrors -> Middleware+defaultOnResponseErrors = \case+ ResponseSchemaNotFound {} -> id+ ResponseIsNotJson {} -> id+ ResponseInvalid _ errs -> \_ _ respond ->+ respond $ serverErrorResponse errs++-- | Run the given action and proceed normally+evaluateOnResponseErrors+ :: (ResponseErrors -> IO ()) -> ResponseErrors -> Middleware+evaluateOnResponseErrors f errs app request respond = do+ f errs+ app request respond++validateRequests :: OpenApi -> (RequestErrors -> Middleware) -> Middleware+validateRequests spec onErrors app request0 respond = do+ result <- runValidateT request0 $ do+ schema <-+ modifyError RequestSchemaNotFound+ $ lookupRequestSchema spec pathMap+ bytes <- previewRequestBody+ body <- decodeBody RequestIsNotJson bytes+ validateBody RequestInvalid definitions schema body++ case result of+ (Left errs, request1) -> onErrors errs app request1 respond+ (Right (), request1) -> app request1 respond+ where+ pathMap = PathMap.fromOpenApi spec+ definitions = spec ^. OpenApi.components . OpenApi.schemas++validateResponses :: OpenApi -> (ResponseErrors -> Middleware) -> Middleware+validateResponses spec onErrors app request0 respond = do+ app request0 $ \response -> do+ result <- runValidateT request0 $ do+ let status = Wai.responseStatus response+ schema <-+ modifyError ResponseSchemaNotFound+ $ lookupResponseSchema status spec pathMap+ bytes <- getResponseBody response+ body <- decodeBody ResponseIsNotJson bytes+ validateBody ResponseInvalid definitions schema body++ case result of+ (Left errs, request1) -> onErrors errs app request1 respond+ (Right (), _) -> respond response+ where+ pathMap = PathMap.fromOpenApi spec+ definitions = spec ^. OpenApi.components . OpenApi.schemas++decodeBody+ :: MonadError e m+ => (BSL.ByteString -> String -> e)+ -> BSL.ByteString+ -> m Value+decodeBody toError bytes =+ either (throwError . toError bytes) pure $ eitherDecode bytes++validateBody+ :: MonadError e m+ => (Value -> ValidationErrors -> e)+ -> Definitions Schema+ -> Schema+ -> Value+ -> m ()+validateBody toError definitions schema body =+ maybe (pure ()) (throwError . toError body . ValidationErrors)+ . NE.nonEmpty+ $ OpenApi.validateJSON definitions schema body++-- | Strictly consume the request body, then mark it as un-consumed+--+-- <https://hackage.haskell.org/package/wai-middleware-validation-0.1.0.2/docs/src/Network.Wai.Middleware.Validation.html#getRequestBody>+previewRequestBody :: (MonadIO m, MonadState Request m) => m BSL.ByteString+previewRequestBody = do+ request <- get+ body <- liftIO $ Wai.strictRequestBody request+ ref <- liftIO $ newIORef body++ -- Update request to mark body as un-consumed+ let newRequestBody = atomicModifyIORef ref (BSL.empty,)+ put $ Wai.setRequestBodyChunks (BSL.toStrict <$> newRequestBody) request++ pure body++getResponseBody :: MonadIO m => Response -> m BSL.ByteString+getResponseBody response = liftIO $ withBody $ \streamingBody -> do+ ref <- newIORef mempty+ streamingBody+ (\b -> atomicModifyIORef ref $ \acc -> (acc <> b, ()))+ (pure ())+ toLazyByteString <$> readIORef ref+ where+ (_, _, withBody) = Wai.responseToStream response
+ src/Network/Wai/Middleware/OpenApi/PathMap.hs view
@@ -0,0 +1,83 @@+module Network.Wai.Middleware.OpenApi.PathMap+ ( PathMap+ , fromOpenApi+ , lookup+ ) where++import Prelude hiding (lookup)++import Control.Applicative ((<|>))+import Control.Lens ((^?))+import Control.Monad (guard)+import Data.Bifunctor (first)+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as BS8+import Data.Function (on)+import Data.HashMap.Strict.InsOrd qualified as IOHM+import Data.List (find)+import Data.List.NonEmpty (nonEmpty)+import Data.List.NonEmpty qualified as NE+import Data.Maybe (fromMaybe)+import Data.OpenApi (OpenApi, PathItem)+import Data.OpenApi qualified as OpenApi+import System.FilePath.Posix qualified as Posix++newtype PathMap = PathMap+ { unwrap :: [(TemplatedPath, PathItem)]+ }++fromOpenApi :: OpenApi -> PathMap+fromOpenApi spec =+ PathMap $ case spec ^? OpenApi.paths of+ Nothing -> []+ Just ps -> map (first toTemplatedPath) $ IOHM.toList ps++lookup :: ByteString -> PathMap -> Maybe PathItem+lookup bs pm =+ fmap snd $ find (matchExact tp . fst) ps <|> find (matchTemplated tp . fst) ps+ where+ tp = toTemplatedPath $ BS8.unpack bs+ ps = pm.unwrap++matchExact :: TemplatedPath -> TemplatedPath -> Bool+matchExact = matchComponents (==) `on` (.unwrap)++matchTemplated :: TemplatedPath -> TemplatedPath -> Bool+matchTemplated = matchComponents go `on` (.unwrap)+ where+ go = curry $ \case+ (Exact l, Exact r) -> l == r+ (ParameterValue, _) -> True+ (_, ParameterValue) -> True++newtype TemplatedPath = TemplatedPath+ { unwrap :: [TemplatedPathComponent]+ }+ deriving stock (Eq)++toTemplatedPath :: FilePath -> TemplatedPath+toTemplatedPath =+ TemplatedPath+ . map toTemplatedPathComponent+ . Posix.splitDirectories++data TemplatedPathComponent+ = Exact FilePath+ | ParameterValue+ deriving stock (Eq)++toTemplatedPathComponent :: FilePath -> TemplatedPathComponent+toTemplatedPathComponent s = fromMaybe (Exact s) $ do+ ne <- nonEmpty s+ guard $ NE.head ne == '{'+ guard $ NE.last ne == '}'+ pure ParameterValue++matchComponents+ :: (TemplatedPathComponent -> TemplatedPathComponent -> Bool)+ -> [TemplatedPathComponent]+ -> [TemplatedPathComponent]+ -> Bool+matchComponents f as bs+ | length as /= length bs = False+ | otherwise = and $ zipWith f as bs
+ src/Network/Wai/Middleware/OpenApi/Schema.hs view
@@ -0,0 +1,140 @@+module Network.Wai.Middleware.OpenApi.Schema+ ( SchemaNotFound (..)+ , lookupRequestSchema+ , lookupResponseSchema+ ) where++import Prelude++import Control.Applicative (asum)+import Control.Lens (Lens', ix, to, (^?), _Just)+import Control.Monad.Except+import Control.Monad.State+import Data.ByteString (ByteString)+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)+import Data.Maybe (fromMaybe)+import Data.OpenApi+ ( Components+ , Definitions+ , HasContent+ , MediaTypeObject+ , OpenApi+ , Operation+ , PathItem+ , Referenced+ , Schema+ )+import Data.OpenApi qualified as OpenApi+import Data.OpenApi.Schema.Generator qualified as OpenApi (dereference)+import Network.HTTP.Media (MediaType)+import Network.HTTP.Types.Method (StdMethod (..), parseMethod)+import Network.HTTP.Types.Status (Status, statusCode)+import Network.Wai (Request)+import Network.Wai qualified as Wai+import Network.Wai.Middleware.OpenApi.PathMap (PathMap)+import Network.Wai.Middleware.OpenApi.PathMap qualified as PathMap++data SchemaNotFound+ = -- | The OpenAPI spec doesn't have this path at all+ MissingPath ByteString+ | -- | The specified path does not have this operation (method)+ MissingOperation ByteString+ | -- | The specified operation defines no request body+ MissingRequestBody+ | -- | The specified operation defines no response for this status+ MissingResponseStatus Status+ | -- | The specified body or response defines no JSON content+ --+ -- We are only able to validate JSON schema. If you are configuring things+ -- such that 'SchemaNotFound' are errors, you likely still want to avoid+ -- erroring on this one.+ MissingContentTypeJson+ deriving stock (Show)++lookupRequestSchema+ :: (MonadError SchemaNotFound m, MonadState Request m)+ => OpenApi+ -> PathMap+ -> m Schema+lookupRequestSchema spec =+ lookupOperationSchema spec $ \operation -> do+ note MissingRequestBody+ $ operation+ ^? OpenApi.requestBody+ . _Just+ . to (dereference spec OpenApi.requestBodies)++lookupResponseSchema+ :: (MonadError SchemaNotFound m, MonadState Request m)+ => Status+ -> OpenApi+ -> PathMap+ -> m Schema+lookupResponseSchema status spec =+ lookupOperationSchema spec $ \operation -> do+ ref <- note (MissingResponseStatus status) $ do+ responses <- operation ^? OpenApi.responses+ asum+ [ responses ^? ix (statusCode status)+ , responses ^? OpenApi.default_ . _Just+ ]+ pure $ dereference spec OpenApi.responses ref++lookupOperationSchema+ :: ( HasContent body (InsOrdHashMap MediaType MediaTypeObject)+ , MonadError SchemaNotFound m+ , MonadState Request m+ )+ => OpenApi+ -> (Operation -> m body)+ -> PathMap+ -> m Schema+lookupOperationSchema spec getBody pathMap = do+ request <- get+ pathItem <- getPathItem request pathMap+ operation <- getOperation request pathItem+ body <- getBody operation+ note MissingContentTypeJson+ $ body+ ^? OpenApi.content+ . ix "application/json"+ . OpenApi.schema+ . _Just+ . to (dereference spec OpenApi.schemas)++getPathItem+ :: MonadError SchemaNotFound m+ => Request+ -> PathMap+ -> m PathItem+getPathItem request = note (MissingPath path) . PathMap.lookup path+ where+ path = Wai.rawPathInfo request++getOperation+ :: MonadError SchemaNotFound m+ => Request+ -> PathItem+ -> m Operation+getOperation request pathItem =+ note (MissingOperation method) $ case parseMethod method of+ Right DELETE -> pathItem ^? OpenApi.delete . _Just+ Right GET -> pathItem ^? OpenApi.get . _Just+ Right PATCH -> pathItem ^? OpenApi.patch . _Just+ Right POST -> pathItem ^? OpenApi.post . _Just+ Right PUT -> pathItem ^? OpenApi.put . _Just+ Right HEAD -> Nothing+ Right TRACE -> Nothing+ Right CONNECT -> Nothing+ Right OPTIONS -> Nothing+ Left _ -> Nothing+ where+ method = Wai.requestMethod request++dereference :: OpenApi -> Lens' Components (Definitions a) -> Referenced a -> a+dereference spec componentL = OpenApi.dereference definitions+ where+ definitions = fromMaybe mempty $ spec ^? OpenApi.components . componentL++note :: MonadError e m => e -> Maybe a -> m a+note e = maybe (throwError e) pure
+ src/Network/Wai/Middleware/OpenApi/Validate.hs view
@@ -0,0 +1,28 @@+module Network.Wai.Middleware.OpenApi.Validate+ ( ValidateT (..)+ , runValidateT+ ) where++import Prelude++import Control.Monad.Except+import Control.Monad.State+import Network.Wai (Request)++newtype ValidateT e m a = ValidateT+ { unwrap :: ExceptT e (StateT Request m) a+ }+ deriving newtype+ ( Applicative+ , Functor+ , Monad+ , MonadError e+ , MonadIO+ , MonadState Request+ )++runValidateT+ :: Request+ -> ValidateT e m a+ -> m (Either e a, Request)+runValidateT request f = runStateT (runExceptT f.unwrap) request
+ src/Network/Wai/Middleware/OpenApi/ValidationError.hs view
@@ -0,0 +1,46 @@+module Network.Wai.Middleware.OpenApi.ValidationError+ ( ValidationErrors (..)++ -- * JSON error responses+ , Error (..)+ , clientErrorResponse+ , serverErrorResponse+ , errorResponse+ ) where++import Prelude++import Data.Aeson (ToJSON, encode)+import Data.List.NonEmpty (NonEmpty)+import Data.OpenApi.Schema.Validation qualified as OpenApi+import Data.Text (Text, pack)+import GHC.Generics (Generic)+import Network.HTTP.Types.Header (hContentType)+import Network.HTTP.Types.Status (Status, status400, status500)+import Network.Wai (Response, responseLBS)++newtype ValidationErrors = ValidationErrors+ { unwrap :: NonEmpty OpenApi.ValidationError+ }+ deriving newtype (Show)++data Error = Error+ { message :: Text+ , details :: NonEmpty Text+ }+ deriving stock (Generic)+ deriving anyclass (ToJSON)++clientErrorResponse :: ValidationErrors -> Response+clientErrorResponse errors =+ errorResponse status400 "Bad Request" $ pack <$> errors.unwrap++serverErrorResponse :: ValidationErrors -> Response+serverErrorResponse errors =+ errorResponse status500 "Internal Server Error" $ pack <$> errors.unwrap++errorResponse :: Status -> Text -> NonEmpty Text -> Response+errorResponse status msg =+ responseLBS status [(hContentType, "application/json")]+ . encode+ . Error msg
+ tests/Network/Wai/Middleware/OpenApi/PathMapSpec.hs view
@@ -0,0 +1,90 @@+module Network.Wai.Middleware.OpenApi.PathMapSpec+ ( spec+ ) where++import Prelude++import Control.Arrow ((&&&))+import Control.Lens ((&), (.~), (?~))+import Data.HashMap.Strict.InsOrd qualified as IOHM+import Data.OpenApi (OpenApi, PathItem)+import Data.OpenApi qualified as OpenApi+import Data.Text (pack)+import Network.Wai.Middleware.OpenApi.PathMap qualified as PathMap+import Test.Hspec++spec :: Spec+spec = do+ describe "lookup" $ do+ specify "OpenApi precedence example" $ do+ let pathMap =+ PathMap.fromOpenApi+ $ testOpenApi+ [ "/pets/{petId}"+ , "/pets/mine"+ ]++ PathMap.lookup "/pets/42" pathMap+ `shouldBe` Just (testPathItem "/pets/{petId}")++ PathMap.lookup "/pets/mine" pathMap+ `shouldBe` Just (testPathItem "/pets/mine")++ specify "Chris' example" $ do+ let pathMap =+ PathMap.fromOpenApi+ $ testOpenApi+ [ "/book/{bookId}/cover"+ , "/book/{bookId}/text"+ , "/{resource}/{resourceId}/text"+ , "/{resource}/{resourceId}/ratings"+ ]++ PathMap.lookup "/book/5/text" pathMap+ `shouldBe` Just (testPathItem "/book/{bookId}/text")++ PathMap.lookup "/article/5/text" pathMap+ `shouldBe` Just (testPathItem "/{resource}/{resourceId}/text")++ -- Chris says s/b Nothing+ -- Spec says s/b (4)+ -- Naive implementation, apparently, agrees with spec+ PathMap.lookup "/book/5/ratings" pathMap+ `shouldBe` Just (testPathItem "/{resource}/{resourceId}/ratings")++ -- These tests are to show what happens, but the spec says its ambiguous so+ -- if we do something to the implementation that breaks these, that's OK.+ context "ambiguous according to spec" $ do+ specify "books" $ do+ let pathMap =+ PathMap.fromOpenApi+ $ testOpenApi+ [ "/{entity}/me"+ , "/books/{id}"+ ]++ PathMap.lookup "/books/5" pathMap+ `shouldBe` Just (testPathItem "/books/{id}")++ PathMap.lookup "/books/me" pathMap+ `shouldBe` Just (testPathItem "/{entity}/me")++ specify "pet-stores" $ do+ let pathMap =+ PathMap.fromOpenApi+ $ testOpenApi+ [ "/pet-stores/{petStoreId}/pets/mine"+ , "/pet-stores/{petStoreId}/pets/{petId}"+ ]++ PathMap.lookup "/pet-stores/5/pets/3" pathMap+ `shouldBe` Just (testPathItem "/pet-stores/{petStoreId}/pets/{petId}")++ PathMap.lookup "/pet-stores/5/pets/mine" pathMap+ `shouldBe` Just (testPathItem "/pet-stores/{petStoreId}/pets/mine")++testOpenApi :: [String] -> OpenApi+testOpenApi ps = mempty & OpenApi.paths .~ IOHM.fromList (map (id &&& testPathItem) ps)++testPathItem :: String -> PathItem+testPathItem p = mempty & OpenApi.summary ?~ pack p
+ tests/Network/Wai/Middleware/OpenApiSpec.hs view
@@ -0,0 +1,70 @@+module Network.Wai.Middleware.OpenApiSpec+ ( spec+ ) where++import Prelude++import Data.Aeson (encode)+import Network.Wai+import Network.Wai.Middleware.OpenApi qualified as OpenApi+import Network.Wai.Test hiding (request)+import Test.Hspec+import TestApp++spec :: Spec+spec = do+ let+ app :: Application+ app = OpenApi.validate testOpenApi testApp++ describe "validate requests" $ do+ let request = (setPath defaultRequest "/tests") {requestMethod = "POST"}++ it "responds 400 for invalid request bodies" $ do+ withSession app $ do+ sresponse <-+ srequest+ $ SRequest+ { simpleRequest = request+ , simpleRequestBody = "{}"+ }++ assertStatus 400 sresponse++ it "passes through valid bodies" $ do+ withSession app $ do+ sresponse <-+ srequest+ $ SRequest+ { simpleRequest = request+ , simpleRequestBody = encode $ NewTest "foo"+ }++ assertStatus 201 sresponse+ assertBody (encode $ OK True) sresponse++ describe "validate responses" $ do+ it "responds 500 for invalid response bodies" $ do+ let request = setPath defaultRequest "/tests/42" -- broken+ withSession app $ do+ sresponse <-+ srequest+ $ SRequest+ { simpleRequest = request+ , simpleRequestBody = ""+ }++ assertStatus 500 sresponse++ it "passes through valid bodies" $ do+ let request = setPath defaultRequest "/tests/99"+ withSession app $ do+ sresponse <-+ srequest+ $ SRequest+ { simpleRequest = request+ , simpleRequestBody = ""+ }++ assertStatus 200 sresponse+ assertBody (encode $ Test "99") sresponse
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -Wno-missing-export-lists #-}
+ tests/TestApp.hs view
@@ -0,0 +1,131 @@+module TestApp+ ( NewTest (..)+ , Test (..)+ , OK (..)+ , testApp+ , testOpenApi+ ) where++import Prelude++import Control.Lens (at, (&), (.~), (?~))+import Data.Aeson (FromJSON, ToJSON, encode)+import Data.HashMap.Strict.InsOrd qualified as IOHM+import Data.OpenApi (OpenApi, ToSchema, declareSchemaRef)+import Data.OpenApi qualified as OpenApi+import Data.OpenApi.Declare (evalDeclare, looks)+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import GHC.Generics (Generic)+import Network.HTTP.Types.Header (hContentType)+import Network.HTTP.Types.Method (Method)+import Network.HTTP.Types.Status+ ( Status+ , status200+ , status201+ , status404+ , status405+ )+import Network.Wai++newtype NewTest = NewTest+ { name :: Text+ }+ deriving stock (Generic)+ deriving anyclass (FromJSON, ToJSON, ToSchema)++newtype Test = Test+ { name :: Text+ }+ deriving stock (Generic)+ deriving anyclass (FromJSON, ToJSON, ToSchema)++newtype OK = OK+ { ok :: Bool+ }+ deriving stock (Generic)+ deriving anyclass (FromJSON, ToJSON, ToSchema)++testApp :: Application+testApp request respond =+ respond $ dispatch (pathInfo request) (requestMethod request)++dispatch :: [Text] -> Method -> Response+dispatch = \case+ ["tests"] -> dispatchTests+ ["tests", x] -> dispatchTest x+ _ -> const response404++dispatchTests :: Method -> Response+dispatchTests = \case+ "POST" -> responseJSON status201 $ OK True+ _ -> response405++dispatchTest :: Text -> Method -> Response+dispatchTest name = \case+ "GET" -> case name of+ "42" -> responseLBS status200 [] "{}" -- invalid+ _ -> responseJSON status200 $ Test name+ _ -> response405++responseJSON :: ToJSON a => Status -> a -> Response+responseJSON status =+ responseLBS status [(hContentType, "application/json")] . encode++response404 :: Response+response404 = responseLBS status404 [] "Not Found"++response405 :: Response+response405 = responseLBS status405 [] "Bad Method"++testOpenApi :: OpenApi+testOpenApi = flip evalDeclare mempty $ do+ newTestRef <- declareSchemaRef $ Proxy @NewTest+ testRef <- declareSchemaRef $ Proxy @Test+ okRef <- declareSchemaRef $ Proxy @OK++ looks $ \d ->+ mempty+ & OpenApi.components . OpenApi.schemas .~ d+ & OpenApi.components . OpenApi.requestBodies+ .~ IOHM.fromList+ [+ ( "Test"+ , mempty+ & OpenApi.content . at "application/json"+ ?~ (mempty & OpenApi.schema ?~ newTestRef)+ )+ ]+ & OpenApi.paths+ .~ IOHM.fromList+ [+ ( "/tests"+ , mempty+ & OpenApi.post+ ?~ ( mempty+ & OpenApi.requestBody+ ?~ OpenApi.Ref (OpenApi.Reference "Test")+ & at 201+ ?~ ( "OK"+ & OpenApi._Inline+ . OpenApi.content+ . at "application/json"+ ?~ (mempty & OpenApi.schema ?~ okRef)+ )+ )+ )+ ,+ ( "/tests/{name}"+ , mempty+ & OpenApi.get+ ?~ ( mempty+ & at 200+ ?~ ( "OK"+ & OpenApi._Inline+ . OpenApi.content+ . at "application/json"+ ?~ (mempty & OpenApi.schema ?~ testRef)+ )+ )+ )+ ]
+ wai-middleware-openapi.cabal view
@@ -0,0 +1,101 @@+cabal-version: 1.18+name: wai-middleware-openapi+version: 0.1.0.0+license: MIT+license-file: LICENSE+maintainer: Freckle Education+synopsis: TODO+description: TODO+category: Web+build-type: Simple+extra-doc-files:+ README.md+ CHANGELOG.md++library+ exposed-modules:+ Network.Wai.Middleware.OpenApi+ Network.Wai.Middleware.OpenApi.PathMap+ Network.Wai.Middleware.OpenApi.Schema+ Network.Wai.Middleware.OpenApi.Validate+ Network.Wai.Middleware.OpenApi.ValidationError++ hs-source-dirs: src+ other-modules: Paths_wai_middleware_openapi+ default-language: GHC2021+ default-extensions:+ DataKinds DeriveAnyClass DerivingStrategies DerivingVia+ DuplicateRecordFields GADTs LambdaCase NoFieldSelectors+ NoImplicitPrelude NoMonomorphismRestriction NoPostfixOperators+ OverloadedRecordDot OverloadedStrings QuasiQuotes TypeFamilies++ ghc-options:+ -Weverything -Wno-all-missed-specialisations+ -Wno-missed-specialisations -Wno-missing-exported-signatures+ -Wno-missing-import-lists -Wno-missing-local-signatures+ -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction+ -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe++ build-depends:+ aeson >=2.0.3.0,+ base >=4.16.4.0 && <5,+ bytestring >=0.11.4.0,+ filepath >=1.4.2.2,+ http-media >=0.8.0.0,+ http-types >=0.12.3,+ insert-ordered-containers >=0.2.5.2,+ lens >=5.1.1,+ mtl >=2.2.2,+ openapi3 >=3.2.3,+ text >=1.2.5.0,+ wai >=3.2.4++ if impl(ghc >=9.8)+ ghc-options: -Wno-missing-role-annotations++ if impl(ghc >=9.2)+ ghc-options: -Wno-missing-kind-signatures++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: tests+ other-modules:+ Network.Wai.Middleware.OpenApi.PathMapSpec+ Network.Wai.Middleware.OpenApiSpec+ TestApp+ Paths_wai_middleware_openapi++ default-language: GHC2021+ default-extensions:+ DataKinds DeriveAnyClass DerivingStrategies DerivingVia+ DuplicateRecordFields GADTs LambdaCase NoFieldSelectors+ NoImplicitPrelude NoMonomorphismRestriction NoPostfixOperators+ OverloadedRecordDot OverloadedStrings QuasiQuotes TypeFamilies++ ghc-options:+ -Weverything -Wno-all-missed-specialisations+ -Wno-missed-specialisations -Wno-missing-exported-signatures+ -Wno-missing-import-lists -Wno-missing-local-signatures+ -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction+ -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe -threaded+ -rtsopts -with-rtsopts=-N++ build-depends:+ aeson >=2.0.3.0,+ base >=4.16.4.0 && <5,+ hspec >=2.9.7,+ http-types >=0.12.3,+ insert-ordered-containers >=0.2.5.2,+ lens >=5.1.1,+ openapi3 >=3.2.3,+ text >=1.2.5.0,+ wai >=3.2.4,+ wai-extra >=3.1.13.0,+ wai-middleware-openapi++ if impl(ghc >=9.8)+ ghc-options: -Wno-missing-role-annotations++ if impl(ghc >=9.2)+ ghc-options: -Wno-missing-kind-signatures