Merge pull request #32 from Simspace/uverb+fragment-support

support UVerb + correctly bound Fragment instance for older servant versions

.github/workflows/ci.yml

@@ -0,0 +1,69 @@
+# modified from https://github.com/jgm/pandoc/blob/master/.github/workflows/ci.yml
+name: CI
+
+on:
+  push:
+    branches:
+    - '**'
+    paths-ignore: []
+  pull_request:
+    paths-ignore: []
+
+jobs:
+  linux:
+
+    runs-on: ubuntu-20.04
+    strategy:
+      fail-fast: false
+      matrix:
+        versions:
+          - ghc: '8.6.5'
+            cabal: '3.6'
+          - ghc: '8.8.4'
+            cabal: '3.6'
+          - ghc: '8.10.7'
+            cabal: '3.6'
+          # - ghc: '9.0.2'
+          #   cabal: '3.6'
+
+    steps:
+    - uses: actions/checkout@v2
+
+    # need to install older cabal/ghc versions from ppa repository
+
+    - name: Install recent cabal/ghc
+      uses: haskell/actions/setup@v1
+      with:
+        ghc-version: ${{ matrix.versions.ghc }}
+        cabal-version: ${{ matrix.versions.cabal }}
+
+    # declare/restore cached things
+    # caching doesn't work for scheduled runs yet
+    # https://github.com/actions/cache/issues/63
+
+    - name: Cache cabal global package db
+      id:   cabal-global
+      uses: actions/cache@v2
+      with:
+        path: |
+          ~/.cabal
+        key: ${{ runner.os }}-${{ matrix.versions.ghc }}-${{ matrix.versions.cabal }}-cabal-global-${{ hashFiles('cabal.project') }}
+
+    - name: Cache cabal work
+      id:   cabal-local
+      uses: actions/cache@v2
+      with:
+        path: |
+          dist-newstyle
+        key: ${{ runner.os }}-${{ matrix.versions.ghc }}-${{ matrix.versions.cabal }}-cabal-local
+
+    - name: Install dependencies
+      run: |
+        cabal update
+        cabal build all --dependencies-only --enable-tests --disable-optimization
+    - name: Build
+      run: |
+        cabal build all --enable-tests --disable-optimization 2>&1 | tee build.log
+    - name: Test
+      run: |
+        cabal test all --disable-optimization

.gitignore

