eeva/servant-ekg
1
0
Fork 0
mirror of https://github.com/haskell-servant/servant-ekg.git synced 2024-11-23 03:29:43 +01:00
Code Issues Projects Releases Wiki Activity

Merge pull request #12 from haskell-servant/rebase-pr-9-and-10

Browse source 
Rebase pr 9 and 10
This commit is contained in:
Oleg Grenrus 2019-02-28 10:35:44 +02:00 committed by GitHub
commit b972d0ddc7
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
7 changed files with 221 additions and 120 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
CHANGELOG.md Normal file
View file

@ -0,0 +1,5 @@
v0.3
- Add HasEndpoint instance for BasicAuth
- Enumerate API and populate counters at start time
- support servant >=0.14 && <0.17

5
README.md
View file

@ -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

19
bench/Main.hs
View file

@ -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 ->

185
lib/Servant/Ekg.hs
View file

@ -8,180 +8,183 @@
{-# 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)
instance HasEndpoint (sub :: *) => HasEndpoint (BasicAuth (realm :: Symbol) a :> sub) where
getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)

87
lib/Servant/Ekg/Internal.hs Normal file
View file

@ -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)

7
servant-ekg.cabal
View file

@ -1,6 +1,6 @@
cabal-version: >=1.10
name: servant-ekg
version: 0.2.2.0
version: 0.3
synopsis: Helpers for using ekg with servant
description: Helpers for using ekg with servant, e.g.. counters per endpoint.
license: BSD3
@ -11,9 +11,10 @@ author:
maintainer:
Servant Contributors <haskell-servant-maintainers@googlegroups.com>
category: System
category: Servant, Web, System
build-type: Simple
tested-with: ghc ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.3
extra-source-files: README.md CHANGELOG.md
source-repository HEAD
type: git
@ -21,11 +22,13 @@ 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
, hashable >=1.2.7.0 && <1.3
, servant >=0.14 && <0.17
, text >=1.2.3.0 && <1.3
, time >=1.6.0.1 && <1.9

33
test/Servant/EkgSpec.hs
View file

@ -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