master..9cea955 · 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+1−11

@@ -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,18 +18,13 @@ 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,

28− containers >= 0.6,

2924 http-types >= 0.12,

3025 request-track,

3126 servant >= 0.19,

32− servant-client-core >= 0.19,

3327 servant-server >= 0.19,

3428 wai >= 3.2

35− if flag(openapi)

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

37− build-depends: servant-openapi3

38− cpp-options: -DOPENAPI

3929 hs-source-dirs: src

4030 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/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+13−69

@@ -3,6 +3,7 @@

33{-# LANGUAGE UndecidableInstances #-}

44module Web.Tracking.Servant.Types where

55

6+import Web.Tracking

67import Web.Tracking

78

89import Control.Monad ((<=<))

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

1011import Data.ByteString (ByteString)

1112import Data.Kind

1213import Data.Proxy

13−import qualified Data.Sequence as Seq

14−import qualified Network.Wai as Wai

14+import Network.Wai

1515import Servant.API

16−import Servant.Client.Core

1716import Servant.Server

1817import Servant.Server.Internal

1918

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

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

4620data RequestTracking

4721

48−-- | See 'RequestTracking'

49−type family TrackingData a

22+type family TrackingData :: Type -> Type

5023

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

5225data RequestTracking_

5326

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

57− } deriving (Functor)

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

27+newtype ReqtrackingHandler o = ReqtrackingHandler { unReqtrackingHandler :: Maybe ReqtrackInfo -> Handler o

28+ } deriving (Functor)

6729

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

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

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

7031mkReqtrackingHandler = ReqtrackingHandler

7132

7233instance forall (api :: Type) context.

7334 ( HasServer api context

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

35+ , HasContextEntry context (ReqtrackingHandler (TrackingData RequestTracking))

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

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

7738

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

7940

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

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

42+ where trackingCheck :: Request -> DelayedIO (TrackingData RequestTracking)

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

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

44+ trackingHandler :: Request -> Handler (TrackingData RequestTracking)

8445 trackingHandler = let ReqtrackingHandler h = getContextEntry context

8546 in h . parseTrackingHeaders

8647

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−

9748instance forall (api :: Type) context.

9849 ( HasServer api context

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

50+ , HasContextEntry context (ReqtrackingHandler ())

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

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

10253

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

10455

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

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

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

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

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

59+ trackingHandler :: Request -> Handler ()

10960 trackingHandler = let ReqtrackingHandler h = getContextEntry context

11061 in h . parseTrackingHeaders

11162

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−

11863

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

12064type ReqtrackHeaders = '[ Header RequestIdHdr ByteString

12165 , Header RequestLevelHdr Word

12266 , 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