1267dee · typeable/request-track

request-track/request-track.cabal+2

compare with master

unifiedsplit

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

17library

18 import: warnings

19 exposed-modules: Web.Tracking

20+ Web.Tracking.Client

20 other-modules: Web.Tracking.Internal

21 other-modules: Web.Tracking.Internal

21 Web.Tracking.Headers

22 Web.Tracking.Headers

22 -- other-extensions:

23 -- other-extensions:

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

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

24 bytestring >= 0.11,

25 bytestring >= 0.11,

25 case-insensitive >= 1.2,

26 case-insensitive >= 1.2,

27+ http-client >= 0.7,

26 http-types >= 0.12,

28 http-types >= 0.12,

27 wai >= 3.2

29 wai >= 3.2

28 hs-source-dirs: src

30 hs-source-dirs: src

request-track/src/Web/Tracking/Client.hsnew file+11

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

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

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

3import Web.Tracking.Internal

4

5import qualified Data.ByteString.Char8 as ByteString

6−import Network.HTTP.Types

7import Network.Wai

6import Network.Wai

8import Text.Read (readMaybe)

7import Text.Read (readMaybe)

9

8

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

18

17

19addTrackingHeaders :: ReqtrackInfo -> Response -> Response

18addTrackingHeaders :: ReqtrackInfo -> Response -> Response

20addTrackingHeaders rti = mapResponseHeaders f

19addTrackingHeaders rti = mapResponseHeaders f

21− where headers :: ResponseHeaders

20+ where f hdrs = mkTrackingHeaders rti ++ removeTrackingHeaders hdrs

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

21

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

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

30trackingMiddleware f app req resp

23trackingMiddleware f app req resp

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

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

3module Web.Tracking.Internal where

4

5import Data.ByteString (ByteString)

6+import qualified Data.ByteString.Char8 as ByteString

6import Data.CaseInsensitive (CI)

7import Data.CaseInsensitive (CI)

7import Data.Proxy

8import Data.Proxy

8import Data.String

9import Data.String

9import GHC.TypeLits

10import GHC.TypeLits

11+import Network.HTTP.Types

10

12

11-- | Request ID header name.

13-- | Request ID header name.

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

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

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

37

39

38replaceSource :: ByteString -> ReqtrackInfo -> ReqtrackInfo

40replaceSource :: ByteString -> ReqtrackInfo -> ReqtrackInfo

39replaceSource s r = r { requestSource = s }

41replaceSource 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+ ]