diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index 8db0c9f24..fc24bf114 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/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,7 +156,10 @@ 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) @@ -161,7 +167,7 @@ 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 diff --git a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs index 41a06572c..6a325fc41 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs +++ b/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 diff --git a/servant-client/test/Servant/MiddlewareSpec.hs b/servant-client/test/Servant/MiddlewareSpec.hs new file mode 100644 index 000000000..843054093 --- /dev/null +++ b/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\"}" diff --git a/servant-client/test/Servant/SuccessSpec.hs b/servant-client/test/Servant/SuccessSpec.hs index 3edfc4218..c86375716 100644 --- a/servant-client/test/Servant/SuccessSpec.hs +++ b/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"