servant-ekg/lib/Servant/Ekg.hs

219 lines
9.4 KiB
Haskell
Raw Normal View History

{-# LANGUAGE CPP #-}
2015-05-01 07:28:43 +02:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
2015-05-01 07:28:43 +02:00
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
2015-05-01 04:40:08 +02:00
module Servant.Ekg (
HasEndpoint(..),
APIEndpoint(..),
monitorEndpoints
) where
2015-05-01 04:40:08 +02:00
import Control.Exception
import Control.Monad
import Data.Hashable (Hashable (..))
2015-05-01 07:28:43 +02:00
import qualified Data.HashMap.Strict as H
import Data.Monoid
import Data.Proxy
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import GHC.TypeLits
import Network.HTTP.Types (Method)
2015-05-01 04:40:08 +02:00
import Network.Wai
2015-05-01 07:28:43 +02:00
import Servant.API
import Servant.Ekg.Internal
2015-05-01 07:28:43 +02:00
import System.Metrics
2015-05-01 04:40:08 +02:00
import qualified System.Metrics.Counter as Counter
import qualified System.Metrics.Distribution as Distribution
import qualified System.Metrics.Gauge as Gauge
monitorEndpoints :: HasEndpoint api => Proxy api -> Store -> IO Middleware
monitorEndpoints proxy store = do
meters <- initializeMetersTable store (enumerateEndpoints proxy)
return (monitorEndpoints' meters)
where
monitorEndpoints' :: H.HashMap APIEndpoint Meters -> Middleware
monitorEndpoints' meters application request respond =
case getEndpoint proxy request >>= \ep -> H.lookup ep meters of
Nothing ->
application request respond
Just meters ->
updateCounters meters application request respond
where
updateCounters Meters{..} =
responseTimeDistribution metersTime
. countResponseCodes (metersC2XX, metersC4XX, metersC5XX, metersCXXX)
. gaugeInflight metersInflight
2015-05-01 07:28:43 +02:00
class HasEndpoint a where
getEndpoint :: Proxy a -> Request -> Maybe APIEndpoint
enumerateEndpoints :: Proxy a -> [APIEndpoint]
2015-05-01 07:28:43 +02:00
2019-02-09 18:50:52 +01:00
instance HasEndpoint EmptyAPI where
getEndpoint _ _ = Nothing
enumerateEndpoints _ = []
2019-02-09 18:50:52 +01:00
2015-05-01 07:28:43 +02:00
instance (HasEndpoint (a :: *), HasEndpoint (b :: *)) => HasEndpoint (a :<|> b) where
getEndpoint _ req =
getEndpoint (Proxy :: Proxy a) req
`mplus` getEndpoint (Proxy :: Proxy b) req
enumerateEndpoints _ =
enumerateEndpoints (Proxy :: Proxy a)
<> enumerateEndpoints (Proxy :: Proxy b)
2015-05-01 07:28:43 +02:00
2016-05-13 16:15:03 +02:00
instance (KnownSymbol (path :: Symbol), HasEndpoint (sub :: *))
=> HasEndpoint (path :> sub) where
2015-05-01 07:28:43 +02:00
getEndpoint _ req =
case pathInfo req of
p:ps | p == T.pack (symbolVal (Proxy :: Proxy path)) -> do
APIEndpoint{..} <- getEndpoint (Proxy :: Proxy sub) req{ pathInfo = ps }
return (APIEndpoint (p:pathSegments) method)
2015-05-01 07:28:43 +02:00
_ -> Nothing
enumerateEndpoints _ =
let endpoints = enumerateEndpoints (Proxy :: Proxy sub)
currentSegment = T.pack $ symbolVal (Proxy :: Proxy path)
qualify APIEndpoint{..} = APIEndpoint (currentSegment : pathSegments) method
in
map qualify endpoints
2016-05-13 16:15:03 +02:00
instance (KnownSymbol (capture :: Symbol), HasEndpoint (sub :: *))
2019-02-09 18:50:52 +01:00
=> HasEndpoint (Capture' mods capture a :> sub) where
2015-05-01 07:28:43 +02:00
getEndpoint _ req =
case pathInfo req of
_:ps -> do
APIEndpoint{..} <- getEndpoint (Proxy :: Proxy sub) req{ pathInfo = ps }
2015-05-01 07:28:43 +02:00
let p = T.pack $ (':':) $ symbolVal (Proxy :: Proxy capture)
return (APIEndpoint (p:pathSegments) method)
2015-05-01 07:28:43 +02:00
_ -> Nothing
enumerateEndpoints _ =
let endpoints = enumerateEndpoints (Proxy :: Proxy sub)
currentSegment = T.pack $ (':':) $ symbolVal (Proxy :: Proxy capture)
qualify APIEndpoint{..} = APIEndpoint (currentSegment : pathSegments) method
in
map qualify endpoints
2015-05-01 07:28:43 +02:00
2019-02-09 18:50:52 +01:00
instance HasEndpoint (sub :: *) => HasEndpoint (Summary d :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)
2019-02-09 18:50:52 +01:00
instance HasEndpoint (sub :: *) => HasEndpoint (Description d :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)
2019-02-09 18:50:52 +01:00
instance HasEndpoint (sub :: *) => HasEndpoint (Header' mods h a :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)
2022-01-30 01:36:48 +01:00
2022-02-05 02:16:25 +01:00
#if MIN_VERSION_servant(0,18,2)
2022-01-30 01:36:48 +01:00
instance HasEndpoint (sub :: *) => HasEndpoint (Fragment a :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)
2022-02-05 02:16:25 +01:00
#endif
2019-02-09 18:50:52 +01:00
instance HasEndpoint (sub :: *) => HasEndpoint (QueryParam' mods (h :: Symbol) a :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)
instance HasEndpoint (sub :: *) => HasEndpoint (QueryParams (h :: Symbol) a :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)
2016-05-13 17:54:18 +02:00
instance HasEndpoint (sub :: *) => HasEndpoint (QueryFlag h :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)
2016-05-13 17:54:18 +02:00
2019-02-09 18:50:52 +01:00
instance HasEndpoint (sub :: *) => HasEndpoint (ReqBody' mods cts a :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)
2019-02-09 18:50:52 +01:00
#if MIN_VERSION_servant(0,15,0)
2019-02-09 18:50:52 +01:00
instance HasEndpoint (sub :: *) => HasEndpoint (StreamBody' mods framing ct a :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)
#endif
2015-05-01 07:28:43 +02:00
2016-05-13 17:54:18 +02:00
instance HasEndpoint (sub :: *) => HasEndpoint (RemoteHost :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)
2016-05-13 17:54:18 +02:00
instance HasEndpoint (sub :: *) => HasEndpoint (IsSecure :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)
2016-05-13 17:54:18 +02:00
instance HasEndpoint (sub :: *) => HasEndpoint (HttpVersion :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)
2016-05-13 17:54:18 +02:00
instance HasEndpoint (sub :: *) => HasEndpoint (Vault :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)
2016-05-13 17:54:18 +02:00
instance HasEndpoint (sub :: *) => HasEndpoint (WithNamedContext x y sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)
2016-05-13 17:54:18 +02:00
2016-05-13 12:27:26 +02:00
instance ReflectMethod method => HasEndpoint (Verb method status cts a) where
2015-05-01 07:28:43 +02:00
getEndpoint _ req = case pathInfo req of
[] | requestMethod req == method -> Just (APIEndpoint [] method)
_ -> Nothing
2016-05-13 12:27:26 +02:00
where method = reflectMethod (Proxy :: Proxy method)
2015-05-01 07:28:43 +02:00
enumerateEndpoints _ = [APIEndpoint mempty method]
where method = reflectMethod (Proxy :: Proxy method)
2020-01-23 22:35:38 +01:00
#if MIN_VERSION_servant(0,17,0)
instance ReflectMethod method => HasEndpoint (NoContentVerb method) where
getEndpoint _ req = case pathInfo req of
[] | requestMethod req == method -> Just (APIEndpoint [] method)
_ -> Nothing
where method = reflectMethod (Proxy :: Proxy method)
enumerateEndpoints _ = [APIEndpoint mempty method]
where method = reflectMethod (Proxy :: Proxy method)
#endif
2022-02-05 02:16:25 +01:00
#if MIN_VERSION_servant(0,18,1)
instance ReflectMethod method => HasEndpoint (UVerb method contentType as) where
getEndpoint _ req = case pathInfo req of
[] | requestMethod req == method -> Just (APIEndpoint [] method)
_ -> Nothing
where method = reflectMethod (Proxy :: Proxy method)
enumerateEndpoints _ = [APIEndpoint mempty method]
where method = reflectMethod (Proxy :: Proxy method)
#endif
2019-02-09 18:50:52 +01:00
instance ReflectMethod method => HasEndpoint (Stream method status framing ct a) where
getEndpoint _ req = case pathInfo req of
[] | requestMethod req == method -> Just (APIEndpoint [] method)
_ -> Nothing
2019-02-09 18:50:52 +01:00
where method = reflectMethod (Proxy :: Proxy method)
enumerateEndpoints _ = [APIEndpoint mempty method]
where method = reflectMethod (Proxy :: Proxy method)
instance HasEndpoint Raw where
getEndpoint _ _ = Just (APIEndpoint [] "RAW")
enumerateEndpoints _ = [APIEndpoint [] "RAW"]
instance HasEndpoint (sub :: *) => HasEndpoint (CaptureAll (h :: Symbol) a :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)
2019-02-12 01:52:05 +01:00
instance HasEndpoint (sub :: *) => HasEndpoint (BasicAuth (realm :: Symbol) a :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)