{-# language ForeignFunctionInterface #-}
{-# language NamedFieldPuns #-}
{-# language OverloadedStrings #-}
{-# language RecordWildCards #-}
{-# language ViewPatterns #-}
module Prometheus.Metric.Proc ( ProcMetrics(..), procMetrics ) where
import Data.Char ( isSpace )
import Data.Int ( Int64 )
import Data.List ( isPrefixOf )
import Data.Maybe ( catMaybes, maybeToList )
import Data.String ( fromString )
import Data.Text ( Text, unpack )
import Data.Text.IO ( readFile )
import Foreign.C
import Prelude hiding ( readFile )
import Prometheus
import System.Directory ( listDirectory )
import System.FilePath
import System.IO.Unsafe
import System.Posix.Memory ( sysconfPageSize )
import System.Posix.Process ( getProcessID )
import System.Posix.Types ( ProcessID )
import qualified Text.Regex.Applicative as RE
import qualified Text.Regex.Applicative.Common as RE
data ProcMetrics =
ProcMetrics
procMetrics :: Prometheus.Metric ProcMetrics
procMetrics =
Metric ( return ( ProcMetrics, collect ) )
foreign import ccall unsafe
clk_tck :: CLong
collect :: IO [ SampleGroup ]
collect = do
pid <-
getProcessID
mprocStat <-
RE.match parseProcStat . unpack <$> readFile ( procPidDir pid </> "stat" )
processOpenFds <-
collectProcessOpenFds pid
processMaxFds <-
collectProcessMaxFds pid
return
( [ processOpenFds ]
<> maybeToList processMaxFds
<> foldMap ( procStatToMetrics ) mprocStat
)
collectProcessOpenFds :: ProcessID -> IO SampleGroup
collectProcessOpenFds pid = do
fmap
( metric "process_open_fds" "Number of open file descriptors." GaugeType . length )
( listDirectory ( procPidDir pid </> "fd" ) )
collectProcessMaxFds :: ProcessID -> IO ( Maybe SampleGroup )
collectProcessMaxFds pid = do
limitLines <-
lines . unpack <$> readFile ( procPidDir pid </> "limits" )
case filter ( "Max open files" `isPrefixOf` ) limitLines of
( words -> _max : _open : _files : n : _ ) : _ ->
return
( Just
( metric
"process_max_fds"
"Maximum number of open file descriptors."
GaugeType
( read n :: Int )
)
)
_ ->
return Nothing
procPidDir :: ProcessID -> FilePath
procPidDir pid =
"/" </> "proc" </> show pid
procStatToMetrics :: ProcStat -> [ SampleGroup ]
procStatToMetrics ProcStat{ utime, stime, starttime, vsize, rss } =
catMaybes
[ Just process_cpu_seconds_total
, process_start_time_seconds
, Just process_virtual_memory_bytes
, Just process_resident_memory_bytes
]
where
process_cpu_seconds_total =
metric
"process_cpu_seconds_total"
"Total user and system CPU time spent in seconds."
CounterType
( fromTicks ( utime + stime ) )
process_start_time_seconds = do
btime <-
mbtime
return
( metric
"process_start_time_seconds"
"Start time of the process since unix epoch in seconds."
GaugeType
( fromIntegral btime + fromTicks starttime )
)
process_virtual_memory_bytes =
metric
"process_virtual_memory_bytes"
"Virtual memory size in bytes."
GaugeType
vsize
process_resident_memory_bytes =
metric
"process_resident_memory_bytes"
"Resident memory size in bytes."
GaugeType
( rss * fromIntegral sysconfPageSize )
metric :: Show a => Text -> Text -> SampleType -> a -> SampleGroup
metric metricName metricHelp metricType value =
SampleGroup
Info{..}
metricType
[ Sample
metricName
[]
( fromString ( show value ) )
]
fromTicks :: Int64 -> Double
fromTicks ticks =
fromIntegral ticks / fromIntegral clk_tck
{-# NOINLINE mbtime #-}
mbtime :: Maybe Int64
mbtime = unsafePerformIO $ do
fmap ( \( _, a, _ ) -> a ) . RE.findFirstInfix ( "btime " *> RE.decimal ) . unpack
<$> readFile "/proc/stat"
data ProcStat = ProcStat
{ utime :: Int64
, stime :: Int64
, starttime :: Int64
, vsize :: Int64
, rss :: Int64
}
deriving
( Show )
parseProcStat :: RE.RE Char ProcStat
parseProcStat =
ProcStat
<$ any
<* token ( RE.sym '(' *> RE.some RE.anySym <* RE.sym ')' )
<* any
<* any
<* any
<* any
<* any
<* any
<* any
<* any
<* any
<* any
<* any
<*> token RE.decimal
<*> token RE.decimal
<* any
<* any
<* any
<* any
<* any
<* any
<*> token RE.decimal
<*> token RE.decimal
<*> token RE.decimal
<* any
<* any
<* any
<* any
<* any
<* any
<* any
<* any
<* any
<* any
<* any
<* any
<* any
<* any
<* any
<* any
<* any
<* any
<* any
<* any
where
token a =
a <* RE.psym isSpace <* RE.few ( RE.psym isSpace )
any =
token ( RE.few RE.anySym )