diff --git a/System/Remote/Common.hs b/System/Remote/Common.hs
new file mode 100644
--- /dev/null
+++ b/System/Remote/Common.hs
@@ -0,0 +1,408 @@
+{-# 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/Monitoring.hs b/System/Remote/Monitoring.hs
--- a/System/Remote/Monitoring.hs
+++ b/System/Remote/Monitoring.hs
@@ -1,5 +1,5 @@
-{-# LANGUAGE CPP, ExistentialQuantification, OverloadedStrings, RecordWildCards,
- FunctionalDependencies #-}
+{-# LANGUAGE CPP #-}
+
-- | This module provides remote monitoring of a running process over
-- HTTP. It can be used to run an HTTP server that provides both a
-- web-based user interface and a machine-readable API (e.g. JSON.)
@@ -22,6 +22,9 @@
-- * Required configuration
-- $configuration
+ -- * Security considerations
+ -- $security
+
-- * REST API
-- $api
@@ -37,44 +40,16 @@
, getLabel
) where
-import Control.Applicative ((<$>), (<|>))
import Control.Concurrent (ThreadId, forkIO)
-import Control.Monad (forM, join, unless)
-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 Data.Function (on)
import qualified Data.HashMap.Strict as M
-import Data.IORef (IORef, atomicModifyIORef, newIORef, readIORef)
-import qualified Data.List as List
-import qualified Data.Map as Map
-import Data.Maybe (listToMaybe)
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import Data.Time.Clock.POSIX (getPOSIXTime)
-import Data.Word (Word8)
-import qualified GHC.Stats as Stats
-import Paths_ekg (getDataDir)
+import Data.IORef (newIORef)
import Prelude hiding (read)
-import Snap.Core (MonadSnap, Request, Snap, finishWith, getHeaders, getRequest,
- getResponse, method, Method(GET), modifyResponse, pass, route,
- rqParams, rqPathInfo, setContentType, setResponseStatus,
- writeBS, writeLBS)
-import Snap.Http.Server (httpServe)
-import qualified Snap.Http.Server.Config as Config
-import Snap.Util.FileServe (serveDirectory)
-import System.FilePath (())
-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
+import System.Remote.Common
+import System.Remote.Snap
+
-- $configuration
--
-- To use this module you must first enable GC statistics collection
@@ -90,15 +65,21 @@
-- The runtime overhead of @-T@ is very small so it's safe to always
-- leave it enabled.
+-- $security
+-- Be aware that if the server started by 'forkServer' is not bound to
+-- \"localhost\" (or equivalent) anyone on the network can access the
+-- monitoring server. Either make sure the network is secure or bind
+-- the server to \"localhost\".
+
-- $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 and gauges. Counters and
--- gauges are stored as nested objects under the @counters@ and
--- @gauges@ attributes, respectively. Content types: \"text\/html\"
--- (default), \"application\/json\"
+-- [\/] 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\"
@@ -171,7 +152,6 @@
--
-- [@peak_megabytes_allocated@] Maximum number of megabytes allocated
--
-#if MIN_VERSION_base(4,6,0)
-- [@par_tot_bytes_copied@] Number of bytes copied during GC, minus
-- space held by mutable lists held by the capabilities. Can be used
-- with 'parMaxBytesCopied' to determine how well parallel GC utilized
@@ -179,79 +159,16 @@
--
-- [@par_avg_bytes_copied@] Deprecated alias for
-- @par_tot_bytes_copied@.
-#else
--- [@par_avg_bytes_copied@] Number of bytes copied during GC, minus
--- space held by mutable lists held by the capabilities. Can be used
--- with 'parMaxBytesCopied' to determine how well parallel GC utilized
--- all cores.
-#endif
--
-- [@par_max_bytes_copied@] Sum of number of bytes copied each GC by
--- the most active GC thread each GC. The ratio of
-#if MIN_VERSION_base(4,6,0)
--- 'parTotBytesCopied' divided by 'parMaxBytesCopied' approaches 1 for
-#else
--- 'parAvgBytesCopied' divided by 'parMaxBytesCopied' approaches 1 for
-#endif
--- a maximally sequential run and approaches the number of threads
--- (set by the RTS flag @-N@) for a maximally parallel run.
-
-------------------------------------------------------------------------
--- * The monitoring server
-
--- 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)
- }
-
--- | The thread ID of the server. You can kill the server by killing
--- this thread (i.e. by throwing it an asynchronous exception.)
-serverThreadId :: Server -> ThreadId
-serverThreadId = threadId
-
--- | Start an HTTP server in a new thread. The server replies to GET
--- requests to the given host and port. The host argument can be
--- either a numeric network address (dotted quad for IPv4,
--- colon-separated hex for IPv6) or a hostname (e.g. \"localhost\".)
--- The client can control the Content-Type used in responses by
--- setting the Accept header. At the moment three content types are
--- available: \"application\/json\", \"text\/html\", and
--- \"text\/plain\".
-forkServer :: S.ByteString -- ^ Host to listen on (e.g. \"localhost\")
- -> Int -- ^ Port to listen on (e.g. 8000)
- -> IO Server
-forkServer host port = do
- counters <- newIORef M.empty
- gauges <- newIORef M.empty
- labels <- newIORef M.empty
- tid <- forkIO $ httpServe conf (monitor counters gauges labels)
- return $! Server tid counters gauges labels
- where conf = Config.setVerbose False $
- Config.setErrorLog Config.ConfigNoLog $
- Config.setAccessLog Config.ConfigNoLog $
- Config.setPort port $
- Config.setHostname host $
- Config.defaultConfig
-
-------------------------------------------------------------------------
--- * User-defined counters, gauges and labels
+-- the most active GC thread each GC. The ratio of
+-- @par_tot_bytes_copied@ divided by @par_max_bytes_copied@ approaches
+-- 1 for a maximally sequential run and approaches the number of
+-- threads (set by the RTS flag @-N@) for a maximally parallel run.
-- $userdefined
-- The monitoring server can store and serve user-defined,
--- integer-valued counters and gauges, and string-value labels. A
+-- integer-valued counters and gauges, and string-valued labels. A
-- counter is a monotonically increasing value (e.g. TCP connections
-- established since program start.) A gauge is a variable value
-- (e.g. the current number of concurrent connections.) A label is a
@@ -281,391 +198,28 @@
-- call e.g. 'System.Remote.Gauge.set' or
-- 'System.Remote.Gauge.modify'. Similar for 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
-
-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
-#if MIN_VERSION_base(4,6,0)
- , parTotBytesCopied = 0
-#else
- , parAvgBytesCopied = 0
-#endif
- , parMaxBytesCopied = 0
- }
-
-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 (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
-#if MIN_VERSION_base(4,6,0)
- , "par_tot_bytes_copied" .= parTotBytesCopied
- , "par_avg_bytes_copied" .= parTotBytesCopied
-#else
- , "par_avg_bytes_copied" .= parAvgBytesCopied
-#endif
- , "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
-
-------------------------------------------------------------------------
--- * HTTP request handler
-
--- | A handler that can be installed into an existing Snap application.
-monitor :: IORef Counters -> IORef Gauges -> IORef Labels -> Snap ()
-monitor counters gauges labels = do
- dataDir <- liftIO getDataDir
- route [
- ("", method GET (format "application/json"
- (serveAll counters gauges labels)))
- , ("combined", method GET (format "application/json"
- (serveCombined counters gauges labels)))
- , ("counters", method GET (format "application/json"
- (serveMany counters)))
- , ("counters/:name", method GET (format "text/plain"
- (serveOne counters)))
- , ("gauges", method GET (format "application/json"
- (serveMany gauges)))
- , ("gauges/:name", method GET (format "text/plain"
- (serveOne gauges)))
- , ("labels", method GET (format "application/json"
- (serveMany labels)))
- , ("labels/:name", method GET (format "text/plain"
- (serveOne labels)))
- ]
- <|> serveDirectory (dataDir "assets")
-
--- | The Accept header of the request.
-acceptHeader :: Request -> Maybe S.ByteString
-acceptHeader req = S.intercalate "," <$> getHeaders "Accept" req
-
--- | Runs a Snap monad action only if the request's Accept header
--- matches the given MIME type.
-format :: MonadSnap m => S.ByteString -> m a -> m a
-format fmt action = do
- req <- getRequest
- let acceptHdr = (List.head . parseHttpAccept) <$> acceptHeader req
- case acceptHdr of
- Just hdr | hdr == fmt -> action
- _ -> pass
-
--- | 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 #-}
-
--- | Serve a collection of counters or gauges, as a JSON object.
-serveMany :: (Ref r t, A.ToJSON t) => IORef (M.HashMap T.Text r) -> Snap ()
-serveMany mapRef = do
- list <- liftIO $ readAllRefs mapRef
- modifyResponse $ setContentType "application/json"
- time <- liftIO getTimeMillis
- writeLBS $ A.encode $ A.toJSON $ Group list time
-{-# INLINABLE serveMany #-}
-
-getGcStats :: IO Stats.GCStats
-getGcStats = do
-#if MIN_VERSION_base(4,6,0)
- enabled <- Stats.getGCStatsEnabled
- if enabled
- then Stats.getGCStats
- else return emptyGCStats
-#else
- Stats.getGCStats
-#endif
-
--- | Serve all counter, gauges and labels, built-in or not, as a
--- nested JSON object.
-serveAll :: IORef Counters -> IORef Gauges -> IORef Labels -> Snap ()
-serveAll counters gauges labels = do
- req <- getRequest
- -- Workaround: Snap still matches requests to /foo to this handler
- -- if the Accept header is "application/json", even though such
- -- requests ought to go to the 'serveOne' handler.
- unless (S.null $ rqPathInfo req) pass
- modifyResponse $ setContentType "application/json"
- gcStats <- liftIO getGcStats
- counterList <- liftIO $ readAllRefs counters
- gaugeList <- liftIO $ readAllRefs gauges
- labelList <- liftIO $ readAllRefs labels
- time <- liftIO getTimeMillis
- writeLBS $ A.encode $ A.toJSON $ Stats gcStats counterList gaugeList
- labelList time
-
--- | Serve all counters and gauges, built-in or not, as a flattened
--- JSON object.
-serveCombined :: IORef Counters -> IORef Gauges -> IORef Labels -> Snap ()
-serveCombined counters gauges labels = do
- modifyResponse $ setContentType "application/json"
- gcStats <- liftIO getGcStats
- counterList <- liftIO $ readAllRefs counters
- gaugeList <- liftIO $ readAllRefs gauges
- labelList <- liftIO $ readAllRefs labels
- time <- liftIO getTimeMillis
- writeLBS $ A.encode $ A.toJSON $ Combined $
- Stats gcStats counterList gaugeList labelList time
-
--- | Serve a single counter, as plain text.
-serveOne :: (Ref r t, Show t) => IORef (M.HashMap T.Text r) -> Snap ()
-serveOne refs = do
- modifyResponse $ setContentType "text/plain"
- m <- liftIO $ readIORef refs
- req <- getRequest
- let mname = T.decodeUtf8 <$> join
- (listToMaybe <$> Map.lookup "name" (rqParams req))
- case mname of
- Nothing -> pass
- Just name -> case M.lookup name m of
- Just counter -> do
- val <- liftIO $ read counter
- writeBS $ S8.pack $ show val
- Nothing ->
- -- Try built-in (e.g. GC) refs
- case Map.lookup name builtinCounters of
- Just f -> do
- gcStats <- liftIO getGcStats
- writeBS $ S8.pack $ f gcStats
- Nothing -> do
- modifyResponse $ setResponseStatus 404 "Not Found"
- r <- getResponse
- finishWith r
-{-# INLINABLE serveOne #-}
-
--- | 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)
-#if MIN_VERSION_base(4,6,0)
- , ("par_tot_bytes_copied" , show . Stats.parTotBytesCopied)
- , ("par_avg_bytes_copied" , show . Stats.parTotBytesCopied)
-#else
- , ("par_avg_bytes_copied" , show . Stats.parAvgBytesCopied)
-#endif
- , ("par_max_bytes_copied" , show . Stats.parMaxBytesCopied)
- ]
-
--- 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 (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)
-#if MIN_VERSION_base(4,6,0)
- , ("par_tot_bytes_copied" , Json parTotBytesCopied)
- , ("par_avg_bytes_copied" , Json parTotBytesCopied)
-#else
- , ("par_avg_bytes_copied" , Json parAvgBytesCopied)
-#endif
- , ("par_max_bytes_copied" , Json 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)
+-- * The monitoring server
-------------------------------------------------------------------------
--- Utilities for working with timestamps
+-- | The thread ID of the server. You can kill the server by killing
+-- this thread (i.e. by throwing it an asynchronous exception.)
+serverThreadId :: Server -> ThreadId
+serverThreadId = threadId
--- | Return the number of milliseconds since epoch.
-getTimeMillis :: IO Double
-getTimeMillis = (realToFrac . (* 1000)) `fmap` getPOSIXTime
+-- | Start an HTTP server in a new thread. The server replies to GET
+-- requests to the given host and port. The host argument can be
+-- either a numeric network address (dotted quad for IPv4,
+-- colon-separated hex for IPv6) or a hostname (e.g. \"localhost\".)
+-- The client can control the Content-Type used in responses by
+-- setting the Accept header. At the moment three content types are
+-- available: \"application\/json\", \"text\/html\", and
+-- \"text\/plain\".
+forkServer :: S.ByteString -- ^ Host to listen on (e.g. \"localhost\")
+ -> Int -- ^ Port to listen on (e.g. 8000)
+ -> IO Server
+forkServer host port = do
+ counters <- newIORef M.empty
+ gauges <- newIORef M.empty
+ labels <- newIORef M.empty
+ tid <- forkIO $ startServer counters gauges labels host port
+ return $! Server tid counters gauges labels
diff --git a/System/Remote/Snap.hs b/System/Remote/Snap.hs
new file mode 100644
--- /dev/null
+++ b/System/Remote/Snap.hs
@@ -0,0 +1,156 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module System.Remote.Snap
+ ( startServer
+ ) where
+
+import Control.Applicative ((<$>), (<|>))
+import Control.Exception (throwIO)
+import Control.Monad (join, unless)
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.Aeson.Types as A
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Char8 as S8
+import qualified Data.HashMap.Strict as M
+import Data.IORef (IORef)
+import qualified Data.List as List
+import qualified Data.Map as Map
+import Data.Maybe (listToMaybe)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import Network.Socket (NameInfoFlag(NI_NUMERICHOST), addrAddress, getAddrInfo,
+ getNameInfo)
+import Paths_ekg (getDataDir)
+import Prelude hiding (read)
+import Snap.Core (MonadSnap, Request, Snap, finishWith, getHeaders, getRequest,
+ getResponse, method, Method(GET), modifyResponse, pass, route,
+ rqParams, rqPathInfo, setContentType, setResponseStatus,
+ writeBS, writeLBS)
+import Snap.Http.Server (httpServe)
+import qualified Snap.Http.Server.Config as Config
+import Snap.Util.FileServe (serveDirectory)
+import System.FilePath (())
+
+import System.Remote.Common
+
+------------------------------------------------------------------------
+
+-- | Convert a host name (e.g. \"localhost\" or \"127.0.0.1\") to a
+-- numeric host address (e.g. \"127.0.0.1\").
+getNumericHostAddress :: S.ByteString -> IO S.ByteString
+getNumericHostAddress host = do
+ ais <- getAddrInfo Nothing (Just (S8.unpack host)) Nothing
+ case ais of
+ [] -> unsupportedAddressError
+ (ai:_) -> do
+ ni <- getNameInfo [NI_NUMERICHOST] True False (addrAddress ai)
+ case ni of
+ (Just numericHost, _) -> return $! S8.pack numericHost
+ _ -> unsupportedAddressError
+ where
+ unsupportedAddressError = throwIO $
+ userError $ "unsupported address: " ++ S8.unpack host
+
+startServer :: IORef Counters -> IORef Gauges -> IORef Labels
+ -> S.ByteString -- ^ Host to listen on (e.g. \"localhost\")
+ -> Int -- ^ Port to listen on (e.g. 8000)
+ -> IO ()
+startServer counters gauges labels host port = do
+ -- Snap doesn't allow for non-numeric host names in
+ -- 'Snap.setBind'. We work around that limitation by converting a
+ -- possible non-numeric host name to a numeric address.
+ numericHost <- getNumericHostAddress host
+ let conf = Config.setVerbose False $
+ Config.setErrorLog Config.ConfigNoLog $
+ Config.setAccessLog Config.ConfigNoLog $
+ Config.setPort port $
+ Config.setHostname host $
+ Config.setBind numericHost $
+ Config.defaultConfig
+ httpServe conf (monitor counters gauges labels)
+
+-- | A handler that can be installed into an existing Snap application.
+monitor :: IORef Counters -> IORef Gauges -> IORef Labels -> Snap ()
+monitor counters gauges labels = do
+ dataDir <- liftIO getDataDir
+ route [
+ ("", method GET (format "application/json"
+ (serveAll counters gauges labels)))
+ , ("combined", method GET (format "application/json"
+ (serveCombined counters gauges labels)))
+ , ("counters", method GET (format "application/json"
+ (serveMany counters)))
+ , ("counters/:name", method GET (format "text/plain"
+ (serveOne counters)))
+ , ("gauges", method GET (format "application/json"
+ (serveMany gauges)))
+ , ("gauges/:name", method GET (format "text/plain"
+ (serveOne gauges)))
+ , ("labels", method GET (format "application/json"
+ (serveMany labels)))
+ , ("labels/:name", method GET (format "text/plain"
+ (serveOne labels)))
+ ]
+ <|> serveDirectory (dataDir "assets")
+
+-- | The Accept header of the request.
+acceptHeader :: Request -> Maybe S.ByteString
+acceptHeader req = S.intercalate "," <$> getHeaders "Accept" req
+
+-- | Runs a Snap monad action only if the request's Accept header
+-- matches the given MIME type.
+format :: MonadSnap m => S.ByteString -> m a -> m a
+format fmt action = do
+ req <- getRequest
+ let acceptHdr = (List.head . parseHttpAccept) <$> acceptHeader req
+ case acceptHdr of
+ Just hdr | hdr == fmt -> action
+ _ -> pass
+
+-- | Serve a collection of counters or gauges, as a JSON object.
+serveMany :: (Ref r t, A.ToJSON t) => IORef (M.HashMap T.Text r) -> Snap ()
+serveMany mapRef = do
+ modifyResponse $ setContentType "application/json"
+ bs <- liftIO $ buildMany mapRef
+ writeLBS bs
+{-# INLINABLE serveMany #-}
+
+-- | Serve all counter, gauges and labels, built-in or not, as a
+-- nested JSON object.
+serveAll :: IORef Counters -> IORef Gauges -> IORef Labels -> Snap ()
+serveAll counters gauges labels = do
+ req <- getRequest
+ -- Workaround: Snap still matches requests to /foo to this handler
+ -- if the Accept header is "application/json", even though such
+ -- requests ought to go to the 'serveOne' handler.
+ unless (S.null $ rqPathInfo req) pass
+ modifyResponse $ setContentType "application/json"
+ bs <- liftIO $ buildAll counters gauges labels
+ writeLBS bs
+
+-- | Serve all counters and gauges, built-in or not, as a flattened
+-- JSON object.
+serveCombined :: IORef Counters -> IORef Gauges -> IORef Labels -> Snap ()
+serveCombined counters gauges labels = do
+ modifyResponse $ setContentType "application/json"
+ bs <- liftIO $ buildCombined counters gauges labels
+ writeLBS bs
+
+-- | Serve a single counter, as plain text.
+serveOne :: (Ref r t, Show t) => IORef (M.HashMap T.Text r) -> Snap ()
+serveOne refs = do
+ modifyResponse $ setContentType "text/plain"
+ req <- getRequest
+ let mname = T.decodeUtf8 <$> join
+ (listToMaybe <$> Map.lookup "name" (rqParams req))
+ case mname of
+ Nothing -> pass
+ Just name -> do
+ mbs <- liftIO $ buildOne refs name
+ case mbs of
+ Just bs -> writeBS bs
+ Nothing -> do
+ modifyResponse $ setResponseStatus 404 "Not Found"
+ r <- getResponse
+ finishWith r
+{-# INLINABLE serveOne #-}
diff --git a/assets/index.html b/assets/index.html
--- a/assets/index.html
+++ b/assets/index.html
@@ -6,13 +6,13 @@
- ekg-0.3.1.1
+ ekg