context-http-client (empty) → 0.1.0.0

raw patch · 8 files changed

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

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

Files

• CHANGELOG.md +5/−0
• LICENSE.md +23/−0
• README.md +14/−0
• context-http-client.cabal +71/−0
• library/Network/HTTP/Client/Context.hs +62/−0
• package.yaml +51/−0
• test-suite/Driver.hs +1/−0
• test-suite/Test/Network/HTTP/Client/ContextSpec.hs +155/−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-http-client][]++[![Version badge][]][version]++🚧 This README is under construction and could use some love. 🚧++`context-http-client` supports modifying `http-client` requests/responses using+`context`.++See the Haddocks for more info on the library.++[context-http-client]: https://github.com/jship/context/context-http-client+[Version badge]: https://img.shields.io/hackage/v/context-http-client?color=brightgreen&label=version&logo=haskell+[version]: https://hackage.haskell.org/package/context-http-client

@@ -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: 1865990c2877a02d8dacd93e6c25398bbb43844bf4cd02afdda60b6540ca6c4f++name:           context-http-client+version:        0.1.0.0+synopsis:       Modify HTTP requests/responses using context+description:    Modify outgoing HTTP requests and incoming HTTP responses using context.+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-http-client++library+  exposed-modules:+      Network.HTTP.Client.Context+  other-modules:+      Paths_context_http_client+  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+    , http-client >=0.5.13.1 && <0.8+  default-language: Haskell2010++test-suite context-http-client-test-suite+  type: exitcode-stdio-1.0+  main-is: Driver.hs+  other-modules:+      Test.Network.HTTP.Client.ContextSpec+      Paths_context_http_client+  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-http-client+    , hspec+    , http-client+    , http-types+    , stm+    , wai+    , warp+  default-language: Haskell2010

@@ -0,0 +1,62 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Network.HTTP.Client.Context+  ( -- * Updating manager settings+    modifyRequestsWithContext+  , modifyResponsesWithContext+  ) where++import Network.HTTP.Client (BodyReader, ManagerSettings, Request, Response)+import Prelude+import qualified Context+import qualified Network.HTTP.Client as HTTP.Client++-- | Update the provided 'ManagerSettings' to modify all outgoing 'Request'+-- values, utilizing the calling thread's registered context if present.+--+-- Note that the modifying function can be called multiple times, so be sure to+-- define your function to first check if the 'Request' needs modification. See+-- 'HTTP.Client.managerModifyRequest' for details.+--+-- @since 0.1.0.0+modifyRequestsWithContext+  :: Context.Store ctx+  -> (Maybe ctx -> Request -> IO Request)+  -> ManagerSettings+  -> ManagerSettings+modifyRequestsWithContext contextStore updateRequest managerSettings =+  managerSettings+    { HTTP.Client.managerModifyRequest = \initRequest -> do+        -- In case the provided manager settings already had a custom+        -- request-modifying action installed, we make sure to run that on the+        -- request so that we do not miss its modifications.+        request <- originalRequestModifier initRequest++        mContext <- Context.mineMay contextStore+        updateRequest mContext request+    }+  where+    originalRequestModifier = HTTP.Client.managerModifyRequest managerSettings++-- | Update the provided 'ManagerSettings' to modify all incoming 'Response'+-- values, utilizing the calling thread's registered context if present.+--+-- @since 0.1.0.0+modifyResponsesWithContext+  :: Context.Store ctx+  -> (Maybe ctx -> Response BodyReader -> IO (Response BodyReader))+  -> ManagerSettings+  -> ManagerSettings+modifyResponsesWithContext contextStore updateResponse managerSettings =+  managerSettings+    { HTTP.Client.managerModifyResponse = \initResponse -> do+        -- In case the provided manager settings already had a custom+        -- response-modifying action installed, we make sure to run that on the+        -- response so that we do not miss its modifications.+        response <- originalResponseModifier initResponse++        mContext <- Context.mineMay contextStore+        updateResponse mContext response+    }+  where+    originalResponseModifier = HTTP.Client.managerModifyResponse managerSettings

@@ -0,0 +1,51 @@+name: context-http-client+version: '0.1.0.0'+github: "jship/context/context-http-client"+license: MIT+license-file: LICENSE.md+copyright: 2020 (c) Jason Shipman+author: "Jason Shipman"+maintainer: "Jason Shipman"+synopsis: Modify HTTP requests/responses using context+description: |+  Modify outgoing HTTP requests and incoming HTTP responses using context.+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+  - http-client >=0.5.13.1 && <0.8+  source-dirs: library++tests:+  context-http-client-test-suite:+    source-dirs: test-suite+    main: Driver.hs+    build-tools:+    - hspec-discover+    dependencies:+    - async+    - base+    - bytestring+    - case-insensitive+    - context+    - hspec+    - http-client+    - context-http-client+    - http-types+    - stm+    - wai+    - warp

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

