diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/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 @@ 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 -> diff --git a/lib/Servant/Ekg.hs b/lib/Servant/Ekg.hs --- a/lib/Servant/Ekg.hs +++ b/lib/Servant/Ekg.hs @@ -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) diff --git a/lib/Servant/Ekg/Internal.hs b/lib/Servant/Ekg/Internal.hs new file mode 100644 --- /dev/null +++ b/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) diff --git a/servant-ekg.cabal b/servant-ekg.cabal --- a/servant-ekg.cabal +++ b/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 , Servant Contributors -maintainer: Servant Contributors -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 , Servant Contributors +maintainer: + Servant Contributors + +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 diff --git a/test/Servant/EkgSpec.hs b/test/Servant/EkgSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/EkgSpec.hs @@ -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