mirror of
https://github.com/haskell-servant/servant-ekg.git
synced 2024-11-26 21:19:43 +01:00
Automatic metering for servant apis
This commit is contained in:
parent
d3bd502568
commit
288cf78e76
2 changed files with 111 additions and 1 deletions
|
@ -17,8 +17,12 @@ source-repository HEAD
|
||||||
library
|
library
|
||||||
exposed-modules: Servant.Ekg
|
exposed-modules: Servant.Ekg
|
||||||
build-depends: base >=4.7 && <4.9
|
build-depends: base >=4.7 && <4.9
|
||||||
|
, bytestring
|
||||||
, ekg-core
|
, ekg-core
|
||||||
|
, servant >=0.2 && <0.3
|
||||||
, http-types
|
, http-types
|
||||||
|
, text
|
||||||
, time
|
, time
|
||||||
|
, unordered-containers
|
||||||
, wai
|
, wai
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
|
@ -1,14 +1,31 @@
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE KindSignatures #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
module Servant.Ekg where
|
module Servant.Ekg where
|
||||||
|
|
||||||
|
import Control.Concurrent.MVar
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
|
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 Data.Time.Clock
|
import Data.Time.Clock
|
||||||
|
import GHC.TypeLits
|
||||||
import Network.HTTP.Types
|
import Network.HTTP.Types
|
||||||
import Network.Wai
|
import Network.Wai
|
||||||
|
import Servant.API
|
||||||
|
import System.Metrics
|
||||||
import qualified System.Metrics.Counter as Counter
|
import qualified System.Metrics.Counter as Counter
|
||||||
import qualified System.Metrics.Distribution as Distribution
|
import qualified System.Metrics.Distribution as Distribution
|
||||||
import qualified System.Metrics.Gauge as Gauge
|
import qualified System.Metrics.Gauge as Gauge
|
||||||
|
|
||||||
|
|
||||||
gaugeInflight :: Gauge.Gauge -> Middleware
|
gaugeInflight :: Gauge.Gauge -> Middleware
|
||||||
gaugeInflight inflight application request respond =
|
gaugeInflight inflight application request respond =
|
||||||
bracket_ (Gauge.inc inflight)
|
bracket_ (Gauge.inc inflight)
|
||||||
|
@ -37,3 +54,92 @@ responseTimeDistribution dist application request respond =
|
||||||
t2 <- getCurrentTime
|
t2 <- getCurrentTime
|
||||||
let dt = diffUTCTime t2 t1
|
let dt = diffUTCTime t2 t1
|
||||||
Distribution.add dist $ fromRational $ toRational dt
|
Distribution.add dist $ fromRational $ toRational dt
|
||||||
|
|
||||||
|
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") store
|
||||||
|
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 <>
|
||||||
|
getEndpoint (Proxy :: Proxy b) req
|
||||||
|
|
||||||
|
instance (KnownSymbol (path :: Symbol), HasEndpoint (sub :: *)) => HasEndpoint (path :> sub) where
|
||||||
|
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
|
||||||
|
|
||||||
|
instance (KnownSymbol (capture :: Symbol), HasEndpoint (sub :: *)) => HasEndpoint (Capture capture a :> sub) where
|
||||||
|
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 ((a :: *) :> sub) where
|
||||||
|
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
|
||||||
|
|
||||||
|
instance HasEndpoint (Get a) where
|
||||||
|
getEndpoint _ req = case pathInfo req of
|
||||||
|
[] | requestMethod req == "GET" -> Just ([],"GET")
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
instance HasEndpoint (Put a) where
|
||||||
|
getEndpoint _ req = case pathInfo req of
|
||||||
|
[] | requestMethod req == "PUT" -> Just ([],"PUT")
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
instance HasEndpoint (Post a) where
|
||||||
|
getEndpoint _ req = case pathInfo req of
|
||||||
|
[] | requestMethod req == "POST" -> Just ([],"POST")
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
instance HasEndpoint (Delete) where
|
||||||
|
getEndpoint _ req = case pathInfo req of
|
||||||
|
[] | requestMethod req == "DELETE" -> Just ([],"DELETE")
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
instance HasEndpoint (Raw) where
|
||||||
|
getEndpoint _ _ = Just ([],"RAW")
|
||||||
|
|
Loading…
Reference in a new issue