03d2841...master · typeable/request-track

README.orgnew file+18

@@ -0,0 +1,18 @@

1+#+TITLE: Request tracking framework

2+#+AUTHOR: Nick <nick@typeable.io>

3+

4+* Mechanism

5+

6+See [[https://github.com/typeable/technical_notes/blob/master/Request%20Tracking/Tracking.org][this note]] for the mechanism description.

7+

8+* Lower-level API

9+

10+~request-track~ library provides WAI primitives to handle the passed headers. At the very least you would want to use ~echoMiddleware~ in order to send back the tracking headers in every HTTP reply.

11+

12+* Servant API

13+

14+~request-track-servant~ provides combinators to use with Servant. See the haddock documentation for more info.

15+

16+* Example server

17+

18+~example-server~ directory contains a simple HTTP server that uses all this stuff.

example-server/example-server.cabal+6

@@ -16,11 +16,17 @@ common warnings

1616executable example-server

1717 import: warnings

1818 main-is: Main.hs

19+ other-modules: API

20+ Client

21+ Server

22+ TLS

1923 build-depends: base >=4.16 && <5,

24+ exceptions >= 0.10,

2025 http-client,

2126 request-track,

2227 request-track-servant,

2328 servant,

29+ servant-client,

2430 servant-server,

2531 thread-local,

2632 wai,

example-server/src/API.hsnew file+13

@@ -0,0 +1,13 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE TypeFamilies #-}

3+module API where

4+

5+import Data.Proxy

6+import Servant.API

7+import Web.Tracking.Servant

8+

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

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

11+

12+exampleAPI :: Proxy ExampleAPI

13+exampleAPI = Proxy

example-server/src/Client.hsnew file+48

@@ -0,0 +1,48 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module Client where

3+

4+import API

5+import TLS

6+

7+import Control.Concurrent.ThreadLocal

8+import Control.Monad.Catch

9+import Network.HTTP.Client

10+import Servant.API

11+import Servant.Client

12+import Web.Tracking (incrLevel, replaceSource)

13+import Web.Tracking.Client

14+import Web.Tracking.Servant

15+

16+callRelayM :: ClientM [Char]

17+callEchoM :: Maybe ReqtrackInfo -> ClientM [Char]

18+callEchoM :<|> callRelayM = client exampleAPI

19+

20+url :: BaseUrl

21+url = BaseUrl { baseUrlScheme = Http

22+ , baseUrlHost = "localhost"

23+ , baseUrlPort = 8080

24+ , baseUrlPath = ""

25+ }

26+

27+callRelay :: IO String

28+callRelay = do mgr <- newManager defaultManagerSettings

29+ let env = mkClientEnv mgr url

30+ r <- runClientM callRelayM env

31+ either throwM return r

32+

33+modifyRequest :: ThreadLocal ReqtrackInfo -> Request -> IO Request

34+modifyRequest tls = addTrackingHeaders (fmap f <$> fetchThreadLocal tls)

35+ where f rti = replaceSource "relay"

36+ $ incrLevel rti

37+

38+callEcho_ :: IO String

39+callEcho_ = do mgr <- newManager defaultManagerSettings { managerModifyRequest = modifyRequest storage }

40+ let env = mkClientEnv mgr url

41+ s <- runClientM (callEchoM Nothing) env

42+ either throwM return s

43+

44+callEcho :: ReqtrackInfo -> IO ()

45+callEcho rti = do mgr <- newManager defaultManagerSettings

46+ let env = mkClientEnv mgr url

47+ s <- runClientM (callEchoM $ Just rti) env

48+ print s

example-server/src/Main.hs+11−31

@@ -1,41 +1,21 @@

11{-# LANGUAGE DataKinds #-}

22{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE TypeFamilies #-}

34module Main where

45

6+import API

7+import Server

8+import TLS

9+

510import Control.Concurrent.ThreadLocal

6−import Control.Monad.IO.Class

7−import Data.Proxy

8−import Network.Wai

911import Network.Wai.Handler.Warp

10−import Servant.API

1112import Servant.Server

12−import Web.Tracking

13+import Web.Tracking hiding (addTrackingHeaders)

1314import Web.Tracking.Servant

1415

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

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

17−

18−echoHandler :: Maybe ReqtrackInfo -> Handler String

19−echoHandler _ = pure "PONG"

20−

21−relayHandler :: Maybe ReqtrackInfo -> Handler String

22−relayHandler _ = pure "RELAY"

23−

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!"

33−

34−server :: Server ExampleAPI

35−server = echoHandler :<|> relayHandler

36−

3716main :: IO ()

38−main = do tls <- newThreadLocalWithGC 60

39− run 1337 $ trackingMiddleware (`insertThreadLocal` tls)

40− $ serveWithContext (Proxy :: Proxy ExampleAPI) ctx server

41− where ctx = mkReqtrackingHandler rqHandler :. EmptyContext

17+main = run 8081 $ trackingMiddleware (`insertThreadLocal` storage)

18+ $ serveWithContext exampleAPI ctx server

19+ where ctx = mkReqtrackingHandler rqHandler

20+ :. mkReqtrackingHandler rqHandler_

21+ :. EmptyContext

example-server/src/Server.hsnew file+38

@@ -0,0 +1,38 @@

1+{-# LANGUAGE TypeFamilies #-}

2+module Server where

3+

4+import API

5+import Client

6+

7+import Control.Monad.IO.Class

8+import Servant.API

9+import Servant.Server

10+import Web.Tracking.Servant

11+

12+type instance TrackingData RequestTracking = Maybe ReqtrackInfo

13+

14+echoHandler :: Maybe ReqtrackInfo -> Handler String

15+echoHandler rti = pure ("PONG, " <> show (requestId <$> rti))

16+

17+relayHandler :: Handler String

18+relayHandler = liftIO callEcho_

19+

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

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

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

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

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

25+ ]))

26+rqHandler Nothing = liftIO (Nothing <$ putStrLn "Request tracking headers not found!")

27+

28+rqHandler_ :: Maybe ReqtrackInfo -> Handler ()

29+rqHandler_ (Just info) = liftIO (putStrLn (unlines [ "Request tracking headers found!"

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

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

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

33+ ]))

34+rqHandler_ Nothing = liftIO (putStrLn "Request tracking headers not found!")

35+

36+

37+server :: Server ExampleAPI

38+server = echoHandler :<|> relayHandler

example-server/src/TLS.hsnew file+9

@@ -0,0 +1,9 @@

1+module TLS where

2+

3+import Control.Concurrent.ThreadLocal

4+import Web.Tracking

5+import System.IO.Unsafe (unsafePerformIO)

6+

7+storage :: ThreadLocal ReqtrackInfo

8+storage = unsafePerformIO (newThreadLocalWithGC 60)

9+{-# NOINLINE storage #-}

nginx.confnew file+41

@@ -0,0 +1,41 @@

1+daemon off;

2+

3+pid nginx.pid;

4+

5+error_log stderr error;

6+

7+

8+http {

9+ log_format logger-json escape=json '{"source": "nginx", "time": $msec, "resp_body_size": $body_bytes_sent, "host": "$http_host", "address": "$remote_addr", "request_length": $request_length, "method": "$request_method", "uri": "$request_uri", "status": $status, "user_agent": "$http_user_agent", "resp_time": $request_time, "upstream_addr": "$upstream_addr"}';

10+ access_log /dev/stdout logger-json;

11+

12+ map $http_x_request_id $req_id {

13+ default $http_x_request_id;

14+ "" $request_id;

15+ }

16+

17+ map $http_x_request_source $req_source {

18+ default $http_x_request_source;

19+ "" "web";

20+ }

21+

22+ map $http_x_request_level $req_level {

23+ default $http_x_request_level;

24+ "" "0";

25+ }

26+

27+ server {

28+ listen 8080;

29+

30+ location / {

31+ proxy_pass http://localhost:8081;

32+

33+ proxy_set_header Host $host;

34+ proxy_set_header X-REQUEST-ID $req_id;

35+ proxy_set_header X-REQUEST-SOURCE $req_source;

36+ proxy_set_header X-REQUEST-LEVEL $req_level;

37+ }

38+ }

39+}

40+

41+events {}

request-track-servant/request-track-servant.cabal+11−1

@@ -11,6 +11,11 @@ maintainer: nick@typeable.io

1111category: Web

1212build-type: Simple

1313

14+flag openapi

15+ description: Enable openapi instances

16+ default: False

17+ manual: True

18+

1419common warnings

1520 ghc-options: -Wall

1621

@@ -18,13 +23,18 @@ library

1823 import: warnings

1924 exposed-modules: Web.Tracking.Servant

2025 other-modules: Web.Tracking.Servant.Types

21− -- other-extensions:

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

2327 bytestring >= 0.11,

28+ containers >= 0.6,

2429 http-types >= 0.12,

2530 request-track,

2631 servant >= 0.19,

32+ servant-client-core >= 0.19,

2733 servant-server >= 0.19,

2834 wai >= 3.2

35+ if flag(openapi)

36+ other-modules: Web.Tracking.Servant.OpenAPI

37+ build-depends: servant-openapi3

38+ cpp-options: -DOPENAPI

2939 hs-source-dirs: src

3040 default-language: GHC2021

request-track-servant/src/Web/Tracking/Servant.hs+4

@@ -1,4 +1,8 @@

1+{-# LANGUAGE CPP #-}

12module Web.Tracking.Servant (module Export) where

23

34import Web.Tracking as Export (ReqtrackInfo(..))

45import Web.Tracking.Servant.Types as Export

6+#ifdef OPENAPI

7+import Web.Tracking.Servant.OpenAPI as Export ()

8+#endif

request-track-servant/src/Web/Tracking/Servant/OpenAPI.hsnew file+14

@@ -0,0 +1,14 @@

1+{-# OPTIONS_GHC -Wno-orphans #-}

2+module Web.Tracking.Servant.OpenAPI where

3+

4+import Web.Tracking.Servant.Types (RequestTracking, RequestTracking_)

5+

6+import Data.Proxy

7+import Servant.API

8+import Servant.OpenApi

9+

10+instance HasOpenApi api => HasOpenApi (RequestTracking :> api) where

11+ toOpenApi _ = toOpenApi (Proxy :: Proxy api)

12+

13+instance HasOpenApi api => HasOpenApi (RequestTracking_ :> api) where

14+ toOpenApi _ = toOpenApi (Proxy :: Proxy api)

request-track-servant/src/Web/Tracking/Servant/Types.hs+69−13

@@ -3,7 +3,6 @@

33{-# LANGUAGE UndecidableInstances #-}

44module Web.Tracking.Servant.Types where

55

6−import Web.Tracking

76import Web.Tracking

87

98import Control.Monad ((<=<))

@@ -11,56 +10,113 @@ import Control.Monad.IO.Class

1110import Data.ByteString (ByteString)

1211import Data.Kind

1312import Data.Proxy

14−import Network.Wai

13+import qualified Data.Sequence as Seq

14+import qualified Network.Wai as Wai

1515import Servant.API

16+import Servant.Client.Core

1617import Servant.Server

1718import Servant.Server.Internal

1819

19−-- | Types to use in you API description

20+-- | Combinator for your Servant API description. Prepend it to your API for greater enjoyment!

21+-- Example:

22+--

23+-- @

24+-- type MyAPI = RequestTracking :> "ping" :> Get '[JSON] Text

25+-- @

26+--

27+-- In addition to the API combinator, you also need to create a context handler that will

28+-- handler the tracking data (see 'ReqtrackInfo') and produce desired output, which in turn

29+-- will be passed to your API handlers.

30+-- The type of values passed to API handlers is controlled by @type instance TrackingData RequestTracking@,

31+-- which isn't set by default.

32+-- The server code should look something like this:

33+--

34+-- @

35+-- data TrackingArg = ...

36+--

37+-- type instance TrackingData RequestTracking = TrackingArg

38+--

39+-- trackingHandler :: ReqtrackingHandler (Maybe ReqtrackInfo) TrackingArg

40+-- trackingHandler = mkReqtrackingHandler $ \mrti ->

41+-- case mrti of

42+-- Just rti -> ... -- Do something with ReqtrackInfo, return TrackingArg

43+-- Nothing -> ...

44+--

45+-- @

2046data RequestTracking

2147

22−type family TrackingData :: Type -> Type

48+-- | See 'RequestTracking'

49+type family TrackingData a

2350

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

2552data RequestTracking_

2653

27−newtype ReqtrackingHandler o = ReqtrackingHandler { unReqtrackingHandler :: Maybe ReqtrackInfo -> Handler o

28− } deriving (Functor)

54+-- | Servant context handler used for processing 'ReqtrackInfo' before passing the result to endpoint handlers.

55+-- Use 'mkReqtrackingHandler' in your code instead of the constructor.

56+newtype ReqtrackingHandler r o = ReqtrackingHandler { runReqtrackingHandler :: r -> Handler o

57+ } deriving (Functor)

58+

59+instance Applicative (ReqtrackingHandler r) where

60+ pure x = ReqtrackingHandler $ \_ -> pure x

61+ f <*> v = ReqtrackingHandler $ \r -> runReqtrackingHandler f r <*> runReqtrackingHandler v r

62+

63+instance Monad (ReqtrackingHandler r) where

64+ return = pure

65+ f >>= g = ReqtrackingHandler $ \r -> do a <- runReqtrackingHandler f r

66+ runReqtrackingHandler (g a) r

2967

30−mkReqtrackingHandler :: (Maybe ReqtrackInfo -> Handler o) -> ReqtrackingHandler o

68+-- | Smart constructor to create 'ReqtrackingHandler'.

69+mkReqtrackingHandler :: (Maybe ReqtrackInfo -> Handler o) -> ReqtrackingHandler (Maybe ReqtrackInfo) o

3170mkReqtrackingHandler = ReqtrackingHandler

3271

3372instance forall (api :: Type) context.

3473 ( HasServer api context

35− , HasContextEntry context (ReqtrackingHandler (TrackingData RequestTracking))

74+ , HasContextEntry context (ReqtrackingHandler (Maybe ReqtrackInfo) (TrackingData RequestTracking))

3675 ) => HasServer (RequestTracking :> api) context where

3776 type ServerT (RequestTracking :> api) m = TrackingData RequestTracking -> ServerT api m

3877

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

4079

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

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

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

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

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

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

4584 trackingHandler = let ReqtrackingHandler h = getContextEntry context

4685 in h . parseTrackingHeaders

4786

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

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

89+

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

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

92+ | otherwise = req

93+

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

95+

96+

4897instance forall (api :: Type) context.

4998 ( HasServer api context

50− , HasContextEntry context (ReqtrackingHandler ())

99+ , HasContextEntry context (ReqtrackingHandler (Maybe ReqtrackInfo) ())

51100 ) => HasServer (RequestTracking_ :> api) context where

52101 type ServerT (RequestTracking_ :> api) m = ServerT api m

53102

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

55104

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

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

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

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

59− trackingHandler :: Request -> Handler ()

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

60109 trackingHandler = let ReqtrackingHandler h = getContextEntry context

61110 in h . parseTrackingHeaders

62111

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

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

114+

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

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

117+

63118

119+-- | Headers list to use with 'Headers'. Currently unused.

64120type ReqtrackHeaders = '[ Header RequestIdHdr ByteString

65121 , Header RequestLevelHdr Word

66122 , Header RequestSourceHdr ByteString

stack.yaml+5−1

@@ -1,4 +1,4 @@

1−resolver: lts-20.26

1+resolver: lts-21.6

22

33packages:

44- example-server

@@ -11,3 +11,7 @@ extra-deps:

1111

1212nix:

1313 packages: [ zlib ]

14+

15+flags:

16+ request-track-servant:

17+ openapi: true