servant-prometheus (empty) → 1.0.0

raw patch · 10 files changed

+730/−0 lines, 10 filesdep +aesondep +basedep +clocksetup-changed

Dependencies added: aeson, base, clock, containers, ghc-prim, hashable, hspec, hspec-expectations-pretty-diff, http-client, http-types, process, prometheus-client, servant, servant-client, servant-prometheus, servant-server, text, wai, warp

Files

• CHANGELOG.md +7/−0
• LICENSE +30/−0
• README.md +32/−0
• Setup.hs +2/−0
• bench/Main.hs +36/−0
• lib/Prometheus/Servant.hs +111/−0
• lib/Prometheus/Servant/Internal.hs +228/−0
• servant-prometheus.cabal +158/−0
• test/Prometheus/ServantSpec.hs +125/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,7 @@+Unreleased+==========++1.0.0+=======++Initial release.

@@ -0,0 +1,30 @@+Copyright (c) 2015, Andrii Demydenko++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.

@@ -0,0 +1,32 @@+# servant-prometheus++[![Build status](https://github.com/worm2fed/servant-prometheus/actions/workflows/ci.yml/badge.svg)](https://github.com/worm2fed/servant-prometheus/actions/workflows/ci.yml)++# Servant Performance Counters++This package lets you track performance counters for each of your Servant endpoints using Prometheus.++# Usage++Servant-Prometheus knows how to handle all official Servant combinators out of the box.++## Instrumenting your API+To use Servant-Prometheus, you'll need to wrap your WAI application with the Servant-Prometheus middleware.++```+import Network.Wai.Handler.Warp+import Prometheus.Servant++main :: IO ()+main = do+  let api    = ...+      server = ...+      app = prometheusMiddleware defaultMetrics 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-prometheus`.

@@ -0,0 +1,2 @@+import           Distribution.Simple+main = defaultMain

@@ -0,0 +1,36 @@+module Main (main) where++import Data.Text (Text)+import Network.Wai (Application)+import Network.Wai.Handler.Warp (withApplication)+import Prometheus.Servant (defaultMetrics, prometheusMiddleware)+import Servant+  ( Capture+  , Get+  , JSON+  , Proxy (..)+  , serve+  , type (:>)+  )+import System.Process (callCommand)++type BenchApi = "hello" :> Capture "name" Text :> Get '[JSON] Text++benchApi :: Proxy BenchApi+benchApi = Proxy++server :: Application+server = serve benchApi pure++benchApp :: Application -> IO ()+benchApp app = do+  withApplication (pure app) $ \port ->+    callCommand $+      "wrk -c 30 -d 20s --latency -s bench/wrk.lua -t 2 'http://localhost:"+        ++ show port+        ++ "'"++main :: IO ()+main = do+  benchApp $ prometheusMiddleware defaultMetrics benchApi server+  benchApp server

