master..aeefc6b · typeable/request-track

README.orgdeleted−18

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

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,17 +16,11 @@ common warnings

1616executable example-server

1717 import: warnings

1818 main-is: Main.hs

19− other-modules: API

20− Client

21− Server

22− TLS

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

24− exceptions >= 0.10,

2520 http-client,

2621 request-track,

2722 request-track-servant,

2823 servant,

29− servant-client,

3024 servant-server,

3125 thread-local,

3226 wai,

example-server/src/API.hsdeleted−13

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

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.hsdeleted−48

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

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+31−11

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

11{-# LANGUAGE DataKinds #-}

22{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE TypeFamilies #-}

43module Main where

54

6−import API

7−import Server

8−import TLS

9−

105import Control.Concurrent.ThreadLocal

6+import Control.Monad.IO.Class

7+import Data.Proxy

8+import Network.Wai

119import Network.Wai.Handler.Warp

10+import Servant.API

1211import Servant.Server

13−import Web.Tracking hiding (addTrackingHeaders)

12+import Web.Tracking

1413import Web.Tracking.Servant

1514

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+

1637main :: IO ()

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

18− $ serveWithContext exampleAPI ctx server

19− where ctx = mkReqtrackingHandler rqHandler

20− :. mkReqtrackingHandler rqHandler_

21− :. EmptyContext

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

example-server/src/Server.hsdeleted−38

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

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.hsdeleted−9

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

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.confdeleted−41

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

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

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

1914common warnings

2015 ghc-options: -Wall

2116

2217library

2318 import: warnings

2419 exposed-modules: Web.Tracking.Servant

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

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

21+ Web.Tracking.Servant.Types

22+ -- other-extensions:

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

2724 bytestring >= 0.11,

28− containers >= 0.6,

2925 http-types >= 0.12,

3026 request-track,

3127 servant >= 0.19,

32− servant-client-core >= 0.19,

3328 servant-server >= 0.19,

3429 wai >= 3.2

35− if flag(openapi)

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

37− build-depends: servant-openapi3

38− cpp-options: -DOPENAPI

3930 hs-source-dirs: src

4031 default-language: GHC2021

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

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

1−{-# LANGUAGE CPP #-}

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

32

43import 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.hsnew file+9

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

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.hsdeleted−14

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

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

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

1010import Data.ByteString (ByteString)

1111import Data.Kind

1212import Data.Proxy

13−import qualified Data.Sequence as Seq

14−import qualified Network.Wai as Wai

13+import Network.Wai

1514import Servant.API

16−import Servant.Client.Core

1715import Servant.Server

1816import Servant.Server.Internal

1917

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

18+-- | Types to use in you API description

4619data RequestTracking

4720

48−-- | See 'RequestTracking'

49−type family TrackingData a

50−

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

5222data RequestTracking_

5323

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

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

5725 } deriving (Functor)

5826

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

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

7028mkReqtrackingHandler = ReqtrackingHandler

7129

7230instance forall (api :: Type) context.

7331 ( HasServer api context

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

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

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

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

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

7735

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

7937

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

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

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

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

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

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

8442 trackingHandler = let ReqtrackingHandler h = getContextEntry context

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−

43+ in h

9644

9745instance forall (api :: Type) context.

9846 ( HasServer api context

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

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

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

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

10250

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

10452

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

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

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

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

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

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

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

10957 trackingHandler = let ReqtrackingHandler h = getContextEntry context

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

58+ in h

11759

11860

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

12061type ReqtrackHeaders = '[ Header RequestIdHdr ByteString

12162 , Header RequestLevelHdr Word

12263 , Header RequestSourceHdr ByteString

request-track/request-track.cabal−2

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

1717library

1818 import: warnings

1919 exposed-modules: Web.Tracking

20− Web.Tracking.Client

2120 other-modules: Web.Tracking.Internal

2221 Web.Tracking.Headers

2322 -- other-extensions:

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

2524 bytestring >= 0.11,

2625 case-insensitive >= 1.2,

27− http-client >= 0.7,

2826 http-types >= 0.12,

2927 wai >= 3.2

3028 hs-source-dirs: src

request-track/src/Web/Tracking/Client.hsdeleted−11

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

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+8−6

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

33import Web.Tracking.Internal

44

55import qualified Data.ByteString.Char8 as ByteString

6+import Network.HTTP.Types

67import Network.Wai

78import Text.Read (readMaybe)

89

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

1718

1819addTrackingHeaders :: ReqtrackInfo -> Response -> Response

1920addTrackingHeaders 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

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

2628

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

2830trackingMiddleware f app req resp

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

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

33module Web.Tracking.Internal where

44

55import Data.ByteString (ByteString)

6−import qualified Data.ByteString.Char8 as ByteString

76import Data.CaseInsensitive (CI)

87import Data.Proxy

98import Data.String

109import GHC.TypeLits

11−import Network.HTTP.Types

1210

1311-- | Request ID header name.

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

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

3937

4038replaceSource :: ByteString -> ReqtrackInfo -> ReqtrackInfo

4139replaceSource 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+1−5

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

1−resolver: lts-21.6

1+resolver: lts-20.26

22

33packages:

44- example-server

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

1111

1212nix:

1313 packages: [ zlib ]

14−

15−flags:

16− request-track-servant:

17− openapi: true