Enumerate API and populate counters at start time

README.md

@@ -20,10 +20,9 @@ import Servant.Ekg
 
 wrapWithEkg :: Proxy api -> Server api -> IO Application
 wrapWithEkg api server = do
-  store   <- newStore
+  monitorEndpoints' <- monitorEndpoints api =<< newStore
-  metrics <- newMVar mempty
 
-  return $ monitorEndpoints api store metrics (serve api server)
+  return $ monitorEndpoints' (serve api server)
 
 main :: IO ()
 main = do

bench/Main.hs

@@ -1,12 +1,11 @@
-{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE DeriveGeneric        #-}
+{-# LANGUAGE DeriveGeneric     #-}
-{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PolyKinds            #-}
+{-# LANGUAGE PolyKinds         #-}
-{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE TypeFamilies      #-}
-{-# LANGUAGE TypeOperators        #-}
+{-# 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
+  mware <- monitorEndpoints benchApi =<< newStore
-  ms <- newMVar mempty
+
-  return $ monitorEndpoints benchApi store ms (serve benchApi server)
+  return $ mware (serve benchApi server)
 
 benchApp :: IO Application -> IO ()
 benchApp app = withApplication app $ \port ->

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.
+monitorEndpoints :: HasEndpoint api => Proxy api -> Store -> IO Middleware
-countResponseCodes
+monitorEndpoints proxy store = do
-    :: (Counter.Counter, Counter.Counter, Counter.Counter, Counter.Counter)
+    meters <- initializeMetersTable store (enumerateEndpoints proxy)
-    -> Middleware
+    return (monitorEndpoints' meters)
-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
+    where
-responseTimeDistribution dist application request respond =
+        monitorEndpoints' :: H.HashMap APIEndpoint Meters -> Middleware
-    bracket getCurrentTime stop $ const $ application request respond
+        monitorEndpoints' meters application request respond =
-  where
+            case getEndpoint proxy request >>= \ep -> H.lookup ep meters of
-    stop t1 = do
+                Nothing ->
-        t2 <- getCurrentTime
+                    application request respond
-        let dt = diffUTCTime t2 t1
+                Just meters ->
-        Distribution.add dist $ fromRational $ (*1000) $ toRational dt
+                    updateCounters meters application request respond
 
-data Meters = Meters
+            where
-    { metersInflight :: Gauge.Gauge
+                updateCounters Meters{..} =
-    , metersC2XX     :: Counter.Counter
+                      responseTimeDistribution metersTime
-    , metersC4XX     :: Counter.Counter
+                    . countResponseCodes (metersC2XX, metersC4XX, metersC5XX, metersCXXX)
-    , metersC5XX     :: Counter.Counter
+                    . gaugeInflight metersInflight
-    , 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
-            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 a) req
-        getEndpoint (Proxy :: Proxy b) 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 }
+                APIEndpoint{..} <- getEndpoint (Proxy :: Proxy sub) req{ pathInfo = ps }
-                return (p:end, method)
+                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)

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)

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

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
+        Just v  -> v `shouldBe` Counter 1
-      case H.lookup "greet.POST" m of
+      case H.lookup "servant.path.greet.POST.responses.2XX" m of
         Nothing -> fail "Expected some value"
-        Just v  -> Counter.read (metersC2XX v) `shouldReturn` 1
+        Just v  -> v `shouldBe` Counter 1
-      case H.lookup "greet.:greetid.DELETE" m of
+      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
+  monitorEndpoints' <- monitorEndpoints testApi ekg
-  withApplication (return $ monitorEndpoints testApi ekg ms test) $ \p -> a p ms
+  withApplication (return $ monitorEndpoints' test) $ \p -> a p ekg