prometheus 0.3.0 → 0.3.1

raw patch · 4 files changed

+47/−49 lines, 4 filesdep −mtlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: mtl

API changes (from Hackage documentation)

Files

• prometheus.cabal +1/−2
• src/System/Metrics/Prometheus/Concurrent/Http.hs +20/−18
• src/System/Metrics/Prometheus/Concurrent/RegistryT.hs +8/−10
• src/System/Metrics/Prometheus/RegistryT.hs +18/−19

@@ -1,5 +1,5 @@ name:                prometheus-version:             0.3.0+version:             0.3.1 synopsis:            Prometheus Haskell Client homepage:            http://github.com/LukeHoersten/prometheus#readme bug-reports:         http://github.com/LukeHoersten/prometheus/issues@@ -78,7 +78,6 @@                , bytestring     >= 0.10 && < 0.11                , containers     >= 0.5  && < 0.6                , http-types     >= 0.9  && < 0.10-               , mtl            >= 2.2  && < 2.3                , text           >= 1.2  && < 1.3                , transformers   >= 0.4  && < 0.5                , wai            >= 3.2  && < 3.3

@@ -3,13 +3,13 @@ module System.Metrics.Prometheus.Concurrent.Http where  import           Control.Monad.IO.Class                         (liftIO)-import           Control.Monad.Reader.Class                     (ask) import           Data.Text                                      (Text) import           Network.HTTP.Types                             (hContentType,                                                                  methodGet,                                                                  status200,                                                                  status404) import           Network.Wai                                    (Application,+                                                                 Request,                                                                  Response,                                                                  pathInfo,                                                                  requestMethod,@@ -17,39 +17,41 @@                                                                  responseLBS) import           Network.Wai.Handler.Warp                       (Port, run) -import           System.Metrics.Prometheus.Concurrent.Registry  (Registry,+import           System.Metrics.Prometheus.Concurrent.RegistryT (RegistryT,                                                                  sample)-import           System.Metrics.Prometheus.Concurrent.RegistryT (RegistryT) import           System.Metrics.Prometheus.Encode               (encodeMetrics)+import           System.Metrics.Prometheus.Registry             (RegistrySample)   type Path = [Text]  -serveHttpTextMetricsDef :: Port -> Registry -> IO ()-serveHttpTextMetricsDef = flip serveHttpTextMetrics ["metrics"]+serveHttpTextMetrics :: Port -> Path -> IO RegistrySample -> IO ()+serveHttpTextMetrics port path = run port . app path  -serveHttpTextMetrics :: Port -> Path -> Registry -> IO ()-serveHttpTextMetrics port path = run port . prometheusApp path+serveHttpTextMetricsT :: Port -> Path -> RegistryT IO ()+serveHttpTextMetricsT port path = liftIO . serveHttpTextMetrics port path =<< sample  -serveHttpTextMetricsT :: Port -> Path -> RegistryT IO ()-serveHttpTextMetricsT port path = liftIO . serveHttpTextMetrics port path =<< ask+app :: Path -> IO RegistrySample -> Application+app path runSample request respond+    | isPrometheusRequest path request = respond =<< prometheusResponse <$> runSample+    | otherwise = respond response404+  where+    prometheusResponse = responseBuilder status200 headers . encodeMetrics+    headers = [(hContentType, "text/plain; version=0.0.4")]  -prometheusApp :: Path -> Registry -> Application-prometheusApp path registry request respond-    | prometheusRequest = prometheusResponse respond registry-    | otherwise = respond $ responseLBS status404 header404 body404+response404 :: Response+response404 = responseLBS status404 header404 body404   where-    prometheusRequest = requestMethod request == methodGet && pathInfo request == path     header404 = [(hContentType, "text/plain")]     body404 = "404"  -prometheusResponse :: (Response -> IO b) -> Registry -> IO b-prometheusResponse respond gr =-    respond . responseBuilder status200 headers . encodeMetrics =<< sample gr+isPrometheusRequest :: Path -> Request -> Bool+isPrometheusRequest path request = isGet && matchesPath   where-    headers = [(hContentType, "text/plain; version=0.0.4")]+    matchesPath = pathInfo request == path+    isGet = requestMethod request == methodGet

@@ -3,10 +3,9 @@ module System.Metrics.Prometheus.Concurrent.RegistryT where  import           Control.Monad.IO.Class                        (MonadIO, liftIO)-import           Control.Monad.Reader.Class                    (MonadReader,-                                                                ask) import           Control.Monad.Trans.Class                     (MonadTrans)-import           Control.Monad.Trans.Reader                    (ReaderT (..))+import           Control.Monad.Trans.Reader                    (ReaderT (..),+                                                                ask)  import           System.Metrics.Prometheus.Concurrent.Registry (Registry, new) import qualified System.Metrics.Prometheus.Concurrent.Registry as R@@ -20,8 +19,7 @@  newtype RegistryT m a =     RegistryT { unRegistryT :: ReaderT Registry m a }-    deriving ( Monad, MonadTrans, Applicative, Functor-             , MonadReader Registry, MonadIO)+    deriving (Monad, MonadTrans, Applicative, Functor, MonadIO)   runRegistryT :: MonadIO m => RegistryT m a -> m a@@ -29,16 +27,16 @@   registerCounter :: MonadIO m => Name -> Labels -> RegistryT m Counter-registerCounter n l = ask >>= liftIO . R.registerCounter n l+registerCounter n l = RegistryT ask >>= liftIO . R.registerCounter n l   registerGauge :: MonadIO m => Name -> Labels -> RegistryT m Gauge-registerGauge n l = ask >>= liftIO . R.registerGauge n l+registerGauge n l = RegistryT ask >>= liftIO . R.registerGauge n l   registerHistogram :: MonadIO m => Name -> Labels -> [Histogram.UpperBound] -> RegistryT m Histogram-registerHistogram n l b = ask >>= liftIO . R.registerHistogram n l b+registerHistogram n l b = RegistryT ask >>= liftIO . R.registerHistogram n l b  -sample :: MonadIO m => RegistryT m RegistrySample-sample = ask >>= liftIO . R.sample+sample :: Monad m => RegistryT m (IO RegistrySample)+sample = R.sample <$> RegistryT ask

@@ -2,56 +2,55 @@  module System.Metrics.Prometheus.RegistryT where -import           Control.Monad.IO.Class                     (MonadIO)-import           Control.Monad.State.Class                  (MonadState, get)-import           Control.Monad.Trans                        (lift)+import           Control.Monad.IO.Class                     (MonadIO, liftIO) import           Control.Monad.Trans.Class                  (MonadTrans) import           Control.Monad.Trans.State.Strict           (StateT (..),                                                              evalStateT,-                                                             execStateT)+                                                             execStateT, get)  import           System.Metrics.Prometheus.Metric.Counter   (Counter) import           System.Metrics.Prometheus.Metric.Gauge     (Gauge) import           System.Metrics.Prometheus.Metric.Histogram (Histogram) import qualified System.Metrics.Prometheus.Metric.Histogram as Histogram import           System.Metrics.Prometheus.MetricId         (Labels, Name)-import           System.Metrics.Prometheus.Registry         (Registry (..), new)+import           System.Metrics.Prometheus.Registry         (Registry,+                                                             RegistrySample,+                                                             new) import qualified System.Metrics.Prometheus.Registry         as R   newtype RegistryT m a =     RegistryT { unRegistryT :: StateT Registry m a }-    deriving ( Monad, MonadTrans, Applicative, Functor-             , MonadState Registry, MonadIO)+    deriving (Monad, MonadTrans, Applicative, Functor, MonadIO)   evalRegistryT :: Monad m => RegistryT m a -> m a-evalRegistryT registry = evalStateT (unRegistryT registry) new+evalRegistryT = flip evalStateT new . unRegistryT   execRegistryT :: Monad m => RegistryT m a -> m Registry-execRegistryT registry = execStateT (unRegistryT registry) new+execRegistryT = flip execStateT new . unRegistryT   runRegistryT :: Monad m => RegistryT m a -> m (a, Registry)-runRegistryT registry = runStateT (unRegistryT registry) new+runRegistryT = flip runStateT new . unRegistryT  -withRegistry :: (Registry -> m (a, Registry)) -> RegistryT m a+withRegistry :: MonadIO m => (Registry -> m (a, Registry)) -> RegistryT m a withRegistry = RegistryT . StateT  -registerCounter :: Name -> Labels -> RegistryT IO Counter-registerCounter = (.) withRegistry . R.registerCounter+registerCounter :: MonadIO m => Name -> Labels -> RegistryT m Counter+registerCounter n l = withRegistry (liftIO . R.registerCounter n l)  -registerGauge :: Name -> Labels -> RegistryT IO Gauge-registerGauge = (.) withRegistry . R.registerGauge+registerGauge :: MonadIO m => Name -> Labels -> RegistryT m Gauge+registerGauge n l = withRegistry (liftIO . R.registerGauge n l)  -registerHistogram :: Name -> Labels -> [Histogram.UpperBound] -> RegistryT IO Histogram-registerHistogram = (.) (withRegistry .) . R.registerHistogram+registerHistogram :: MonadIO m => Name -> Labels -> [Histogram.UpperBound] -> RegistryT m Histogram+registerHistogram n l u = withRegistry (liftIO . R.registerHistogram n l u)  -sample :: RegistryT IO R.RegistrySample-sample = get >>= (lift . R.sample)+sample :: Monad m => RegistryT m (IO RegistrySample)+sample = R.sample <$> RegistryT get