From 72b7abb94de33780c882b6f6170bde7854da68bd Mon Sep 17 00:00:00 2001 From: Michael Bock Date: Wed, 24 Jan 2024 10:26:16 +0100 Subject: [PATCH] Client middleware (#1720) --- .github/workflows/master.yml | 1 - changelog.d/1720 | 10 ++ .../src/Servant/Client/Internal/HttpClient.hs | 21 +++- .../Client/Internal/HttpClient/Streaming.hs | 4 +- servant-client/test/Servant/MiddlewareSpec.hs | 117 ++++++++++++++++++ servant-client/test/Servant/SuccessSpec.hs | 2 +- 6 files changed, 148 insertions(+), 7 deletions(-) create mode 100644 changelog.d/1720 create mode 100644 servant-client/test/Servant/MiddlewareSpec.hs diff --git a/.github/workflows/master.yml b/.github/workflows/master.yml index 86c960a0d..ea7da30ab 100644 --- a/.github/workflows/master.yml +++ b/.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" diff --git a/changelog.d/1720 b/changelog.d/1720 new file mode 100644 index 000000000..cfd3d1cb5 --- /dev/null +++ b/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`. + +} \ No newline at end of file diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index 8db0c9f24..d6e02f25e 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/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,7 +165,10 @@ 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) @@ -161,7 +176,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..648ca1311 --- /dev/null +++ b/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"] \ No newline at end of file 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"