master..7eb83f8 · typeable/request-track

README.orgdeleted−18

since splitsnapshots

unifiedsplit

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

16executable example-server

17 import: warnings

18 main-is: Main.hs

19− other-modules: API

20− Client

21− Server

22− TLS

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

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

24− exceptions >= 0.10,

25 http-client,

20 http-client,

26 request-track,

21 request-track,

27 request-track-servant,

22 request-track-servant,

28 servant,

23 servant,

29− servant-client,

30 servant-server,

24 servant-server,

31 thread-local,

25 thread-local,

32 wai,

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE TypeFamilies #-}

4module Main where

3module Main where

5

4

6−import API

7−import Server

8−import TLS

9−

10import Control.Concurrent.ThreadLocal

5import Control.Concurrent.ThreadLocal

6+import Control.Monad.IO.Class

7+import Data.Proxy

8+import Network.Wai

11import Network.Wai.Handler.Warp

9import Network.Wai.Handler.Warp

10+import Servant.API

12import Servant.Server

11import Servant.Server

13−import Web.Tracking hiding (addTrackingHeaders)

12+import Web.Tracking

14import Web.Tracking.Servant

13import Web.Tracking.Servant

15

14

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+

16main :: IO ()

37main :: IO ()

38+main = do tls <- newThreadLocalWithGC 60

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

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

18− $ serveWithContext exampleAPI ctx server

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

19− where ctx = mkReqtrackingHandler rqHandler

41+ where ctx = mkReqtrackingHandler rqHandler :. EmptyContext

20− :. mkReqtrackingHandler rqHandler_

21− :. 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

11category: Web

12build-type: Simple

13

14−flag openapi

15− description: Enable openapi instances

16− default: False

17− manual: True

18−

19common warnings

14common warnings

20 ghc-options: -Wall

15 ghc-options: -Wall

21

16

22library

17library

23 import: warnings

18 import: warnings

24 exposed-modules: Web.Tracking.Servant

19 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:

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

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

27 bytestring >= 0.11,

24 bytestring >= 0.11,

28− containers >= 0.6,

29 http-types >= 0.12,

25 http-types >= 0.12,

30 request-track,

26 request-track,

31 servant >= 0.19,

27 servant >= 0.19,

32− servant-client-core >= 0.19,

33 servant-server >= 0.19,

28 servant-server >= 0.19,

34 wai >= 3.2

29 wai >= 3.2

35− if flag(openapi)

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

37− build-depends: servant-openapi3

38− cpp-options: -DOPENAPI

39 hs-source-dirs: src

30 hs-source-dirs: src

40 default-language: GHC2021

31 default-language: GHC2021

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

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

1−{-# LANGUAGE CPP #-}

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

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

3

2

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

3import 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.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

10import Data.ByteString (ByteString)

11import Data.Kind

12import Data.Proxy

13−import qualified Data.Sequence as Seq

14−import qualified Network.Wai as Wai

13+import Network.Wai

15import Servant.API

14import Servant.API

16−import Servant.Client.Core

17import Servant.Server

15import Servant.Server

18import Servant.Server.Internal

16import Servant.Server.Internal

19

17

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

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

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

46data RequestTracking

19data RequestTracking

47

20

48−-- | See 'RequestTracking'

49−type family TrackingData a

50−

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

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

52data RequestTracking_

22data RequestTracking_

53

23

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

57 } deriving (Functor)

25 } deriving (Functor)

58

26

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

70mkReqtrackingHandler = ReqtrackingHandler

28mkReqtrackingHandler = ReqtrackingHandler

71

29

72instance forall (api :: Type) context.

30instance forall (api :: Type) context.

73 ( HasServer api context

31 ( HasServer api context

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

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

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

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

77

35

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

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

79

37

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

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

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

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

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

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

84 trackingHandler = let ReqtrackingHandler h = getContextEntry context

42 trackingHandler = let ReqtrackingHandler h = getContextEntry context

85− in h . parseTrackingHeaders

43+ in h

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−

96

44

97instance forall (api :: Type) context.

45instance forall (api :: Type) context.

98 ( HasServer api context

46 ( HasServer api context

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

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

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

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

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

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

102

50

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

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

104

52

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

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

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

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

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

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

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

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

109 trackingHandler = let ReqtrackingHandler h = getContextEntry context

57 trackingHandler = let ReqtrackingHandler h = getContextEntry context

110− in h . parseTrackingHeaders

58+ in h

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

117

59

118

60

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

120type ReqtrackHeaders = '[ Header RequestIdHdr ByteString

61type ReqtrackHeaders = '[ Header RequestIdHdr ByteString

121 , Header RequestLevelHdr Word

62 , Header RequestLevelHdr Word

122 , Header RequestSourceHdr ByteString

63 , Header RequestSourceHdr ByteString

stack.yaml+1−5

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

1−resolver: lts-21.6

1+resolver: lts-20.26

2

3packages:

4- example-server

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

11

12nix:

13 packages: [ zlib ]

14−

15−flags:

16− request-track-servant:

17− openapi: true