{-# language ForeignFunctionInterface #-}
{-# language NamedFieldPuns #-}
{-# language OverloadedStrings #-}
{-# language RecordWildCards #-}
{-# language ViewPatterns #-}

{-|

This module exposes a @prometheus-client@ "Metric" for exporting information
about the currently running process.

-}
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


-- | The tag for 'procMetrics'.
data ProcMetrics =
  ProcMetrics


{-|

Unregistered metrics for the current process. This is to be used with
'Prometheus.register' to register the metrics.

This exports the following:


* @process_cpu_seconds_total@
* @process_start_time_seconds@
* @process_virtual_memory_bytes@
* @process_resident_memory_bytes@

See the official Prometheus documentation for more information on these standard
metrics: https://prometheus.io/docs/instrumenting/writing_clientlibs/#standard-and-runtime-collectors

-}
procMetrics :: Prometheus.Metric ProcMetrics
procMetrics :: Metric ProcMetrics
procMetrics =
  forall s. IO (s, IO [SampleGroup]) -> Metric s
Metric ( forall (m :: * -> *) a. Monad m => a -> m a
return ( ProcMetrics
ProcMetrics, IO [SampleGroup]
collect ) )


-- | Returns the number of CPU clock ticks per second.
foreign import ccall unsafe
  clk_tck :: CLong


collect :: IO [ SampleGroup ]
collect :: IO [SampleGroup]
collect = do
  ProcessID
pid <-
    IO ProcessID
getProcessID

  Maybe ProcStat
mprocStat <-
      forall s a. RE s a -> [s] -> Maybe a
RE.match RE Char ProcStat
parseProcStat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
readFile ( ProcessID -> String
procPidDir ProcessID
pid String -> String -> String
</> String
"stat" )

  SampleGroup
processOpenFds <-
    ProcessID -> IO SampleGroup
collectProcessOpenFds ProcessID
pid

  Maybe SampleGroup
processMaxFds <-
    ProcessID -> IO (Maybe SampleGroup)
collectProcessMaxFds ProcessID
pid

  forall (m :: * -> *) a. Monad m => a -> m a
return
    ( [ SampleGroup
processOpenFds ]
        forall a. Semigroup a => a -> a -> a
<> forall a. Maybe a -> [a]
maybeToList Maybe SampleGroup
processMaxFds
        forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ( ProcStat -> [SampleGroup]
procStatToMetrics ) Maybe ProcStat
mprocStat
    )


collectProcessOpenFds :: ProcessID -> IO SampleGroup
collectProcessOpenFds :: ProcessID -> IO SampleGroup
collectProcessOpenFds ProcessID
pid = do
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    ( forall a. Show a => Text -> Text -> SampleType -> a -> SampleGroup
metric Text
"process_open_fds" Text
"Number of open file descriptors." SampleType
GaugeType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length )
    ( String -> IO [String]
listDirectory ( ProcessID -> String
procPidDir ProcessID
pid String -> String -> String
</> String
"fd" ) )


collectProcessMaxFds :: ProcessID -> IO ( Maybe SampleGroup )
collectProcessMaxFds :: ProcessID -> IO (Maybe SampleGroup)
collectProcessMaxFds ProcessID
pid = do
  [String]
limitLines <-
    String -> [String]
lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
readFile ( ProcessID -> String
procPidDir ProcessID
pid String -> String -> String
</> String
"limits" )

  case forall a. (a -> Bool) -> [a] -> [a]
filter ( String
"Max open files" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` ) [String]
limitLines of
    ( String -> [String]
words -> String
_max : String
_open : String
_files : String
n : [String]
_ ) : [String]
_ ->
      forall (m :: * -> *) a. Monad m => a -> m a
return
        ( forall a. a -> Maybe a
Just
            ( forall a. Show a => Text -> Text -> SampleType -> a -> SampleGroup
metric
                Text
"process_max_fds"
                Text
"Maximum number of open file descriptors."
                SampleType
GaugeType
                ( forall a. Read a => String -> a
read String
n :: Int )
            )
        )

    [String]
_ ->
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing


procPidDir :: ProcessID -> FilePath
procPidDir :: ProcessID -> String
procPidDir ProcessID
pid =
  String
"/" String -> String -> String
</> String
"proc" String -> String -> String
</> forall a. Show a => a -> String
show ProcessID
pid


procStatToMetrics :: ProcStat -> [ SampleGroup ]
procStatToMetrics :: ProcStat -> [SampleGroup]
procStatToMetrics ProcStat{ Int64
utime :: ProcStat -> Int64
utime :: Int64
utime, Int64
stime :: ProcStat -> Int64
stime :: Int64
stime, Int64
starttime :: ProcStat -> Int64
starttime :: Int64
starttime, Int64
vsize :: ProcStat -> Int64
vsize :: Int64
vsize, Int64
rss :: ProcStat -> Int64
rss :: Int64
rss } =
  forall a. [Maybe a] -> [a]
catMaybes
    [ forall a. a -> Maybe a
Just SampleGroup
process_cpu_seconds_total
    , Maybe SampleGroup
process_start_time_seconds
    , forall a. a -> Maybe a
Just SampleGroup
process_virtual_memory_bytes
    , forall a. a -> Maybe a
Just SampleGroup
process_resident_memory_bytes
    ]

  where

    process_cpu_seconds_total :: SampleGroup
process_cpu_seconds_total =
      forall a. Show a => Text -> Text -> SampleType -> a -> SampleGroup
metric
        Text
"process_cpu_seconds_total"
        Text
"Total user and system CPU time spent in seconds."
        SampleType
CounterType
        ( Int64 -> Double
fromTicks ( Int64
utime forall a. Num a => a -> a -> a
+ Int64
stime ) )

    process_start_time_seconds :: Maybe SampleGroup
process_start_time_seconds = do
      Int64
btime <-
        Maybe Int64
mbtime

      forall (m :: * -> *) a. Monad m => a -> m a
return
        ( forall a. Show a => Text -> Text -> SampleType -> a -> SampleGroup
metric
            Text
"process_start_time_seconds"
            Text
"Start time of the process since unix epoch in seconds."
            SampleType
GaugeType
            ( forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
btime forall a. Num a => a -> a -> a
+ Int64 -> Double
fromTicks Int64
starttime )
        )

    process_virtual_memory_bytes :: SampleGroup
process_virtual_memory_bytes =
      forall a. Show a => Text -> Text -> SampleType -> a -> SampleGroup
metric
        Text
"process_virtual_memory_bytes"
        Text
"Virtual memory size in bytes."
        SampleType
GaugeType
        Int64
vsize

    process_resident_memory_bytes :: SampleGroup
process_resident_memory_bytes =
      forall a. Show a => Text -> Text -> SampleType -> a -> SampleGroup
metric
        Text
"process_resident_memory_bytes"
        Text
"Resident memory size in bytes."
        SampleType
GaugeType
        ( Int64
rss forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sysconfPageSize )


metric :: Show a => Text -> Text -> SampleType -> a -> SampleGroup
metric :: forall a. Show a => Text -> Text -> SampleType -> a -> SampleGroup
metric Text
metricName Text
metricHelp SampleType
metricType a
value =
  Info -> SampleType -> [Sample] -> SampleGroup
SampleGroup
    Info{Text
metricName :: Text
metricHelp :: Text
metricHelp :: Text
metricName :: Text
..}
    SampleType
metricType
    [ Text -> LabelPairs -> ByteString -> Sample
Sample
        Text
metricName
        []
        ( forall a. IsString a => String -> a
fromString ( forall a. Show a => a -> String
show a
value ) )
    ]


-- | Convert a number of clock ticks into the corresponding duration in seconds.
fromTicks :: Int64 -> Double
fromTicks :: Int64 -> Double
fromTicks Int64
ticks =
  forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
ticks forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral CLong
clk_tck


{-|

Returns the current boot time in seconds since Unix epoch. This is a Maybe
as we might not to be able to successfully parse this information out of
@/proc/stat@.

'unsafePerformIO' is used as this value does not change during the
execution of the program, so this gives us a lightweight cache for this
value.

-}
{-# NOINLINE mbtime #-}
mbtime :: Maybe Int64
mbtime :: Maybe Int64
mbtime = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ( \( String
_, Int64
a, String
_ ) -> Int64
a ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. RE s a -> [s] -> Maybe ([s], a, [s])
RE.findFirstInfix ( RE Char String
"btime " forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Num a => RE Char a
RE.decimal ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
readFile String
"/proc/stat"


-- | Specific metrics from @/proc/xyz/stat@ that we are interested in.
data ProcStat = ProcStat
  { ProcStat -> Int64
utime :: Int64
    -- ^ Amount of time that this process has been scheduled in user mode,
    -- measured in clock ticks (divide by sysconf(_SC_CLK_TCK)).
  , ProcStat -> Int64
stime :: Int64
    -- ^ Amount of time that this process has been scheduled in kernel mode,
    -- measured in clock ticks (divide by sysconf(_SC_CLK_TCK)).
  , ProcStat -> Int64
starttime :: Int64
    -- ^ The time the process started after system boot. In kernels before Linux
    -- 2.6, this value was expressed in jiffies. Since Linux 2.6, the value is
    -- expressed in clock ticks (divide by sysconf(_SC_CLK_TCK)).
  , ProcStat -> Int64
vsize :: Int64
    -- ^ Virtual memory size in bytes.
  , ProcStat -> Int64
rss :: Int64
    -- ^ Resident Set Size: number of pages the process has in real memory. This
    -- is just the pages which count toward text, data, or stack space. This
    -- does not include pages which have not been demand-loaded in, or which are
    -- swapped out.
  }
  deriving
    ( Int -> ProcStat -> String -> String
[ProcStat] -> String -> String
ProcStat -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ProcStat] -> String -> String
$cshowList :: [ProcStat] -> String -> String
show :: ProcStat -> String
$cshow :: ProcStat -> String
showsPrec :: Int -> ProcStat -> String -> String
$cshowsPrec :: Int -> ProcStat -> String -> String
Show )


{-|

A regular expression for parsing @/proc/xyz/stat@. See
@man 5 proc@ for more information on the format of this file:
https://linux.die.net/man/5/proc.

-}
parseProcStat :: RE.RE Char ProcStat
parseProcStat :: RE Char ProcStat
parseProcStat =
  Int64 -> Int64 -> Int64 -> Int64 -> Int64 -> ProcStat
ProcStat
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  RE Char String
any                                                     -- pid %d
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  forall {a}. RE Char a -> RE Char a
token ( forall s. Eq s => s -> RE s s
RE.sym Char
'(' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
RE.some forall s. RE s s
RE.anySym forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s. Eq s => s -> RE s s
RE.sym Char
')' ) -- comm %s
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- state %c
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- ppid %d
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- pgrp %d
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- session %d
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- tty_nr %d
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- tpgid %d
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- flags %u (%lu before Linux 2.6.22)
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- minflt %lu
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- cminflt %lu
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- majflt %lu
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- cmajflt %lu
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {a}. RE Char a -> RE Char a
token forall a. Num a => RE Char a
RE.decimal                                        -- utime %lu
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {a}. RE Char a -> RE Char a
token forall a. Num a => RE Char a
RE.decimal                                        -- stime %lu
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- cutime %ld
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- cstime %ld
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- priority %ld
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- nice %ld
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- num_threads %ld
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- itrealvalue %ld
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {a}. RE Char a -> RE Char a
token forall a. Num a => RE Char a
RE.decimal                                        -- starttime %llu (was %lu before Linux 2.6)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {a}. RE Char a -> RE Char a
token forall a. Num a => RE Char a
RE.decimal                                        -- vsize %lu
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {a}. RE Char a -> RE Char a
token forall a. Num a => RE Char a
RE.decimal                                        -- rss %ld
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- rsslim %lu
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- startcode %lu
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- endcode %lu
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- startstack %lu
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- kstkesp %lu
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- kstkeip %lu
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- signal %lu
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- blocked %lu
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- sigignore %lu
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- sigcatch %lu
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- wchan %lu
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- nswap %lu
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- cnswap %lu
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- exit_signal %d (since Linux 2.1.22)
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- processor %d (since Linux 2.2.8)
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- rt_priority %u (since Linux 2.5.19; was %lu before Linux 2.6.22)
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- policy %u (since Linux 2.5.19; was %lu before Linux 2.6.22)
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- delayacct_blkio_ticks %llu (since Linux 2.6.18)
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- guest_time %lu (since Linux 2.6.24)
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  RE Char String
any                                                     -- cguest_time %ld (since Linux 2.6.24)

  where

    token :: RE Char a -> RE Char a
token RE Char a
a =
      RE Char a
a forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s. (s -> Bool) -> RE s s
RE.psym Char -> Bool
isSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s a. RE s a -> RE s [a]
RE.few ( forall s. (s -> Bool) -> RE s s
RE.psym Char -> Bool
isSpace )

    any :: RE Char String
any =
      forall {a}. RE Char a -> RE Char a
token ( forall s a. RE s a -> RE s [a]
RE.few forall s. RE s s
RE.anySym )