diff --git a/prometheus.cabal b/prometheus.cabal --- a/prometheus.cabal +++ b/prometheus.cabal @@ -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 diff --git a/src/System/Metrics/Prometheus/Concurrent/Http.hs b/src/System/Metrics/Prometheus/Concurrent/Http.hs --- a/src/System/Metrics/Prometheus/Concurrent/Http.hs +++ b/src/System/Metrics/Prometheus/Concurrent/Http.hs @@ -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 diff --git a/src/System/Metrics/Prometheus/Concurrent/RegistryT.hs b/src/System/Metrics/Prometheus/Concurrent/RegistryT.hs --- a/src/System/Metrics/Prometheus/Concurrent/RegistryT.hs +++ b/src/System/Metrics/Prometheus/Concurrent/RegistryT.hs @@ -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 diff --git a/src/System/Metrics/Prometheus/RegistryT.hs b/src/System/Metrics/Prometheus/RegistryT.hs --- a/src/System/Metrics/Prometheus/RegistryT.hs +++ b/src/System/Metrics/Prometheus/RegistryT.hs @@ -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