diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,97 @@ +## 0.4.0.0 (2014-05-01) + + * Lots of the internals were split off into a new package, ekg-core. + + * The `Gauge.modify` function was removed, as it can't be supported + by the new, more efficient implementation of gauges. + + * The JSON API was significantly overhauled. The the Haddock + documentation for details. + + * The metric store used internally by the server is now exposed and + can be used to share the same metric store between ekg and e.g. + ekg-statsd. + + * It's now possible to provide a custom metric store to the server. + + * The getDistribution function was added. + + * The UI now has less special treatment for built-in metrics. + +## 0.3.1.3 (2013-02-22) + + * Fixed security issue where ekg would always listen to all incoming + requests, even if "localhost" was specified. + + * Always export par_tot_bytes_copied. Previously it was only exported + if using base-4.6 and later. + +## 0.3.1.2 (2012-09-18) + + * Support GHC 7.6 + +## 0.3.1.1 (2012-06-25) + + * Bump dependencies. + +## 0.3.1.0 (2012-04-17) + + * Add labels, which are free-form string values exported by the + monitoring server. Labels allow you to export e.g. the command + line arguments used to start the executable or the host name it's + running on. + +## 0.3.0.4 (2012-04-03) + + * Add original JavaScript files to tarball to ease distribution + packaging. + +## 0.3.0.4 (2012-04-03) + + * Change icons to Creative Commons Attribution 3.0 licensed one + +## 0.3.0.3 (2012-03-19) + + * Support Snap 0.8 + +## 0.3.0.2 (2012-03-07) + + * Don't require an internet connection, by serving Bootstrap CSS and + jQuery from the monitoring server. + +## 0.3.0.1 (2012-01-26) + + * Switch from Blueprint to Bootstrap CSS + + * Overhaul look-and-feel + +## 0.3.0.0 (2012-01-01) + + * Add gauges and change counters to always be monotonically increasing + + * Add web interface column headers + + * Reorganize the web interface to show counters and gauges in separate sections + + * Change REST API to allow separate access to counters and gauges + + * Return the server time in the JSON response it and use server time + instead of client time when graphing + + * Make it possible to graph user-defined counters and gauges + + * Format numbers using comma separators + + * Show a message box when the server can't be reached + +## 0.2.0.0 (2011-12-30) + + * Add user-defined counters + + * Suppress Snap logging to stdio + + * Add REST-style API for accessing single counters + +## 0.1.0.0 (2011-12-27) + + * First EKG release diff --git a/System/Remote/Common.hs b/System/Remote/Common.hs deleted file mode 100644 --- a/System/Remote/Common.hs +++ /dev/null @@ -1,408 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module System.Remote.Common - ( - -- * Types - Counters - , Gauges - , Labels - , Server(..) - - , Ref(..) - - -- * User-defined counters, gauges, and labels - , getCounter - , getGauge - , getLabel - - , buildMany - , buildAll - , buildCombined - , buildOne - - , parseHttpAccept - ) where - -import Control.Concurrent (ThreadId) -import Control.Monad (forM) -import Control.Monad.IO.Class (liftIO) -import qualified Data.Aeson.Encode as A -import Data.Aeson.Types ((.=)) -import qualified Data.Aeson.Types as A -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy as L -import Data.Function (on) -import qualified Data.HashMap.Strict as M -import Data.IORef (IORef, atomicModifyIORef, readIORef) -import Data.Int (Int64) -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Text as T -import Data.Time.Clock.POSIX (getPOSIXTime) -import Data.Word (Word8) -import qualified GHC.Stats as Stats -import Prelude hiding (read) - -import System.Remote.Counter (Counter) -import qualified System.Remote.Counter.Internal as Counter -import System.Remote.Gauge (Gauge) -import qualified System.Remote.Gauge.Internal as Gauge -import System.Remote.Label (Label) -import qualified System.Remote.Label.Internal as Label - ------------------------------------------------------------------------- - --- Map of user-defined counters. -type Counters = M.HashMap T.Text Counter - --- Map of user-defined gauges. -type Gauges = M.HashMap T.Text Gauge - --- Map of user-defined labels. -type Labels = M.HashMap T.Text Label - --- | A handle that can be used to control the monitoring server. --- Created by 'forkServer'. -data Server = Server { - threadId :: {-# UNPACK #-} !ThreadId - , userCounters :: !(IORef Counters) - , userGauges :: !(IORef Gauges) - , userLabels :: !(IORef Labels) - } - ------------------------------------------------------------------------- --- * User-defined counters, gauges and labels - -class Ref r t | r -> t where - new :: IO r - read :: r -> IO t - -instance Ref Counter Int where - new = Counter.new - read = Counter.read - -instance Ref Gauge Int where - new = Gauge.new - read = Gauge.read - -instance Ref Label T.Text where - new = Label.new - read = Label.read - --- | Lookup a 'Ref' by name in the given map. If no 'Ref' exists --- under the given name, create a new one, insert it into the map and --- return it. -getRef :: Ref r t - => T.Text -- ^ 'Ref' name - -> IORef (M.HashMap T.Text r) -- ^ Server that will serve the 'Ref' - -> IO r -getRef name mapRef = do - empty <- new - ref <- atomicModifyIORef mapRef $ \ m -> - case M.lookup name m of - Nothing -> let m' = M.insert name empty m - in (m', empty) - Just ref -> (m, ref) - return ref -{-# INLINABLE getRef #-} - --- | Return the counter associated with the given name and server. --- Multiple calls to 'getCounter' with the same arguments will return --- the same counter. The first time 'getCounter' is called for a --- given name and server, a new, zero-initialized counter will be --- returned. -getCounter :: T.Text -- ^ Counter name - -> Server -- ^ Server that will serve the counter - -> IO Counter -getCounter name server = getRef name (userCounters server) - --- | Return the gauge associated with the given name and server. --- Multiple calls to 'getGauge' with the same arguments will return --- the same gauge. The first time 'getGauge' is called for a given --- name and server, a new, zero-initialized gauge will be returned. -getGauge :: T.Text -- ^ Gauge name - -> Server -- ^ Server that will serve the gauge - -> IO Gauge -getGauge name server = getRef name (userGauges server) - --- | Return the label associated with the given name and server. --- Multiple calls to 'getLabel' with the same arguments will return --- the same label. The first time 'getLabel' is called for a given --- name and server, a new, empty label will be returned. -getLabel :: T.Text -- ^ Label name - -> Server -- ^ Server that will serve the label - -> IO Label -getLabel name server = getRef name (userLabels server) - ------------------------------------------------------------------------- --- * JSON serialization - --- | All the stats exported by the server (i.e. GC stats plus user --- defined counters). -data Stats = Stats - !Stats.GCStats -- GC statistics - ![(T.Text, Json)] -- Counters - ![(T.Text, Json)] -- Gauges - ![(T.Text, Json)] -- Labels - {-# UNPACK #-} !Double -- Milliseconds since epoch - -instance A.ToJSON Stats where - toJSON (Stats gcStats counters gauges labels t) = A.object $ - [ "server_timestamp_millis" .= t - , "counters" .= Assocs (gcCounters ++ counters) - , "gauges" .= Assocs (gcGauges ++ gauges) - , "labels" .= Assocs (labels) - ] - where - (gcCounters, gcGauges) = partitionGcStats gcStats - --- | 'Stats' encoded as a flattened JSON object. -newtype Combined = Combined Stats - -instance A.ToJSON Combined where - toJSON (Combined (Stats s@(Stats.GCStats {..}) counters gauges labels t)) = - A.object $ - [ "server_timestamp_millis" .= t - , "bytes_allocated" .= bytesAllocated - , "num_gcs" .= numGcs - , "max_bytes_used" .= maxBytesUsed - , "num_bytes_usage_samples" .= numByteUsageSamples - , "cumulative_bytes_used" .= cumulativeBytesUsed - , "bytes_copied" .= bytesCopied - , "current_bytes_used" .= currentBytesUsed - , "current_bytes_slop" .= currentBytesSlop - , "max_bytes_slop" .= maxBytesSlop - , "peak_megabytes_allocated" .= peakMegabytesAllocated - , "mutator_cpu_seconds" .= mutatorCpuSeconds - , "mutator_wall_seconds" .= mutatorWallSeconds - , "gc_cpu_seconds" .= gcCpuSeconds - , "gc_wall_seconds" .= gcWallSeconds - , "cpu_seconds" .= cpuSeconds - , "wall_seconds" .= wallSeconds - , "par_tot_bytes_copied" .= gcParTotBytesCopied s - , "par_avg_bytes_copied" .= gcParTotBytesCopied s - , "par_max_bytes_copied" .= parMaxBytesCopied - ] ++ - map (uncurry (.=)) counters ++ - map (uncurry (.=)) gauges ++ - map (uncurry (.=)) labels - --- | A list of string keys and JSON-encodable values. Used to render --- a list of key-value pairs as a JSON object. -newtype Assocs = Assocs [(T.Text, Json)] - -instance A.ToJSON Assocs where - toJSON (Assocs xs) = A.object $ map (uncurry (.=)) xs - --- | A group of either counters or gauges. -data Group = Group - ![(T.Text, Json)] - {-# UNPACK #-} !Double -- Milliseconds since epoch - -instance A.ToJSON Group where - toJSON (Group xs t) = - A.object $ ("server_timestamp_millis" .= t) : map (uncurry (.=)) xs - ------------------------------------------------------------------------- - --- | Get a snapshot of all values. Note that we're not guaranteed to --- see a consistent snapshot of the whole map. -readAllRefs :: (Ref r t, A.ToJSON t) => IORef (M.HashMap T.Text r) - -> IO [(T.Text, Json)] -readAllRefs mapRef = do - m <- readIORef mapRef - forM (M.toList m) $ \ (name, ref) -> do - val <- read ref - return (name, Json val) -{-# INLINABLE readAllRefs #-} - - --- Existential wrapper used for OO-style polymorphism. -data Json = forall a. A.ToJSON a => Json a - -instance A.ToJSON Json where - toJSON (Json x) = A.toJSON x - --- | Partition GC statistics into counters and gauges. -partitionGcStats :: Stats.GCStats -> ([(T.Text, Json)], [(T.Text, Json)]) -partitionGcStats s@(Stats.GCStats {..}) = (counters, gauges) - where - counters = [ - ("bytes_allocated" , Json bytesAllocated) - , ("num_gcs" , Json numGcs) - , ("num_bytes_usage_samples" , Json numByteUsageSamples) - , ("cumulative_bytes_used" , Json cumulativeBytesUsed) - , ("bytes_copied" , Json bytesCopied) - , ("mutator_cpu_seconds" , Json mutatorCpuSeconds) - , ("mutator_wall_seconds" , Json mutatorWallSeconds) - , ("gc_cpu_seconds" , Json gcCpuSeconds) - , ("gc_wall_seconds" , Json gcWallSeconds) - , ("cpu_seconds" , Json cpuSeconds) - , ("wall_seconds" , Json wallSeconds) - ] - gauges = [ - ("max_bytes_used" , Json maxBytesUsed) - , ("current_bytes_used" , Json currentBytesUsed) - , ("current_bytes_slop" , Json currentBytesSlop) - , ("max_bytes_slop" , Json maxBytesSlop) - , ("peak_megabytes_allocated" , Json peakMegabytesAllocated) - , ("par_tot_bytes_copied" , Json (gcParTotBytesCopied s)) - , ("par_avg_bytes_copied" , Json (gcParTotBytesCopied s)) - , ("par_max_bytes_copied" , Json parMaxBytesCopied) - ] - ------------------------------------------------------------------------- - --- | Serve a collection of counters or gauges, as a JSON object. -buildMany :: (Ref r t, A.ToJSON t) => IORef (M.HashMap T.Text r) - -> IO L.ByteString -buildMany mapRef = do - list <- readAllRefs mapRef - time <- getTimeMillis - return $ A.encode $ A.toJSON $ Group list time -{-# INLINABLE buildMany #-} - --- | Serve all counter, gauges and labels, built-in or not, as a --- nested JSON object. -buildAll :: IORef Counters -> IORef Gauges -> IORef Labels -> IO L.ByteString -buildAll counters gauges labels = do - gcStats <- getGcStats - counterList <- readAllRefs counters - gaugeList <- readAllRefs gauges - labelList <- readAllRefs labels - time <- getTimeMillis - return $ A.encode $ A.toJSON $ Stats gcStats counterList gaugeList - labelList time - -buildCombined :: IORef Counters -> IORef Gauges -> IORef Labels -> IO L.ByteString -buildCombined counters gauges labels = do - gcStats <- getGcStats - counterList <- readAllRefs counters - gaugeList <- readAllRefs gauges - labelList <- readAllRefs labels - time <- getTimeMillis - return $ A.encode $ A.toJSON $ Combined $ - Stats gcStats counterList gaugeList labelList time - -buildOne :: (Ref r t, Show t) - => IORef (M.HashMap T.Text r) -> T.Text - -> IO (Maybe S.ByteString) -buildOne refs name = do - m <- readIORef refs - case M.lookup name m of - Just counter -> do - val <- read counter - return $ Just $ S8.pack $ show val - Nothing -> - -- Try built-in (e.g. GC) refs - case Map.lookup name builtinCounters of - Just f -> do - gcStats <- liftIO getGcStats - return $ Just $ S8.pack $ f gcStats - Nothing -> return Nothing -{-# INLINABLE buildOne #-} - -getGcStats :: IO Stats.GCStats -#if MIN_VERSION_base(4,6,0) -getGcStats = do - enabled <- Stats.getGCStatsEnabled - if enabled - then Stats.getGCStats - else return emptyGCStats - -emptyGCStats :: Stats.GCStats -emptyGCStats = Stats.GCStats - { bytesAllocated = 0 - , numGcs = 0 - , maxBytesUsed = 0 - , numByteUsageSamples = 0 - , cumulativeBytesUsed = 0 - , bytesCopied = 0 - , currentBytesUsed = 0 - , currentBytesSlop = 0 - , maxBytesSlop = 0 - , peakMegabytesAllocated = 0 - , mutatorCpuSeconds = 0 - , mutatorWallSeconds = 0 - , gcCpuSeconds = 0 - , gcWallSeconds = 0 - , cpuSeconds = 0 - , wallSeconds = 0 - , parTotBytesCopied = 0 - , parMaxBytesCopied = 0 - } -#else -getGcStats = Stats.getGCStats -#endif - --- | A list of all built-in (e.g. GC) counters, together with a --- pretty-printing function for each. -builtinCounters :: Map.Map T.Text (Stats.GCStats -> String) -builtinCounters = Map.fromList [ - ("bytes_allocated" , show . Stats.bytesAllocated) - , ("num_gcs" , show . Stats.numGcs) - , ("max_bytes_used" , show . Stats.maxBytesUsed) - , ("num_bytes_usage_samples" , show . Stats.numByteUsageSamples) - , ("cumulative_bytes_used" , show . Stats.cumulativeBytesUsed) - , ("bytes_copied" , show . Stats.bytesCopied) - , ("current_bytes_used" , show . Stats.currentBytesUsed) - , ("current_bytes_slop" , show . Stats.currentBytesSlop) - , ("max_bytes_slop" , show . Stats.maxBytesSlop) - , ("peak_megabytes_allocated" , show . Stats.peakMegabytesAllocated) - , ("mutator_cpu_seconds" , show . Stats.mutatorCpuSeconds) - , ("mutator_wall_seconds" , show . Stats.mutatorWallSeconds) - , ("gc_cpu_seconds" , show . Stats.gcCpuSeconds) - , ("gc_wall_seconds" , show . Stats.gcWallSeconds) - , ("cpu_seconds" , show . Stats.cpuSeconds) - , ("wall_seconds" , show . Stats.wallSeconds) - , ("par_tot_bytes_copied" , show . gcParTotBytesCopied) - , ("par_avg_bytes_copied" , show . gcParTotBytesCopied) - , ("par_max_bytes_copied" , show . Stats.parMaxBytesCopied) - ] - ------------------------------------------------------------------------- - --- Utilities for working with accept headers - --- | Parse the HTTP accept string to determine supported content types. -parseHttpAccept :: S.ByteString -> [S.ByteString] -parseHttpAccept = List.map fst - . List.sortBy (rcompare `on` snd) - . List.map grabQ - . S.split 44 -- comma - where - rcompare :: Double -> Double -> Ordering - rcompare = flip compare - grabQ s = - let (s', q) = breakDiscard 59 s -- semicolon - (_, q') = breakDiscard 61 q -- equals sign - in (trimWhite s', readQ $ trimWhite q') - readQ s = case reads $ S8.unpack s of - (x, _):_ -> x - _ -> 1.0 - trimWhite = S.dropWhile (== 32) -- space - -breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString) -breakDiscard w s = - let (x, y) = S.break (== w) s - in (x, S.drop 1 y) - ------------------------------------------------------------------------- --- Utilities for working with timestamps - --- | Return the number of milliseconds since epoch. -getTimeMillis :: IO Double -getTimeMillis = (realToFrac . (* 1000)) `fmap` getPOSIXTime - --- | Helper to work around rename in GHC.Stats in base-4.6. -gcParTotBytesCopied :: Stats.GCStats -> Int64 -#if MIN_VERSION_base(4,6,0) -gcParTotBytesCopied = Stats.parTotBytesCopied -#else -gcParTotBytesCopied = Stats.parAvgBytesCopied -#endif diff --git a/System/Remote/Counter.hs b/System/Remote/Counter.hs --- a/System/Remote/Counter.hs +++ b/System/Remote/Counter.hs @@ -1,28 +1,18 @@ -{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_HADDOCK not-home #-} + -- | This module defines a type for mutable, integer-valued counters. -- Counters are non-negative, monotonically increasing values and can -- be used to track e.g. the number of requests served since program -- start. All operations on counters are thread-safe. +-- +-- N.B. This module exists to maintain backwards compatibility with +-- older versions of this library. New code should use the +-- @System.Metrics.Counter@ module from the ekg-core package instead. module System.Remote.Counter ( - Counter - , inc - , add + Counter.Counter + , Counter.inc + , Counter.add ) where -import Data.IORef (atomicModifyIORef) -import Prelude hiding (subtract) - -import System.Remote.Counter.Internal - --- | Increase the counter by one. -inc :: Counter -> IO () -inc (C ref) = do - !_ <- atomicModifyIORef ref $ \ n -> let n' = n + 1 in (n', n') - return () - --- | Increase the counter by the given amount. -add :: Counter -> Int -> IO () -add (C ref) i = do - !_ <- atomicModifyIORef ref $ \ n -> let n' = n + i in (n', n') - return () +import qualified System.Metrics.Counter as Counter diff --git a/System/Remote/Counter/Internal.hs b/System/Remote/Counter/Internal.hs deleted file mode 100644 --- a/System/Remote/Counter/Internal.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# OPTIONS_HADDOCK not-home #-} -module System.Remote.Counter.Internal - ( - Counter(..) - , new - , read - ) where - -import Data.IORef (IORef, newIORef, readIORef) -import Prelude hiding (read) - --- | A mutable, integer-valued counter. -newtype Counter = C { unC :: IORef Int } - --- | Create a new, zero initialized, counter. -new :: IO Counter -new = C `fmap` newIORef 0 - -read :: Counter -> IO Int -read = readIORef . unC diff --git a/System/Remote/Gauge.hs b/System/Remote/Gauge.hs --- a/System/Remote/Gauge.hs +++ b/System/Remote/Gauge.hs @@ -1,55 +1,21 @@ -{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_HADDOCK not-home #-} + -- | This module defines a type for mutable, integer-valued gauges. -- Gauges are variable values and can be used to track e.g. the -- current number of concurrent connections. All operations on gauges -- are thread-safe. +-- +-- N.B. This module exists to maintain backwards compatibility with +-- older versions of this library. New code should use the +-- @System.Metrics.Gauge@ module from the ekg-core package instead. module System.Remote.Gauge ( - Gauge - , inc - , dec - , add - , subtract - , set - , modify + Gauge.Gauge + , Gauge.inc + , Gauge.dec + , Gauge.add + , Gauge.subtract + , Gauge.set ) where -import Data.IORef (atomicModifyIORef) -import Prelude hiding (subtract) - -import System.Remote.Gauge.Internal - --- | Increase the gauge by one. -inc :: Gauge -> IO () -inc (C ref) = do - !_ <- atomicModifyIORef ref $ \ n -> let n' = n + 1 in (n', n') - return () - --- | Decrease the gauge by one. -dec :: Gauge -> IO () -dec (C ref) = do - !_ <- atomicModifyIORef ref $ \ n -> let n' = n - 1 in (n', n') - return () - --- | Increase the gauge by the given amount. -add :: Gauge -> Int -> IO () -add (C ref) i = do - !_ <- atomicModifyIORef ref $ \ n -> let n' = n + i in (n', n') - return () - --- | Decrease the gauge by the given amount. -subtract :: Gauge -> Int -> IO () -subtract (C ref) i = do - !_ <- atomicModifyIORef ref $ \ n -> let n' = n - i in (n', n') - return () - --- | Set the gauge to the given value. -set :: Gauge -> Int -> IO () -set (C ref) !i = atomicModifyIORef ref $ \ _ -> (i, ()) - --- | Set the gauge to the result of applying the given function to the --- value. -modify :: (Int -> Int) -> Gauge -> IO () -modify f (C ref) = do - !_ <- atomicModifyIORef ref $ \ i -> let i' = f i in (i', i') - return () +import qualified System.Metrics.Gauge as Gauge diff --git a/System/Remote/Gauge/Internal.hs b/System/Remote/Gauge/Internal.hs deleted file mode 100644 --- a/System/Remote/Gauge/Internal.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# OPTIONS_HADDOCK not-home #-} -module System.Remote.Gauge.Internal - ( - Gauge(..) - , new - , read - ) where - -import Data.IORef (IORef, newIORef, readIORef) -import Prelude hiding (read) - --- | A mutable, integer-valued gauge. -newtype Gauge = C { unC :: IORef Int } - --- | Create a new, zero initialized, gauge. -new :: IO Gauge -new = C `fmap` newIORef 0 - -read :: Gauge -> IO Int -read = readIORef . unC diff --git a/System/Remote/Json.hs b/System/Remote/Json.hs new file mode 100644 --- /dev/null +++ b/System/Remote/Json.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Remote.Json + ( + encodeAll + , encodeOne + ) where + +import qualified Data.Aeson.Encode as A +import qualified Data.Aeson.Types as A +import qualified Data.ByteString.Lazy as L +import qualified Data.HashMap.Strict as M +import Data.Int (Int64) +import qualified Data.Text as T +import Prelude hiding (read) + +import System.Metrics +import qualified System.Metrics.Distribution as Distribution + +------------------------------------------------------------------------ +-- * JSON serialization + +data MetricType = + CounterType + | GaugeType + | LabelType + | DistributionType + +metricType :: MetricType -> T.Text +metricType CounterType = "c" +metricType GaugeType = "g" +metricType LabelType = "l" +metricType DistributionType = "d" + +-- | Encode metrics as nested JSON objects. Each "." in the metric +-- name introduces a new level of nesting. For example, the metrics +-- @[("foo.bar", 10), ("foo.baz", "label")]@ are encoded as +-- +-- > { +-- > "foo": { +-- > "bar": { +-- > "type:", "c", +-- > "val": 10 +-- > }, +-- > "baz": { +-- > "type": "l", +-- > "val": "label" +-- > } +-- > } +-- > } +-- +encodeAll :: Sample -> L.ByteString +encodeAll metrics = + A.encode $ buildOne metrics $ A.emptyObject + where + buildOne :: M.HashMap T.Text Value -> A.Value -> A.Value + buildOne m o = M.foldlWithKey' build o m + + build :: A.Value -> T.Text -> Value -> A.Value + build m name val = go m (T.splitOn "." name) val + + go :: A.Value -> [T.Text] -> Value -> A.Value + go (A.Object m) [str] val = A.Object $ M.insert str metric m + where metric = buildOneM val + go (A.Object m) (str:rest) val = case M.lookup str m of + Nothing -> A.Object $ M.insert str (go A.emptyObject rest val) m + Just m' -> A.Object $ M.insert str (go m' rest val) m + go v _ _ = typeMismatch "Object" v + +buildOneM :: Value -> A.Value +buildOneM (Counter n) = goOne n CounterType +buildOneM (Gauge n) = goOne n GaugeType +buildOneM (Label l) = goOne l LabelType +buildOneM (Distribution l) = goDistribution l + +goDistribution :: Distribution.Stats -> A.Value +goDistribution stats = A.object [ + ("mean", A.toJSON $! Distribution.mean stats), + ("variance", A.toJSON $! Distribution.variance stats), + ("count", A.toJSON $! Distribution.count stats), + ("sum", A.toJSON $! Distribution.sum stats), + ("min", A.toJSON $! Distribution.min stats), + ("max", A.toJSON $! Distribution.max stats), + ("type", A.toJSON (metricType DistributionType))] + +goOne :: A.ToJSON a => a -> MetricType -> A.Value +goOne val ty = A.object [ + ("val", A.toJSON val), ("type", A.toJSON (metricType ty))] +{-# SPECIALIZE goOne :: Int64 -> MetricType -> A.Value #-} +{-# SPECIALIZE goOne :: T.Text -> MetricType -> A.Value #-} + +encodeOne :: Value -> L.ByteString +encodeOne = A.encode . buildOneM + +typeMismatch :: String -- ^ The expected type + -> A.Value -- ^ The actual value encountered + -> a +typeMismatch expected actual = + error $ "when expecting a " ++ expected ++ ", encountered " ++ name ++ + " instead" + where + name = case actual of + A.Object _ -> "Object" + A.Array _ -> "Array" + A.String _ -> "String" + A.Number _ -> "Number" + A.Bool _ -> "Boolean" + A.Null -> "Null" diff --git a/System/Remote/Label.hs b/System/Remote/Label.hs --- a/System/Remote/Label.hs +++ b/System/Remote/Label.hs @@ -1,27 +1,18 @@ -{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_HADDOCK not-home #-} + -- | This module defines a type for mutable, string-valued labels. -- Labels are variable values and can be used to track e.g. the -- command line arguments or other free-form values. All operations on -- labels are thread-safe. +-- +-- N.B. This module exists to maintain backwards compatibility with +-- older versions of this library. New code should use the +-- @System.Metrics.Label@ module from the ekg-core package instead. module System.Remote.Label ( - Label - , set - , modify + Label.Label + , Label.set + , Label.modify ) where -import Data.IORef (atomicModifyIORef) -import qualified Data.Text as T - -import System.Remote.Label.Internal - --- | Set the label to the given value. -set :: Label -> T.Text -> IO () -set (C ref) !i = atomicModifyIORef ref $ \ _ -> (i, ()) - --- | Set the label to the result of applying the given function to the --- value. -modify :: (T.Text -> T.Text) -> Label -> IO () -modify f (C ref) = do - !_ <- atomicModifyIORef ref $ \ i -> let i' = f i in (i', i') - return () +import qualified System.Metrics.Label as Label diff --git a/System/Remote/Label/Internal.hs b/System/Remote/Label/Internal.hs deleted file mode 100644 --- a/System/Remote/Label/Internal.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# OPTIONS_HADDOCK not-home #-} -module System.Remote.Label.Internal - ( - Label(..) - , new - , read - ) where - -import Data.IORef (IORef, newIORef, readIORef) -import qualified Data.Text as T -import Prelude hiding (read) - --- | A mutable, text-valued label. -newtype Label = C { unC :: IORef T.Text } - --- | Create a new empty label. -new :: IO Label -new = C `fmap` newIORef T.empty - -read :: Label -> IO T.Text -read = readIORef . unC diff --git a/System/Remote/Monitoring.hs b/System/Remote/Monitoring.hs --- a/System/Remote/Monitoring.hs +++ b/System/Remote/Monitoring.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} -- | This module provides remote monitoring of a running process over -- HTTP. It can be used to run an HTTP server that provides both a @@ -31,30 +31,37 @@ -- * The monitoring server Server , serverThreadId + , serverMetricStore , forkServer + , forkServerWith - -- * User-defined counters, gauges, and labels + -- * Defining metrics -- $userdefined , getCounter , getGauge , getLabel + , getDistribution ) where import Control.Concurrent (ThreadId, forkIO) import qualified Data.ByteString as S -import qualified Data.HashMap.Strict as M -import Data.IORef (newIORef) +import Data.Int (Int64) +import qualified Data.Text as T +import Data.Time.Clock.POSIX (getPOSIXTime) import Prelude hiding (read) -import System.Remote.Common - +import qualified System.Metrics as Metrics +import qualified System.Metrics.Counter as Counter +import qualified System.Metrics.Distribution as Distribution +import qualified System.Metrics.Gauge as Gauge +import qualified System.Metrics.Label as Label import System.Remote.Snap -- $configuration -- --- To use this module you must first enable GC statistics collection --- in the run-time system. To enable GC statistics collection, either --- run your program with +-- To make full use out of this this module you must first enable GC +-- statistics collection in the run-time system. To enable GC +-- statistics collection, either run your program with -- -- > +RTS -T -- @@ -73,118 +80,79 @@ -- $api -- To use the machine-readable REST API, send an HTTP GET request to --- the host and port passed to 'forkServer'. The following resources --- (i.e. URLs) are available: --- --- [\/] JSON object containing all counters, gauges and labels. --- Counters, gauges, and labels are stored as nested objects under the --- @counters@, @gauges@, and @labels@ attributes, respectively. --- Content types: \"text\/html\" (default), \"application\/json\" --- --- [\/combined] Flattened JSON object containing all counters, gauges, --- and labels. Content types: \"application\/json\" --- --- [\/counters] JSON object containing all counters. Content types: --- \"application\/json\" --- --- [\/counters/\] Value of a single counter, as a --- string. The name should be UTF-8 encoded. Content types: --- \"text\/plain\" +-- the host and port passed to 'forkServer'. -- --- [\/gauges] JSON object containing all gauges. Content types: --- \"application\/json\" +-- The API is versioned to allow for API evolution. This document is +-- for version 1. To ensure you're using this version, append @?v=1@ +-- to your resource URLs. Omitting the version number will give you +-- the latest version of the API. -- --- [\/gauges/\] Value of a single gauge, as a string. --- The name should be UTF-8 encoded. Content types: \"text\/plain\" +-- The following resources (i.e. URLs) are available: -- --- [\/labels] JSON object containing all labels. Content types: +-- [\/] JSON object containing all metrics. Metrics are stored as +-- nested objects, with one new object layer per \".\" in the metric +-- name (see example below.) Content types: \"text\/html\" (default), -- \"application\/json\" -- --- [\/labels/\