master..1fe3a57 · 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+30−10

@@ -3,19 +3,39 @@

33{-# LANGUAGE TypeFamilies #-}

44module Main where

55

6−import API

7−import Server

8−import TLS

9−

106import Control.Concurrent.ThreadLocal

7+import Control.Monad.IO.Class

8+import Data.Proxy

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 instance TrackingData RequestTracking = ()

16+

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

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

19+

20+echoHandler :: () -> Handler String

21+echoHandler _ = pure "PONG"

22+

23+relayHandler :: Handler String

24+relayHandler = pure "RELAY"

25+

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

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

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

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

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

31+ ])

32+rqHandler Nothing = liftIO $ 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 :. 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+1−9

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

@@ -23,6 +18,7 @@ library

2318 import: warnings

2419 exposed-modules: Web.Tracking.Servant

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

21+ -- other-extensions:

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

2723 bytestring >= 0.11,

2824 containers >= 0.6,

@@ -32,9 +28,5 @@ library

3228 servant-client-core >= 0.19,

3329 servant-server >= 0.19,

3430 wai >= 3.2

35− if flag(openapi)

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

37− build-depends: servant-openapi3

38− cpp-options: -DOPENAPI

3931 hs-source-dirs: src

4032 default-language: GHC2021

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

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

1−{-# LANGUAGE CPP #-}

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

32

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

54import 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.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+2−41

@@ -17,55 +17,17 @@ import Servant.Client.Core

1717import Servant.Server

1818import Servant.Server.Internal

1919

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

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

4621data RequestTracking

4722

48−-- | See 'RequestTracking'

4923type family TrackingData a

5024

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

5226data RequestTracking_

5327

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

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

5729 } deriving (Functor)

5830

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

6931mkReqtrackingHandler :: (Maybe ReqtrackInfo -> Handler o) -> ReqtrackingHandler (Maybe ReqtrackInfo) o

7032mkReqtrackingHandler = ReqtrackingHandler

7133

@@ -116,7 +78,6 @@ instance HasClient m api => HasClient m (RequestTracking_ :> api) where

11678 hoistClientMonad pm Proxy f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl

11779

11880

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

12081type ReqtrackHeaders = '[ Header RequestIdHdr ByteString

12182 , Header RequestLevelHdr Word

12283 , Header RequestSourceHdr ByteString

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