Add client middleware

servant-client/src/Servant/Client/Internal/HttpClient.hs

@@ -86,11 +86,14 @@ data ClientEnv
   --      1. 'makeClientRequest' exists to allow overriding operational semantics e.g. 'responseTimeout' per request,
   --          If you need global modifications, you should use 'managerModifyRequest'
   --      2. the 'cookieJar', if defined, is being applied after 'makeClientRequest' is called.
+  , middleware :: ClientMiddleware 
   }
 
+type ClientMiddleware = (Request -> ClientM Response) -> Request -> ClientM Response
+
 -- | 'ClientEnv' smart constructor.
 mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv
-mkClientEnv mgr burl = ClientEnv mgr burl Nothing defaultMakeClientRequest
+mkClientEnv mgr burl = ClientEnv mgr burl Nothing defaultMakeClientRequest id
 
 -- | Generates a set of client functions for an API.
 --
@@ -153,15 +156,18 @@ instance Alt ClientM where
   a <!> b = a `catchError` \_ -> b
 
 instance RunClient ClientM where
-  runRequestAcceptStatus = performRequest
+  runRequestAcceptStatus statuses req = do
+    ClientEnv _ _ _ _ mid <- ask
+    let oldApp = performRequest statuses
+    mid oldApp req
   throwClientError = throwError
 
 runClientM :: ClientM a -> ClientEnv -> IO (Either ClientError a)
 runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
 
 performRequest :: Maybe [Status] -> Request -> ClientM Response
 performRequest acceptStatus req = do
-  ClientEnv m burl cookieJar' createClientRequest <- ask
+  ClientEnv m burl cookieJar' createClientRequest _ <- ask
   clientRequest <- liftIO $ createClientRequest burl req
   request <- case cookieJar' of
     Nothing -> pure clientRequest

servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs

@@ -140,7 +140,7 @@ runClientM cm env = withClientM cm env (evaluate . force)
 performRequest :: Maybe [Status] -> Request -> ClientM Response
 performRequest acceptStatus req = do
     -- TODO: should use Client.withResponse here too
-  ClientEnv m burl cookieJar' createClientRequest <- ask
+  ClientEnv m burl cookieJar' createClientRequest _ <- ask
   clientRequest <- liftIO $ createClientRequest burl req
   request <- case cookieJar' of
     Nothing -> pure clientRequest
@@ -175,7 +175,7 @@ performRequest acceptStatus req = do
 -- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above).
 performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
 performWithStreamingRequest req k = do
-  ClientEnv m burl cookieJar' createClientRequest <- ask
+  ClientEnv m burl cookieJar' createClientRequest _ <- ask
   clientRequest <- liftIO $ createClientRequest burl req
   request <- case cookieJar' of
     Nothing -> pure clientRequest

servant-client/test/Servant/MiddlewareSpec.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -freduction-depth=100 #-}
+
+module Servant.MiddlewareSpec (spec) where
+
+import Control.Arrow
+  ( left,
+  )
+import Control.Concurrent (newEmptyMVar, putMVar, takeMVar)
+import Control.Monad.IO.Class
+import Data.ByteString.Builder (toLazyByteString)
+import Data.Monoid ()
+import Prelude.Compat
+import Servant.Client
+import Servant.Client.Core (RequestF (..))
+import Servant.Client.Internal.HttpClient (ClientMiddleware)
+import Servant.ClientTestUtils
+import Test.Hspec
+import Prelude ()
+
+spec :: Spec
+spec = describe "Servant.MiddlewareSpec" $ do
+  successSpec
+
+runClientWithMiddleware :: ClientM a -> ClientMiddleware -> BaseUrl -> IO (Either ClientError a)
+runClientWithMiddleware x mid baseUrl' =
+  runClientM x ((mkClientEnv manager' baseUrl') {middleware = mid})
+
+successSpec :: Spec
+successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
+  describe "mMiddleware" $ do
+    it "Raw request and response can be accessed in middleware" $ \(_, baseUrl) -> do
+      mvarReq <- newEmptyMVar
+      mvarResp <- newEmptyMVar
+
+      let mid :: ClientMiddleware
+          mid oldApp req = do
+            -- "Log" request
+            liftIO $ putMVar mvarReq req
+            -- perform request
+            resp <- oldApp req
+            -- "Log" response
+            liftIO $ putMVar mvarResp resp
+            pure resp
+
+      -- Same as without middleware
+      left show <$> runClientWithMiddleware getGet mid baseUrl `shouldReturn` Right alice
+
+      -- Access some raw request data
+      req <- takeMVar mvarReq
+      toLazyByteString (requestPath req) `shouldBe` "/get"
+
+      -- Access some raw response data
+      resp <- takeMVar mvarResp
+      responseBody resp `shouldBe` "{\"_age\":42,\"_name\":\"Alice\"}"

servant-client/test/Servant/SuccessSpec.hs

@@ -154,7 +154,7 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
     it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do
       mgr <- C.newManager C.defaultManagerSettings
       cj <- atomically . newTVar $ C.createCookieJar []
-      _ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj) defaultMakeClientRequest)
+      _ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj) defaultMakeClientRequest id)
       cookie <- listToMaybe . C.destroyCookieJar <$> atomically (readTVar cj)
       C.cookie_name <$> cookie `shouldBe` Just "testcookie"
       C.cookie_value <$> cookie `shouldBe` Just "test"