ekg 0.3.1.2 → 0.3.1.3
raw patch · 6 files changed
+622/−496 lines, 6 filesdep +networkPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: network
API changes (from Hackage documentation)
- System.Remote.Monitoring: instance Ref Counter Int
- System.Remote.Monitoring: instance Ref Gauge Int
- System.Remote.Monitoring: instance Ref Label Text
- System.Remote.Monitoring: instance ToJSON Assocs
- System.Remote.Monitoring: instance ToJSON Combined
- System.Remote.Monitoring: instance ToJSON Group
- System.Remote.Monitoring: instance ToJSON Json
- System.Remote.Monitoring: instance ToJSON Stats
Files
- System/Remote/Common.hs +408/−0
- System/Remote/Monitoring.hs +46/−492
- System/Remote/Snap.hs +156/−0
- assets/index.html +2/−2
- ekg.cabal +4/−1
- examples/Basic.hs +6/−1
+ System/Remote/Common.hs view
@@ -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
System/Remote/Monitoring.hs view
@@ -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
+ System/Remote/Snap.hs view
@@ -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 #-}
assets/index.html view
@@ -6,13 +6,13 @@ <link rel="stylesheet" href="monitor.css" type="text/css"> <script type="text/javascript" src="jquery-1.6.4.min.js"></script> <script type="text/javascript" src="jquery.flot.min.js"></script>- <title>ekg-0.3.1.1</title>+ <title>ekg</title> </head> <body> <div class="topbar"> <div class="topbar-inner"> <div class="container-fluid">- <span class="brand">ekg-0.3.1.1</span>+ <span class="brand">ekg</span> <p class="pull-right">Polling interval: <select id="updateInterval" class="small"> <option value="100">100 ms</option>
ekg.cabal view
@@ -1,5 +1,5 @@ name: ekg-version: 0.3.1.2+version: 0.3.1.3 synopsis: Remote monitoring of processes description: This library lets you remotely monitor a running process over HTTP.@@ -28,15 +28,18 @@ System.Remote.Monitoring other-modules: Paths_ekg+ System.Remote.Common System.Remote.Counter.Internal System.Remote.Gauge.Internal System.Remote.Label.Internal+ System.Remote.Snap build-depends: aeson < 0.7, base >= 4.5 && < 5, bytestring < 1.0, containers < 0.6, filepath < 1.4,+ network < 2.5, snap-core < 0.10, snap-server < 0.10, text < 0.12,
examples/Basic.hs view
@@ -6,12 +6,17 @@ import Control.Concurrent import Control.Exception+import Data.List import qualified System.Remote.Counter as Counter import qualified System.Remote.Label as Label import System.Remote.Monitoring +-- 'sum' is using a non-strict lazy fold and will blow the stack.+sum' :: Num a => [a] -> a+sum' = foldl' (+) 0+ mean :: Fractional a => [a] -> a-mean xs = sum xs / fromIntegral (length xs)+mean xs = sum' xs / fromIntegral (length xs) main :: IO () main = do