git.iko.soy/typeable/request-track
on master help sign in
Feed ReqtrackInfo directly into the handler.
9cea955Nick
request-track-servant/request-track-servant.cabal+1−2
compare with master
unifiedsplit
@@ -17,8 +17,7 @@ common warnings
17library
17library
18 import: warnings
18 import: warnings
19 exposed-modules: Web.Tracking.Servant
19 exposed-modules: Web.Tracking.Servant
20− other-modules: Web.Tracking.Servant.Handler
20+ other-modules: Web.Tracking.Servant.Types
21− Web.Tracking.Servant.Types
22 -- other-extensions:
21 -- other-extensions:
23 build-depends: base >=4.14.0.0 && < 5,
22 build-depends: base >=4.14.0.0 && < 5,
24 bytestring >= 0.11,
23 bytestring >= 0.11,
request-track-servant/src/Web/Tracking/Servant/Handler.hsdeleted−9
@@ -1,9 +0,0 @@
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.hs+15−12
@@ -3,6 +3,7 @@
3{-# LANGUAGE UndecidableInstances #-}
3{-# LANGUAGE UndecidableInstances #-}
4module Web.Tracking.Servant.Types where
4module Web.Tracking.Servant.Types where
5
5
6+import Web.Tracking
6import Web.Tracking
7import Web.Tracking
7
8
8import Control.Monad ((<=<))
9import Control.Monad ((<=<))
@@ -18,33 +19,35 @@ import Servant.Server.Internal
18-- | Types to use in you API description
19-- | Types to use in you API description
19data RequestTracking
20data RequestTracking
20
21
22+type family TrackingData :: Type -> Type
23+
21-- | Same as above, except no argument is passed to a handler.
24-- | Same as above, except no argument is passed to a handler.
22data RequestTracking_
25data RequestTracking_
23
26
24−newtype ReqtrackingHandler r o = ReqtrackingHandler { unReqtrackingHandler :: r -> Handler o
27+newtype ReqtrackingHandler o = ReqtrackingHandler { unReqtrackingHandler :: Maybe ReqtrackInfo -> Handler o
25− } deriving (Functor)
28+ } deriving (Functor)
26
29
27−mkReqtrackingHandler :: (r -> Handler o) -> ReqtrackingHandler r o
30+mkReqtrackingHandler :: (Maybe ReqtrackInfo -> Handler o) -> ReqtrackingHandler o
28mkReqtrackingHandler = ReqtrackingHandler
31mkReqtrackingHandler = ReqtrackingHandler
29
32
30instance forall (api :: Type) context.
33instance forall (api :: Type) context.
31 ( HasServer api context
34 ( HasServer api context
32− , HasContextEntry context (ReqtrackingHandler Request (Maybe ReqtrackInfo))
35+ , HasContextEntry context (ReqtrackingHandler (TrackingData RequestTracking))
33 ) => HasServer (RequestTracking :> api) context where
36 ) => HasServer (RequestTracking :> api) context where
34− type ServerT (RequestTracking :> api) m = Maybe ReqtrackInfo -> ServerT api m
37+ type ServerT (RequestTracking :> api) m = TrackingData RequestTracking -> ServerT api m
35
38
36 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
39 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
37
40
38 route _ context subserver = route (Proxy :: Proxy api) context (subserver `addHeaderCheck` withRequest trackingCheck)
41 route _ context subserver = route (Proxy :: Proxy api) context (subserver `addHeaderCheck` withRequest trackingCheck)
39− where trackingCheck :: Request -> DelayedIO (Maybe ReqtrackInfo)
42+ where trackingCheck :: Request -> DelayedIO (TrackingData RequestTracking)
40 trackingCheck = either delayedFailFatal return <=< liftIO . runHandler . trackingHandler
43 trackingCheck = either delayedFailFatal return <=< liftIO . runHandler . trackingHandler
41− trackingHandler :: Request -> Handler (Maybe ReqtrackInfo)
44+ trackingHandler :: Request -> Handler (TrackingData RequestTracking)
42 trackingHandler = let ReqtrackingHandler h = getContextEntry context
45 trackingHandler = let ReqtrackingHandler h = getContextEntry context
43− in h
46+ in h . parseTrackingHeaders
44
47
45instance forall (api :: Type) context.
48instance forall (api :: Type) context.
46 ( HasServer api context
49 ( HasServer api context
47− , HasContextEntry context (ReqtrackingHandler Request (Maybe ReqtrackInfo))
50+ , HasContextEntry context (ReqtrackingHandler ())
48 ) => HasServer (RequestTracking_ :> api) context where
51 ) => HasServer (RequestTracking_ :> api) context where
49 type ServerT (RequestTracking_ :> api) m = ServerT api m
52 type ServerT (RequestTracking_ :> api) m = ServerT api m
50
53
@@ -52,10 +55,10 @@ instance forall (api :: Type) context.
52
55
53 route _ context subserver = route (Proxy :: Proxy api) context (fmap const subserver `addHeaderCheck` withRequest trackingCheck)
56 route _ context subserver = route (Proxy :: Proxy api) context (fmap const subserver `addHeaderCheck` withRequest trackingCheck)
54 where trackingCheck :: Request -> DelayedIO ()
57 where trackingCheck :: Request -> DelayedIO ()
55− trackingCheck = either delayedFailFatal (const $ return ())<=< liftIO . runHandler . trackingHandler
58+ trackingCheck = either delayedFailFatal (const $ return ()) <=< liftIO . runHandler . trackingHandler
56− trackingHandler :: Request -> Handler (Maybe ReqtrackInfo)
59+ trackingHandler :: Request -> Handler ()
57 trackingHandler = let ReqtrackingHandler h = getContextEntry context
60 trackingHandler = let ReqtrackingHandler h = getContextEntry context
58− in h
61+ in h . parseTrackingHeaders
59
62
60
63
61type ReqtrackHeaders = '[ Header RequestIdHdr ByteString
64type ReqtrackHeaders = '[ Header RequestIdHdr ByteString