@@ -0,0 +1,111 @@+module Prometheus.Servant+  ( prometheusMiddleware+  , Metrics (..)+  , defaultMetrics+  , RequestLatencyMetric+  , ActiveRequestsMetric+  ) where++import Control.Exception (finally)+import Data.Data (Proxy)+import Data.Ratio ((%))+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Network.HTTP.Types (Status (..))+import Network.Wai (Middleware, responseStatus)+import Prometheus qualified as P+import System.Clock+  ( Clock (Monotonic)+  , diffTimeSpec+  , getTime+  , s2ns+  , toNanoSecs+  )++import Prometheus.Servant.Internal (Endpoint (..), HasEndpoint (..))++-- | 'Middleware' to observe 'Metrics'.+prometheusMiddleware+  :: (P.Label mLatencyLabel, P.Label mActiveLabel, HasEndpoint api)+  => Metrics mLatencyLabel mActiveLabel+  -> Proxy api+  -> Middleware+prometheusMiddleware Metrics{..} proxy application request sendResponse = do+  case getEndpoint proxy request of+    Just endpoint -> do+      let mActiveLabel = mGetActiveLabels endpoint+      !start <- getTime Monotonic+      P.withLabel mActive mActiveLabel P.incGauge+      application request $ \response -> do+        let mLatencyLabel = mGetLatencyLabels endpoint (responseStatus response)+        sendResponse response `finally` do+          !end <- getTime Monotonic+          let latency = fromRational $ toNanoSecs (end `diffTimeSpec` start) % s2ns+          P.withLabel mLatency mLatencyLabel $ flip P.observe latency+          P.withLabel mActive mActiveLabel P.decGauge+    Nothing -> application request sendResponse++-- | Supported metrics and a function to get relevant labels from 'Endpoint'.+data Metrics mLatencyLabel mActiveLabel = Metrics+  { mLatency :: RequestLatencyMetric mLatencyLabel+  , mGetLatencyLabels :: Endpoint -> Status -> mLatencyLabel+  , mActive :: ActiveRequestsMetric mActiveLabel+  , mGetActiveLabels :: Endpoint -> mActiveLabel+  }++-- | Default 'Metrics'.+defaultMetrics :: Metrics P.Label3 P.Label2+defaultMetrics =+  Metrics+    { mLatency = mHttpRequestLatency+    , mGetLatencyLabels = getHttpRequestLatencyLabels+    , mActive = mHttpActiveRequests+    , mGetActiveLabels = getHttpActiveRequestsLabels+    }++-- | Request latency metric parametrized with some label @l@.+type RequestLatencyMetric l = P.Vector l P.Histogram++-- | Metric to measure HTTP server request latency.+mHttpRequestLatency :: RequestLatencyMetric P.Label3+mHttpRequestLatency =+  P.unsafeRegister+    . P.vector ("route_name", "method", "status_code")+    $ P.histogram i P.defaultBuckets+  where+    i =+      P.Info+        "http_request_duration_seconds"+        "The HTTP server request latencies in seconds."+{-# NOINLINE mHttpRequestLatency #-}++-- | Defines how to get labels for 'mHttpRequestLatency' from 'Endpoint'.+getHttpRequestLatencyLabels :: Endpoint -> Status -> P.Label3+getHttpRequestLatencyLabels Endpoint{..} status =+  ( "/" <> T.intercalate "/" ePathSegments+  , T.decodeUtf8 eMethod+  , T.pack . show $ statusCode status+  )++-- | Active requests metric parametrized with some label @l@.+type ActiveRequestsMetric l = P.Vector l P.Gauge++-- | Metric to track HTTP active requests.+mHttpActiveRequests :: ActiveRequestsMetric P.Label2+mHttpActiveRequests =+  P.unsafeRegister+    . P.vector ("route_name", "method")+    $ P.gauge i+  where+    i =+      P.Info+        "http_active_requests"+        "The HTTP active requests."+{-# NOINLINE mHttpActiveRequests #-}++-- | Defines how to get labels for 'mHttpActiveRequests' from 'Endpoint'.+getHttpActiveRequestsLabels :: Endpoint -> P.Label2+getHttpActiveRequestsLabels Endpoint{..} =+  ( "/" <> T.intercalate "/" ePathSegments+  , T.decodeUtf8 eMethod+  )

@@ -0,0 +1,228 @@+{-# LANGUAGE CPP #-}++module Prometheus.Servant.Internal+  ( Endpoint (..)+  , HasEndpoint (..)+  ) where++import Control.Monad (MonadPlus (..))+import Data.Hashable (Hashable (..))+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics (Generic)+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import GHC.Types (Type)+import Network.HTTP.Types (Method)+import Network.Wai (Request (..))+import Servant.API++-- | Servant 'Endpoint'.+data Endpoint = Endpoint+  { ePathSegments :: [Text]+  -- ^ Path segments of an endpoint.+  , eMethod :: Method+  -- ^ Endpoint method.+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Hashable)++-- | Specifies that @api@ has servant 'Endpoint'.+class HasEndpoint api where+  -- | Tries to get 'Endpoint' from 'Request' for given @api@.+  getEndpoint :: Proxy api -> Request -> Maybe Endpoint++  -- | Enumerates @api@ to get list of 'Endpoint's.+  enumerateEndpoints :: Proxy api -> [Endpoint]++instance HasEndpoint EmptyAPI where+  getEndpoint _ _ = Nothing++  enumerateEndpoints _ = []++instance HasEndpoint (ToServantApi sub) => HasEndpoint (NamedRoutes sub) where+  getEndpoint _ = getEndpoint (Proxy :: Proxy (ToServantApi sub))++  enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy (ToServantApi sub))++instance (HasEndpoint (a :: Type), HasEndpoint (b :: Type)) => HasEndpoint (a :<|> b) where+  getEndpoint _ 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 :: Type))+  => HasEndpoint (path :> sub)+  where+  getEndpoint _ req =+    case pathInfo req of+      p : ps | p == T.pack (symbolVal (Proxy :: Proxy path)) -> do+        Endpoint{..} <- getEndpoint (Proxy :: Proxy sub) req{pathInfo = ps}+        pure $ Endpoint (p : ePathSegments) eMethod+      _otherwise -> Nothing++  enumerateEndpoints _ = do+    let currentSegment = T.pack $ symbolVal (Proxy :: Proxy path)+        qualify Endpoint{..} = Endpoint (currentSegment : ePathSegments) eMethod+    map qualify $ enumerateEndpoints (Proxy :: Proxy sub)++instance+  (KnownSymbol (capture :: Symbol), HasEndpoint (sub :: Type))+  => HasEndpoint (Capture' mods capture a :> sub)+  where+  getEndpoint _ req =+    case pathInfo req of+      _ : ps -> do+        Endpoint{..} <- getEndpoint (Proxy :: Proxy sub) req{pathInfo = ps}+        let p = T.pack $ (':' :) $ symbolVal (Proxy :: Proxy capture)+        pure $ Endpoint (p : ePathSegments) eMethod+      _otherwise -> Nothing++  enumerateEndpoints _ = do+    let currentSegment = T.pack $ (':' :) $ symbolVal (Proxy :: Proxy capture)+        qualify Endpoint{..} = Endpoint (currentSegment : ePathSegments) eMethod+    map qualify $ enumerateEndpoints (Proxy :: Proxy sub)++instance HasEndpoint (sub :: Type) => HasEndpoint (Summary d :> sub) where+  getEndpoint _ = getEndpoint (Proxy :: Proxy sub)++  enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)++instance HasEndpoint (sub :: Type) => HasEndpoint (Description d :> sub) where+  getEndpoint _ = getEndpoint (Proxy :: Proxy sub)++  enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)++instance HasEndpoint (sub :: Type) => HasEndpoint (Header' mods h a :> sub) where+  getEndpoint _ = getEndpoint (Proxy :: Proxy sub)++  enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)++#if MIN_VERSION_servant(0,18,2)+instance HasEndpoint (sub :: Type) => HasEndpoint (Fragment a :> sub) where+  getEndpoint _ = getEndpoint (Proxy :: Proxy sub)++  enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)+#endif++instance+  HasEndpoint (sub :: Type)+  => HasEndpoint (QueryParam' mods (h :: Symbol) a :> sub)+  where+  getEndpoint _ = getEndpoint (Proxy :: Proxy sub)++  enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)++instance HasEndpoint (sub :: Type) => HasEndpoint (QueryParams (h :: Symbol) a :> sub) where+  getEndpoint _ = getEndpoint (Proxy :: Proxy sub)++  enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)++instance HasEndpoint (sub :: Type) => HasEndpoint (QueryFlag h :> sub) where+  getEndpoint _ = getEndpoint (Proxy :: Proxy sub)++  enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)++instance HasEndpoint (sub :: Type) => 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 :: Type) => HasEndpoint (StreamBody' mods framing cts a :> sub) where+  getEndpoint _ = getEndpoint (Proxy :: Proxy sub)++  enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)+#endif++instance HasEndpoint (sub :: Type) => HasEndpoint (RemoteHost :> sub) where+  getEndpoint _ = getEndpoint (Proxy :: Proxy sub)++  enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)++instance HasEndpoint (sub :: Type) => HasEndpoint (IsSecure :> sub) where+  getEndpoint _ = getEndpoint (Proxy :: Proxy sub)++  enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)++instance HasEndpoint (sub :: Type) => HasEndpoint (HttpVersion :> sub) where+  getEndpoint _ = getEndpoint (Proxy :: Proxy sub)++  enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)++instance HasEndpoint (sub :: Type) => HasEndpoint (Vault :> sub) where+  getEndpoint _ = getEndpoint (Proxy :: Proxy sub)++  enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)++instance HasEndpoint (sub :: Type) => HasEndpoint (WithNamedContext x y sub) where+  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 (Endpoint [] method)+    _otherwise -> Nothing+    where+      method = reflectMethod (Proxy :: Proxy method)++  enumerateEndpoints _ = [Endpoint mempty method]+    where+      method = reflectMethod (Proxy :: Proxy method)++#if MIN_VERSION_servant(0,17,0)+instance ReflectMethod method => HasEndpoint (NoContentVerb method) where+  getEndpoint _ req = case pathInfo req of+    [] | requestMethod req == method -> Just (Endpoint [] method)+    _ -> Nothing+    where+      method = reflectMethod (Proxy :: Proxy method)++  enumerateEndpoints _ = [Endpoint mempty method]+    where+      method = reflectMethod (Proxy :: Proxy method)+#endif++#if MIN_VERSION_servant(0,18,1)+instance ReflectMethod method => HasEndpoint (UVerb method contentType as) where+  getEndpoint _ req = case pathInfo req of+    [] | requestMethod req == method -> Just (Endpoint [] method)+    _ -> Nothing+    where+      method = reflectMethod (Proxy :: Proxy method)++  enumerateEndpoints _ = [Endpoint mempty method]+    where+      method = reflectMethod (Proxy :: Proxy method)+#endif++instance ReflectMethod method => HasEndpoint (Stream method status framing ct a) where+  getEndpoint _ req = case pathInfo req of+    [] | requestMethod req == method -> Just (Endpoint [] method)+    _ -> Nothing+    where+      method = reflectMethod (Proxy :: Proxy method)++  enumerateEndpoints _ = [Endpoint mempty method]+    where+      method = reflectMethod (Proxy :: Proxy method)++instance HasEndpoint Raw where+  getEndpoint _ _ = Just (Endpoint [] "RAW")++  enumerateEndpoints _ = [Endpoint [] "RAW"]++instance HasEndpoint (sub :: Type) => HasEndpoint (CaptureAll (h :: Symbol) a :> sub) where+  getEndpoint _ = getEndpoint (Proxy :: Proxy sub)++  enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)++instance HasEndpoint (sub :: Type) => HasEndpoint (BasicAuth (realm :: Symbol) a :> sub) where+  getEndpoint _ = getEndpoint (Proxy :: Proxy sub)++  enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)

@@ -0,0 +1,158 @@+cabal-version: 2.4++-- This file has been generated from package.yaml by hpack version 0.35.2.+--+-- see: https://github.com/sol/hpack++name:           servant-prometheus+version:        1.0.0+synopsis:       Helpers for using prometheus with servant+description:    Please see the README on GitHub at <https://github.com/worm2fed/servant-prometheus#readme>+category:       Servant, Web, System+homepage:       https://github.com/worm2fed/servant-prometheus#readme+bug-reports:    https://github.com/worm2fed/servant-prometheus/issues+author:         Andrii Demydenko <worm2fed@gmail.com>, Anchor Engineering <engineering@lists.anchor.net.au>, Servant Contributors+maintainer:     Andrii Demydenko <worm2fed@gmail.com>+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+tested-with:+    GHC ==9.2.8+extra-source-files:+    README.md+    LICENSE+extra-doc-files:+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/worm2fed/servant-prometheus++flag warning-as-error+  description: Assume every warning as error+  manual: True+  default: False++library+  exposed-modules:+      Prometheus.Servant+      Prometheus.Servant.Internal+  other-modules:+      Paths_servant_prometheus+  autogen-modules:+      Paths_servant_prometheus+  hs-source-dirs:+      lib+  default-extensions:+      BangPatterns+      DataKinds+      DeriveAnyClass+      DeriveGeneric+      DerivingStrategies+      FlexibleContexts+      FlexibleInstances+      ImportQualifiedPost+      OverloadedStrings+      PolyKinds+      RecordWildCards+      ScopedTypeVariables+      TypeOperators+      UndecidableInstances+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-inferred-safe-imports -Wno-missing-safe-haskell-mode -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-missing-kind-signatures -Wno-implicit-prelude+  build-depends:+      base >=4.10 && <4.17+    , clock >=0.8.3 && <0.9+    , ghc-prim >=0.8.0 && <0.9+    , hashable >=1.4.2 && <1.5+    , http-types >=0.12.3 && <0.13+    , prometheus-client >=1.1.0 && <1.2+    , servant >=0.14 && <0.20+    , text >=1.2.5 && <1.3+    , wai >=3.2.3 && <3.3+  default-language: Haskell2010+  if flag(warning-as-error)+    ghc-options: -Werror++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Prometheus.ServantSpec+      Paths_servant_prometheus+  autogen-modules:+      Paths_servant_prometheus+  hs-source-dirs:+      test+  default-extensions:+      BangPatterns+      DataKinds+      DeriveAnyClass+      DeriveGeneric+      DerivingStrategies+      FlexibleContexts+      FlexibleInstances+      ImportQualifiedPost+      OverloadedStrings+      PolyKinds+      RecordWildCards+      ScopedTypeVariables+      TypeOperators+      UndecidableInstances+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-inferred-safe-imports -Wno-missing-safe-haskell-mode -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-missing-kind-signatures -Wno-implicit-prelude -Wno-missing-export-lists -threaded "-with-rtsopts=-N -A64m -AL256m"+  build-tool-depends:+      hspec-discover:hspec-discover+  build-depends:+      aeson ==2.0.*+    , base >=4.10 && <4.17+    , containers >=0.6.5 && <0.7+    , hspec ==2.*+    , hspec-expectations-pretty-diff >=0.7.2.2 && <0.8+    , http-client >=0.7.13 && <0.8+    , prometheus-client+    , servant+    , servant-client >=0.14 && <0.20+    , servant-prometheus+    , servant-server >=0.14 && <0.20+    , text+    , wai+    , warp >=3.2.4 && <3.4+  default-language: Haskell2010+  if flag(warning-as-error)+    ghc-options: -Werror++benchmark bench+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Paths_servant_prometheus+  autogen-modules:+      Paths_servant_prometheus+  hs-source-dirs:+      bench+  default-extensions:+      BangPatterns+      DataKinds+      DeriveAnyClass+      DeriveGeneric+      DerivingStrategies+      FlexibleContexts+      FlexibleInstances+      ImportQualifiedPost+      OverloadedStrings+      PolyKinds+      RecordWildCards+      ScopedTypeVariables+      TypeOperators+      UndecidableInstances+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-inferred-safe-imports -Wno-missing-safe-haskell-mode -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-missing-kind-signatures -Wno-implicit-prelude -threaded "-with-rtsopts=-N -A64m -AL256m"+  build-depends:+      base >=4.10 && <4.17+    , process >=1.6.16 && <1.7+    , servant-prometheus+    , servant-server+    , text+    , wai+    , warp+  default-language: Haskell2010+  if flag(warning-as-error)+    ghc-options: -Werror

@@ -0,0 +1,125 @@+module Prometheus.ServantSpec (spec) where++import Data.Aeson (FromJSON, ToJSON)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics (Generic)+import Network.HTTP.Client (defaultManagerSettings, newManager)+import Network.Wai (Application)+import Network.Wai.Handler.Warp (Port, withApplication)+import Prometheus qualified as P+import Servant+  ( Capture+  , Delete+  , Get+  , JSON+  , NoContent (..)+  , Post+  , Proxy (..)+  , QueryParam+  , ReqBody+  , Server+  , serve+  , type (:<|>) (..)+  , type (:>)+  )+import Servant.Client+  ( BaseUrl (..)+  , ClientError+  , ClientM+  , Scheme (..)+  , client+  , mkClientEnv+  , runClientM+  )+import Servant.Test.ComprehensiveAPI (comprehensiveAPI)+import Test.Hspec (Spec, describe, it)+import Test.Hspec.Expectations.Pretty (shouldBe)++import Prometheus.Servant (Metrics (..), defaultMetrics, prometheusMiddleware)+import Prometheus.Servant.Internal (Endpoint (..), HasEndpoint (..))++-- * Spec++spec :: Spec+spec = describe "servant-prometheus" $ do+  let getEp :<|> postEp :<|> deleteEp = client testApi++  it "collects number of request" $+    withApp $ \port -> 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"++      let Metrics{..} = defaultMetrics+      latencies <- P.getVectorWith mLatency P.getHistogram+      map fst latencies+        `shouldBe` [ ("/greet", "POST", "200")+                   , ("/greet/:greetid", "DELETE", "200")+                   , ("/hello/:name", "GET", "200")+                   ]+      map (sum . map snd . Map.toList . snd) latencies+        `shouldBe` [1, 1, 1]++  it "is comprehensive" $ do+    let !_typeLevelTest = prometheusMiddleware defaultMetrics comprehensiveAPI+    True `shouldBe` True++  it "enumerates the parts of an API correctly" $+    enumerateEndpoints testApi+      `shouldBe` [ Endpoint ["hello", ":name"] "GET"+                 , Endpoint ["greet"] "POST"+                 , Endpoint ["greet", ":greetid"] "DELETE"+                 ]++-- * Example++-- | A greet message data type+newtype Greet = Greet {_msg :: Text}+  deriving stock (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) = pure . Greet $ "Hello, " <> name+    helloH name (Just True) = pure . Greet . T.toUpper $ "Hello, " <> name++    postGreetH = pure++    deleteGreetH _ = pure 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 -> IO a) -> IO a+withApp =+  withApplication (pure $ prometheusMiddleware defaultMetrics testApi test)

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}