9cea955 · typeable/request-track

git.iko.soy/typeable/request-track

Feed ReqtrackInfo directly into the handler.

commit9cea955fe5856b3f5a108c4a8c61cb2ed1f20a65 authorNick <nick@typeable.io> dateThu 20 Jul 2023, 18:01 (3 years ago) parent7eb83f8

3 files changed+16−23

compare with master

unifiedsplit

request-track-servant/request-track-servant.cabal+1−2 request-track-servant/src/Web/Tracking/Servant/Handler.hs−9 request-track-servant/src/Web/Tracking/Servant/Types.hs+15−12

request-track-servant/request-track-servant.cabal+1−2

@@ -17,8 +17,7 @@ common warnings

1717library

1818 import: warnings

1919 exposed-modules: Web.Tracking.Servant

20− other-modules: Web.Tracking.Servant.Handler

21− Web.Tracking.Servant.Types

20+ other-modules: Web.Tracking.Servant.Types

2221 -- other-extensions:

2322 build-depends: base >=4.14.0.0 && < 5,

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

33{-# LANGUAGE UndecidableInstances #-}

44module Web.Tracking.Servant.Types where

6+import Web.Tracking

67import Web.Tracking

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

@@ -18,33 +19,35 @@ import Servant.Server.Internal

1819-- | Types to use in you API description

1920data RequestTracking

2021

22+type family TrackingData :: Type -> Type

23+

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

2225data RequestTracking_

2326

24−newtype ReqtrackingHandler r o = ReqtrackingHandler { unReqtrackingHandler :: r -> Handler o

25− } deriving (Functor)

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

28+ } deriving (Functor)

2629

27−mkReqtrackingHandler :: (r -> Handler o) -> ReqtrackingHandler r o

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

2831mkReqtrackingHandler = ReqtrackingHandler

2932

3033instance forall (api :: Type) context.

3134 ( HasServer api context

32− , HasContextEntry context (ReqtrackingHandler Request (Maybe ReqtrackInfo))

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

3336 ) => 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

3538

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

3740

3841 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)

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

41− trackingHandler :: Request -> Handler (Maybe ReqtrackInfo)

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

4245 trackingHandler = let ReqtrackingHandler h = getContextEntry context

43− in h

46+ in h . parseTrackingHeaders

4447

4548instance forall (api :: Type) context.

4649 ( HasServer api context

47− , HasContextEntry context (ReqtrackingHandler Request (Maybe ReqtrackInfo))

50+ , HasContextEntry context (ReqtrackingHandler ())

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

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

5053

@@ -52,10 +55,10 @@ instance forall (api :: Type) context.

5255

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

5457 where trackingCheck :: Request -> DelayedIO ()

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

56− trackingHandler :: Request -> Handler (Maybe ReqtrackInfo)

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

59+ trackingHandler :: Request -> Handler ()

5760 trackingHandler = let ReqtrackingHandler h = getContextEntry context

58− in h

61+ in h . parseTrackingHeaders

5962

6063

6164type ReqtrackHeaders = '[ Header RequestIdHdr ByteString