module System.Remote.Common
(
Counters
, Gauges
, Labels
, Server(..)
, Ref(..)
, 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
type Counters = M.HashMap T.Text Counter
type Gauges = M.HashMap T.Text Gauge
type Labels = M.HashMap T.Text Label
data Server = Server {
threadId :: !ThreadId
, userCounters :: !(IORef Counters)
, userGauges :: !(IORef Gauges)
, userLabels :: !(IORef 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
getRef :: Ref r t
=> T.Text
-> IORef (M.HashMap T.Text r)
-> 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
getCounter :: T.Text
-> Server
-> IO Counter
getCounter name server = getRef name (userCounters server)
getGauge :: T.Text
-> Server
-> IO Gauge
getGauge name server = getRef name (userGauges server)
getLabel :: T.Text
-> Server
-> IO Label
getLabel name server = getRef name (userLabels server)
data Stats = Stats
!Stats.GCStats
![(T.Text, Json)]
![(T.Text, Json)]
![(T.Text, Json)]
!Double
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
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
newtype Assocs = Assocs [(T.Text, Json)]
instance A.ToJSON Assocs where
toJSON (Assocs xs) = A.object $ map (uncurry (.=)) xs
data Group = Group
![(T.Text, Json)]
!Double
instance A.ToJSON Group where
toJSON (Group xs t) =
A.object $ ("server_timestamp_millis" .= t) : map (uncurry (.=)) xs
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)
data Json = forall a. A.ToJSON a => Json a
instance A.ToJSON Json where
toJSON (Json x) = A.toJSON x
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)
]
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
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 ->
case Map.lookup name builtinCounters of
Just f -> do
gcStats <- liftIO getGcStats
return $ Just $ S8.pack $ f gcStats
Nothing -> return Nothing
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
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)
]
parseHttpAccept :: S.ByteString -> [S.ByteString]
parseHttpAccept = List.map fst
. List.sortBy (rcompare `on` snd)
. List.map grabQ
. S.split 44
where
rcompare :: Double -> Double -> Ordering
rcompare = flip compare
grabQ s =
let (s', q) = breakDiscard 59 s
(_, q') = breakDiscard 61 q
in (trimWhite s', readQ $ trimWhite q')
readQ s = case reads $ S8.unpack s of
(x, _):_ -> x
_ -> 1.0
trimWhite = S.dropWhile (== 32)
breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
breakDiscard w s =
let (x, y) = S.break (== w) s
in (x, S.drop 1 y)
getTimeMillis :: IO Double
getTimeMillis = (realToFrac . (* 1000)) `fmap` getPOSIXTime
gcParTotBytesCopied :: Stats.GCStats -> Int64
#if MIN_VERSION_base(4,6,0)
gcParTotBytesCopied = Stats.parTotBytesCopied
#else
gcParTotBytesCopied = Stats.parAvgBytesCopied
#endif