@@ -0,0 +1,155 @@+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}++{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Test.Network.HTTP.Client.ContextSpec+  ( spec+  ) where++import Network.HTTP.Client (BodyReader, Request, Response)+import Prelude+import Test.Hspec (Spec, describe, it, shouldBe)+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.List as List+import qualified Network.HTTP.Client as HTTP.Client+import qualified Network.HTTP.Client.Context as HTTP.Client.Context+import qualified Network.HTTP.Types as HTTP.Types+import qualified Network.Wai as Wai+import qualified Network.Wai.Handler.Warp as Warp++spec :: Spec+spec = do+  describe "modifyRequestsWithContext" do+    it "concurrent test" do+      numberQueue <- TQueue.newTQueueIO @Int+      let app = \request sendResponse -> do+            let headers = Wai.requestHeaders request+            let [number] =+                  fmap (read . ByteString.Char8.unpack . snd)+                    $ flip filter headers \(headerName, _) ->+                        "number" == CI.foldedCase headerName++            STM.atomically $ TQueue.writeTQueue numberQueue number++            sendResponse+              $ Wai.responseLBS+                  HTTP.Types.status200+                  [("Content-Type", "text/plain")]+                  "Test.Network.HTTP.Client.ContextSpec"++      -- This function modifies the request using a value of our context type -+      -- 'Int' - by adding a "number" header to the request containing this+      -- value.+      let modifyRequest :: Maybe Int -> Request -> IO Request+          modifyRequest mContext request = do+            case mContext of+              Nothing -> do+                error "mContext was Nothing!"+              Just context -> do+                pure request+                  { HTTP.Client.requestHeaders =+                      ("number", ByteString.Char8.pack $ show context)+                        : flip filter (HTTP.Client.requestHeaders request)+                            \(headerName, _) ->+                              "number" /= CI.foldedCase headerName+                  }++      Context.withEmptyStore \contextStore -> do+        manager <-+          HTTP.Client.newManager+            $ HTTP.Client.Context.modifyRequestsWithContext+                contextStore+                modifyRequest+                HTTP.Client.defaultManagerSettings++        -- Spin up a test server for the 'app' defined above.+        Warp.testWithApplication (pure app) \port -> do+          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+              -- By using a context here, behind the scenes the manager will also+              -- have access to this context as it will send on this same thread.+              Context.use contextStore (3 * i + j) do+                response <- HTTP.Client.httpLbs request manager+                HTTP.Types.statusCode (HTTP.Client.responseStatus response)+                  `shouldBe` 200+                HTTP.Client.responseBody response+                  `shouldBe` "Test.Network.HTTP.Client.ContextSpec"++        numbers <- STM.atomically $ TQueue.flushTQueue numberQueue+        List.sort numbers `shouldBe` [1..30]++  describe "modifyResponsesWithContext" do+    it "concurrent test" do+      let app = \_request sendResponse -> do+            sendResponse+              $ Wai.responseLBS+                  HTTP.Types.status200+                  [("Content-Type", "text/plain")]+                  "Test.Network.HTTP.Client.ContextSpec"++      -- This function modifies the request using a value of our context type -+      -- 'Int' - by adding a "number" header to the request containing this+      -- value.+      let modifyResponse+            :: Maybe Int+            -> Response BodyReader+            -> IO (Response BodyReader)+          modifyResponse mContext response = do+            case mContext of+              Nothing -> do+                error "mContext was Nothing!"+              Just context -> do+                pure response+                  { HTTP.Client.responseHeaders =+                      ("number", ByteString.Char8.pack $ show context)+                        : HTTP.Client.responseHeaders response+                  }++      Context.withEmptyStore \contextStore -> do+        manager <-+          HTTP.Client.newManager+            $ HTTP.Client.Context.modifyResponsesWithContext+                contextStore+                modifyResponse+                HTTP.Client.defaultManagerSettings++        -- Spin up a test server for the 'app' defined above.+        Warp.testWithApplication (pure app) \port -> do+          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+              Context.use contextStore (3 * i + j) do+                response <- HTTP.Client.httpLbs request manager+                HTTP.Types.statusCode (HTTP.Client.responseStatus response)+                  `shouldBe` 200+                HTTP.Client.responseBody response+                  `shouldBe` "Test.Network.HTTP.Client.ContextSpec"++                let headers = HTTP.Client.responseHeaders response+                let [number] =+                      fmap (read . ByteString.Char8.unpack . snd)+                        $ flip filter headers \(headerName, _) ->+                            "number" == CI.foldedCase headerName++                number `shouldBe` 3 * i + j