diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Change log + +## 0.1.0.0 + +Initial release diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,23 @@ +[The MIT License (MIT)][] + +Copyright (c) 2020 Jason Shipman + +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. + +[The MIT License (MIT)]: https://opensource.org/licenses/MIT diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,14 @@ +# [context-wai-middleware][] + +[![Version badge][]][version] + +🚧 This README is under construction and could use some love. 🚧 + +`context-wai-middleware` supports adding request-specific (or not!) context to +your WAI applications. + +See the Haddocks for more info on the library. + +[context-wai-middleware]: https://github.com/jship/context +[Version badge]: https://img.shields.io/hackage/v/context-wai-middleware?color=brightgreen&label=version&logo=haskell +[version]: https://hackage.haskell.org/package/context-wai-middleware diff --git a/context-wai-middleware.cabal b/context-wai-middleware.cabal new file mode 100644 --- /dev/null +++ b/context-wai-middleware.cabal @@ -0,0 +1,71 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 402f8eded58ae9b921e8d899368a09ce17ec0777f49fb810766e91cdaeb4e7f4 + +name: context-wai-middleware +version: 0.1.0.0 +synopsis: Add request-specific (or not!) context to your WAI applications +description: Add request-specific (or not!) context to your WAI applications. +category: Web +homepage: https://github.com/jship/context#readme +bug-reports: https://github.com/jship/context/issues +author: Jason Shipman +maintainer: Jason Shipman +copyright: 2020 (c) Jason Shipman +license: MIT +license-file: LICENSE.md +build-type: Simple +extra-source-files: + CHANGELOG.md + LICENSE.md + package.yaml + README.md + +source-repository head + type: git + location: https://github.com/jship/context + subdir: context-wai-middleware + +library + exposed-modules: + Network.Wai.Middleware.Context + other-modules: + Paths_context_wai_middleware + hs-source-dirs: + library + ghc-options: -Wall -fwarn-tabs -Wincomplete-uni-patterns -Wredundant-constraints + build-depends: + base >=4.12 && <5 + , context >=0.1.0.0 && <0.2 + , wai >=3.0.3.0 && <3.3 + default-language: Haskell2010 + +test-suite context-wai-middleware-test-suite + type: exitcode-stdio-1.0 + main-is: Driver.hs + other-modules: + Test.Network.Wai.Middleware.ContextSpec + Paths_context_wai_middleware + hs-source-dirs: + test-suite + ghc-options: -Wall -fwarn-tabs -Wincomplete-uni-patterns -Wredundant-constraints + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + async + , base + , bytestring + , case-insensitive + , context + , context-wai-middleware + , hspec + , http-client + , http-types + , stm + , wai + , warp + default-language: Haskell2010 diff --git a/library/Network/Wai/Middleware/Context.hs b/library/Network/Wai/Middleware/Context.hs new file mode 100644 --- /dev/null +++ b/library/Network/Wai/Middleware/Context.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Network.Wai.Middleware.Context + ( -- * Middlewares + -- ** Request-specific + addRequestContext + , addRequestContextMay + + -- ** General + , addContext + ) where + +import Prelude +import qualified Context +import qualified Network.Wai as Wai + +-- | Register request-specific context into the provided 'Context.Store', for +-- subsequent use in your 'Wai.Application'. This middleware expects to be able +-- to build a context value from every request. Use the 'addRequestContextMay' +-- variant in your application instead if only some requests will result in a +-- context value. +-- +-- Endpoints can access their context from the middleware via `Context.mine' +-- and friends. +-- +-- @since 0.1.0.0 +addRequestContext + :: Context.Store ctx + -> (Wai.Request -> IO ctx) + -> Wai.Middleware +addRequestContext contextStore mkContext app = \request sendResponse -> do + context <- mkContext request + Context.use contextStore context do + app request sendResponse + +-- | Register request-specific context into the provided 'Context.Store', for +-- subsequent use in your 'Wai.Application'. This middleware does not expect to +-- be able to build a context value from every request. Use the +-- 'addRequestContext' variant in your application instead if all requests will +-- result in a context value. +-- +-- Endpoints can access their context from the middleware via `Context.mineMay' +-- and friends. +-- +-- @since 0.1.0.0 +addRequestContextMay + :: Context.Store ctx + -> (Wai.Request -> IO (Maybe ctx)) + -> Wai.Middleware +addRequestContextMay contextStore mkContext app = \request sendResponse -> do + mkContext request >>= \case + Nothing -> app request sendResponse + Just context -> + Context.use contextStore context do + app request sendResponse + +-- | Register arbitrary context into the provided 'Context.Store', for +-- subsequent use in your 'Wai.Application'. This middleware ignores requests +-- when building context values. Use 'addRequestContext'/'addRequestContextMay' +-- in your application instead if you would like to register request-specific +-- context. +-- +-- Endpoints can access their context from the middleware via `Context.mine' +-- and friends. +-- +-- @since 0.1.0.0 +addContext :: Context.Store ctx -> IO ctx -> Wai.Middleware +addContext contextStore mkContext app = \request sendResponse -> do + context <- mkContext + Context.use contextStore context do + app request sendResponse diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -0,0 +1,51 @@ +name: context-wai-middleware +version: '0.1.0.0' +github: "jship/context/context-wai-middleware" +license: MIT +license-file: LICENSE.md +copyright: 2020 (c) Jason Shipman +author: "Jason Shipman" +maintainer: "Jason Shipman" +synopsis: Add request-specific (or not!) context to your WAI applications +description: | + Add request-specific (or not!) context to your WAI applications. +category: Web + +extra-source-files: +- CHANGELOG.md +- LICENSE.md +- package.yaml +- README.md + +ghc-options: + - -Wall + - -fwarn-tabs + - -Wincomplete-uni-patterns + - -Wredundant-constraints + +library: + dependencies: + - base >=4.12 && <5 + - context >=0.1.0.0 && <0.2 + - wai >=3.0.3.0 && <3.3 + source-dirs: library + +tests: + context-wai-middleware-test-suite: + source-dirs: test-suite + main: Driver.hs + build-tools: + - hspec-discover + dependencies: + - async + - base + - bytestring + - case-insensitive + - context + - context-wai-middleware + - hspec + - http-client + - http-types + - stm + - wai + - warp diff --git a/test-suite/Driver.hs b/test-suite/Driver.hs new file mode 100644 --- /dev/null +++ b/test-suite/Driver.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test-suite/Test/Network/Wai/Middleware/ContextSpec.hs b/test-suite/Test/Network/Wai/Middleware/ContextSpec.hs new file mode 100644 --- /dev/null +++ b/test-suite/Test/Network/Wai/Middleware/ContextSpec.hs @@ -0,0 +1,128 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Network.Wai.Middleware.ContextSpec + ( spec + ) where + +import Control.Concurrent.STM.TQueue (TQueue) +import Network.Wai (Middleware, Request) +import Prelude +import Test.Hspec +import qualified Context +import qualified Control.Concurrent.Async as Async +import qualified Control.Concurrent.STM as STM +import qualified Control.Concurrent.STM.TQueue as TQueue +import qualified Data.ByteString.Char8 as ByteString.Char8 +import qualified Data.CaseInsensitive as CI +import qualified Data.Foldable as Foldable +import qualified Data.IORef as IORef +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import qualified Network.HTTP.Client as HTTP.Client +import qualified Network.HTTP.Types as HTTP.Types +import qualified Network.Wai as Wai +import qualified Network.Wai.Handler.Warp as Warp +import qualified Network.Wai.Middleware.Context as Middleware + +spec :: Spec +spec = do + describe "addRequestContext" do + it "concurrent test" do + -- This function creates a value of our context type - 'Int' - by + -- plucking the "number" header off the request. The header must be + -- present. + let mkContext :: Request -> IO Int + mkContext request = do + let headers = Wai.requestHeaders request + let [number] = + fmap (read . ByteString.Char8.unpack . snd) + $ flip filter headers \(headerName, _) -> + "number" == CI.foldedCase headerName + pure number + + Context.withEmptyStore \contextStore -> do + numberQueue <- TQueue.newTQueueIO + runTest numberQueue contextStore + $ Middleware.addRequestContext contextStore mkContext + + describe "addRequestContextMay" do + it "concurrent test" do + -- This function creates a value of our context type - 'Int' - by + -- plucking the "number" header off the request, if present. + let mkContext :: Request -> IO (Maybe Int) + mkContext request = do + let headers = Wai.requestHeaders request + let mNumber@Just {} = + Maybe.listToMaybe + $ fmap (read . ByteString.Char8.unpack . snd) + $ flip filter headers \(headerName, _) -> + "number" == CI.foldedCase headerName + pure mNumber + + Context.withEmptyStore \contextStore -> do + numberQueue <- TQueue.newTQueueIO + runTest numberQueue contextStore + $ Middleware.addRequestContextMay contextStore mkContext + + describe "addContext" do + it "concurrent test" do + counterRef <- IORef.newIORef 0 + + -- This function creates a value of our context type - 'Int' - by + -- using a sequential counter. + let mkContext :: IO Int + mkContext = do + IORef.atomicModifyIORef' counterRef \counter -> + (1 + counter, 1 + counter) + + Context.withEmptyStore \contextStore -> do + numberQueue <- TQueue.newTQueueIO + runTest numberQueue contextStore + $ Middleware.addContext contextStore mkContext + +runTest :: TQueue Int -> Context.Store Int -> Middleware -> IO () +runTest numberQueue contextStore middleware = do + let app = + middleware \_request sendResponse -> do + -- Ask for the request handler thread's context, then write it + -- to the number queue, if present. + Context.mineMay contextStore >>= \case + Nothing -> + pure () + Just number -> + STM.atomically $ TQueue.writeTQueue numberQueue number + + sendResponse + $ Wai.responseLBS + HTTP.Types.status200 + [("Content-Type", "text/plain")] + "Test.Network.Wai.Middleware.ContextSpec" + + -- Spin up a test server for the 'app' defined above. + Warp.testWithApplication (pure app) \port -> do + manager <- HTTP.Client.newManager HTTP.Client.defaultManagerSettings + request <- HTTP.Client.parseRequest $ "http://localhost:" <> show port <> "/abc/def" + + -- Spin up 10 threads that each make 3 http requests into the test + -- server. + Async.forConcurrently_ [0 :: Int .. 9] \i -> do + Foldable.for_ [1..3] \j -> do + -- Every request gets a "number" header added to it. + let newHeader = ("number", ByteString.Char8.pack $ show $ 3 * i + j) + response <- flip HTTP.Client.httpLbs manager request + { HTTP.Client.requestHeaders = + newHeader : HTTP.Client.requestHeaders request + } + HTTP.Types.statusCode (HTTP.Client.responseStatus response) + `shouldBe` 200 + HTTP.Client.responseBody response + `shouldBe` "Test.Network.Wai.Middleware.ContextSpec" + + numbers <- STM.atomically $ TQueue.flushTQueue numberQueue + List.sort numbers `shouldBe` [1..30]