1fe3a57 · typeable/request-track

git.iko.soy/typeable/request-track

Add servant-client instances for RequestTracking.

commit1fe3a573aff4e627169ce853e65858f02f0e9c0e authorNick <nick@typeable.io> dateSat 22 Jul 2023, 17:19 (3 years ago) parentdb625c2

3 files changed+41−21

compare with master

unifiedsplit

example-server/src/Main.hs+15−15 request-track-servant/request-track-servant.cabal+2 request-track-servant/src/Web/Tracking/Servant/Types.hs+24−6

example-server/src/Main.hs+15−15

@@ -1,35 +1,35 @@

11{-# LANGUAGE DataKinds #-}

22{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE TypeFamilies #-}

34module Main where

56import Control.Concurrent.ThreadLocal

67import Control.Monad.IO.Class

78import Data.Proxy

8−import Network.Wai

99import Network.Wai.Handler.Warp

1010import Servant.API

1111import Servant.Server

1212import Web.Tracking

1313import Web.Tracking.Servant

1414

15+type instance TrackingData RequestTracking = ()

16+

1517type ExampleAPI = RequestTracking :> "echo" :> Get '[JSON] String

16− :<|> RequestTracking :> "relay" :> Get '[JSON] String

18+ :<|> RequestTracking_ :> "relay" :> Get '[JSON] String

1719

18−echoHandler :: Maybe ReqtrackInfo -> Handler String

20+echoHandler :: () -> Handler String

1921echoHandler _ = pure "PONG"

2022

21−relayHandler :: Maybe ReqtrackInfo -> Handler String

22−relayHandler _ = pure "RELAY"

23+relayHandler :: Handler String

24+relayHandler = pure "RELAY"

2325

24−rqHandler :: Request -> Handler (Maybe ReqtrackInfo)

25−rqHandler req | Just info <- parseTrackingHeaders req =

26− liftIO $ do putStrLn (unlines [ "Request tracking headers found!"

27− , "Request Id: " <> show (requestId info)

28− , "Request Source: " <> show (requestSource info)

29− , "Request Level: " <> show (requestLevel info)

30− ])

31− return (Just info)

32− | otherwise = liftIO $ Nothing <$ putStrLn "Request tracking headers not found!"

26+rqHandler :: Maybe ReqtrackInfo -> Handler ()

27+rqHandler (Just info) = liftIO $ putStrLn (unlines [ "Request tracking headers found!"

28+ , "Request Id: " <> show (requestId info)

29+ , "Request Source: " <> show (requestSource info)

30+ , "Request Level: " <> show (requestLevel info)

31+ ])

32+rqHandler Nothing = liftIO $ putStrLn "Request tracking headers not found!"

3333

3434server :: Server ExampleAPI

3535server = echoHandler :<|> relayHandler

@@ -38,4 +38,4 @@ main :: IO ()

3838main = do tls <- newThreadLocalWithGC 60

3939 run 1337 $ trackingMiddleware (`insertThreadLocal` tls)

4040 $ serveWithContext (Proxy :: Proxy ExampleAPI) ctx server

41− where ctx = mkReqtrackingHandler rqHandler :. EmptyContext

41+ where ctx = mkReqtrackingHandler rqHandler :. mkReqtrackingHandler rqHandler :. EmptyContext

request-track-servant/request-track-servant.cabal+2

@@ -21,9 +21,11 @@ library

2121 -- other-extensions:

2222 build-depends: base >=4.14.0.0 && < 5,

2323 bytestring >= 0.11,

24+ containers >= 0.6,

2425 http-types >= 0.12,

2526 request-track,

2627 servant >= 0.19,

28+ servant-client-core >= 0.19,

2729 servant-server >= 0.19,

2830 wai >= 3.2

2931 hs-source-dirs: src

request-track-servant/src/Web/Tracking/Servant/Types.hs+24−6

@@ -10,15 +10,17 @@ import Control.Monad.IO.Class

1010import Data.ByteString (ByteString)

1111import Data.Kind

1212import Data.Proxy

13−import Network.Wai

13+import qualified Data.Sequence as Seq

14+import qualified Network.Wai as Wai

1415import Servant.API

16+import Servant.Client.Core

1517import Servant.Server

1618import Servant.Server.Internal

1719

1820-- | Types to use in you API description

1921data RequestTracking

2022

21−type family TrackingData :: Type -> Type

23+type family TrackingData a

2224

2325-- | Same as above, except no argument is passed to a handler.

2426data RequestTracking_

@@ -38,12 +40,22 @@ instance forall (api :: Type) context.

3840 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

3941

4042 route _ context subserver = route (Proxy :: Proxy api) context (subserver `addHeaderCheck` withRequest trackingCheck)

41− where trackingCheck :: Request -> DelayedIO (TrackingData RequestTracking)

43+ where trackingCheck :: Wai.Request -> DelayedIO (TrackingData RequestTracking)

4244 trackingCheck = either delayedFailFatal return <=< liftIO . runHandler . trackingHandler

43− trackingHandler :: Request -> Handler (TrackingData RequestTracking)

45+ trackingHandler :: Wai.Request -> Handler (TrackingData RequestTracking)

4446 trackingHandler = let ReqtrackingHandler h = getContextEntry context

4547 in h . parseTrackingHeaders

4648

49+instance HasClient m api => HasClient m (RequestTracking :> api) where

50+ type Client m (RequestTracking :> api) = Maybe ReqtrackInfo -> Client m api

51+

52+ clientWithRoute pm Proxy req mrti = clientWithRoute pm (Proxy :: Proxy api) req'

53+ where req' | Just rti <- mrti = req { requestHeaders = Seq.fromList (mkTrackingHeaders rti) <> requestHeaders req }

54+ | otherwise = req

55+

56+ hoistClientMonad pm Proxy f cl = \rti -> hoistClientMonad pm (Proxy :: Proxy api) f (cl rti)

57+

58+

4759instance forall (api :: Type) context.

4860 ( HasServer api context

4961 , HasContextEntry context (ReqtrackingHandler (Maybe ReqtrackInfo) ())

@@ -53,12 +65,18 @@ instance forall (api :: Type) context.

5365 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s

5466

5567 route _ context subserver = route (Proxy :: Proxy api) context (fmap const subserver `addHeaderCheck` withRequest trackingCheck)

56− where trackingCheck :: Request -> DelayedIO ()

68+ where trackingCheck :: Wai.Request -> DelayedIO ()

5769 trackingCheck = either delayedFailFatal (const $ return ()) <=< liftIO . runHandler . trackingHandler

58− trackingHandler :: Request -> Handler ()

70+ trackingHandler :: Wai.Request -> Handler ()

5971 trackingHandler = let ReqtrackingHandler h = getContextEntry context

6072 in h . parseTrackingHeaders

6173

74+instance HasClient m api => HasClient m (RequestTracking_ :> api) where

75+ type Client m (RequestTracking_ :> api) = Client m api

76+

77+ clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy api)

78+ hoistClientMonad pm Proxy f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl

79+

6280

6381type ReqtrackHeaders = '[ Header RequestIdHdr ByteString

6482 , Header RequestLevelHdr Word