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

@@ -11,21 +11,30 @@ 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

1722library

1823 import: warnings

1924 exposed-modules: Web.Tracking.Servant

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

21− Web.Tracking.Servant.Types

22− -- other-extensions:

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

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

2427 bytestring >= 0.11,

28+ containers >= 0.6,

2529 http-types >= 0.12,

2630 request-track,

2731 servant >= 0.19,

32+ servant-client-core >= 0.19,

2833 servant-server >= 0.19,

2934 wai >= 3.2

35+ if flag(openapi)

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

37+ build-depends: servant-openapi3

38+ cpp-options: -DOPENAPI

3039 hs-source-dirs: src

3140 default-language: GHC2021

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

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

1+{-# LANGUAGE CPP #-}

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

23

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

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

55import 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

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

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

1946data RequestTracking

2047

48+-- | See 'RequestTracking'

49+type family TrackingData a

50+

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

2252data RequestTracking_

2353

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

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

2557 } deriving (Functor)

2658

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

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'.

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

2870mkReqtrackingHandler = ReqtrackingHandler

2971

3072instance forall (api :: Type) context.

3173 ( HasServer api context

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

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

3375 ) => 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

3577

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

3779

3880 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)

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

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

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

4284 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+

4496

4597instance forall (api :: Type) context.

4698 ( HasServer api context

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

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

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

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

50102

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

52104

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

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

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

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

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

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

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

57109 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

59117

60118

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

61120type ReqtrackHeaders = '[ Header RequestIdHdr ByteString

62121 , Header RequestLevelHdr Word

63122 , Header RequestSourceHdr ByteString

request-track/request-track.cabal+2

@@ -17,12 +17,14 @@ common warnings

1717library

1818 import: warnings

1919 exposed-modules: Web.Tracking

20+ Web.Tracking.Client

2021 other-modules: Web.Tracking.Internal

2122 Web.Tracking.Headers

2223 -- other-extensions:

2324 build-depends: base >=4.14 && < 5,

2425 bytestring >= 0.11,

2526 case-insensitive >= 1.2,

27+ http-client >= 0.7,

2628 http-types >= 0.12,

2729 wai >= 3.2

2830 hs-source-dirs: src

request-track/src/Web/Tracking/Client.hsnew file+11

@@ -0,0 +1,11 @@

1+module Web.Tracking.Client where

2+

3+import Web.Tracking.Internal

4+

5+import Network.HTTP.Client

6+

7+addTrackingHeaders :: IO (Maybe ReqtrackInfo) -> Request -> IO Request

8+addTrackingHeaders getRti req = f <$> getRti

9+ where f Nothing = req

10+ f (Just rti) = req { requestHeaders = mkTrackingHeaders rti ++ removeTrackingHeaders (requestHeaders req)}

11+

request-track/src/Web/Tracking/Headers.hs+6−8

@@ -3,7 +3,6 @@ module Web.Tracking.Headers where

33import Web.Tracking.Internal

44

55import qualified Data.ByteString.Char8 as ByteString

6−import Network.HTTP.Types

76import Network.Wai

87import Text.Read (readMaybe)

98

@@ -18,13 +17,12 @@ parseTrackingHeaders req = ReqtrackInfo <$> reqId

1817

1918addTrackingHeaders :: ReqtrackInfo -> Response -> Response

2019addTrackingHeaders rti = mapResponseHeaders f

21− where headers :: ResponseHeaders

22− headers = [ (requestIdHdr, requestId rti)

23− , (requestLevelHdr, ByteString.pack (show (requestLevel rti)))

24− , (requestSourceHdr, requestSource rti)

25− ]

26− filterHdrs = filter (\(hdr,_) -> hdr `notElem` [requestIdHdr, requestLevelHdr, requestSourceHdr])

27− f hdrs = headers ++ filterHdrs hdrs

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

2826

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

3028trackingMiddleware f app req resp

request-track/src/Web/Tracking/Internal.hs+11

@@ -3,10 +3,12 @@

33module Web.Tracking.Internal where

44

55import Data.ByteString (ByteString)

6+import qualified Data.ByteString.Char8 as ByteString

67import Data.CaseInsensitive (CI)

78import Data.Proxy

89import Data.String

910import GHC.TypeLits

11+import Network.HTTP.Types

1012

1113-- | Request ID header name.

1214-- Note that this is unofficial but a widespread thing.

@@ -37,3 +39,12 @@ incrLevel r@ReqtrackInfo{requestLevel} = r { requestLevel = requestLevel + 1 }

3739

3840replaceSource :: ByteString -> ReqtrackInfo -> ReqtrackInfo

3941replaceSource s r = r { requestSource = s }

42+

43+removeTrackingHeaders :: [Header] -> [Header]

44+removeTrackingHeaders = filter (\(hdr,_) -> hdr `notElem` [requestIdHdr, requestLevelHdr, requestSourceHdr])

45+

46+mkTrackingHeaders :: ReqtrackInfo -> [Header]

47+mkTrackingHeaders rti = [ (requestIdHdr, requestId rti)

48+ , (requestLevelHdr, ByteString.pack (show (requestLevel rti)))

49+ , (requestSourceHdr, requestSource rti)

50+ ]

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