1267dee...master · typeable/request-track

README.orgnew file+18

since splitsnapshots

unifiedsplit

@@ -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

16executable example-server

17 import: warnings

18 main-is: Main.hs

19+ other-modules: API

20+ Client

21+ Server

22+ TLS

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

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

24+ exceptions >= 0.10,

20 http-client,

25 http-client,

21 request-track,

26 request-track,

22 request-track-servant,

27 request-track-servant,

23 servant,

28 servant,

29+ servant-client,

24 servant-server,

30 servant-server,

25 thread-local,

31 thread-local,

26 wai,

32 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 @@

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE TypeFamilies #-}

3module Main where

4module Main where

4

5

6+import API

7+import Server

8+import TLS

9+

5import Control.Concurrent.ThreadLocal

10import Control.Concurrent.ThreadLocal

6−import Control.Monad.IO.Class

7−import Data.Proxy

8−import Network.Wai

9import Network.Wai.Handler.Warp

11import Network.Wai.Handler.Warp

10−import Servant.API

11import Servant.Server

12import Servant.Server

12−import Web.Tracking

13+import Web.Tracking hiding (addTrackingHeaders)

13import Web.Tracking.Servant

14import Web.Tracking.Servant

14

15

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−

37main :: IO ()

16main :: IO ()

38−main = do tls <- newThreadLocalWithGC 60

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

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

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

18+ $ serveWithContext exampleAPI ctx server

41− where ctx = mkReqtrackingHandler rqHandler :. EmptyContext

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+12−3

@@ -11,21 +11,30 @@ maintainer: nick@typeable.io

11category: Web

12build-type: Simple

13

14+flag openapi

15+ description: Enable openapi instances

16+ default: False

17+ manual: True

18+

14common warnings

19common warnings

15 ghc-options: -Wall

20 ghc-options: -Wall

16

21

17library

22library

18 import: warnings

23 import: warnings

19 exposed-modules: Web.Tracking.Servant

24 exposed-modules: Web.Tracking.Servant

20− other-modules: Web.Tracking.Servant.Handler

25+ other-modules: Web.Tracking.Servant.Types

21− Web.Tracking.Servant.Types

22− -- other-extensions:

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

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

24 bytestring >= 0.11,

27 bytestring >= 0.11,

28+ containers >= 0.6,

25 http-types >= 0.12,

29 http-types >= 0.12,

26 request-track,

30 request-track,

27 servant >= 0.19,

31 servant >= 0.19,

32+ servant-client-core >= 0.19,

28 servant-server >= 0.19,

33 servant-server >= 0.19,

29 wai >= 3.2

34 wai >= 3.2

35+ if flag(openapi)

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

37+ build-depends: servant-openapi3

38+ cpp-options: -DOPENAPI

30 hs-source-dirs: src

39 hs-source-dirs: src

31 default-language: GHC2021

40 default-language: GHC2021

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

@@ -1,5 +1,8 @@

1+{-# LANGUAGE CPP #-}

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

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

2

3

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

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

4−import Web.Tracking.Servant.Handler as Export

5import 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/Handler.hsdeleted−9

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

1−module Web.Tracking.Servant.Handler where

2−

3−import Web.Tracking

4−

5−import Network.Wai

6−import Servant.Server

7−

8−simpleTrackingHandler :: Request -> Handler (Maybe ReqtrackInfo)

9−simpleTrackingHandler = pure . parseTrackingHeaders

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+73−14

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

10import Data.ByteString (ByteString)

11import Data.Kind

12import Data.Proxy

13+import qualified Data.Sequence as Seq

13−import Network.Wai

14+import qualified Network.Wai as Wai

14import Servant.API

15import Servant.API

16+import Servant.Client.Core

15import Servant.Server

17import Servant.Server

16import Servant.Server.Internal

18import Servant.Server.Internal

17

19

18−-- | 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+-- @

19data RequestTracking

46data RequestTracking

20

47

48+-- | See 'RequestTracking'

49+type family TrackingData a

50+

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

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

22data RequestTracking_

52data RequestTracking_

23

53

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.

24−newtype ReqtrackingHandler r o = ReqtrackingHandler { unReqtrackingHandler :: r -> Handler o

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

25 } deriving (Functor)

57 } deriving (Functor)

26

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

67+

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

27−mkReqtrackingHandler :: (r -> Handler o) -> ReqtrackingHandler r o

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

28mkReqtrackingHandler = ReqtrackingHandler

70mkReqtrackingHandler = ReqtrackingHandler

29

71

30instance forall (api :: Type) context.

72instance forall (api :: Type) context.

31 ( HasServer api context

73 ( HasServer api context

32− , HasContextEntry context (ReqtrackingHandler Request (Maybe ReqtrackInfo))

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

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

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

34− type ServerT (RequestTracking :> api) m = Maybe ReqtrackInfo -> ServerT api m

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

35

77

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

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

37

79

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

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

39− where trackingCheck :: Request -> DelayedIO (Maybe ReqtrackInfo)

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

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

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

41− trackingHandler :: Request -> Handler (Maybe ReqtrackInfo)

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

42 trackingHandler = let ReqtrackingHandler h = getContextEntry context

84 trackingHandler = let ReqtrackingHandler h = getContextEntry context

43− in h

85+ in h . parseTrackingHeaders

86+

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+

44

96

45instance forall (api :: Type) context.

97instance forall (api :: Type) context.

46 ( HasServer api context

98 ( HasServer api context

47− , HasContextEntry context (ReqtrackingHandler Request (Maybe ReqtrackInfo))

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

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

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

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

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

50

102

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

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

52

104

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

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

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

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

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

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

56− trackingHandler :: Request -> Handler (Maybe ReqtrackInfo)

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

57 trackingHandler = let ReqtrackingHandler h = getContextEntry context

109 trackingHandler = let ReqtrackingHandler h = getContextEntry context

58− in h

110+ in h . parseTrackingHeaders

111+

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

59

117

60

118

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

61type ReqtrackHeaders = '[ Header RequestIdHdr ByteString

120type ReqtrackHeaders = '[ Header RequestIdHdr ByteString

62 , Header RequestLevelHdr Word

121 , Header RequestLevelHdr Word

63 , Header RequestSourceHdr ByteString

122 , Header RequestSourceHdr ByteString

request-track/src/Web/Tracking/Headers.hs+5

@@ -19,6 +19,11 @@ addTrackingHeaders :: ReqtrackInfo -> Response -> Response

19addTrackingHeaders rti = mapResponseHeaders f

20 where f hdrs = mkTrackingHeaders rti ++ removeTrackingHeaders hdrs

21

22+echoMiddleware :: Middleware

23+echoMiddleware app req resp

24+ | Just rti <- parseTrackingHeaders req = app req (resp . addTrackingHeaders rti)

25+ | otherwise = app req resp

26+

22trackingMiddleware :: (ReqtrackInfo -> IO ()) -> Middleware

27trackingMiddleware :: (ReqtrackInfo -> IO ()) -> Middleware

23trackingMiddleware f app req resp

28trackingMiddleware f app req resp

24 | Just rti <- parseTrackingHeaders req = do f rti

29 | Just rti <- parseTrackingHeaders req = do f rti

stack.yaml+5−1

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

1−resolver: lts-20.26

1+resolver: lts-21.6

2

3packages:

4- example-server

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

11

12nix:

13 packages: [ zlib ]

14+

15+flags:

16+ request-track-servant:

17+ openapi: true