Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Split out Common and Snap modules

Move the Snap-specific code to a single module, to allow backends
using other webservers.
  • Loading branch information...
commit 1bf10844ce5800cbfaf1abe2b35f16b78d2ee4fc 1 parent d782506
@kfish kfish authored
View
448 System/Remote/Common.hs
@@ -0,0 +1,448 @@
+{-# 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
+ -- $userdefined
+ , 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 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
+
+-- $userdefined
+-- The monitoring server can store and serve user-defined,
+-- integer-valued counters and gauges, and string-value 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
+-- free-form string value (e.g. exporting the command line arguments
+-- or host name.) Each counter, gauge, and label is associated with a
+-- name, which is used when it is displayed in the UI or returned in a
+-- JSON object.
+--
+-- Even though it's technically possible to have a counter and a gauge
+-- with the same name, associated with the same server, it's not
+-- recommended as it might make it harder for clients to distinguish
+-- the two.
+--
+-- To create and use a counter, simply call 'getCounter' to create it
+-- and then call e.g. 'System.Remote.Counter.inc' or
+-- 'System.Remote.Counter.add' to modify its value. Example:
+--
+-- > main = do
+-- > handle <- forkServer "localhost" 8000
+-- > counter <- getCounter "iterations" handle
+-- > let loop n = do
+-- > inc counter
+-- > loop
+-- > loop
+--
+-- To create a gauge, use 'getGauge' instead of 'getCounter' and then
+-- 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
+
+------------------------------------------------------------------------
+
+-- | 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 (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)
+ ]
+
+------------------------------------------------------------------------
+
+-- | 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
+getGcStats = do
+#if MIN_VERSION_base(4,6,0)
+ enabled <- Stats.getGCStatsEnabled
+ if enabled
+ then Stats.getGCStats
+ else return emptyGCStats
+#else
+ 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)
+#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)
+ ]
+
+------------------------------------------------------------------------
+
+-- 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
View
523 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.)
@@ -37,44 +37,15 @@ module System.Remote.Monitoring
, 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 qualified Data.ByteString.Lazy as L
-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
--
@@ -200,24 +171,6 @@ import qualified System.Remote.Label.Internal as Label
------------------------------------------------------------------------
-- * 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
@@ -238,467 +191,5 @@ forkServer host port = do
counters <- newIORef M.empty
gauges <- newIORef M.empty
labels <- newIORef M.empty
- tid <- forkIO $ httpServe conf (monitor counters gauges labels)
+ tid <- forkIO $ startServer counters gauges labels host port
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
-
--- $userdefined
--- The monitoring server can store and serve user-defined,
--- integer-valued counters and gauges, and string-value 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
--- free-form string value (e.g. exporting the command line arguments
--- or host name.) Each counter, gauge, and label is associated with a
--- name, which is used when it is displayed in the UI or returned in a
--- JSON object.
---
--- Even though it's technically possible to have a counter and a gauge
--- with the same name, associated with the same server, it's not
--- recommended as it might make it harder for clients to distinguish
--- the two.
---
--- To create and use a counter, simply call 'getCounter' to create it
--- and then call e.g. 'System.Remote.Counter.inc' or
--- 'System.Remote.Counter.add' to modify its value. Example:
---
--- > main = do
--- > handle <- forkServer "localhost" 8000
--- > counter <- getCounter "iterations" handle
--- > let loop n = do
--- > inc counter
--- > loop
--- > loop
---
--- To create a gauge, use 'getGauge' instead of 'getCounter' and then
--- 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
- modifyResponse $ setContentType "application/json"
- bs <- liftIO $ buildMany mapRef
- writeLBS bs
-{-# 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"
- 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 #-}
-
--- | 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 #-}
-
--- | 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)
-
-------------------------------------------------------------------------
--- Utilities for working with timestamps
-
--- | Return the number of milliseconds since epoch.
-getTimeMillis :: IO Double
-getTimeMillis = (realToFrac . (* 1000)) `fmap` getPOSIXTime
View
132 System/Remote/Snap.hs
@@ -0,0 +1,132 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module System.Remote.Snap
+ ( startServer
+ ) where
+
+import Control.Applicative ((<$>), (<|>))
+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.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 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
+
+------------------------------------------------------------------------
+
+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 =
+ httpServe conf (monitor counters gauges labels)
+ where conf = Config.setVerbose False $
+ Config.setErrorLog Config.ConfigNoLog $
+ Config.setAccessLog Config.ConfigNoLog $
+ Config.setPort port $
+ Config.setHostname host $
+ Config.defaultConfig
+
+
+-- | 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 #-}
View
2  ekg.cabal
@@ -28,9 +28,11 @@ library
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,
Please sign in to comment.
Something went wrong with that request. Please try again.