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,90 @@
+# 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.validateRequestBody settings
+    . OpenApi.validateResponseBody settings
+    . theOtherMiddleware
+
+settings :: OpenApi.Settings
+settings = OpenApi.defaultSettings openApi
+
+-- 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.
+
+## Evaluation
+
+When first implementing this, you probably want to log invalid cases but still
+respond normally.
+
+```hs
+settings :: OpenApi.Settings
+settings = (OpenApi.defaultSettings openApi)
+  { OpenApi.onValidationErrors = {- metrics, logging, etc -}
+  , OpenApi.evaluateOnly = True
+  }
+```
+
+Once you address what you find in the logs, you can disable `evaluateOnly`.
+
+## 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.validateRequestBody settings
+    . OpenApi.validateResponseBody settings
+
+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,96 @@
+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
+    - 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,71 @@
+module Network.Wai.Middleware.OpenApi
+  ( Settings (..)
+  , defaultSettings
+  , ValidationErrors (..)
+  , ValidationError
+  , validateRequestBody
+  , validateResponseBody
+  ) where
+
+import Prelude
+
+import Data.ByteString.Builder (toLazyByteString)
+import Data.ByteString.Lazy qualified as BSL
+import Data.IORef (atomicModifyIORef, newIORef, readIORef)
+import Network.Wai (Middleware, Request, Response)
+import Network.Wai qualified as Wai
+import Network.Wai.Middleware.OpenApi.Schema
+import Network.Wai.Middleware.OpenApi.Settings
+import Network.Wai.Middleware.OpenApi.Validate
+import Network.Wai.Middleware.OpenApi.ValidationError
+
+validateRequestBody :: Settings -> Middleware
+validateRequestBody settings app request respond =
+  validate
+    ValidateOptions
+      { settings
+      , request
+      , schema = lookupRequestSchema settings.spec settings.pathMap request
+      , getBody = getRequestBody request
+      , respondActual = \case
+          Nothing -> app request respond
+          Just newReq -> app newReq respond
+      , respondErrors = respond . clientErrorResponse
+      }
+
+validateResponseBody :: Settings -> Middleware
+validateResponseBody settings app request respond =
+  app request $ \response -> do
+    let status = Wai.responseStatus response
+    validate
+      ValidateOptions
+        { settings
+        , request
+        , schema = lookupResponseSchema status settings.spec settings.pathMap request
+        , getBody = (,()) <$> getResponseBody response
+        , respondActual = \_ -> respond response
+        , respondErrors = respond . serverErrorResponse
+        }
+
+-- | 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>
+getRequestBody :: Request -> IO (BSL.ByteString, Request)
+getRequestBody request = do
+  body <- Wai.strictRequestBody request
+  ref <- newIORef body
+  let
+    newRequestBody = atomicModifyIORef ref (BSL.empty,)
+    newReq = Wai.setRequestBodyChunks (BSL.toStrict <$> newRequestBody) request
+  pure (body, newReq)
+
+-- <https://hackage.haskell.org/package/wai-middleware-validation-0.1.0.2/docs/src/Network.Wai.Middleware.Validation.html#getResponseBody>
+getResponseBody :: Response -> IO BSL.ByteString
+getResponseBody response = 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

@@ -0,0 +1,59 @@
+module Network.Wai.Middleware.OpenApi.PathMap
+  ( PathMap
+  , fromOpenApi
+  , lookup
+  ) where
+
+import Prelude hiding (lookup)
+
+import Control.Lens ((^?))
+import Data.Bifunctor (first)
+import Data.ByteString (ByteString)
+import Data.ByteString.Char8 qualified as BS8
+import Data.HashMap.Strict.InsOrd qualified as IHashMap
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as Map
+import Data.OpenApi (OpenApi, PathItem)
+import Data.OpenApi qualified as OpenApi
+import System.FilePath.Posix qualified as Posix
+
+newtype PathMap = PathMap
+  { unwrap :: Map TemplatedPath PathItem
+  }
+
+fromOpenApi :: OpenApi -> PathMap
+fromOpenApi spec =
+  PathMap $ case spec ^? OpenApi.paths of
+    Nothing -> Map.empty
+    Just ps -> Map.fromList $ map (first toTemplatedPath) $ IHashMap.toList ps
+
+lookup :: ByteString -> PathMap -> Maybe PathItem
+lookup p pm = Map.lookup (toTemplatedPath $ BS8.unpack p) pm.unwrap
+
+newtype TemplatedPath = TemplatedPath
+  { _unwrap :: [TemplatedPathComponent]
+  }
+  deriving stock (Eq, Ord)
+
+toTemplatedPath :: FilePath -> TemplatedPath
+toTemplatedPath =
+  TemplatedPath
+    . map toTemplatedPathComponent
+    . Posix.splitDirectories
+
+data TemplatedPathComponent
+  = Exact FilePath
+  | ParameterValue
+
+instance Eq TemplatedPathComponent where
+  Exact l == Exact r = l == r
+  _ == _ = True
+
+instance Ord TemplatedPathComponent where
+  compare (Exact l) (Exact r) = compare l r
+  compare _ _ = EQ
+
+toTemplatedPathComponent :: FilePath -> TemplatedPathComponent
+toTemplatedPathComponent s
+  | not (null s) && head s == '{' && last s == '}' = ParameterValue
+  | otherwise = Exact s