context-wai-middleware (empty) → 0.1.0.0

raw patch · 8 files changed

+366/−0 lines, 8 filesdep +asyncdep +basedep +bytestring

Dependencies added: async, base, bytestring, case-insensitive, context, context-wai-middleware, hspec, http-client, http-types, stm, wai, warp

Files

• CHANGELOG.md +5/−0
• LICENSE.md +23/−0
• README.md +14/−0
• context-wai-middleware.cabal +71/−0
• library/Network/Wai/Middleware/Context.hs +73/−0
• package.yaml +51/−0
• test-suite/Driver.hs +1/−0
• test-suite/Test/Network/Wai/Middleware/ContextSpec.hs +128/−0

@@ -0,0 +1,5 @@+# Change log++## 0.1.0.0++Initial release

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

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

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

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

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

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

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