git.iko.soy/typeable/request-track
on master help sign in
Initial.
aeefc6bNick
.gitignorenew file+1
compare with master
unifiedsplit
@@ -0,0 +1 @@
1+.stack-work
example-server/LICENSEnew file+20
@@ -0,0 +1,20 @@
1+Copyright (c) 2023 Nick
2+
3+Permission is hereby granted, free of charge, to any person obtaining
4+a copy of this software and associated documentation files (the
5+"Software"), to deal in the Software without restriction, including
6+without limitation the rights to use, copy, modify, merge, publish,
7+distribute, sublicense, and/or sell copies of the Software, and to
8+permit persons to whom the Software is furnished to do so, subject to
9+the following conditions:
10+
11+The above copyright notice and this permission notice shall be included
12+in all copies or substantial portions of the Software.
13+
14+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
17+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
18+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
19+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
20+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
example-server/example-server.cabalnew file+29
@@ -0,0 +1,29 @@
1+cabal-version: 3.0
2+name: example-server
3+version: 0.1
4+synopsis: Example server to showcase request tracking
5+-- description:
6+license: MIT
7+license-file: LICENSE
8+author: Nick
9+maintainer: nick@typeable.io
10+category: Web
11+build-type: Simple
12+
13+common warnings
14+ ghc-options: -Wall
15+
16+executable example-server
17+ import: warnings
18+ main-is: Main.hs
19+ build-depends: base >=4.16 && <5,
20+ http-client,
21+ request-track,
22+ request-track-servant,
23+ servant,
24+ servant-server,
25+ thread-local,
26+ wai,
27+ warp >= 3.3
28+ hs-source-dirs: src
29+ default-language: GHC2021
example-server/src/Main.hsnew file+41
@@ -0,0 +1,41 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Main where
4+
5+import Control.Concurrent.ThreadLocal
6+import Control.Monad.IO.Class
7+import Data.Proxy
8+import Network.Wai
9+import Network.Wai.Handler.Warp
10+import Servant.API
11+import Servant.Server
12+import Web.Tracking
13+import Web.Tracking.Servant
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+
37+main :: 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
request-track-servant/LICENSEnew file+20
@@ -0,0 +1,20 @@
1+Copyright (c) 2023 Nick
2+
3+Permission is hereby granted, free of charge, to any person obtaining
4+a copy of this software and associated documentation files (the
5+"Software"), to deal in the Software without restriction, including
6+without limitation the rights to use, copy, modify, merge, publish,
7+distribute, sublicense, and/or sell copies of the Software, and to
8+permit persons to whom the Software is furnished to do so, subject to
9+the following conditions:
10+
11+The above copyright notice and this permission notice shall be included
12+in all copies or substantial portions of the Software.
13+
14+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
17+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
18+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
19+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
20+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
request-track-servant/request-track-servant.cabalnew file+31
@@ -0,0 +1,31 @@
1+cabal-version: 3.0
2+name: request-track-servant
3+version: 0.1
4+synopsis: Servant combinators for request tracking
5+-- description:
6+license: MIT
7+license-file: LICENSE
8+author: Nick
9+maintainer: nick@typeable.io
10+-- copyright:
11+category: Web
12+build-type: Simple
13+
14+common warnings
15+ ghc-options: -Wall
16+
17+library
18+ import: warnings
19+ exposed-modules: Web.Tracking.Servant
20+ other-modules: Web.Tracking.Servant.Handler
21+ Web.Tracking.Servant.Types
22+ -- other-extensions:
23+ build-depends: base >=4.14.0.0 && < 5,
24+ bytestring >= 0.11,
25+ http-types >= 0.12,
26+ request-track,
27+ servant >= 0.19,
28+ servant-server >= 0.19,
29+ wai >= 3.2
30+ hs-source-dirs: src
31+ default-language: GHC2021
request-track-servant/src/Web/Tracking/Servant.hsnew file+5
@@ -0,0 +1,5 @@
1+module Web.Tracking.Servant (module Export) where
2+
3+import Web.Tracking as Export (ReqtrackInfo(..))
4+import Web.Tracking.Servant.Handler as Export
5+import Web.Tracking.Servant.Types as Export
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/Types.hsnew file+64
@@ -0,0 +1,64 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE UndecidableInstances #-}
4+module Web.Tracking.Servant.Types where
5+
6+import Web.Tracking
7+
8+import Control.Monad ((<=<))
9+import Control.Monad.IO.Class
10+import Data.ByteString (ByteString)
11+import Data.Kind
12+import Data.Proxy
13+import Network.Wai
14+import Servant.API
15+import Servant.Server
16+import Servant.Server.Internal
17+
18+-- | Types to use in you API description
19+data RequestTracking
20+
21+-- | Same as above, except no argument is passed to a handler.
22+data RequestTracking_
23+
24+newtype ReqtrackingHandler r o = ReqtrackingHandler { unReqtrackingHandler :: r -> Handler o
25+ } deriving (Functor)
26+
27+mkReqtrackingHandler :: (r -> Handler o) -> ReqtrackingHandler r o
28+mkReqtrackingHandler = ReqtrackingHandler
29+
30+instance forall (api :: Type) context.
31+ ( HasServer api context
32+ , HasContextEntry context (ReqtrackingHandler Request (Maybe ReqtrackInfo))
33+ ) => HasServer (RequestTracking :> api) context where
34+ type ServerT (RequestTracking :> api) m = Maybe ReqtrackInfo -> ServerT api m
35+
36+ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
37+
38+ route _ context subserver = route (Proxy :: Proxy api) context (subserver `addHeaderCheck` withRequest trackingCheck)
39+ where trackingCheck :: Request -> DelayedIO (Maybe ReqtrackInfo)
40+ trackingCheck = either delayedFailFatal return <=< liftIO . runHandler . trackingHandler
41+ trackingHandler :: Request -> Handler (Maybe ReqtrackInfo)
42+ trackingHandler = let ReqtrackingHandler h = getContextEntry context
43+ in h
44+
45+instance forall (api :: Type) context.
46+ ( HasServer api context
47+ , HasContextEntry context (ReqtrackingHandler Request (Maybe ReqtrackInfo))
48+ ) => HasServer (RequestTracking_ :> api) context where
49+ type ServerT (RequestTracking_ :> api) m = ServerT api m
50+
51+ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s
52+
53+ 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)
57+ trackingHandler = let ReqtrackingHandler h = getContextEntry context
58+ in h
59+
60+
61+type ReqtrackHeaders = '[ Header RequestIdHdr ByteString
62+ , Header RequestLevelHdr Word
63+ , Header RequestSourceHdr ByteString
64+ ]
request-track/LICENSEnew file+20
@@ -0,0 +1,20 @@
1+Copyright (c) 2023 Nick
2+
3+Permission is hereby granted, free of charge, to any person obtaining
4+a copy of this software and associated documentation files (the
5+"Software"), to deal in the Software without restriction, including
6+without limitation the rights to use, copy, modify, merge, publish,
7+distribute, sublicense, and/or sell copies of the Software, and to
8+permit persons to whom the Software is furnished to do so, subject to
9+the following conditions:
10+
11+The above copyright notice and this permission notice shall be included
12+in all copies or substantial portions of the Software.
13+
14+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
17+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
18+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
19+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
20+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
request-track/request-track.cabalnew file+29
@@ -0,0 +1,29 @@
1+cabal-version: 3.0
2+name: request-track
3+version: 0.1
4+synopsis: Track HTTP requests across services
5+-- description:
6+license: MIT
7+license-file: LICENSE
8+author: Nick
9+maintainer: nick@typeable.io
10+copyright: Typeable.io
11+category: Web
12+build-type: Simple
13+
14+common warnings
15+ ghc-options: -Wall
16+
17+library
18+ import: warnings
19+ exposed-modules: Web.Tracking
20+ other-modules: Web.Tracking.Internal
21+ Web.Tracking.Headers
22+ -- other-extensions:
23+ build-depends: base >=4.14 && < 5,
24+ bytestring >= 0.11,
25+ case-insensitive >= 1.2,
26+ http-types >= 0.12,
27+ wai >= 3.2
28+ hs-source-dirs: src
29+ default-language: GHC2021
request-track/src/Web/Tracking.hsnew file+4
@@ -0,0 +1,4 @@
1+module Web.Tracking (module Export) where
2+
3+import Web.Tracking.Headers as Export
4+import Web.Tracking.Internal as Export
request-track/src/Web/Tracking/Headers.hsnew file+33
@@ -0,0 +1,33 @@
1+module Web.Tracking.Headers where
2+
3+import Web.Tracking.Internal
4+
5+import qualified Data.ByteString.Char8 as ByteString
6+import Network.HTTP.Types
7+import Network.Wai
8+import Text.Read (readMaybe)
9+
10+parseTrackingHeaders :: Request -> Maybe ReqtrackInfo
11+parseTrackingHeaders req = ReqtrackInfo <$> reqId
12+ <*> reqLevel
13+ <*> reqSource
14+ where headers = requestHeaders req
15+ reqId = lookup requestIdHdr headers
16+ reqLevel = readMaybe . ByteString.unpack =<< lookup requestLevelHdr headers
17+ reqSource = lookup requestSourceHdr headers
18+
19+addTrackingHeaders :: ReqtrackInfo -> Response -> Response
20+addTrackingHeaders 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
28+
29+trackingMiddleware :: (ReqtrackInfo -> IO ()) -> Middleware
30+trackingMiddleware f app req resp
31+ | Just rti <- parseTrackingHeaders req = do f rti
32+ app req (resp . addTrackingHeaders rti)
33+ | otherwise = app req resp
request-track/src/Web/Tracking/Internal.hsnew file+39
@@ -0,0 +1,39 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Web.Tracking.Internal where
4+
5+import Data.ByteString (ByteString)
6+import Data.CaseInsensitive (CI)
7+import Data.Proxy
8+import Data.String
9+import GHC.TypeLits
10+
11+-- | Request ID header name.
12+-- Note that this is unofficial but a widespread thing.
13+-- See here for more details: https://http.dev/x-request-id
14+type RequestIdHdr = "X-REQUEST-ID"
15+requestIdHdr :: CI ByteString
16+requestIdHdr = fromString (symbolVal (Proxy :: Proxy RequestIdHdr))
17+
18+-- | Request level header.
19+-- Contains a number. Each sub-request must be an increment of the received value.
20+type RequestLevelHdr = "X-REQUEST-LEVEL"
21+requestLevelHdr :: CI ByteString
22+requestLevelHdr = fromString (symbolVal (Proxy :: Proxy RequestLevelHdr))
23+
24+-- | Source for outgoing request.
25+-- Should be the name of the service that makes a request or a subrequest.
26+type RequestSourceHdr = "X-REQUEST-SOURCE"
27+requestSourceHdr :: CI ByteString
28+requestSourceHdr = fromString (symbolVal (Proxy :: Proxy RequestSourceHdr))
29+
30+data ReqtrackInfo = ReqtrackInfo { requestId :: ByteString
31+ , requestLevel :: Word
32+ , requestSource :: ByteString
33+ } deriving (Eq, Show)
34+
35+incrLevel :: ReqtrackInfo -> ReqtrackInfo
36+incrLevel r@ReqtrackInfo{requestLevel} = r { requestLevel = requestLevel + 1 }
37+
38+replaceSource :: ByteString -> ReqtrackInfo -> ReqtrackInfo
39+replaceSource s r = r { requestSource = s }
stack.yamlnew file+13
@@ -0,0 +1,13 @@
1+resolver: lts-20.26
2+
3+packages:
4+- example-server
5+- request-track
6+- request-track-servant
7+
8+extra-deps:
9+ - git: https://github.com/typeable/thread-local.git
10+ commit: 10965a0cd5a208db7e4a513dd505eea1f4dc2167
11+
12+nix:
13+ packages: [ zlib ]