diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for prometheus-wai-middleware + +## 1.0.0.0 - 2020-06-26 + +First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +BSD 3-Clause License + +Copyright (c) 2020-present, Bitnomial, Inc. +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 the copyright holder nor the names of its + 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 HOLDER 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/exec/Main.hs b/exec/Main.hs new file mode 100644 --- /dev/null +++ b/exec/Main.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Concurrent.Async (async) +import Control.Monad.IO.Class (liftIO) +import Network.HTTP.Types.Status (status200, + status404) +import Network.Wai (pathInfo, + responseLBS) +import Network.Wai.Handler.Warp (run) +import System.Metrics.Prometheus.Concurrent.RegistryT (runRegistryT) +import System.Metrics.Prometheus.Http.Scrape (serveHttpTextMetricsT) +import System.Metrics.Prometheus.MetricId (fromList) + +import Network.Wai.Middleware.Prometheus (applicationMetrics, + instrumentApplication) + + +main :: IO () +main = runRegistryT $ do + ms <- applicationMetrics $ fromList [("app", "example_server")] + let webserver = run 8080 . instrumentApplication ms $ \req respond -> + respond (makeResponse req) + liftIO $ async webserver + serveHttpTextMetricsT 8081 [] + where + success = responseLBS status200 [] "ok" + failure = responseLBS status404 [] mempty + makeResponse req + | pathInfo req == ["test"] = success + | otherwise = failure diff --git a/prometheus-wai-middleware.cabal b/prometheus-wai-middleware.cabal new file mode 100644 --- /dev/null +++ b/prometheus-wai-middleware.cabal @@ -0,0 +1,46 @@ +cabal-version: 2.2 +name: prometheus-wai-middleware +version: 1.0.0.0 +synopsis: Instrument a wai application with various metrics +description: See https://github.com/bitnomial/prometheus-wai-middleware/tree/master/readme.md +bug-reports: https://github.com/bitnomial/prometheus-wai-middleware/issues +license: BSD-3-Clause +license-file: LICENSE +author: Ian Shipman +maintainer: ian.shipman@bitnomial.com +copyright: 2020 Bitnomial, Inc. +category: Web +build-type: Simple +extra-source-files: CHANGELOG.md + +source-repository head + type: git + location: https://github.com/bitnomial/prometheus-wai-middleware + +library + default-language: Haskell2010 + hs-source-dirs: src/ + exposed-modules: + Network.Wai.Middleware.Prometheus + build-depends: + base >= 4.12 && < 4.14 + , containers >= 0.5 && < 0.7 + , clock ^>= 0.8 + , http-types >= 0.8 && < 0.13 + , prometheus ^>= 2.1.3 + , text ^>= 1.2 + , wai ^>= 3.2 + + +executable prometheus-wai-middleware-example + default-language: Haskell2010 + hs-source-dirs: exec/ + main-is: Main.hs + build-depends: + async ^>= 2.2 + , base >= 4.12 && < 4.14 + , http-types >= 0.8 && < 0.13 + , prometheus ^>= 2.1.3 + , prometheus-wai-middleware + , wai ^>= 3.2 + , warp >= 3.2 && < 3.5 diff --git a/src/Network/Wai/Middleware/Prometheus.hs b/src/Network/Wai/Middleware/Prometheus.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Middleware/Prometheus.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Network.Wai.Middleware.Prometheus + ( ApplicationMetrics + , applicationMetrics + , countStatusCode + , observeDuration + , instrumentApplication + ) where + +import Control.Monad.IO.Class (MonadIO) +import Data.Map.Strict (Map, fromList) +import qualified Data.Map.Strict as Map +import Data.Text (pack) +import Network.HTTP.Types (Status (..)) +import Network.Wai (Middleware, + responseStatus) +import System.Clock (Clock (Monotonic), + TimeSpec (..), + diffTimeSpec, + getTime, + toNanoSecs) +import System.Metrics.Prometheus.Concurrent.RegistryT (RegistryT, + registerCounter, + registerHistogram) +import System.Metrics.Prometheus.Metric.Counter (Counter, inc) +import System.Metrics.Prometheus.Metric.Histogram (Histogram, + observe) +import System.Metrics.Prometheus.MetricId (Labels (..)) + + +data ApplicationMetrics = ApplicationMetrics + { statusCodeMetrics :: Map Int Counter + , durationMetrics :: Histogram + } + + +-- | Increment the count for a specific status code, by number +countStatusCode :: ApplicationMetrics -> Int -> IO () +countStatusCode ms s = mapM_ inc . Map.lookup s $ statusCodeMetrics ms + + +-- | Add a request duration observation in ms +observeDuration :: ApplicationMetrics -> Double -> IO () +observeDuration ms i = observe i $ durationMetrics ms + + +-- | Set up the metrics for HTTP response codes and request handling durations. We identify the response code counters +-- by @http_requests_total@ with codes labeled by @http_response_code@. We identify the duration histogram by +-- @http_request_duration_milliseconds@ Use labels to identify your particular application. +applicationMetrics :: MonadIO m => Labels -> RegistryT m ApplicationMetrics +applicationMetrics ls = + ApplicationMetrics . fromList <$> traverse codeCounter codes <*> hist + where + codeCounter i = (i, ) <$> registerCounter "http_requests_total" (mkLabels i) + mkLabels i = Labels $ fromList [("http_response_code", (pack . show) i)] <> unLabels ls + + codes = [100 .. 103] + <> [200 .. 208] <> [226] + <> [300 .. 308] + <> [400 .. 418] <> [421 .. 426] <> [428, 429, 431, 451] + <> [500 .. 508] <> [510, 511] + + hist = registerHistogram "http_request_duration_milliseconds" ls durationBounds + durationBounds = [1 .. 20] <> [30, 40 .. 200] <> [300, 400 .. 900] <> [1000, 2000 .. 10000] + + +-- | This middleware adds response code tracking and request duration statistics for the application, aggregating across all requests +instrumentApplication :: ApplicationMetrics -> Middleware +instrumentApplication ms app req respond = do + t0 <- getTime Monotonic + app req $ \r -> do + t1 <- getTime Monotonic + countStatusCode ms (statusCode $ responseStatus r) + observeDuration ms $ diffTimeMS t0 t1 + respond r + + +diffTimeMS :: TimeSpec -> TimeSpec -> Double +diffTimeMS t0 t1 = toMS $ t1 `diffTimeSpec` t0 + where + toMS = fromIntegral . (`quot` oneMillion) . toNanoSecs + oneMillion = 1000000