Client middleware (#1720)

.github/workflows/master.yml

@@ -15,7 +15,6 @@ jobs:
         os: [ubuntu-latest]
         cabal: ["3.10"]
         ghc:
-          - "8.6.5"
           - "8.8.4"
           - "8.10.7"
           - "9.0.2"

changelog.d/1720

@@ -0,0 +1,10 @@
+synopsis: Client Middleware
+prs: #1720
+
+description: {
+
+Clients now support real middleware of type `(Request -> ClientM Response) -> Request -> ClientM Response` which can be configured in `ClientEnv`.
+This allows access to raw request and response data. It can also be used to control how/when/if actual requests are performed.
+Middleware can be chained with function composition `mid1 . mid2 . mid3`.
+
+}

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

@@ -9,6 +9,7 @@
 {-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE NamedFieldPuns             #-}
 module Servant.Client.Internal.HttpClient where
 
 import           Prelude ()
@@ -86,11 +87,22 @@ 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 ClientApplication = Request -> ClientM Response
+
+type ClientMiddleware = ClientApplication -> ClientApplication
+
 -- | 'ClientEnv' smart constructor.
 mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv
-mkClientEnv mgr burl = ClientEnv mgr burl Nothing defaultMakeClientRequest
+mkClientEnv manager baseUrl = ClientEnv 
+  { manager
+  , baseUrl
+  , cookieJar = Nothing
+  , makeClientRequest = defaultMakeClientRequest
+  , middleware = id
+  }
 
 -- | Generates a set of client functions for an API.
 --
@@ -153,15 +165,18 @@ instance Alt ClientM where
   a <!> b = a `catchError` \_ -> b
 
 instance RunClient ClientM where
-  runRequestAcceptStatus = performRequest
+  runRequestAcceptStatus statuses req = do
+    ClientEnv {middleware} <- ask
+    let oldApp = performRequest statuses
+    middleware 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,117 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# 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.Exception (Exception, throwIO, try)
+import Control.Monad.IO.Class
+import Data.ByteString.Builder (toLazyByteString)
+import Data.IORef (modifyIORef, newIORef, readIORef)
+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 ()
+
+runClientWithMiddleware :: ClientM a -> ClientMiddleware -> BaseUrl -> IO (Either ClientError a)
+runClientWithMiddleware x mid baseUrl' =
+  runClientM x ((mkClientEnv manager' baseUrl') {middleware = mid})
+
+data CustomException = CustomException deriving (Show, Eq)
+
+instance Exception CustomException
+
+spec :: Spec
+spec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ 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\"}"
+
+  it "errors can be thrown in middleware" $ \(_, baseUrl) -> do
+    let mid :: ClientMiddleware
+        mid oldApp req = do
+          -- perform request
+          resp <- oldApp req
+          -- throw error
+          _ <- liftIO $ throwIO CustomException
+          pure resp
+
+    try (runClientWithMiddleware getGet mid baseUrl) `shouldReturn` Left CustomException
+
+  it "runs in the expected order" $ \(_, baseUrl) -> do
+    ref <- newIORef []
+
+    let mid1 :: ClientMiddleware
+        mid1 oldApp req = do
+          liftIO $ modifyIORef ref (\xs -> xs <> ["req1"])
+          resp <- oldApp req
+          liftIO $ modifyIORef ref (\xs -> xs <> ["resp1"])
+          pure resp
+
+    let mid2 :: ClientMiddleware
+        mid2 oldApp req = do
+          liftIO $ modifyIORef ref (\xs -> xs <> ["req2"])
+          resp <- oldApp req
+          liftIO $ modifyIORef ref (\xs -> xs <> ["resp2"])
+          pure resp
+
+    let mid3 :: ClientMiddleware
+        mid3 oldApp req = do
+          liftIO $ modifyIORef ref (\xs -> xs <> ["req3"])
+          resp <- oldApp req
+          liftIO $ modifyIORef ref (\xs -> xs <> ["resp3"])
+          pure resp
+
+    let mid :: ClientMiddleware
+        mid = mid1 . mid2 . mid3
+        -- \^ Composition in "reverse order".
+        -- It is equivalent to the following, which is more intuitive:
+        -- mid :: ClientMiddleware
+        -- mid oldApp = mid1 (mid2 (mid3 oldApp))
+
+    -- Same as without middleware
+    left show <$> runClientWithMiddleware getGet mid baseUrl `shouldReturn` Right alice
+
+    ref <- readIORef ref
+    ref `shouldBe` ["req1", "req2", "req3", "resp3", "resp2", "resp1"]

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"