@@ -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+ ]