servant-ekg/lib/Servant/Ekg.hs

169 lines
6.7 KiB
Haskell
Raw Permalink Normal View History

{-# LANGUAGE CPP #-}
2015-05-01 07:28:43 +02:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
2016-05-13 12:27:26 +02:00
{-# LANGUAGE PolyKinds #-}
2015-05-01 04:40:08 +02:00
module Servant.Ekg where
2015-05-01 07:28:43 +02:00
import Control.Concurrent.MVar
2015-05-01 04:40:08 +02:00
import Control.Exception
import Control.Monad
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
2015-05-01 04:40:08 +02:00
import Data.Time.Clock
2015-05-01 07:28:43 +02:00
import GHC.TypeLits
import Network.HTTP.Types (Method, Status (..))
2015-05-01 04:40:08 +02:00
import Network.Wai
2015-05-01 07:28:43 +02:00
import Servant.API
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
gaugeInflight :: Gauge.Gauge -> Middleware
gaugeInflight inflight application request respond =
bracket_ (Gauge.inc inflight)
(Gauge.dec inflight)
(application request respond)
-- | Count responses with 2XX, 4XX, 5XX, and XXX response codes.
countResponseCodes
:: (Counter.Counter, Counter.Counter, Counter.Counter, Counter.Counter)
-> Middleware
countResponseCodes (c2XX, c4XX, c5XX, cXXX) application request respond =
application request respond'
where
respond' res = count (responseStatus res) >> respond res
count Status{statusCode = sc }
| 200 <= sc && sc < 300 = Counter.inc c2XX
| 400 <= sc && sc < 500 = Counter.inc c4XX
| 500 <= sc && sc < 600 = Counter.inc c5XX
| otherwise = Counter.inc cXXX
responseTimeDistribution :: Distribution.Distribution -> Middleware
responseTimeDistribution dist application request respond =
bracket getCurrentTime stop $ const $ application request respond
where
stop t1 = do
t2 <- getCurrentTime
let dt = diffUTCTime t2 t1
Distribution.add dist $ fromRational $ (*1000) $ toRational dt
2015-05-01 07:28:43 +02:00
data Meters = Meters
{ metersInflight :: Gauge.Gauge
, metersC2XX :: Counter.Counter
, metersC4XX :: Counter.Counter
, metersC5XX :: Counter.Counter
, metersCXXX :: Counter.Counter
, metersTime :: Distribution.Distribution
}
monitorEndpoints
:: HasEndpoint api
=> Proxy api
-> Store
-> MVar (H.HashMap Text Meters)
-> Middleware
monitorEndpoints proxy store meters application request respond = do
let path = case getEndpoint proxy request of
Nothing -> "unknown"
Just (ps,method) -> T.intercalate "." $ ps <> [T.decodeUtf8 method]
Meters{..} <- modifyMVar meters $ \ms -> case H.lookup path ms of
Nothing -> do
let prefix = "servant.path." <> path <> "."
metersInflight <- createGauge (prefix <> "in_flight") store
metersC2XX <- createCounter (prefix <> "responses.2XX") store
metersC4XX <- createCounter (prefix <> "responses.4XX") store
metersC5XX <- createCounter (prefix <> "responses.5XX") store
metersCXXX <- createCounter (prefix <> "responses.XXX") store
metersTime <- createDistribution (prefix <> "time_ms") store
2015-05-01 07:28:43 +02:00
let m = Meters{..}
return (H.insert path m ms, m)
Just m -> return (ms,m)
let application' =
responseTimeDistribution metersTime .
countResponseCodes (metersC2XX, metersC4XX, metersC5XX, metersCXXX) .
gaugeInflight metersInflight $
application
application' request respond
class HasEndpoint a where
getEndpoint :: Proxy a -> Request -> Maybe ([Text], Method)
instance (HasEndpoint (a :: *), HasEndpoint (b :: *)) => HasEndpoint (a :<|> b) where
getEndpoint _ req =
getEndpoint (Proxy :: Proxy a) req `mplus`
2015-05-01 07:28:43 +02:00
getEndpoint (Proxy :: Proxy b) req
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
(end, method) <- getEndpoint (Proxy :: Proxy sub) req{ pathInfo = ps }
return (p:end, method)
_ -> Nothing
2016-05-13 16:15:03 +02:00
instance (KnownSymbol (capture :: Symbol), HasEndpoint (sub :: *))
=> HasEndpoint (Capture capture a :> sub) where
2015-05-01 07:28:43 +02:00
getEndpoint _ req =
case pathInfo req of
_:ps -> do
(end, method) <- getEndpoint (Proxy :: Proxy sub) req{ pathInfo = ps }
let p = T.pack $ (':':) $ symbolVal (Proxy :: Proxy capture)
return (p:end, method)
_ -> Nothing
instance HasEndpoint (sub :: *) => HasEndpoint (Header h a :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
instance HasEndpoint (sub :: *) => HasEndpoint (QueryParam (h :: Symbol) a :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
instance HasEndpoint (sub :: *) => HasEndpoint (QueryParams (h :: Symbol) a :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
2016-05-13 17:54:18 +02:00
instance HasEndpoint (sub :: *) => HasEndpoint (QueryFlag h :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
2016-05-13 12:27:26 +02:00
instance HasEndpoint (sub :: *) => HasEndpoint (ReqBody cts a :> sub) where
2015-05-01 07:28:43 +02:00
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
2016-05-13 17:54:18 +02:00
instance HasEndpoint (sub :: *) => HasEndpoint (RemoteHost :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
instance HasEndpoint (sub :: *) => HasEndpoint (IsSecure :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
instance HasEndpoint (sub :: *) => HasEndpoint (HttpVersion :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
instance HasEndpoint (sub :: *) => HasEndpoint (Vault :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
instance HasEndpoint (sub :: *) => HasEndpoint (WithNamedContext x y sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
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
2016-05-13 12:27:26 +02:00
[] | requestMethod req == method -> Just ([], method)
2015-05-01 07:28:43 +02:00
_ -> Nothing
2016-05-13 12:27:26 +02:00
where method = reflectMethod (Proxy :: Proxy method)
2015-05-01 07:28:43 +02:00
instance HasEndpoint (Raw) where
getEndpoint _ _ = Just ([],"RAW")
#if MIN_VERSION_servant(0,8,1)
instance HasEndpoint (sub :: *) => HasEndpoint (CaptureAll (h :: Symbol) a :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
#endif