First version

.gitignore

@@ -0,0 +1 @@
+.stack-work

LICENSE

@@ -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

@@ -0,0 +1,114 @@
+# 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.
+
+---
+
+[CHANGELOG](./CHANGELOG.md) | [LICENSE](./LICENSE)

package.yaml

@@ -0,0 +1,97 @@
+name: wai-middleware-openapi
+version: 0.0.0.0
+maintainer: Freckle Education
+category: Web
+synopsis: TODO
+description: TODO
+
+extra-doc-files:
+  - README.md
+  - CHANGELOG.md
+
+ghc-options:
+  - -Weverything
+  - -Wno-all-missed-specialisations
+  - -Wno-missed-specialisations
+  - -Wno-missing-exported-signatures # re-enables missing-signatures
+  - -Wno-missing-import-lists
+  - -Wno-missing-local-signatures
+  - -Wno-monomorphism-restriction
+  - -Wno-safe
+  - -Wno-unsafe
+
+when:
+  - condition: "impl(ghc >= 9.2)"
+    ghc-options:
+      - -Wno-missing-kind-signatures
+  - condition: "impl(ghc >= 8.10)"
+    ghc-options:
+      - -Wno-missing-safe-haskell-mode
+      - -Wno-prepositive-qualified-module
+
+dependencies:
+  - base < 5
+
+language: GHC2021
+
+default-extensions:
+  - DataKinds
+  - DeriveAnyClass
+  - DerivingStrategies
+  - DerivingVia
+  - DuplicateRecordFields
+  - GADTs
+  - LambdaCase
+  - NoFieldSelectors
+  - NoImplicitPrelude
+  - NoMonomorphismRestriction
+  - NoPostfixOperators
+  - OverloadedRecordDot
+  - OverloadedStrings
+  - QuasiQuotes
+  - TypeFamilies
+
+library:
+  source-dirs: src
+  dependencies:
+    - aeson
+    - bytestring
+    - containers
+    - filepath
+    - http-types
+    - insert-ordered-containers
+    - lens
+    - mtl
+    - openapi3
+    - text
+    - wai
+
+tests:
+  spec:
+    main: Spec.hs
+    source-dirs: tests
+    ghc-options: -threaded -rtsopts "-with-rtsopts=-N"
+    dependencies:
+      - aeson
+      - hspec
+      - http-types
+      - insert-ordered-containers
+      - lens
+      - openapi3
+      - text
+      - wai
+      - wai-extra
+      - wai-middleware-openapi
+
+  # readme:
+  #   main: README.lhs
+  #   ghc-options: -pgmL markdown-unlit
+  #   dependencies:
+  #     - Blammo
+  #     - amazonka-core
+  #     - amazonka-mtl
+  #     - amazonka-s3
+  #     - conduit
+  #     - lens
+  #     - markdown-unlit
+  #     - mtl

src/Network/Wai/Middleware/OpenApi.hs

@@ -0,0 +1,159 @@
+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
+
+-- | Validate using 'defaultOnRequestErrors' and 'defaultOnResponseErrors'
+validate :: OpenApi -> Middleware
+validate spec =
+  validateRequests spec defaultOnRequestErrors
+    . validateResponses spec defaultOnResponseErrors
+
+data RequestErrors
+  = RequestSchemaNotFound SchemaNotFound
+  | RequestIsNotJson BSL.ByteString String
+  | 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
+  = ResponseSchemaNotFound SchemaNotFound
+  | ResponseIsNotJson BSL.ByteString String
+  | 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