git.iko.soy/typeable/request-track
on master help sign in
Add a thing for http-client.
commit1267deee4da6a5c6c58491bd412016d82eb213a9 authorNick <nick@typeable.io> dateMon 17 Jul 2023, 05:34 (3 years ago) parentaeefc6b
4 files changed+25−8
compare with master
unifiedsplit
request-track/request-track.cabal+2 request-track/src/Web/Tracking/Client.hs+11 request-track/src/Web/Tracking/Headers.hs+1−8 request-track/src/Web/Tracking/Internal.hs+11
request-track/request-track.cabal+2
@@ -17,12 +17,14 @@ common warnings
1717library
1818 import: warnings
1919 exposed-modules: Web.Tracking
20+ Web.Tracking.Client
2021 other-modules: Web.Tracking.Internal
2122 Web.Tracking.Headers
2223 -- other-extensions:
2324 build-depends: base >=4.14 && < 5,
2425 bytestring >= 0.11,
2526 case-insensitive >= 1.2,
27+ http-client >= 0.7,
2628 http-types >= 0.12,
2729 wai >= 3.2
2830 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
33import Web.Tracking.Internal
44
55import qualified Data.ByteString.Char8 as ByteString
6−import Network.HTTP.Types
76import Network.Wai
87import Text.Read (readMaybe)
98
@@ -18,13 +17,7 @@ parseTrackingHeaders req = ReqtrackInfo <$> reqId
1817
1918addTrackingHeaders :: ReqtrackInfo -> Response -> Response
2019addTrackingHeaders 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
20+ where f hdrs = mkTrackingHeaders rti ++ removeTrackingHeaders hdrs
2821
2922trackingMiddleware :: (ReqtrackInfo -> IO ()) -> Middleware
3023trackingMiddleware f app req resp
request-track/src/Web/Tracking/Internal.hs+11
@@ -3,10 +3,12 @@
33module Web.Tracking.Internal where
44
55import Data.ByteString (ByteString)
6+import qualified Data.ByteString.Char8 as ByteString
67import Data.CaseInsensitive (CI)
78import Data.Proxy
89import Data.String
910import GHC.TypeLits
11+import Network.HTTP.Types
1012
1113-- | Request ID header name.
1214-- Note that this is unofficial but a widespread thing.
@@ -37,3 +39,12 @@ incrLevel r@ReqtrackInfo{requestLevel} = r { requestLevel = requestLevel + 1 }
3739
3840replaceSource :: ByteString -> ReqtrackInfo -> ReqtrackInfo
3941replaceSource 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+ ]