packages feed

servant-ekg 0.2.0.0 → 0.3

raw patch · 7 files changed

+456/−162 lines, 7 filesdep +hashabledep ~basedep ~ekg-coredep ~http-typesnew-uploader

Dependencies added: hashable

Dependency ranges changed: base, ekg-core, http-types, servant, text, time, unordered-containers, wai

Files

+ CHANGELOG.md view
@@ -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
+ README.md view
@@ -0,0 +1,40 @@+# servant-ekg++[![Build Status](https://travis-ci.org/haskell-servant/servant-ekg.png)](https://travis-ci.org/haskell-servant/servant-ekg)++# Servant Performance Counters++This package lets you track peformance counters for each of your Servant endpoints using EKG.++# Usage++Servant-EKG knows how to handle all official Servant combinators out of the box.++## Instrumenting your API+To use Servant-EKG, you'll need to wrap your WAI application with the Servant-EKG middleware.++```+import Network.Wai.Handler.Warp+import System.Metrics+import Servant.Ekg++wrapWithEkg :: Proxy api -> Server api -> IO Application+wrapWithEkg api server = do+  monitorEndpoints' <- monitorEndpoints api =<< newStore++  return $ monitorEndpoints' (serve api server)++main :: IO ()+main = do+  let api    = ...+      server = ...++  app <- wrapWithEkg api server++  run 8080 app+```++## Runtime overhead+Instrumenting your API introduces a non-zero runtime overhead, on the order of 200 - 600 µsec depending upon your machine. It's a good idea to run the benchmarks on your intended production platform to get an idea of how large the overhead will be. You'll need to have `wrk` installed to run the benchmarks.++In general, the runtime overhead should be effectively negligible if your handlers are issuing network requests, such as to databases. If you have handlers that are small, CPU-only, and requested frequently, you will see a performance hit from Servant-EKG.
bench/Main.hs view
@@ -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 @@  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 ->
lib/Servant/Ekg.hs view
@@ -4,165 +4,187 @@ {-# LANGUAGE FlexibleInstances   #-} {-# LANGUAGE KindSignatures      #-} {-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE PolyKinds           #-} {-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators       #-}-{-# LANGUAGE PolyKinds           #-}-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+    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 capture a :> sub) where+    => 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 (Header h a :> sub) where-    getEndpoint _ = getEndpoint (Proxy :: Proxy sub)+instance HasEndpoint (sub :: *) => HasEndpoint (Summary d :> sub) where+    getEndpoint        _ = getEndpoint        (Proxy :: Proxy sub)+    enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub) -instance HasEndpoint (sub :: *) => HasEndpoint (QueryParam (h :: Symbol) a :> sub) where-    getEndpoint _ = getEndpoint (Proxy :: Proxy sub)+instance HasEndpoint (sub :: *) => HasEndpoint (Description d :> sub) where+    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)+    enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)++instance HasEndpoint (sub :: *) => HasEndpoint (QueryParam' mods (h :: Symbol) a :> sub) where+    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 cts a :> sub) where-    getEndpoint _ = getEndpoint (Proxy :: Proxy sub)+instance HasEndpoint (sub :: *) => HasEndpoint (ReqBody' mods cts a :> sub) where+    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)+    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)-        _ -> Nothing+        [] | requestMethod req == method -> Just (APIEndpoint [] method)+        _                                -> Nothing       where method = reflectMethod (Proxy :: Proxy method) -instance HasEndpoint (Raw) where-    getEndpoint _ _ = Just ([],"RAW")+    enumerateEndpoints _ = [APIEndpoint mempty method]+      where method = reflectMethod (Proxy :: Proxy method) -#if MIN_VERSION_servant(0,8,1)+instance ReflectMethod method => HasEndpoint (Stream method status framing ct a) where+    getEndpoint _ req = case pathInfo req of+        [] | 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 (APIEndpoint [] "RAW")+    enumerateEndpoints _ =      [APIEndpoint [] "RAW"]+ instance HasEndpoint (sub :: *) => HasEndpoint (CaptureAll (h :: Symbol) a :> sub) where-    getEndpoint _ = getEndpoint (Proxy :: Proxy sub)-#endif+    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)
+ lib/Servant/Ekg/Internal.hs view
@@ -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 view
@@ -1,66 +1,81 @@-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+cabal-version: >=1.10+name:          servant-ekg+version:       0.3+synopsis:      Helpers for using ekg with servant+description:   Helpers for using ekg with servant, e.g.. counters per endpoint.+license:       BSD3+license-file:  LICENSE+author:+  Anchor Engineering <engineering@lists.anchor.net.au>, Servant Contributors +maintainer:+  Servant Contributors <haskell-servant-maintainers@googlegroups.com>++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-  location: https://github.com/servant/servant-ekg.git+  type:     git+  location: https://github.com/haskell-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+  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+    , unordered-containers  >=0.2.9.0  && <0.3+    , wai                   >=3.2.0    && <3.3 +  default-language: Haskell2010+ test-suite spec-  type: exitcode-stdio-1.0-  ghc-options: -Wall+  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+  hs-source-dirs:   test+  main-is:          Spec.hs+  other-modules:    Servant.EkgSpec+  build-tool-depends: hspec-discover:hspec-discover+  build-depends:+      aeson+    , base+    , ekg+    , ekg-core+    , hspec                 >=2     && <3+    , http-client+    , servant+    , servant-client+    , servant-ekg+    , servant-server+    , text+    , transformers+    , unordered-containers+    , wai+    , warp                  >=3.2.4 && <3.3 -executable bench-  hs-source-dirs: bench-  main-is: Main.hs-  ghc-options: -Wall -threaded -O2+benchmark bench+  type:             exitcode-stdio-1.0+  hs-source-dirs:   bench+  main-is:          Main.hs+  ghc-options:      -Wall -threaded   default-language: Haskell2010-  build-depends:      base == 4.*-                    , aeson-                    , ekg-                    , ekg-core-                    , servant-ekg-                    , servant-server-                    , text-                    , wai-                    , warp >= 3.2.4 && < 3.3-                    , process+  build-depends:+      aeson+    , base            >=4     && <5+    , ekg+    , ekg-core+    , process+    , servant-ekg+    , servant-server+    , text+    , wai+    , warp            >=3.2.4 && <3.3
+ test/Servant/EkgSpec.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds         #-}+{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE TypeOperators     #-}++module Servant.EkgSpec (spec) where++import           Data.Aeson+import qualified Data.HashMap.Strict                        as H+import           Data.Monoid                                ((<>))+import           Data.Proxy+import           Data.Text+import           GHC.Generics+import           Network.HTTP.Client                        (defaultManagerSettings,+                                                             newManager)+import           Network.Wai+import           Network.Wai.Handler.Warp+import           Servant+import           Servant.Client+#if MIN_VERSION_servant(0,15,0)+import           Servant.Test.ComprehensiveAPI              (comprehensiveAPI)+#else+import           Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI)+#endif+import           System.Metrics+import           Test.Hspec++import           Servant.Ekg++#if !MIN_VERSION_servant_client(0,16,0)+#define ClientError ServantError+#endif++-- * Spec++spec :: Spec+spec = describe "servant-ekg" $ do++  let getEp :<|> postEp :<|> deleteEp = client testApi++  it "collects number of request" $+    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 <- sampleAll store+      case H.lookup "servant.path.hello.:name.GET.responses.2XX" m of+        Nothing -> fail "Expected some value"+        Just v  -> v `shouldBe` Counter 1+      case H.lookup "servant.path.greet.POST.responses.2XX" m of+        Nothing -> fail "Expected some value"+        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  -> v `shouldBe` Counter 1++  it "is comprehensive" $ do+    _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++-- | A greet message data type+newtype Greet = Greet { _msg :: Text }+  deriving (Generic, Show)++instance FromJSON Greet+instance ToJSON Greet++-- API specification+type TestApi =+       -- GET /hello/:name?capital={true, false}  returns a Greet as JSON+       "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet++       -- POST /greet with a Greet as JSON in the request body,+       --             returns a Greet as JSON+  :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet++       -- DELETE /greet/:greetid+  :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent++testApi :: Proxy TestApi+testApi = Proxy++-- Server-side handlers.+--+-- There's one handler per endpoint, which, just like in the type+-- that represents the API, are glued together using :<|>.+--+-- Each handler runs in the 'EitherT (Int, String) IO' monad.+server :: Server TestApi+server = helloH :<|> postGreetH :<|> deleteGreetH++  where helloH name Nothing = helloH name (Just False)+        helloH name (Just False) = return . Greet $ "Hello, " <> name+        helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name++        postGreetH = return++        deleteGreetH _ = return NoContent++-- Turn the server into a WAI app. 'serve' is provided by servant,+-- more precisely by the Servant.Server module.+test :: Application+test = serve testApi server++withApp :: (Port -> Store -> IO a) -> IO a+withApp a = do+  ekg <- newStore+  monitorEndpoints' <- monitorEndpoints testApi ekg+  withApplication (return $ monitorEndpoints' test) $ \p -> a p ekg