{-# 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 )