@@ -3,4 +3,5 @@
 .cabal-sandbox/*
 *dist/
 *dist-newstyle/
+.ghc.environment.*
 .stack-work/

.travis.yml

@@ -0,0 +1,152 @@
+# This Travis job script has been generated by a script via
+#
+#   haskell-ci 'servant-ekg.cabal'
+#
+# To regenerate the script (for example after adjusting tested-with) run
+#
+#   haskell-ci regenerate
+#
+# For more information, see https://github.com/haskell-CI/haskell-ci
+#
+# version: 0.10.2
+#
+version: ~> 1.0
+language: c
+os: linux
+dist: xenial
+git:
+  # whether to recursively clone submodules
+  submodules: false
+cache:
+  directories:
+    - $HOME/.cabal/packages
+    - $HOME/.cabal/store
+    - $HOME/.hlint
+before_cache:
+  - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
+  # remove files that are regenerated by 'cabal update'
+  - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
+  - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
+  - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
+  - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
+  - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
+  - rm -rfv $CABALHOME/packages/head.hackage
+jobs:
+  include:
+    - compiler: ghc-8.10.2
+      addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.10.2","cabal-install-3.2"]}}
+      os: linux
+    - compiler: ghc-8.8.4
+      addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.4","cabal-install-3.2"]}}
+      os: linux
+    - compiler: ghc-8.6.5
+      addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.2"]}}
+      os: linux
+    - compiler: ghc-8.4.4
+      addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.2"]}}
+      os: linux
+    - compiler: ghc-8.2.2
+      addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.2"]}}
+      os: linux
+    - compiler: ghc-8.0.2
+      addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.2"]}}
+      os: linux
+before_install:
+  - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
+  - WITHCOMPILER="-w $HC"
+  - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
+  - HCPKG="$HC-pkg"
+  - unset CC
+  - CABAL=/opt/ghc/bin/cabal
+  - CABALHOME=$HOME/.cabal
+  - export PATH="$CABALHOME/bin:$PATH"
+  - TOP=$(pwd)
+  - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"
+  - echo $HCNUMVER
+  - CABAL="$CABAL -vnormal+nowrap"
+  - set -o pipefail
+  - TEST=--enable-tests
+  - BENCH=--enable-benchmarks
+  - HEADHACKAGE=false
+  - rm -f $CABALHOME/config
+  - |
+    echo "verbose: normal +nowrap +markoutput"          >> $CABALHOME/config
+    echo "remote-build-reporting: anonymous"            >> $CABALHOME/config
+    echo "write-ghc-environment-files: always"          >> $CABALHOME/config
+    echo "remote-repo-cache: $CABALHOME/packages"       >> $CABALHOME/config
+    echo "logs-dir:          $CABALHOME/logs"           >> $CABALHOME/config
+    echo "world-file:        $CABALHOME/world"          >> $CABALHOME/config
+    echo "extra-prog-path:   $CABALHOME/bin"            >> $CABALHOME/config
+    echo "symlink-bindir:    $CABALHOME/bin"            >> $CABALHOME/config
+    echo "installdir:        $CABALHOME/bin"            >> $CABALHOME/config
+    echo "build-summary:     $CABALHOME/logs/build.log" >> $CABALHOME/config
+    echo "store-dir:         $CABALHOME/store"          >> $CABALHOME/config
+    echo "install-dirs user"                            >> $CABALHOME/config
+    echo "  prefix: $CABALHOME"                         >> $CABALHOME/config
+    echo "repository hackage.haskell.org"               >> $CABALHOME/config
+    echo "  url: http://hackage.haskell.org/"           >> $CABALHOME/config
+install:
+  - ${CABAL} --version
+  - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
+  - |
+    echo "program-default-options"                >> $CABALHOME/config
+    echo "  ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config
+  - cat $CABALHOME/config
+  - rm -fv cabal.project cabal.project.local cabal.project.freeze
+  - travis_retry ${CABAL} v2-update -v
+  # Generate cabal.project
+  - rm -rf cabal.project cabal.project.local cabal.project.freeze
+  - touch cabal.project
+  - |
+    echo "packages: ." >> cabal.project
+  - if [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-ekg' >> cabal.project ; fi
+  - "if [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - |
+  - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(servant-ekg)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
+  - cat cabal.project || true
+  - cat cabal.project.local || true
+  - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
+  - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH}
+  - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
+  - rm  cabal.project.freeze
+  - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all
+  - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all
+script:
+  - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
+  # Packaging...
+  - ${CABAL} v2-sdist all
+  # Unpacking...
+  - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
+  - cd ${DISTDIR} || false
+  - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
+  - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm       '{}' \;
+  - PKGDIR_servant_ekg="$(find . -maxdepth 1 -type d -regex '.*/servant-ekg-[0-9.]*')"
+  # Generate cabal.project
+  - rm -rf cabal.project cabal.project.local cabal.project.freeze
+  - touch cabal.project
+  - |
+    echo "packages: ${PKGDIR_servant_ekg}" >> cabal.project
+  - if [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-ekg' >> cabal.project ; fi
+  - "if [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - |
+  - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(servant-ekg)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
+  - cat cabal.project || true
+  - cat cabal.project.local || true
+  # Building...
+  # this builds all libraries and executables (without tests/benchmarks)
+  - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all
+  # Building with tests and benchmarks...
+  # build & run tests, build benchmarks
+  - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all
+  # Testing...
+  - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all
+  # cabal check...
+  - (cd ${PKGDIR_servant_ekg} && ${CABAL} -vnormal check)
+  # haddock...
+  - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all
+  # Building without installed constraints for packages in global-db...
+  - rm -f cabal.project.local
+  - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all
+
+# REGENDATA ("0.10.2",["servant-ekg.cabal"])
+# EOF

CHANGELOG.md

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

@@ -0,0 +1,41 @@
+# servant-ekg
+
+[![Build Status](https://travis-ci.org/haskell-servant/servant-ekg.png)](https://travis-ci.org/haskell-servant/servant-ekg)
+[![Build status](https://github.com/haskell-servant/servant-ekg/actions/workflows/ci.yml/badge.svg)](https://github.com/haskell-servant/servant-ekg/actions/workflows/ci.yml)
+
+# 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

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

cabal.haskell-ci

@@ -0,0 +1,17 @@
+branches: master
+
+constraint-set servant-0.15
+  ghc: >= 8.0 && <8.8
+  constraints: servant ==0.15.*
+
+constraint-set servant-0.16
+  ghc: >= 8.0 && <8.10
+  constraints: servant ==0.16.*
+
+constraint-set servant-0.17
+  ghc: >= 8.0 && <8.10
+  constraints: servant ==0.17.*
+
+constraint-set servant-0.18
+  ghc: >= 8.0 && <9.0
+  constraints: servant ==0.18.*

cabal.project

@@ -0,0 +1 @@
+packages: .

cabal.project.local

@@ -0,0 +1 @@
+tests: True

lib/Servant/Ekg.hs

@@ -4,165 +4,215 @@
 {-# 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)
+
+#if MIN_VERSION_servant(0,18,2)
+instance HasEndpoint (sub :: *) => HasEndpoint (Fragment a :> sub) where
+    getEndpoint        _ = getEndpoint        (Proxy :: Proxy sub)
+    enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)
+#endif
+
+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 HasEndpoint (sub :: *) => HasEndpoint (CaptureAll (h :: Symbol) a :> sub) where
-    getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
+#if MIN_VERSION_servant(0,17,0)
+instance ReflectMethod method => HasEndpoint (NoContentVerb method) 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)
 #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 (APIEndpoint [] method)
+        _                                -> Nothing
+      where method = reflectMethod (Proxy :: Proxy method)
+
+    enumerateEndpoints _ = [APIEndpoint 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 (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)
+    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

@@ -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,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.2
+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.6.5 || ==8.8.4 || ==8.10.7
+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.16
+    , ekg-core              >=0.1.1.4 && <0.2
+    , http-types            >=0.12.2  && <0.13
+    , hashable              >=1.2.7.0 && <1.4
+    , servant               >=0.14    && <0.20
+    , text                  >=1.2.3.0 && <1.3
+    , time                  >=1.6.0.1 && <1.12
+    , 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

stack.yaml

@@ -1,61 +1,6 @@
-
-# Resolver to choose a 'specific' stackage snapshot or a compiler version.
-# A snapshot resolver dictates the compiler version and the set of packages
-# to be used for project dependencies. For example:
-#
-# resolver: lts-3.5
-# resolver: nightly-2015-09-21
-# resolver: ghc-7.10.2
-# resolver: ghcjs-0.1.0_ghc-7.10.2
-# resolver:
-#  name: custom-snapshot
-#  location: "./custom-snapshot.yaml"
-resolver: lts-7.18
-
-# User packages to be built.
-# Various formats can be used as shown in the example below.
-#
-# packages:
-# - some-directory
-# - https://example.com/foo/bar/baz-0.0.2.tar.gz
-# - location:
-#    git: https://github.com/commercialhaskell/stack.git
-#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
-# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
-#   extra-dep: true
-#  subdirs:
-#  - auto-update
-#  - wai
-#
-# A package marked 'extra-dep: true' will only be built if demanded by a
-# non-dependency (i.e. a user package), and its test suites and benchmarks
-# will not be run. This is useful for tweaking upstream packages.
+resolver: lts-13.6
 packages:
 - '.'
-# Dependency packages to be pulled from upstream that are not in the resolver
-# (e.g., acme-missiles-0.3)
 extra-deps:
-
-# Override default flag values for local packages and extra-deps
-flags: {}
-
-# Extra package databases containing global packages
-extra-package-dbs: []
-
-# Control whether we use the GHC we find on the path
-# system-ghc: true
-#
-# Require a specific version of stack, using version ranges
-# require-stack-version: -any # Default
-# require-stack-version: ">=1.1"
-#
-# Override the architecture used by stack, especially useful on Windows
-# arch: i386
-# arch: x86_64
-#
-# Extra directories used by stack for building
-# extra-include-dirs: [/path/to/dir]
-# extra-lib-dirs: [/path/to/dir]
-#
-# Allow a newer minor version of GHC than the snapshot specifies
-# compiler-check: newer-minor
+- ekg-0.4.0.15
+- ekg-json-0.1.0.6

test/Servant/EkgSpec.hs

@@ -1,35 +1,39 @@
-{-# LANGUAGE CPP                  #-}
-{-# LANGUAGE DataKinds            #-}
-{-# LANGUAGE DeriveGeneric        #-}
-{-# LANGUAGE OverloadedStrings    #-}
-{-# LANGUAGE PolyKinds            #-}
-{-# LANGUAGE TypeFamilies         #-}
-{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds         #-}
+{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE TypeFamilies      #-}
+{-# LANGUAGE TypeOperators     #-}
 
 module Servant.EkgSpec (spec) where
 
-import           Control.Concurrent
-#if !MIN_VERSION_servant(0,9,0)
-import           Control.Monad.Trans.Except
-#endif
 import           Data.Aeson
-import           Data.Monoid
+import qualified Data.HashMap.Strict                        as H
+import           Data.Monoid                                ((<>))
 import           Data.Proxy
-import qualified Data.HashMap.Strict as H
 import           Data.Text
 import           GHC.Generics
-import           Network.HTTP.Client (defaultManagerSettings, newManager, Manager)
+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 qualified System.Metrics.Counter as Counter
 import           Test.Hspec
 
 import           Servant.Ekg
 
+#if !MIN_VERSION_servant_client(0,16,0)
+#define ClientError ServantError
+#endif
 
 -- * Spec
 
@@ -38,33 +42,36 @@ spec = describe "servant-ekg" $ do
 
   let getEp :<|> postEp :<|> deleteEp = client testApi
 
-  it "collects number of request" $ do
-    withApp $ \port mvar -> do
+  it "collects number of request" $
+    withApp $ \port store -> do
       mgr <- newManager defaultManagerSettings
-      let runFn :: (Manager -> BaseUrl -> ExceptT e m a) -> m (Either e a)
-#if MIN_VERSION_servant(0,9,0)
-          runFn fn = runClientM $ fn mgr (ClientEnv mgr (BaseUrl Http "localhost" port ""))
-#else
-          runFn fn = runExceptT $ fn mgr (BaseUrl Http "localhost" port "")
-#endif
+      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
 
@@ -85,11 +92,7 @@ type TestApi =
   :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
 
        -- DELETE /greet/:greetid
-#if MIN_VERSION_servant(0,8,0)
   :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent
-#else
-  :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] ()
-#endif
 
 testApi :: Proxy TestApi
 testApi = Proxy
@@ -109,19 +112,15 @@ server = helloH :<|> postGreetH :<|> deleteGreetH
 
         postGreetH = return
 
-#if MIN_VERSION_servant(0,8,0)
         deleteGreetH _ = return NoContent
-#else
-        deleteGreetH _ = return ()
-#endif
 
 -- 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 -> 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