servant-ekg (empty) → 0.2.0.0
raw patch · 6 files changed
+309/−0 lines, 6 filesdep +aesondep +basedep +ekgsetup-changed
Dependencies added: aeson, base, ekg, ekg-core, hspec, http-client, http-types, process, servant, servant-client, servant-ekg, servant-server, text, time, transformers, unordered-containers, wai, warp
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- bench/Main.hs +42/−0
- lib/Servant/Ekg.hs +168/−0
- servant-ekg.cabal +66/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Anchor Systems++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Anchor Systems nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Main.hs view
@@ -0,0 +1,42 @@+{-# 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+import Servant+import Servant.Ekg+import System.Metrics+import System.Process+++type BenchApi = "hello" :> Capture "name" Text :> Get '[JSON] Text++benchApi :: Proxy BenchApi+benchApi = Proxy++server :: Server BenchApi+server = return++servantEkgServer :: IO Application+servantEkgServer = do+ store <- newStore+ ms <- newMVar mempty+ return $ monitorEndpoints benchApi store ms (serve benchApi server)++benchApp :: IO Application -> IO ()+benchApp app = withApplication app $ \port ->+ callCommand $ "wrk -c 30 -d 20s --latency -s bench/wrk.lua -t 2 'http://localhost:" ++ show port ++ "'"++main :: IO ()+main = do+ putStrLn "Benchmarking servant-ekg"+ benchApp servantEkgServer+ putStrLn "Benchmarking without servant-ekg"+ benchApp . return $ serve benchApi server
+ lib/Servant/Ekg.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE PolyKinds #-}+module Servant.Ekg where++import Control.Concurrent.MVar+import Control.Exception+import Control.Monad+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.Wai+import Servant.API+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++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++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+ 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`+ 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 (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)++instance HasEndpoint (sub :: *) => HasEndpoint (QueryFlag h :> sub) where+ getEndpoint _ = getEndpoint (Proxy :: Proxy sub)++instance HasEndpoint (sub :: *) => HasEndpoint (ReqBody cts a :> sub) where+ getEndpoint _ = getEndpoint (Proxy :: Proxy sub)++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)++instance ReflectMethod method => HasEndpoint (Verb method status cts a) where+ getEndpoint _ req = case pathInfo req of+ [] | requestMethod req == method -> Just ([], method)+ _ -> Nothing+ where method = reflectMethod (Proxy :: Proxy method)++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
+ servant-ekg.cabal view
@@ -0,0 +1,66 @@+name: servant-ekg+version: 0.2.0.0+synopsis: Helpers for using ekg with servant+description: Helpers for using ekg with servant+license: BSD3+license-file: LICENSE+author: Anchor Engineering <engineering@lists.anchor.net.au>, Servant Contributors+maintainer: Servant Contributors <haskell-servant-maintainers@googlegroups.com>+category: System+build-type: Simple+cabal-version: >=1.10++source-repository HEAD+ type: git+ location: https://github.com/servant/servant-ekg.git++library+ exposed-modules: Servant.Ekg+ hs-source-dirs: lib+ build-depends: base >=4.7 && < 4.10+ , ekg-core+ , servant > 0.5 && < 0.10+ , http-types+ , text+ , time+ , unordered-containers+ , wai+ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ ghc-options: -Wall+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base == 4.*+ , aeson+ , ekg+ , ekg-core+ , servant-ekg+ , servant-server+ , servant-client+ , servant+ , http-client+ , text+ , wai+ , warp >= 3.2.4 && < 3.3+ , hspec == 2.*+ , unordered-containers+ , transformers++executable bench+ hs-source-dirs: bench+ main-is: Main.hs+ ghc-options: -Wall -threaded -O2+ default-language: Haskell2010+ build-depends: base == 4.*+ , aeson+ , ekg+ , ekg-core+ , servant-ekg+ , servant-server+ , text+ , wai+ , warp >= 3.2.4 && < 3.3+ , process
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}