From 2183528966772c75643126c1f5ad95eb14ed2b94 Mon Sep 17 00:00:00 2001 From: Jesse Kempf Date: Mon, 11 Feb 2019 09:43:16 -0800 Subject: [PATCH] Enumerate API and populate counters at start time --- README.md | 5 +- bench/Main.hs | 19 ++-- lib/Servant/Ekg.hs | 181 ++++++++++++++++++------------------ lib/Servant/Ekg/Internal.hs | 87 +++++++++++++++++ servant-ekg.cabal | 6 +- test/Servant/EkgSpec.hs | 33 ++++--- 6 files changed, 211 insertions(+), 120 deletions(-) create mode 100644 lib/Servant/Ekg/Internal.hs diff --git a/README.md b/README.md index 03d6bc7..a9e17dd 100644 --- a/README.md +++ b/README.md @@ -20,10 +20,9 @@ import Servant.Ekg wrapWithEkg :: Proxy api -> Server api -> IO Application wrapWithEkg api server = do - store <- newStore - metrics <- newMVar mempty + monitorEndpoints' <- monitorEndpoints api =<< newStore - return $ monitorEndpoints api store metrics (serve api server) + return $ monitorEndpoints' (serve api server) main :: IO () main = do diff --git a/bench/Main.hs b/bench/Main.hs index 1c29b7e..acdb5cb 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,12 +1,11 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Main (main) where -import Control.Concurrent import Data.Text (Text) import Network.Wai (Application) import Network.Wai.Handler.Warp @@ -26,9 +25,9 @@ server = return servantEkgServer :: IO Application servantEkgServer = do - store <- newStore - ms <- newMVar mempty - return $ monitorEndpoints benchApi store ms (serve benchApi server) + mware <- monitorEndpoints benchApi =<< newStore + + return $ mware (serve benchApi server) benchApp :: IO Application -> IO () benchApp app = withApplication app $ \port -> diff --git a/lib/Servant/Ekg.hs b/lib/Servant/Ekg.hs index bda2d65..b7c6d0f 100644 --- a/lib/Servant/Ekg.hs +++ b/lib/Servant/Ekg.hs @@ -8,180 +8,179 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} -module Servant.Ekg where -import Control.Concurrent.MVar +module Servant.Ekg ( + HasEndpoint(..), + APIEndpoint(..), + monitorEndpoints +) where + import Control.Exception import Control.Monad +import Data.Hashable (Hashable (..)) 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 GHC.TypeLits -import Network.HTTP.Types (Method, Status (..)) +import Network.HTTP.Types (Method) import Network.Wai import Servant.API +import Servant.Ekg.Internal import System.Metrics 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 +monitorEndpoints :: HasEndpoint api => Proxy api -> Store -> IO Middleware +monitorEndpoints proxy store = do + meters <- initializeMetersTable store (enumerateEndpoints proxy) + return (monitorEndpoints' meters) -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 + 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 -data Meters = Meters - { metersInflight :: Gauge.Gauge - , metersC2XX :: Counter.Counter - , metersC4XX :: Counter.Counter - , metersC5XX :: Counter.Counter - , metersCXXX :: Counter.Counter - , metersTime :: Distribution.Distribution - } + where + updateCounters Meters{..} = + responseTimeDistribution metersTime + . countResponseCodes (metersC2XX, metersC4XX, metersC5XX, metersCXXX) + . gaugeInflight metersInflight -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 - 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) + getEndpoint :: Proxy a -> Request -> Maybe APIEndpoint + enumerateEndpoints :: Proxy a -> [APIEndpoint] instance HasEndpoint EmptyAPI where - getEndpoint _ _ = Nothing + getEndpoint _ _ = Nothing + enumerateEndpoints _ = [] instance (HasEndpoint (a :: *), HasEndpoint (b :: *)) => HasEndpoint (a :<|> b) where getEndpoint _ req = - getEndpoint (Proxy :: Proxy a) req `mplus` - getEndpoint (Proxy :: Proxy b) req + getEndpoint (Proxy :: Proxy a) req + `mplus` getEndpoint (Proxy :: Proxy b) req + + enumerateEndpoints _ = + enumerateEndpoints (Proxy :: Proxy a) + <> enumerateEndpoints (Proxy :: Proxy b) 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) + APIEndpoint{..} <- getEndpoint (Proxy :: Proxy sub) req{ pathInfo = ps } + return (APIEndpoint (p:pathSegments) method) _ -> 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 instance (KnownSymbol (capture :: Symbol), HasEndpoint (sub :: *)) => HasEndpoint (Capture' mods capture a :> sub) where getEndpoint _ req = case pathInfo req of _:ps -> do - (end, method) <- getEndpoint (Proxy :: Proxy sub) req{ pathInfo = ps } + APIEndpoint{..} <- getEndpoint (Proxy :: Proxy sub) req{ pathInfo = ps } let p = T.pack $ (':':) $ symbolVal (Proxy :: Proxy capture) - return (p:end, method) + return (APIEndpoint (p:pathSegments) method) _ -> 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 instance HasEndpoint (sub :: *) => HasEndpoint (Summary d :> sub) where - getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub) instance HasEndpoint (sub :: *) => HasEndpoint (Description d :> sub) where - getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub) instance HasEndpoint (sub :: *) => HasEndpoint (Header' mods h a :> sub) where - getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub) instance HasEndpoint (sub :: *) => HasEndpoint (QueryParam' mods (h :: Symbol) a :> sub) where - getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + 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) + getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub) instance HasEndpoint (sub :: *) => HasEndpoint (QueryFlag h :> sub) where - getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub) instance HasEndpoint (sub :: *) => HasEndpoint (ReqBody' mods cts a :> sub) where - getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub) #if MIN_VERSION_servant(0,15,0) instance HasEndpoint (sub :: *) => HasEndpoint (StreamBody' mods framing ct a :> sub) where - getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub) #endif instance HasEndpoint (sub :: *) => HasEndpoint (RemoteHost :> sub) where - getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub) instance HasEndpoint (sub :: *) => HasEndpoint (IsSecure :> sub) where - getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub) instance HasEndpoint (sub :: *) => HasEndpoint (HttpVersion :> sub) where - getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub) instance HasEndpoint (sub :: *) => HasEndpoint (Vault :> sub) where - getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub) instance HasEndpoint (sub :: *) => HasEndpoint (WithNamedContext x y sub) where - getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub) instance ReflectMethod method => HasEndpoint (Verb method status cts a) where getEndpoint _ req = case pathInfo req of - [] | requestMethod req == method -> Just ([], method) + [] | requestMethod req == method -> Just (APIEndpoint [] method) _ -> Nothing where method = reflectMethod (Proxy :: Proxy method) + enumerateEndpoints _ = [APIEndpoint mempty method] + where method = reflectMethod (Proxy :: Proxy method) + instance ReflectMethod method => HasEndpoint (Stream method status framing ct a) where getEndpoint _ req = case pathInfo req of - [] | requestMethod req == method -> Just ([], method) + [] | requestMethod req == method -> Just (APIEndpoint [] method) _ -> Nothing where method = reflectMethod (Proxy :: Proxy method) + enumerateEndpoints _ = [APIEndpoint mempty method] + where method = reflectMethod (Proxy :: Proxy method) + instance HasEndpoint Raw where - getEndpoint _ _ = Just ([],"RAW") + getEndpoint _ _ = Just (APIEndpoint [] "RAW") + enumerateEndpoints _ = [APIEndpoint [] "RAW"] instance HasEndpoint (sub :: *) => HasEndpoint (CaptureAll (h :: Symbol) a :> sub) where - getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + getEndpoint _ = getEndpoint (Proxy :: Proxy sub) + enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub) diff --git a/lib/Servant/Ekg/Internal.hs b/lib/Servant/Ekg/Internal.hs new file mode 100644 index 0000000..4d5236e --- /dev/null +++ b/lib/Servant/Ekg/Internal.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Servant.Ekg.Internal where + +import Control.Exception +import Control.Monad +import Data.Hashable (Hashable (..)) +import qualified Data.HashMap.Strict as H +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time.Clock +import GHC.Generics (Generic) +import Network.HTTP.Types (Method, Status (..)) +import Network.Wai (Middleware, responseStatus) +import System.Metrics +import qualified System.Metrics.Counter as Counter +import qualified System.Metrics.Distribution as Distribution +import qualified System.Metrics.Gauge as Gauge + +data Meters = Meters + { metersInflight :: Gauge.Gauge + , metersC2XX :: Counter.Counter + , metersC4XX :: Counter.Counter + , metersC5XX :: Counter.Counter + , metersCXXX :: Counter.Counter + , metersTime :: Distribution.Distribution + } + +data APIEndpoint = APIEndpoint { + pathSegments :: [Text], + method :: Method +} deriving (Eq, Hashable, Show, Generic) + +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 + +initializeMeters :: Store -> APIEndpoint -> IO Meters +initializeMeters store APIEndpoint{..} = do + 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 + + return Meters{..} + + where + prefix = "servant.path." <> path <> "." + path = T.intercalate "." $ pathSegments <> [T.decodeUtf8 method] + +initializeMetersTable :: Store -> [APIEndpoint] -> IO (H.HashMap APIEndpoint Meters) +initializeMetersTable store endpoints = do + meters <- mapM (initializeMeters store) endpoints + + return $ H.fromList (zip endpoints meters) diff --git a/servant-ekg.cabal b/servant-ekg.cabal index 6db4619..5cb3606 100644 --- a/servant-ekg.cabal +++ b/servant-ekg.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: servant-ekg -version: 0.2.2.0 +version: 0.3.0.0 synopsis: Helpers for using ekg with servant description: Helpers for using ekg with servant, e.g.. counters per endpoint. license: BSD3 @@ -21,12 +21,14 @@ source-repository HEAD library exposed-modules: Servant.Ekg + other-modules: Servant.Ekg.Internal hs-source-dirs: lib build-depends: base >=4.9 && <4.13 , ekg-core >=0.1.1.4 && <0.2 , http-types >=0.12.2 && <0.13 - , servant >=0.14 && <0.17 + , hashable >=1.2.7.0 && <1.3 + , servant >=0.14 && <0.16 , text >=1.2.3.0 && <1.3 , time >=1.6.0.1 && <1.9 , unordered-containers >=0.2.9.0 && <0.3 diff --git a/test/Servant/EkgSpec.hs b/test/Servant/EkgSpec.hs index b7d9d0d..3530d48 100644 --- a/test/Servant/EkgSpec.hs +++ b/test/Servant/EkgSpec.hs @@ -9,7 +9,6 @@ module Servant.EkgSpec (spec) where -import Control.Concurrent import Data.Aeson import qualified Data.HashMap.Strict as H import Data.Monoid ((<>)) @@ -28,7 +27,6 @@ import Servant.Test.ComprehensiveAPI (comprehensiveAPI) import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI) #endif import System.Metrics -import qualified System.Metrics.Counter as Counter import Test.Hspec import Servant.Ekg @@ -45,28 +43,35 @@ spec = describe "servant-ekg" $ do let getEp :<|> postEp :<|> deleteEp = client testApi it "collects number of request" $ - withApp $ \port mvar -> do + withApp $ \port store -> do mgr <- newManager defaultManagerSettings let runFn :: ClientM a -> IO (Either ClientError a) runFn fn = runClientM fn (mkClientEnv mgr (BaseUrl Http "localhost" port "")) _ <- runFn $ getEp "name" Nothing _ <- runFn $ postEp (Greet "hi") _ <- runFn $ deleteEp "blah" - m <- readMVar mvar - case H.lookup "hello.:name.GET" m of + + m <- sampleAll store + case H.lookup "servant.path.hello.:name.GET.responses.2XX" m of Nothing -> fail "Expected some value" - Just v -> Counter.read (metersC2XX v) `shouldReturn` 1 - case H.lookup "greet.POST" m of + Just v -> v `shouldBe` Counter 1 + case H.lookup "servant.path.greet.POST.responses.2XX" m of Nothing -> fail "Expected some value" - Just v -> Counter.read (metersC2XX v) `shouldReturn` 1 - case H.lookup "greet.:greetid.DELETE" m of + Just v -> v `shouldBe` Counter 1 + case H.lookup "servant.path.greet.:greetid.DELETE.responses.2XX" m of Nothing -> fail "Expected some value" - Just v -> Counter.read (metersC2XX v) `shouldReturn` 1 + Just v -> v `shouldBe` Counter 1 it "is comprehensive" $ do - let _typeLevelTest = monitorEndpoints comprehensiveAPI undefined undefined undefined + _typeLevelTest <- monitorEndpoints comprehensiveAPI =<< newStore True `shouldBe` True + it "enumerates the parts of an API correctly" $ + enumerateEndpoints testApi `shouldBe` [ + APIEndpoint ["hello",":name"] "GET", + APIEndpoint ["greet"] "POST", + APIEndpoint ["greet",":greetid"] "DELETE" + ] -- * Example @@ -114,8 +119,8 @@ server = helloH :<|> postGreetH :<|> deleteGreetH test :: Application test = serve testApi server -withApp :: (Port -> MVar (H.HashMap Text Meters) -> IO a) -> IO a +withApp :: (Port -> Store -> IO a) -> IO a withApp a = do ekg <- newStore - ms <- newMVar mempty - withApplication (return $ monitorEndpoints testApi ekg ms test) $ \p -> a p ms + monitorEndpoints' <- monitorEndpoints testApi ekg + withApplication (return $ monitorEndpoints' test) $ \p -> a p ekg