223 lines
8 KiB
Haskell
223 lines
8 KiB
Haskell
{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
|
|
-- | Allows for remote monitoring of a running process over HTTP.
|
|
--
|
|
-- This module can be used to run an HTTP server that replies to HTTP
|
|
-- requests with either an HTML page or a JSON object. The former can
|
|
-- be used by a human to get an overview of a program's GC stats and
|
|
-- the latter can be used be automated tools.
|
|
--
|
|
-- Typical usage is to start the monitor server on program startup
|
|
--
|
|
-- > main = do
|
|
-- > forkServer "localhost" 8000
|
|
-- > ...
|
|
--
|
|
-- and then periodically check the stats using a web browser or a
|
|
-- command line tool like curl
|
|
--
|
|
-- > $ curl -H "Accept: application/json" http://localhost:8000/
|
|
module System.Remote.Monitoring
|
|
(
|
|
-- * Required configuration
|
|
-- $configuration
|
|
|
|
-- * JSON API
|
|
-- $api
|
|
Server
|
|
, serverThreadId
|
|
, forkServer
|
|
) where
|
|
|
|
import Control.Applicative ((<$>), (<|>))
|
|
import Control.Concurrent (ThreadId, forkIO)
|
|
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.List as List
|
|
import Data.Word (Word8)
|
|
import qualified GHC.Stats as Stats
|
|
import Paths_ekg (getDataDir)
|
|
import Snap.Core (Request, Snap, getHeaders, getRequest, modifyResponse, pass,
|
|
route, setContentType, writeLBS)
|
|
import Snap.Http.Server (httpServe)
|
|
import qualified Snap.Http.Server.Config as Config
|
|
import Snap.Util.FileServe (serveDirectory)
|
|
import System.FilePath ((</>))
|
|
|
|
-- $configuration
|
|
--
|
|
-- To use this module you must first enable GC stats collection for
|
|
-- your program. To enable GC stats collection, either run your
|
|
-- program with
|
|
--
|
|
-- > +RTS -T
|
|
--
|
|
-- or compile it with
|
|
--
|
|
-- > -with-rtsopts=-T
|
|
--
|
|
-- The runtime overhead of @-T@ is very small so it's safe to always
|
|
-- leave it enabled.
|
|
|
|
-- $api
|
|
--
|
|
-- The HTTP server replies to GET requests to the host and port passed
|
|
-- to 'forkServer'. To get a JSON formatted response, the client must
|
|
-- set the Accept header to \"application\/json\". The server returns
|
|
-- a JSON object with the following members:
|
|
--
|
|
-- [@bytes_allocated@] Total number of bytes allocated
|
|
--
|
|
-- [@num_gcs@] Number of garbage collections performed
|
|
--
|
|
-- [@max_bytes_used@] Maximum number of live bytes seen so far
|
|
--
|
|
-- [@num_bytes_usage_samples@] Number of byte usage samples taken
|
|
--
|
|
-- [@cumulative_bytes_used@] Sum of all byte usage samples, can be
|
|
-- used with @numByteUsageSamples@ to calculate averages with
|
|
-- arbitrary weighting (if you are sampling this record multiple
|
|
-- times).
|
|
--
|
|
-- [@bytes_copied@] Number of bytes copied during GC
|
|
--
|
|
-- [@current_bytes_used@] Current number of live bytes
|
|
--
|
|
-- [@current_bytes_slop@] Current number of bytes lost to slop
|
|
--
|
|
-- [@max_bytes_slop@] Maximum number of bytes lost to slop at any one time so far
|
|
--
|
|
-- [@peak_megabytes_allocated@] Maximum number of megabytes allocated
|
|
--
|
|
-- [@mutator_cpu_seconds@] CPU time spent running mutator threads.
|
|
-- This does not include any profiling overhead or initialization.
|
|
--
|
|
-- [@mutator_wall_seconds@] Wall clock time spent running mutator
|
|
-- threads. This does not include initialization.
|
|
--
|
|
-- [@gc_cpu_seconds@] CPU time spent running GC
|
|
--
|
|
-- [@gc_wall_seconds@] Wall clock time spent running GC
|
|
--
|
|
-- [@cpu_seconds@] Total CPU time elapsed since program start
|
|
--
|
|
-- [@wall_seconds@] Total wall clock time elapsed since start
|
|
--
|
|
-- [@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.
|
|
--
|
|
-- [@par_max_bytes_copied@] Sum of number of bytes copied each GC by
|
|
-- the most active GC thread each GC. The ratio of
|
|
-- 'parAvgBytesCopied' divided by 'parMaxBytesCopied' approaches 1 for
|
|
-- a maximally sequential run and approaches the number of threads
|
|
-- (set by the RTS flag @-N@) for a maximally parallel run.
|
|
|
|
-- | A handle that can be used to control the monitor server.
|
|
data Server = Server {
|
|
threadId :: {-# UNPACK #-} !ThreadId
|
|
}
|
|
|
|
-- | 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 set the desired response format (i.e. Content-Type)
|
|
-- by setting the Accept header. At the moment two response formats
|
|
-- are available: \"application\/json\" and \"text\/html\".
|
|
forkServer :: S.ByteString -- ^ Host to listen on (e.g. \"localhost\")
|
|
-> Int -- ^ Port to listen on (e.g. 8000)
|
|
-> IO Server
|
|
forkServer host port = do
|
|
tid <- forkIO $ httpServe conf monitor
|
|
return $! Server tid
|
|
where conf = Config.setErrorLog Config.ConfigNoLog $
|
|
Config.setAccessLog Config.ConfigNoLog $
|
|
Config.setPort port $
|
|
Config.setHostname host $
|
|
Config.defaultConfig
|
|
|
|
-- Newtype wrapper to avoid orphan instance.
|
|
newtype Stats = Stats Stats.GCStats
|
|
|
|
instance A.ToJSON Stats where
|
|
toJSON (Stats (Stats.GCStats {..})) = A.object
|
|
[ "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_avg_bytes_copied" .= parAvgBytesCopied
|
|
, "par_max_bytes_copied" .= parMaxBytesCopied
|
|
]
|
|
|
|
-- | A handler that can be installed into an existing Snap application.
|
|
monitor :: Snap ()
|
|
monitor = do
|
|
dataDir <- liftIO getDataDir
|
|
route [ ("/", index) ]
|
|
<|> serveDirectory (dataDir </> "public")
|
|
|
|
index :: Snap ()
|
|
index = do
|
|
req <- getRequest
|
|
let acceptHdr = maybe "application/json" (List.head . parseHttpAccept) $
|
|
getAcceptHeader req
|
|
if acceptHdr == "application/json"
|
|
then serveJson
|
|
else pass
|
|
where
|
|
serveJson = do
|
|
modifyResponse $ setContentType "application/json"
|
|
stats <- liftIO Stats.getGCStats
|
|
writeLBS $ A.encode $ A.toJSON $ Stats $ stats
|
|
|
|
getAcceptHeader :: Request -> Maybe S.ByteString
|
|
getAcceptHeader req = S.intercalate "," <$> getHeaders "Accept" req
|
|
|
|
------------------------------------------------------------------------
|
|
-- 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)
|