content: {-# 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 ( return ( ProcMetrics, collect ) )
  
  
  -- | Returns the number of CPU clock ticks per second.
  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 ) )
      ]
  
  
  -- | Convert a number of clock ticks into the corresponding duration in seconds.
  fromTicks :: Int64 -> Double
  fromTicks ticks =
    fromIntegral ticks / fromIntegral 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 = unsafePerformIO $ do
    fmap ( \( _, a, _ ) -> a ) . RE.findFirstInfix ( "btime " *> RE.decimal ) . unpack
      <$> readFile "/proc/stat"
  
  
  -- | Specific metrics from @/proc/xyz/stat@ that we are interested in.
  data ProcStat = ProcStat
    { utime :: Int64
      -- ^ Amount of time that this process has been scheduled in user mode,
      -- measured in clock ticks (divide by sysconf(_SC_CLK_TCK)).
    , stime :: Int64
      -- ^ Amount of time that this process has been scheduled in kernel mode,
      -- measured in clock ticks (divide by sysconf(_SC_CLK_TCK)).
    , 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)).
    , vsize :: Int64
      -- ^ Virtual memory size in bytes.
    , 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
      ( 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 =
    ProcStat
      <$  any                                                     -- pid %d
      <*  token ( RE.sym '(' *> RE.some RE.anySym <* RE.sym ')' ) -- comm %s
      <*  any                                                     -- state %c
      <*  any                                                     -- ppid %d
      <*  any                                                     -- pgrp %d
      <*  any                                                     -- session %d
      <*  any                                                     -- tty_nr %d
      <*  any                                                     -- tpgid %d
      <*  any                                                     -- flags %u (%lu before Linux 2.6.22)
      <*  any                                                     -- minflt %lu
      <*  any                                                     -- cminflt %lu
      <*  any                                                     -- majflt %lu
      <*  any                                                     -- cmajflt %lu
      <*> token RE.decimal                                        -- utime %lu
      <*> token RE.decimal                                        -- stime %lu
      <*  any                                                     -- cutime %ld
      <*  any                                                     -- cstime %ld
      <*  any                                                     -- priority %ld
      <*  any                                                     -- nice %ld
      <*  any                                                     -- num_threads %ld
      <*  any                                                     -- itrealvalue %ld
      <*> token RE.decimal                                        -- starttime %llu (was %lu before Linux 2.6)
      <*> token RE.decimal                                        -- vsize %lu
      <*> token RE.decimal                                        -- rss %ld
      <*  any                                                     -- rsslim %lu
      <*  any                                                     -- startcode %lu
      <*  any                                                     -- endcode %lu
      <*  any                                                     -- startstack %lu
      <*  any                                                     -- kstkesp %lu
      <*  any                                                     -- kstkeip %lu
      <*  any                                                     -- signal %lu
      <*  any                                                     -- blocked %lu
      <*  any                                                     -- sigignore %lu
      <*  any                                                     -- sigcatch %lu
      <*  any                                                     -- wchan %lu
      <*  any                                                     -- nswap %lu
      <*  any                                                     -- cnswap %lu
      <*  any                                                     -- exit_signal %d (since Linux 2.1.22)
      <*  any                                                     -- processor %d (since Linux 2.2.8)
      <*  any                                                     -- rt_priority %u (since Linux 2.5.19; was %lu before Linux 2.6.22)
      <*  any                                                     -- policy %u (since Linux 2.5.19; was %lu before Linux 2.6.22)
      <*  any                                                     -- delayacct_blkio_ticks %llu (since Linux 2.6.18)
      <*  any                                                     -- guest_time %lu (since Linux 2.6.24)
      <*  any                                                     -- cguest_time %ld (since Linux 2.6.24)
  
    where
  
      token a =
        a <* RE.psym isSpace <* RE.few ( RE.psym isSpace )
  
      any =
        token ( RE.few RE.anySym )
  