{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

{- |
Module      : System.MemInfo
Copyright   : (c) 2023 Tim Emiola
Maintainer  : Tim Emiola <adetokunbo@emio.la>
SPDX-License-Identifier: BSD3

Implements __printmem__, a command that computes the memory usage of some
processes
-}
module System.MemInfo (
  -- * Implement __printmem__
  getChoices,
  printProcs,

  -- * Read /MemUsage/
  readForOnePid,
  readForOnePid',
  readMemUsage',
  readMemUsage,
  NotRun (..),
  LostPid (..),

  -- * Stream /MemUsage/ periodically
  unfoldMemUsage,
  unfoldMemUsageAfter',
  unfoldMemUsageAfter,

  -- * Obtain the process/program name
  ProcNamer,
  nameFromExeOnly,
  nameFor,
  nameAsFullCmd,

  -- * Index by pid or name
  ProcName,
  Indexer,
  dropId,
  withPid,

  -- * Print /MemUsage/
  printUsage',
  printUsage,

  -- * Convenient re-exports
  mkReportBud,
  ProcessID,
  AsCmdName (..),
) where

import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (MonadReader (ask), runReaderT)
import Data.Bifunctor (Bifunctor (..))
import Data.Functor ((<&>))
import Data.List (sortBy)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Ord (Down (..), comparing)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Fmt (
  listF,
  (+|),
  (|+),
 )
import System.Exit (exitFailure)
import System.MemInfo.Choices (
  Choices (..),
  Mem (..),
  PrintOrder (..),
  Style (..),
  asFloat,
  defaultRoot,
  getChoices,
 )
import System.MemInfo.Prelude
import System.MemInfo.Print (
  AsCmdName (..),
  fmtMemUsage,
  styleOutput,
 )
import System.MemInfo.Proc (
  BadStatus (..),
  ExeInfo (..),
  MemUsage (..),
  ProcUsage (..),
  StatusInfo (..),
  amass,
  parseExeInfo,
  parseFromSmap,
  parseFromStatm,
  parseStatusInfo,
 )
import System.MemInfo.SysInfo (
  ReportBud (..),
  fmtRamFlaws,
  fmtSwapFlaws,
  mkReportBud,
 )


{- | Print a report to @stdout@ displaying the memory usage of the programs
specified by @Choices@
-}
printProcs :: Choices -> IO ()
printProcs :: Choices -> IO ()
printProcs cs :: Choices
cs@Choices {choiceByPid :: Choices -> Bool
choiceByPid = Bool
byPid} = do
  ReportBud
bud <- Choices -> IO ReportBud
verify Choices
cs
  if Bool
byPid
    then Indexer (ProcessID, Text) -> ReportBud -> Choices -> IO ()
forall a.
(Ord a, AsCmdName a) =>
Indexer a -> ReportBud -> Choices -> IO ()
printProcs' Indexer (ProcessID, Text)
withPid ReportBud
bud Choices
cs
    else Indexer Text -> ReportBud -> Choices -> IO ()
forall a.
(Ord a, AsCmdName a) =>
Indexer a -> ReportBud -> Choices -> IO ()
printProcs' Indexer Text
dropId ReportBud
bud Choices
cs


printProcs' :: (Ord a, AsCmdName a) => Indexer a -> ReportBud -> Choices -> IO ()
printProcs' :: forall a.
(Ord a, AsCmdName a) =>
Indexer a -> ReportBud -> Choices -> IO ()
printProcs' Indexer a
indexer ReportBud
bud Choices
cs = do
  let Choices
        { choiceShowSwap :: Choices -> Bool
choiceShowSwap = Bool
showSwap
        , choiceOnlyTotal :: Choices -> Bool
choiceOnlyTotal = Bool
onlyTotal
        , choiceWatchSecs :: Choices -> Maybe Natural
choiceWatchSecs = Maybe Natural
watchSecsMb
        , choicePrintOrder :: Choices -> Maybe PrintOrder
choicePrintOrder = Maybe PrintOrder
printOrder
        , choiceReversed :: Choices -> Bool
choiceReversed = Bool
reversed
        , choiceStyle :: Choices -> Maybe Style
choiceStyle = Maybe Style
style
        , choiceMinMemory :: Choices -> Maybe Mem
choiceMinMemory = Maybe Mem
mem
        } = Choices
cs
      style' :: Style
style' = Style -> Maybe Style -> Style
forall a. a -> Maybe a -> a
fromMaybe Style
Normal Maybe Style
style
      toList :: Map a MemUsage -> [(a, MemUsage)]
toList = Maybe Mem -> [(a, MemUsage)] -> [(a, MemUsage)]
forall a. Maybe Mem -> [(a, MemUsage)] -> [(a, MemUsage)]
filterLT Maybe Mem
mem ([(a, MemUsage)] -> [(a, MemUsage)])
-> (Map a MemUsage -> [(a, MemUsage)])
-> Map a MemUsage
-> [(a, MemUsage)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, MemUsage) -> (a, MemUsage) -> Ordering)
-> [(a, MemUsage)] -> [(a, MemUsage)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Bool
-> Maybe PrintOrder -> (a, MemUsage) -> (a, MemUsage) -> Ordering
forall a.
Ord a =>
Bool
-> Maybe PrintOrder -> (a, MemUsage) -> (a, MemUsage) -> Ordering
byPrintOrder' Bool
reversed Maybe PrintOrder
printOrder) ([(a, MemUsage)] -> [(a, MemUsage)])
-> (Map a MemUsage -> [(a, MemUsage)])
-> Map a MemUsage
-> [(a, MemUsage)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a MemUsage -> [(a, MemUsage)]
forall k a. Map k a -> [(k, a)]
Map.toList
      printEachCmd :: Map a MemUsage -> IO ()
printEachCmd = ReportBud -> Style -> Bool -> Bool -> [(a, MemUsage)] -> IO ()
forall a.
AsCmdName a =>
ReportBud -> Style -> Bool -> Bool -> [(a, MemUsage)] -> IO ()
printMemUsages ReportBud
bud Style
style' Bool
showSwap Bool
onlyTotal ([(a, MemUsage)] -> IO ())
-> (Map a MemUsage -> [(a, MemUsage)]) -> Map a MemUsage -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a MemUsage -> [(a, MemUsage)]
toList
      printTheTotal :: Map a MemUsage -> IO ()
printTheTotal = ReportBud -> Bool -> Bool -> [(a, MemUsage)] -> IO ()
forall k.
AsCmdName k =>
ReportBud -> Bool -> Bool -> [(k, MemUsage)] -> IO ()
onlyPrintTotal ReportBud
bud Bool
showSwap Bool
onlyTotal ([(a, MemUsage)] -> IO ())
-> (Map a MemUsage -> [(a, MemUsage)]) -> Map a MemUsage -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a MemUsage -> [(a, MemUsage)]
forall k a. Map k a -> [(k, a)]
Map.toList
      showTotal :: Map a MemUsage -> IO ()
showTotal = if Bool
onlyTotal then Map a MemUsage -> IO ()
printTheTotal else Map a MemUsage -> IO ()
printEachCmd
      namer :: ProcNamer
namer = if Choices -> Bool
choiceSplitArgs Choices
cs then ProcNamer
nameAsFullCmd else ProcNamer
nameFor
  case Maybe Natural
watchSecsMb of
    Maybe Natural
Nothing -> ProcNamer
-> Indexer a -> ReportBud -> IO (Either LostPid (Map a MemUsage))
forall a.
Ord a =>
ProcNamer
-> Indexer a -> ReportBud -> IO (Either LostPid (Map a MemUsage))
readMemUsage' ProcNamer
namer Indexer a
indexer ReportBud
bud IO (Either LostPid (Map a MemUsage))
-> (Either LostPid (Map a MemUsage) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (LostPid -> IO ())
-> (Map a MemUsage -> IO ())
-> Either LostPid (Map a MemUsage)
-> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either LostPid -> IO ()
forall a. LostPid -> IO a
haltLostPid Map a MemUsage -> IO ()
showTotal
    (Just Natural
spanSecs) -> do
      let unfold :: ReportBud
-> IO
     (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfold = ProcNamer
-> Indexer a
-> Natural
-> ReportBud
-> IO
     (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
forall a seconds.
(Ord a, AsCmdName a, Integral seconds) =>
ProcNamer
-> Indexer a
-> seconds
-> ReportBud
-> IO
     (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfoldMemUsageAfter' ProcNamer
namer Indexer a
indexer Natural
spanSecs
      (ReportBud
 -> IO
      (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud)))
-> ReportBud -> (Map a MemUsage -> IO ()) -> IO ()
forall c.
(Ord c, AsCmdName c) =>
(ReportBud
 -> IO
      (Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud)))
-> ReportBud -> (Map c MemUsage -> IO ()) -> IO ()
loopPrintMemUsages ReportBud
-> IO
     (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfold ReportBud
bud Map a MemUsage -> IO ()
showTotal


printMemUsages ::
  (AsCmdName a) =>
  ReportBud ->
  Style ->
  Bool ->
  Bool ->
  [(a, MemUsage)] ->
  IO ()
printMemUsages :: forall a.
AsCmdName a =>
ReportBud -> Style -> Bool -> Bool -> [(a, MemUsage)] -> IO ()
printMemUsages ReportBud
bud Style
style Bool
showSwap Bool
onlyTotal [(a, MemUsage)]
totals = do
  let overallIsAccurate :: Bool
overallIsAccurate = (Bool
showSwap Bool -> Bool -> Bool
&& ReportBud -> Bool
rbHasSwapPss ReportBud
bud) Bool -> Bool -> Bool
|| ReportBud -> Bool
rbHasPss ReportBud
bud
      output :: [Text]
output = Bool -> Style -> Bool -> [(a, MemUsage)] -> [Text]
forall a.
AsCmdName a =>
Bool -> Style -> Bool -> [(a, MemUsage)] -> [Text]
styleOutput Bool
showSwap Style
style Bool
overallIsAccurate [(a, MemUsage)]
totals
  (Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> IO ()
Text.putStrLn [Text]
output
  ReportBud -> Bool -> Bool -> IO ()
reportFlaws ReportBud
bud Bool
showSwap Bool
onlyTotal


-- | Print the program name and memory usage, optionally hiding the swap size
printUsage' :: (AsCmdName a) => (a, MemUsage) -> Bool -> IO ()
printUsage' :: forall a. AsCmdName a => (a, MemUsage) -> Bool -> IO ()
printUsage' (a
name, MemUsage
mu) Bool
showSwap = Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> a -> MemUsage -> Text
forall a. AsCmdName a => Bool -> a -> MemUsage -> Text
fmtMemUsage Bool
showSwap a
name MemUsage
mu


-- | Like @'printUsage''@, but alway shows the swap size
printUsage :: (AsCmdName a) => (a, MemUsage) -> IO ()
printUsage :: forall a. AsCmdName a => (a, MemUsage) -> IO ()
printUsage = ((a, MemUsage) -> Bool -> IO ()) -> Bool -> (a, MemUsage) -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a, MemUsage) -> Bool -> IO ()
forall a. AsCmdName a => (a, MemUsage) -> Bool -> IO ()
printUsage' Bool
True


onlyPrintTotal :: (AsCmdName k) => ReportBud -> Bool -> Bool -> [(k, MemUsage)] -> IO ()
onlyPrintTotal :: forall k.
AsCmdName k =>
ReportBud -> Bool -> Bool -> [(k, MemUsage)] -> IO ()
onlyPrintTotal ReportBud
bud Bool
showSwap Bool
onlyTotal [(k, MemUsage)]
totals = do
  let (Int
private, Int
swap) = [MemUsage] -> (Int, Int)
overallTotals ([MemUsage] -> (Int, Int)) -> [MemUsage] -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ ((k, MemUsage) -> MemUsage) -> [(k, MemUsage)] -> [MemUsage]
forall a b. (a -> b) -> [a] -> [b]
map (k, MemUsage) -> MemUsage
forall a b. (a, b) -> b
snd [(k, MemUsage)]
totals
      printRawTotal :: Int -> IO ()
printRawTotal = Text -> IO ()
Text.putStrLn (Text -> IO ()) -> (Int -> Text) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text
fmtMemBytes
  if Bool
showSwap
    then do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ReportBud -> Bool
rbHasSwapPss ReportBud
bud) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
printRawTotal Int
swap
      ReportBud -> Bool -> Bool -> IO ()
reportFlaws ReportBud
bud Bool
showSwap Bool
onlyTotal
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe SwapFlaw -> Bool
forall a. Maybe a -> Bool
isJust (Maybe SwapFlaw -> Bool) -> Maybe SwapFlaw -> Bool
forall a b. (a -> b) -> a -> b
$ ReportBud -> Maybe SwapFlaw
rbSwapFlaws ReportBud
bud) IO ()
forall a. IO a
exitFailure
    else do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ReportBud -> Bool
rbHasPss ReportBud
bud) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
printRawTotal Int
private
      ReportBud -> Bool -> Bool -> IO ()
reportFlaws ReportBud
bud Bool
showSwap Bool
onlyTotal
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe RamFlaw -> Bool
forall a. Maybe a -> Bool
isJust (Maybe RamFlaw -> Bool) -> Maybe RamFlaw -> Bool
forall a b. (a -> b) -> a -> b
$ ReportBud -> Maybe RamFlaw
rbRamFlaws ReportBud
bud) IO ()
forall a. IO a
exitFailure


loopPrintMemUsages ::
  (Ord c, AsCmdName c) =>
  (ReportBud -> IO (Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud))) ->
  ReportBud ->
  (Map c MemUsage -> IO ()) ->
  IO ()
loopPrintMemUsages :: forall c.
(Ord c, AsCmdName c) =>
(ReportBud
 -> IO
      (Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud)))
-> ReportBud -> (Map c MemUsage -> IO ()) -> IO ()
loopPrintMemUsages ReportBud
-> IO
     (Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud))
unfold ReportBud
bud Map c MemUsage -> IO ()
showTotal = do
  let clearScreen :: IO ()
clearScreen = ProcRoot -> IO ()
putStrLn ProcRoot
"\o033c"
      warnHalting :: IO ()
warnHalting = Bool -> Text -> IO ()
errStrLn Bool
False Text
"halting: all monitored processes have stopped"
      handleNext :: Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud)
-> IO ()
handleNext (Left [ProcessID]
stopped) = do
        [ProcessID] -> IO ()
warnStopped [ProcessID]
stopped
        IO ()
warnHalting
      handleNext (Right ((Map c MemUsage
total, [ProcessID]
stopped), ReportBud
updated)) = do
        IO ()
clearScreen
        [ProcessID] -> IO ()
warnStopped [ProcessID]
stopped
        Map c MemUsage -> IO ()
showTotal Map c MemUsage
total
        ReportBud -> IO ()
go ReportBud
updated
      go :: ReportBud -> IO ()
go ReportBud
initial = ReportBud
-> IO
     (Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud))
unfold ReportBud
initial IO (Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud))
-> (Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud)
    -> IO ())
-> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud)
-> IO ()
handleNext
  ReportBud -> IO ()
go ReportBud
bud


warnStopped :: [ProcessID] -> IO ()
warnStopped :: [ProcessID] -> IO ()
warnStopped [ProcessID]
pids = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ProcessID] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ProcessID]
pids) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  let errMsg :: Text
errMsg = Builder
"some processes stopped:pids:" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger (ProcessID -> Integer) -> [ProcessID] -> [Integer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ProcessID]
pids [Integer] -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
  Bool -> Text -> IO ()
errStrLn Bool
False Text
errMsg


-- | The name of a process or program in the memory report.
type ProcName = Text


-- | Like @'unfoldMemUsageAfter''@, but uses the default 'ProcNamer' and 'Indexer'
unfoldMemUsageAfter ::
  (Integral seconds) =>
  seconds ->
  ReportBud ->
  IO (Either [ProcessID] ((Map ProcName MemUsage, [ProcessID]), ReportBud))
unfoldMemUsageAfter :: forall seconds.
Integral seconds =>
seconds
-> ReportBud
-> IO
     (Either [ProcessID] ((Map Text MemUsage, [ProcessID]), ReportBud))
unfoldMemUsageAfter = ProcNamer
-> Indexer Text
-> seconds
-> ReportBud
-> IO
     (Either [ProcessID] ((Map Text MemUsage, [ProcessID]), ReportBud))
forall a seconds.
(Ord a, AsCmdName a, Integral seconds) =>
ProcNamer
-> Indexer a
-> seconds
-> ReportBud
-> IO
     (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfoldMemUsageAfter' ProcNamer
nameFor Indexer Text
dropId


-- | Like @'unfoldMemUsage'@ but computes the @'MemUsage's@ after a delay
unfoldMemUsageAfter' ::
  (Ord a, AsCmdName a, Integral seconds) =>
  ProcNamer ->
  Indexer a ->
  seconds ->
  ReportBud ->
  IO (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfoldMemUsageAfter' :: forall a seconds.
(Ord a, AsCmdName a, Integral seconds) =>
ProcNamer
-> Indexer a
-> seconds
-> ReportBud
-> IO
     (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfoldMemUsageAfter' ProcNamer
namer Indexer a
mkCmd seconds
spanSecs ReportBud
bud = do
  let spanMicros :: Int
spanMicros = Int
1000000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Integer -> Int
forall a. Num a => Integer -> a
fromInteger (seconds -> Integer
forall a. Integral a => a -> Integer
toInteger seconds
spanSecs)
  Int -> IO ()
threadDelay Int
spanMicros
  ProcNamer
-> Indexer a
-> ReportBud
-> IO
     (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
forall a.
Ord a =>
ProcNamer
-> Indexer a
-> ReportBud
-> IO
     (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfoldMemUsage ProcNamer
namer Indexer a
mkCmd ReportBud
bud


{- | Unfold @'MemUsage's@ specified by a @'ReportBud'@

The @ProcessID@ of stopped processes are reported, both as part of intermediate
invocations (via the @[ProcessID]@ in the @Right@), and in the final one (as the
value of the @Left@).
-}
unfoldMemUsage ::
  (Ord a) =>
  ProcNamer ->
  Indexer a ->
  ReportBud ->
  IO (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfoldMemUsage :: forall a.
Ord a =>
ProcNamer
-> Indexer a
-> ReportBud
-> IO
     (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfoldMemUsage ProcNamer
namer Indexer a
mkCmd ReportBud
bud = do
  let changePids :: NonEmpty ProcessID -> ReportBud
changePids NonEmpty ProcessID
rbPids = ReportBud
bud {rbPids}
      dropStopped :: ReportBud -> [ProcessID] -> Maybe ReportBud
dropStopped ReportBud
t [] = ReportBud -> Maybe ReportBud
forall a. a -> Maybe a
Just ReportBud
t
      dropStopped ReportBud {rbPids :: ReportBud -> NonEmpty ProcessID
rbPids = NonEmpty ProcessID
ps} [ProcessID]
stopped =
        NonEmpty ProcessID -> ReportBud
changePids (NonEmpty ProcessID -> ReportBud)
-> Maybe (NonEmpty ProcessID) -> Maybe ReportBud
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ProcessID] -> Maybe (NonEmpty ProcessID)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ((ProcessID -> Bool) -> NonEmpty ProcessID -> [ProcessID]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.filter (ProcessID -> [ProcessID] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ProcessID]
stopped) NonEmpty ProcessID
ps)
      ReportBud {rbPids :: ReportBud -> NonEmpty ProcessID
rbPids = NonEmpty ProcessID
pids, rbHasPss :: ReportBud -> Bool
rbHasPss = Bool
hasPss} = ReportBud
bud
      nextState :: ([ProcessID], [(ProcessID, Text, ProcUsage)])
-> Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud)
nextState ([ProcessID]
stopped, []) = [ProcessID]
-> Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud)
forall a b. a -> Either a b
Left [ProcessID]
stopped
      nextState ([ProcessID]
stopped, [(ProcessID, Text, ProcUsage)]
xs) = case ReportBud -> [ProcessID] -> Maybe ReportBud
dropStopped ReportBud
bud [ProcessID]
stopped of
        Just ReportBud
updated -> ((Map a MemUsage, [ProcessID]), ReportBud)
-> Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud)
forall a b. b -> Either a b
Right ((Bool -> [(a, ProcUsage)] -> Map a MemUsage
forall a. Ord a => Bool -> [(a, ProcUsage)] -> Map a MemUsage
amass Bool
hasPss (Indexer a -> [(ProcessID, Text, ProcUsage)] -> [(a, ProcUsage)]
forall a b. (a -> b) -> [a] -> [b]
map Indexer a
mkCmd [(ProcessID, Text, ProcUsage)]
xs), [ProcessID]
stopped), ReportBud
updated)
        Maybe ReportBud
Nothing -> [ProcessID]
-> Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud)
forall a b. a -> Either a b
Left [ProcessID]
stopped
  ([ProcessID], [(ProcessID, Text, ProcUsage)])
-> Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud)
nextState (([ProcessID], [(ProcessID, Text, ProcUsage)])
 -> Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
-> IO ([ProcessID], [(ProcessID, Text, ProcUsage)])
-> IO
     (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ProcessID -> IO (Either LostPid (ProcessID, Text, ProcUsage)))
-> NonEmpty ProcessID
-> IO ([ProcessID], [(ProcessID, Text, ProcUsage)])
forall (t :: * -> *) (m :: * -> *) a b c.
(Foldable t, Monad m) =>
(a -> m (Either b c)) -> t a -> m ([a], [c])
foldlEitherM' (ProcNamer
-> ReportBud
-> ProcessID
-> IO (Either LostPid (ProcessID, Text, ProcUsage))
readNameAndStats ProcNamer
namer ReportBud
bud) NonEmpty ProcessID
pids


{- | Like 'readForOnePid', but assumes the process file hierarchy
root is the linux default
-}
readForOnePid :: ProcessID -> IO (Either NotRun (ProcName, MemUsage))
readForOnePid :: ProcessID -> IO (Either NotRun (Text, MemUsage))
readForOnePid = ProcRoot -> ProcessID -> IO (Either NotRun (Text, MemUsage))
readForOnePid' ProcRoot
defaultRoot


-- | Load the @'MemUsage'@ of a program specified by its @ProcessID@
readForOnePid' ::
  ProcRoot ->
  -- | the root of the process file system; usually @/proc@
  ProcessID ->
  -- | the ID of a valid process
  IO (Either NotRun (ProcName, MemUsage))
readForOnePid' :: ProcRoot -> ProcessID -> IO (Either NotRun (Text, MemUsage))
readForOnePid' ProcRoot
root ProcessID
pid = do
  let mkBud' :: NonEmpty ProcessID -> IO (Either NotRun ReportBud)
mkBud' NonEmpty ProcessID
xs = ProcRoot -> NonEmpty ProcessID -> IO (Maybe ReportBud)
mkReportBud ProcRoot
root NonEmpty ProcessID
xs IO (Maybe ReportBud)
-> (Maybe ReportBud -> Either NotRun ReportBud)
-> IO (Either NotRun ReportBud)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Either NotRun ReportBud
-> (ReportBud -> Either NotRun ReportBud)
-> Maybe ReportBud
-> Either NotRun ReportBud
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NotRun -> Either NotRun ReportBud
forall a b. a -> Either a b
Left NotRun
OddKernel) ReportBud -> Either NotRun ReportBud
forall a b. b -> Either a b
Right
      noProc :: LostPid
noProc = ProcessID -> LostPid
NoProc ProcessID
pid
      fromMemUsage :: Map k a -> Either NotRun (k, a)
fromMemUsage Map k a
x = Either NotRun (k, a)
-> ((k, a) -> Either NotRun (k, a))
-> Maybe (k, a)
-> Either NotRun (k, a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NotRun -> Either NotRun (k, a)
forall a b. a -> Either a b
Left (NotRun -> Either NotRun (k, a)) -> NotRun -> Either NotRun (k, a)
forall a b. (a -> b) -> a -> b
$ LostPid -> NotRun
PidLost LostPid
noProc) (k, a) -> Either NotRun (k, a)
forall a b. b -> Either a b
Right (Map k a -> Maybe (k, a)
forall k a. Map k a -> Maybe (k, a)
Map.lookupMin Map k a
x)
      andFromUsage :: Either LostPid (Map k a) -> Either NotRun (k, a)
andFromUsage = (LostPid -> Either NotRun (k, a))
-> (Map k a -> Either NotRun (k, a))
-> Either LostPid (Map k a)
-> Either NotRun (k, a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (NotRun -> Either NotRun (k, a)
forall a b. a -> Either a b
Left (NotRun -> Either NotRun (k, a))
-> (LostPid -> NotRun) -> LostPid -> Either NotRun (k, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LostPid -> NotRun
PidLost) Map k a -> Either NotRun (k, a)
forall {k} {a}. Map k a -> Either NotRun (k, a)
fromMemUsage
  ProcNamer
nameFor ProcRoot
root ProcessID
pid IO (Either LostPid Text)
-> (Either LostPid Text -> IO (Either NotRun (Text, MemUsage)))
-> IO (Either NotRun (Text, MemUsage))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left LostPid
err -> Either NotRun (Text, MemUsage)
-> IO (Either NotRun (Text, MemUsage))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either NotRun (Text, MemUsage)
 -> IO (Either NotRun (Text, MemUsage)))
-> Either NotRun (Text, MemUsage)
-> IO (Either NotRun (Text, MemUsage))
forall a b. (a -> b) -> a -> b
$ NotRun -> Either NotRun (Text, MemUsage)
forall a b. a -> Either a b
Left (NotRun -> Either NotRun (Text, MemUsage))
-> NotRun -> Either NotRun (Text, MemUsage)
forall a b. (a -> b) -> a -> b
$ LostPid -> NotRun
PidLost LostPid
err
    Right Text
_ ->
      NonEmpty ProcessID -> IO (Either NotRun ReportBud)
mkBud' (ProcessID
pid ProcessID -> [ProcessID] -> NonEmpty ProcessID
forall a. a -> [a] -> NonEmpty a
:| []) IO (Either NotRun ReportBud)
-> (Either NotRun ReportBud -> IO (Either NotRun (Text, MemUsage)))
-> IO (Either NotRun (Text, MemUsage))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left NotRun
err -> Either NotRun (Text, MemUsage)
-> IO (Either NotRun (Text, MemUsage))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either NotRun (Text, MemUsage)
 -> IO (Either NotRun (Text, MemUsage)))
-> Either NotRun (Text, MemUsage)
-> IO (Either NotRun (Text, MemUsage))
forall a b. (a -> b) -> a -> b
$ NotRun -> Either NotRun (Text, MemUsage)
forall a b. a -> Either a b
Left NotRun
err
        Right ReportBud
bud -> ReportBud -> IO (Either LostPid (Map Text MemUsage))
readMemUsage ReportBud
bud IO (Either LostPid (Map Text MemUsage))
-> (Either LostPid (Map Text MemUsage)
    -> Either NotRun (Text, MemUsage))
-> IO (Either NotRun (Text, MemUsage))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Either LostPid (Map Text MemUsage)
-> Either NotRun (Text, MemUsage)
forall {k} {a}. Either LostPid (Map k a) -> Either NotRun (k, a)
andFromUsage


-- | Like @'readMemUsage''@ but uses the default 'ProcNamer' and 'Indexer'
readMemUsage :: ReportBud -> IO (Either LostPid (Map ProcName MemUsage))
readMemUsage :: ReportBud -> IO (Either LostPid (Map Text MemUsage))
readMemUsage = ProcNamer
-> Indexer Text
-> ReportBud
-> IO (Either LostPid (Map Text MemUsage))
forall a.
Ord a =>
ProcNamer
-> Indexer a -> ReportBud -> IO (Either LostPid (Map a MemUsage))
readMemUsage' ProcNamer
nameFor Indexer Text
dropId


{- | Loads the @'MemUsage'@ specified by a @'ReportBud'@

Fails if

- the system does not have the expected process filesystem memory records
- any of the processes specified by @'ReportBud'@ are missing or inaccessible
-}
readMemUsage' ::
  (Ord a) =>
  ProcNamer ->
  Indexer a ->
  ReportBud ->
  IO (Either LostPid (Map a MemUsage))
readMemUsage' :: forall a.
Ord a =>
ProcNamer
-> Indexer a -> ReportBud -> IO (Either LostPid (Map a MemUsage))
readMemUsage' ProcNamer
namer Indexer a
mkCmd ReportBud
bud = do
  let amass' :: [(ProcessID, Text, ProcUsage)] -> Map a MemUsage
amass' [(ProcessID, Text, ProcUsage)]
cmds = Bool -> [(a, ProcUsage)] -> Map a MemUsage
forall a. Ord a => Bool -> [(a, ProcUsage)] -> Map a MemUsage
amass (ReportBud -> Bool
rbHasPss ReportBud
bud) ([(a, ProcUsage)] -> Map a MemUsage)
-> [(a, ProcUsage)] -> Map a MemUsage
forall a b. (a -> b) -> a -> b
$ Indexer a -> [(ProcessID, Text, ProcUsage)] -> [(a, ProcUsage)]
forall a b. (a -> b) -> [a] -> [b]
map Indexer a
mkCmd [(ProcessID, Text, ProcUsage)]
cmds
  ([(ProcessID, Text, ProcUsage)] -> Map a MemUsage)
-> Either LostPid [(ProcessID, Text, ProcUsage)]
-> Either LostPid (Map a MemUsage)
forall a b. (a -> b) -> Either LostPid a -> Either LostPid b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(ProcessID, Text, ProcUsage)] -> Map a MemUsage
amass' (Either LostPid [(ProcessID, Text, ProcUsage)]
 -> Either LostPid (Map a MemUsage))
-> IO (Either LostPid [(ProcessID, Text, ProcUsage)])
-> IO (Either LostPid (Map a MemUsage))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ProcessID -> IO (Either LostPid (ProcessID, Text, ProcUsage)))
-> NonEmpty ProcessID
-> IO (Either LostPid [(ProcessID, Text, ProcUsage)])
forall (t :: * -> *) (m :: * -> *) a b c.
(Foldable t, Monad m) =>
(a -> m (Either b c)) -> t a -> m (Either b [c])
foldlEitherM (ProcNamer
-> ReportBud
-> ProcessID
-> IO (Either LostPid (ProcessID, Text, ProcUsage))
readNameAndStats ProcNamer
namer ReportBud
bud) (ReportBud -> NonEmpty ProcessID
rbPids ReportBud
bud)


readNameAndStats ::
  ProcNamer ->
  ReportBud ->
  ProcessID ->
  IO (Either LostPid (ProcessID, ProcName, ProcUsage))
readNameAndStats :: ProcNamer
-> ReportBud
-> ProcessID
-> IO (Either LostPid (ProcessID, Text, ProcUsage))
readNameAndStats = ProcNamer
-> ReportBud
-> ProcessID
-> IO (Either LostPid (ProcessID, Text, ProcUsage))
readNameAndStats'


readNameAndStats' ::
  ProcNamer ->
  ReportBud ->
  ProcessID ->
  IO (Either LostPid (ProcessID, ProcName, ProcUsage))
readNameAndStats' :: ProcNamer
-> ReportBud
-> ProcessID
-> IO (Either LostPid (ProcessID, Text, ProcUsage))
readNameAndStats' ProcNamer
namer ReportBud
bud ProcessID
pid = do
  let withProcRoot :: ReaderT ProcRoot m a -> m a
withProcRoot = (ReaderT ProcRoot m a -> ProcRoot -> m a)
-> ProcRoot -> ReaderT ProcRoot m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT ProcRoot m a -> ProcRoot -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ProcRoot
root
      root :: ProcRoot
root = ReportBud -> ProcRoot
rbProcRoot ReportBud
bud
  ProcNamer
namer ProcRoot
root ProcessID
pid IO (Either LostPid Text)
-> (Either LostPid Text
    -> IO (Either LostPid (ProcessID, Text, ProcUsage)))
-> IO (Either LostPid (ProcessID, Text, ProcUsage))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left LostPid
e -> Either LostPid (ProcessID, Text, ProcUsage)
-> IO (Either LostPid (ProcessID, Text, ProcUsage))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid (ProcessID, Text, ProcUsage)
 -> IO (Either LostPid (ProcessID, Text, ProcUsage)))
-> Either LostPid (ProcessID, Text, ProcUsage)
-> IO (Either LostPid (ProcessID, Text, ProcUsage))
forall a b. (a -> b) -> a -> b
$ LostPid -> Either LostPid (ProcessID, Text, ProcUsage)
forall a b. a -> Either a b
Left LostPid
e
    Right Text
name ->
      ReaderT ProcRoot IO (Either LostPid (ProcessID, Text, ProcUsage))
-> IO (Either LostPid (ProcessID, Text, ProcUsage))
forall {m :: * -> *} {a}. ReaderT ProcRoot m a -> m a
withProcRoot (ReaderT ProcRoot IO (Either LostPid (ProcessID, Text, ProcUsage))
 -> IO (Either LostPid (ProcessID, Text, ProcUsage)))
-> ReaderT
     ProcRoot IO (Either LostPid (ProcessID, Text, ProcUsage))
-> IO (Either LostPid (ProcessID, Text, ProcUsage))
forall a b. (a -> b) -> a -> b
$
        ReportBud
-> ProcessID -> ReaderT ProcRoot IO (Either LostPid ProcUsage)
forall (m :: * -> *).
(MonadReader ProcRoot m, MonadIO m) =>
ReportBud -> ProcessID -> m (Either LostPid ProcUsage)
readMemStats ReportBud
bud ProcessID
pid ReaderT ProcRoot IO (Either LostPid ProcUsage)
-> (Either LostPid ProcUsage
    -> ReaderT
         ProcRoot IO (Either LostPid (ProcessID, Text, ProcUsage)))
-> ReaderT
     ProcRoot IO (Either LostPid (ProcessID, Text, ProcUsage))
forall a b.
ReaderT ProcRoot IO a
-> (a -> ReaderT ProcRoot IO b) -> ReaderT ProcRoot IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left LostPid
e -> Either LostPid (ProcessID, Text, ProcUsage)
-> ReaderT
     ProcRoot IO (Either LostPid (ProcessID, Text, ProcUsage))
forall a. a -> ReaderT ProcRoot IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid (ProcessID, Text, ProcUsage)
 -> ReaderT
      ProcRoot IO (Either LostPid (ProcessID, Text, ProcUsage)))
-> Either LostPid (ProcessID, Text, ProcUsage)
-> ReaderT
     ProcRoot IO (Either LostPid (ProcessID, Text, ProcUsage))
forall a b. (a -> b) -> a -> b
$ LostPid -> Either LostPid (ProcessID, Text, ProcUsage)
forall a b. a -> Either a b
Left LostPid
e
          Right ProcUsage
stats -> Either LostPid (ProcessID, Text, ProcUsage)
-> ReaderT
     ProcRoot IO (Either LostPid (ProcessID, Text, ProcUsage))
forall a. a -> ReaderT ProcRoot IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid (ProcessID, Text, ProcUsage)
 -> ReaderT
      ProcRoot IO (Either LostPid (ProcessID, Text, ProcUsage)))
-> Either LostPid (ProcessID, Text, ProcUsage)
-> ReaderT
     ProcRoot IO (Either LostPid (ProcessID, Text, ProcUsage))
forall a b. (a -> b) -> a -> b
$ (ProcessID, Text, ProcUsage)
-> Either LostPid (ProcessID, Text, ProcUsage)
forall a b. b -> Either a b
Right (ProcessID
pid, Text
name, ProcUsage
stats)


reportFlaws :: ReportBud -> Bool -> Bool -> IO ()
reportFlaws :: ReportBud -> Bool -> Bool -> IO ()
reportFlaws ReportBud
bud Bool
showSwap Bool
onlyTotal = do
  let reportSwap :: SwapFlaw -> IO ()
reportSwap = Bool -> Text -> IO ()
errStrLn Bool
onlyTotal (Text -> IO ()) -> (SwapFlaw -> Text) -> SwapFlaw -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SwapFlaw -> Text
fmtSwapFlaws
      reportRam :: RamFlaw -> IO ()
reportRam = Bool -> Text -> IO ()
errStrLn Bool
onlyTotal (Text -> IO ()) -> (RamFlaw -> Text) -> RamFlaw -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RamFlaw -> Text
fmtRamFlaws
      (Maybe RamFlaw
ram, Maybe SwapFlaw
swap) = (ReportBud -> Maybe RamFlaw
rbRamFlaws ReportBud
bud, ReportBud -> Maybe SwapFlaw
rbSwapFlaws ReportBud
bud)
  -- when showSwap, report swap flaws
  -- unless (showSwap and onlyTotal), show ram flaws
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
showSwap (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> (SwapFlaw -> IO ()) -> Maybe SwapFlaw -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) SwapFlaw -> IO ()
reportSwap Maybe SwapFlaw
swap
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
onlyTotal Bool -> Bool -> Bool
&& Bool
showSwap) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> (RamFlaw -> IO ()) -> Maybe RamFlaw -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) RamFlaw -> IO ()
reportRam Maybe RamFlaw
ram


verify :: Choices -> IO ReportBud
verify :: Choices -> IO ReportBud
verify Choices
cs = ProcRoot
-> Maybe (NonEmpty ProcessID) -> IO (Either NotRun ReportBud)
verify' (Choices -> ProcRoot
choiceProcRoot Choices
cs) (Choices -> Maybe (NonEmpty ProcessID)
choicePidsToShow Choices
cs) IO (Either NotRun ReportBud)
-> (Either NotRun ReportBud -> IO ReportBud) -> IO ReportBud
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (NotRun -> IO ReportBud)
-> (ReportBud -> IO ReportBud)
-> Either NotRun ReportBud
-> IO ReportBud
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> IO ReportBud
forall a. Text -> IO a
haltErr (Text -> IO ReportBud)
-> (NotRun -> Text) -> NotRun -> IO ReportBud
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NotRun -> Text
fmtNotRun) ReportBud -> IO ReportBud
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure


verify' :: FilePath -> Maybe (NonEmpty ProcessID) -> IO (Either NotRun ReportBud)
verify' :: ProcRoot
-> Maybe (NonEmpty ProcessID) -> IO (Either NotRun ReportBud)
verify' ProcRoot
root Maybe (NonEmpty ProcessID)
pidsMb = do
  let mkBud' :: NonEmpty ProcessID -> IO (Either NotRun ReportBud)
mkBud' NonEmpty ProcessID
xs = ProcRoot -> NonEmpty ProcessID -> IO (Maybe ReportBud)
mkReportBud ProcRoot
root NonEmpty ProcessID
xs IO (Maybe ReportBud)
-> (Maybe ReportBud -> Either NotRun ReportBud)
-> IO (Either NotRun ReportBud)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Either NotRun ReportBud
-> (ReportBud -> Either NotRun ReportBud)
-> Maybe ReportBud
-> Either NotRun ReportBud
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NotRun -> Either NotRun ReportBud
forall a b. a -> Either a b
Left NotRun
OddKernel) ReportBud -> Either NotRun ReportBud
forall a b. b -> Either a b
Right
      thenMkBud :: Either NotRun (NonEmpty ProcessID) -> IO (Either NotRun ReportBud)
thenMkBud = (NotRun -> IO (Either NotRun ReportBud))
-> (NonEmpty ProcessID -> IO (Either NotRun ReportBud))
-> Either NotRun (NonEmpty ProcessID)
-> IO (Either NotRun ReportBud)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either NotRun ReportBud -> IO (Either NotRun ReportBud)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either NotRun ReportBud -> IO (Either NotRun ReportBud))
-> (NotRun -> Either NotRun ReportBud)
-> NotRun
-> IO (Either NotRun ReportBud)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NotRun -> Either NotRun ReportBud
forall a b. a -> Either a b
Left) NonEmpty ProcessID -> IO (Either NotRun ReportBud)
mkBud'
  case Maybe (NonEmpty ProcessID)
pidsMb of
    Just NonEmpty ProcessID
pids -> ProcRoot
-> NonEmpty ProcessID -> IO (Either NotRun (NonEmpty ProcessID))
checkAllExist ProcRoot
root NonEmpty ProcessID
pids IO (Either NotRun (NonEmpty ProcessID))
-> (Either NotRun (NonEmpty ProcessID)
    -> IO (Either NotRun ReportBud))
-> IO (Either NotRun ReportBud)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either NotRun (NonEmpty ProcessID) -> IO (Either NotRun ReportBud)
thenMkBud
    Maybe (NonEmpty ProcessID)
Nothing -> ProcRoot -> IO (Either NotRun (NonEmpty ProcessID))
allKnownProcs ProcRoot
root IO (Either NotRun (NonEmpty ProcessID))
-> (Either NotRun (NonEmpty ProcessID)
    -> IO (Either NotRun ReportBud))
-> IO (Either NotRun ReportBud)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either NotRun (NonEmpty ProcessID) -> IO (Either NotRun ReportBud)
thenMkBud


-- | The root of the process file hierarchy
type ProcRoot = FilePath


pidPath :: (MonadReader ProcRoot m) => FilePath -> ProcessID -> m FilePath
pidPath :: forall (m :: * -> *).
MonadReader ProcRoot m =>
ProcRoot -> ProcessID -> m ProcRoot
pidPath ProcRoot
base ProcessID
pid = m ProcRoot
forall r (m :: * -> *). MonadReader r m => m r
ask m ProcRoot -> (ProcRoot -> m ProcRoot) -> m ProcRoot
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ProcRoot
root -> ProcRoot -> m ProcRoot
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProcRoot -> m ProcRoot) -> ProcRoot -> m ProcRoot
forall a b. (a -> b) -> a -> b
$ Builder
"" Builder -> Builder -> ProcRoot
forall b. FromBuilder b => Builder -> Builder -> b
+| ProcRoot
root ProcRoot -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"/" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger ProcessID
pid Integer -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"/" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| ProcRoot
base ProcRoot -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""


{- | pidExists returns false for any ProcessID that does not exist or cannot
be accessed
-}
pidExeExists :: FilePath -> ProcessID -> IO Bool
pidExeExists :: ProcRoot -> ProcessID -> IO Bool
pidExeExists ProcRoot
root ProcessID
pid = do
  Either LostPid ExeInfo
result <- (ReaderT ProcRoot IO (Either LostPid ExeInfo)
 -> ProcRoot -> IO (Either LostPid ExeInfo))
-> ProcRoot
-> ReaderT ProcRoot IO (Either LostPid ExeInfo)
-> IO (Either LostPid ExeInfo)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT ProcRoot IO (Either LostPid ExeInfo)
-> ProcRoot -> IO (Either LostPid ExeInfo)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ProcRoot
root (ReaderT ProcRoot IO (Either LostPid ExeInfo)
 -> IO (Either LostPid ExeInfo))
-> ReaderT ProcRoot IO (Either LostPid ExeInfo)
-> IO (Either LostPid ExeInfo)
forall a b. (a -> b) -> a -> b
$ ProcessID -> ReaderT ProcRoot IO (Either LostPid ExeInfo)
forall (m :: * -> *).
(MonadReader ProcRoot m, MonadIO m) =>
ProcessID -> m (Either LostPid ExeInfo)
exeInfo ProcessID
pid
  Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ (LostPid -> Bool)
-> (ExeInfo -> Bool) -> Either LostPid ExeInfo -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> LostPid -> Bool
forall a b. a -> b -> a
const Bool
False) (Bool -> ExeInfo -> Bool
forall a b. a -> b -> a
const Bool
True) Either LostPid ExeInfo
result


-- | Obtain the @ProcName@ as the full cmd path
nameAsFullCmd :: ProcNamer
nameAsFullCmd :: ProcNamer
nameAsFullCmd ProcRoot
root ProcessID
pid = do
  let withProcRoot :: ReaderT ProcRoot m a -> m a
withProcRoot = (ReaderT ProcRoot m a -> ProcRoot -> m a)
-> ProcRoot -> ReaderT ProcRoot m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT ProcRoot m a -> ProcRoot -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ProcRoot
root
      err :: LostPid
err = ProcessID -> LostPid
NoCmdLine ProcessID
pid
      recombine :: NonEmpty Text -> Text
recombine = Text -> [Text] -> Text
Text.intercalate Text
" " ([Text] -> Text)
-> (NonEmpty Text -> [Text]) -> NonEmpty Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NE.toList
      orLostPid :: Maybe (NonEmpty Text) -> Either LostPid Text
orLostPid = Either LostPid Text
-> (NonEmpty Text -> Either LostPid Text)
-> Maybe (NonEmpty Text)
-> Either LostPid Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (LostPid -> Either LostPid Text
forall a b. a -> Either a b
Left LostPid
err) (Text -> Either LostPid Text
forall a b. b -> Either a b
Right (Text -> Either LostPid Text)
-> (NonEmpty Text -> Text) -> NonEmpty Text -> Either LostPid Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Text -> Text
recombine)
  ReaderT ProcRoot IO Text -> IO Text
forall {m :: * -> *} {a}. ReaderT ProcRoot m a -> m a
withProcRoot (ProcessID -> ReaderT ProcRoot IO Text
forall (m :: * -> *).
(MonadReader ProcRoot m, MonadIO m) =>
ProcessID -> m Text
readCmdlinePath ProcessID
pid) IO Text
-> (Text -> IO (Either LostPid Text)) -> IO (Either LostPid Text)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Either LostPid Text -> IO (Either LostPid Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid Text -> IO (Either LostPid Text))
-> (Maybe (NonEmpty Text) -> Either LostPid Text)
-> Maybe (NonEmpty Text)
-> IO (Either LostPid Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (NonEmpty Text) -> Either LostPid Text
orLostPid) (Maybe (NonEmpty Text) -> IO (Either LostPid Text))
-> (Text -> Maybe (NonEmpty Text))
-> Text
-> IO (Either LostPid Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe (NonEmpty Text)
parseCmdline


readCmdlinePath :: (MonadReader ProcRoot m, MonadIO m) => ProcessID -> m Text
readCmdlinePath :: forall (m :: * -> *).
(MonadReader ProcRoot m, MonadIO m) =>
ProcessID -> m Text
readCmdlinePath ProcessID
pid = ProcRoot -> ProcessID -> m ProcRoot
forall (m :: * -> *).
MonadReader ProcRoot m =>
ProcRoot -> ProcessID -> m ProcRoot
pidPath ProcRoot
"cmdline" ProcessID
pid m ProcRoot -> (ProcRoot -> m Text) -> m Text
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Text -> m Text
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> (ProcRoot -> IO Text) -> ProcRoot -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcRoot -> IO Text
readUtf8Text


{- | Obtain the @ProcName@ by examining the path linked by
__{proc_root}\/pid\/exe__
-}
nameFromExeOnly :: ProcNamer
nameFromExeOnly :: ProcNamer
nameFromExeOnly ProcRoot
root ProcessID
pid = do
  let withProcRoot :: ReaderT ProcRoot m a -> m a
withProcRoot = (ReaderT ProcRoot m a -> ProcRoot -> m a)
-> ProcRoot -> ReaderT ProcRoot m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT ProcRoot m a -> ProcRoot -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ProcRoot
root
      pickSuffix :: Maybe (NonEmpty Text) -> IO (Either LostPid Text)
pickSuffix = \case
        Just (Text
x :| [Text]
_) -> do
          let addSuffix' :: Bool -> Text
addSuffix' Bool
b = Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if Bool
b then Text
" [updated]" else Text
" [deleted]"
          Text -> Either LostPid Text
forall a b. b -> Either a b
Right (Text -> Either LostPid Text)
-> (Bool -> Text) -> Bool -> Either LostPid Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
baseName (Text -> Text) -> (Bool -> Text) -> Bool -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Text
addSuffix' (Bool -> Either LostPid Text)
-> IO Bool -> IO (Either LostPid Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO Bool
exists Text
x
        -- args should not be empty when {pid_root}/exe resolves to a
        -- path, it's an error if it is
        Maybe (NonEmpty Text)
Nothing -> Either LostPid Text -> IO (Either LostPid Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid Text -> IO (Either LostPid Text))
-> Either LostPid Text -> IO (Either LostPid Text)
forall a b. (a -> b) -> a -> b
$ LostPid -> Either LostPid Text
forall a b. a -> Either a b
Left (LostPid -> Either LostPid Text) -> LostPid -> Either LostPid Text
forall a b. (a -> b) -> a -> b
$ ProcessID -> LostPid
NoCmdLine ProcessID
pid

  ReaderT ProcRoot IO (Either LostPid ExeInfo)
-> IO (Either LostPid ExeInfo)
forall {m :: * -> *} {a}. ReaderT ProcRoot m a -> m a
withProcRoot (ProcessID -> ReaderT ProcRoot IO (Either LostPid ExeInfo)
forall (m :: * -> *).
(MonadReader ProcRoot m, MonadIO m) =>
ProcessID -> m (Either LostPid ExeInfo)
exeInfo ProcessID
pid) IO (Either LostPid ExeInfo)
-> (Either LostPid ExeInfo -> IO (Either LostPid Text))
-> IO (Either LostPid Text)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left LostPid
e -> Either LostPid Text -> IO (Either LostPid Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid Text -> IO (Either LostPid Text))
-> Either LostPid Text -> IO (Either LostPid Text)
forall a b. (a -> b) -> a -> b
$ LostPid -> Either LostPid Text
forall a b. a -> Either a b
Left LostPid
e
    Right ExeInfo
i | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ExeInfo -> Bool
eiDeleted ExeInfo
i -> Either LostPid Text -> IO (Either LostPid Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid Text -> IO (Either LostPid Text))
-> Either LostPid Text -> IO (Either LostPid Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either LostPid Text
forall a b. b -> Either a b
Right (Text -> Either LostPid Text) -> Text -> Either LostPid Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
baseName (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ExeInfo -> Text
eiOriginal ExeInfo
i
    -- when the exe bud ends with (deleted), the version of the exe used to
    -- invoke the process has been removed from the filesystem. Sometimes it has
    -- been updated; examining both the original bud and the version in
    -- cmdline help determine what occurred
    Right ExeInfo {eiOriginal :: ExeInfo -> Text
eiOriginal = Text
orig} ->
      Text -> IO Bool
exists Text
orig IO Bool
-> (Bool -> IO (Either LostPid Text)) -> IO (Either LostPid Text)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
wasUpdated ->
        if Bool
wasUpdated
          then Either LostPid Text -> IO (Either LostPid Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid Text -> IO (Either LostPid Text))
-> Either LostPid Text -> IO (Either LostPid Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either LostPid Text
forall a b. b -> Either a b
Right (Text -> Either LostPid Text) -> Text -> Either LostPid Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
baseName (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Builder
"" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| Text
orig Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" [updated]"
          else ReaderT ProcRoot IO Text -> IO Text
forall {m :: * -> *} {a}. ReaderT ProcRoot m a -> m a
withProcRoot (ProcessID -> ReaderT ProcRoot IO Text
forall (m :: * -> *).
(MonadReader ProcRoot m, MonadIO m) =>
ProcessID -> m Text
readCmdlinePath ProcessID
pid) IO Text
-> (Text -> IO (Either LostPid Text)) -> IO (Either LostPid Text)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (NonEmpty Text) -> IO (Either LostPid Text)
pickSuffix (Maybe (NonEmpty Text) -> IO (Either LostPid Text))
-> (Text -> Maybe (NonEmpty Text))
-> Text
-> IO (Either LostPid Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe (NonEmpty Text)
parseCmdline


-- | Functions that obtain a process name given its @pid@
type ProcNamer = ProcRoot -> ProcessID -> IO (Either LostPid ProcName)


{- | Obtain the @ProcName@ by examining the path linked by
__{proc_root}\/pid\/exe__ or its parent's name if that is a better match
-}
nameFor :: ProcNamer
nameFor :: ProcNamer
nameFor ProcRoot
root ProcessID
pid =
  ProcNamer
nameFromExeOnly ProcRoot
root ProcessID
pid
    IO (Either LostPid Text)
-> (Either LostPid Text -> IO (Either LostPid Text))
-> IO (Either LostPid Text)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (LostPid -> IO (Either LostPid Text))
-> (Text -> IO (Either LostPid Text))
-> Either LostPid Text
-> IO (Either LostPid Text)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either LostPid Text -> IO (Either LostPid Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid Text -> IO (Either LostPid Text))
-> (LostPid -> Either LostPid Text)
-> LostPid
-> IO (Either LostPid Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LostPid -> Either LostPid Text
forall a b. a -> Either a b
Left) (ProcRoot -> ProcessID -> Text -> IO (Either LostPid Text)
parentNameIfMatched2 ProcRoot
root ProcessID
pid)


parentNameIfMatched2 :: FilePath -> ProcessID -> Text -> IO (Either LostPid ProcName)
parentNameIfMatched2 :: ProcRoot -> ProcessID -> Text -> IO (Either LostPid Text)
parentNameIfMatched2 ProcRoot
root ProcessID
pid Text
candidate = do
  let isMatch :: StatusInfo -> Bool
isMatch = (Text -> Text -> Bool) -> Text -> Text -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Text -> Bool
Text.isPrefixOf Text
candidate (Text -> Bool) -> (StatusInfo -> Text) -> StatusInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StatusInfo -> Text
siName
      withProcRoot :: ReaderT ProcRoot m a -> m a
withProcRoot = (ReaderT ProcRoot m a -> ProcRoot -> m a)
-> ProcRoot -> ReaderT ProcRoot m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT ProcRoot m a -> ProcRoot -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ProcRoot
root
  ReaderT ProcRoot IO (Either LostPid StatusInfo)
-> IO (Either LostPid StatusInfo)
forall {m :: * -> *} {a}. ReaderT ProcRoot m a -> m a
withProcRoot (ProcessID -> ReaderT ProcRoot IO (Either LostPid StatusInfo)
forall (m :: * -> *).
(MonadReader ProcRoot m, MonadIO m) =>
ProcessID -> m (Either LostPid StatusInfo)
statusInfo ProcessID
pid) IO (Either LostPid StatusInfo)
-> (Either LostPid StatusInfo -> IO (Either LostPid Text))
-> IO (Either LostPid Text)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left LostPid
err -> Either LostPid Text -> IO (Either LostPid Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid Text -> IO (Either LostPid Text))
-> Either LostPid Text -> IO (Either LostPid Text)
forall a b. (a -> b) -> a -> b
$ LostPid -> Either LostPid Text
forall a b. a -> Either a b
Left LostPid
err
    Right StatusInfo
si | StatusInfo -> Bool
isMatch StatusInfo
si -> Either LostPid Text -> IO (Either LostPid Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid Text -> IO (Either LostPid Text))
-> Either LostPid Text -> IO (Either LostPid Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either LostPid Text
forall a b. b -> Either a b
Right Text
candidate
    Right StatusInfo
si ->
      ProcNamer
nameFromExeOnly ProcRoot
root (StatusInfo -> ProcessID
siParent StatusInfo
si) IO (Either LostPid Text)
-> (Either LostPid Text -> IO (Either LostPid Text))
-> IO (Either LostPid Text)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right Text
n | Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
candidate -> Either LostPid Text -> IO (Either LostPid Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid Text -> IO (Either LostPid Text))
-> Either LostPid Text -> IO (Either LostPid Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either LostPid Text
forall a b. b -> Either a b
Right Text
n
        Either LostPid Text
_anyLostPid -> Either LostPid Text -> IO (Either LostPid Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid Text -> IO (Either LostPid Text))
-> Either LostPid Text -> IO (Either LostPid Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either LostPid Text
forall a b. b -> Either a b
Right (Text -> Either LostPid Text) -> Text -> Either LostPid Text
forall a b. (a -> b) -> a -> b
$ StatusInfo -> Text
siName StatusInfo
si


-- | Represents errors that prevent a report from being generated
data NotRun
  = PidLost !LostPid
  | MissingPids !(NonEmpty ProcessID)
  | NeedsRoot
  | OddKernel
  | NoRecords
  deriving (NotRun -> NotRun -> Bool
(NotRun -> NotRun -> Bool)
-> (NotRun -> NotRun -> Bool) -> Eq NotRun
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NotRun -> NotRun -> Bool
== :: NotRun -> NotRun -> Bool
$c/= :: NotRun -> NotRun -> Bool
/= :: NotRun -> NotRun -> Bool
Eq, Int -> NotRun -> ShowS
[NotRun] -> ShowS
NotRun -> ProcRoot
(Int -> NotRun -> ShowS)
-> (NotRun -> ProcRoot) -> ([NotRun] -> ShowS) -> Show NotRun
forall a.
(Int -> a -> ShowS) -> (a -> ProcRoot) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NotRun -> ShowS
showsPrec :: Int -> NotRun -> ShowS
$cshow :: NotRun -> ProcRoot
show :: NotRun -> ProcRoot
$cshowList :: [NotRun] -> ShowS
showList :: [NotRun] -> ShowS
Show)


fmtNotRun :: NotRun -> Text
fmtNotRun :: NotRun -> Text
fmtNotRun NotRun
NeedsRoot = Text
"run as root when no pids are specified using -p"
fmtNotRun (PidLost LostPid
x) = LostPid -> Text
fmtLostPid LostPid
x
fmtNotRun NotRun
OddKernel = Text
"unrecognized kernel version"
fmtNotRun (MissingPids NonEmpty ProcessID
pids) = Builder
"no records available for: " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| NonEmpty Integer -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
listF (ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger (ProcessID -> Integer) -> NonEmpty ProcessID -> NonEmpty Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty ProcessID
pids) Builder -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
fmtNotRun NotRun
NoRecords = Text
"could not find any process records"


{- | Represents reasons a specified @pid@ may not have memory
records.
-}
data LostPid
  = NoExeFile !ProcessID
  | NoStatusCmd !ProcessID
  | NoStatusParent !ProcessID
  | NoCmdLine !ProcessID
  | BadStatm !ProcessID
  | NoProc !ProcessID
  deriving (LostPid -> LostPid -> Bool
(LostPid -> LostPid -> Bool)
-> (LostPid -> LostPid -> Bool) -> Eq LostPid
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LostPid -> LostPid -> Bool
== :: LostPid -> LostPid -> Bool
$c/= :: LostPid -> LostPid -> Bool
/= :: LostPid -> LostPid -> Bool
Eq, Int -> LostPid -> ShowS
[LostPid] -> ShowS
LostPid -> ProcRoot
(Int -> LostPid -> ShowS)
-> (LostPid -> ProcRoot) -> ([LostPid] -> ShowS) -> Show LostPid
forall a.
(Int -> a -> ShowS) -> (a -> ProcRoot) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LostPid -> ShowS
showsPrec :: Int -> LostPid -> ShowS
$cshow :: LostPid -> ProcRoot
show :: LostPid -> ProcRoot
$cshowList :: [LostPid] -> ShowS
showList :: [LostPid] -> ShowS
Show)


fmtLostPid :: LostPid -> Text
fmtLostPid :: LostPid -> Text
fmtLostPid (NoStatusCmd ProcessID
pid) = Builder
"missing:no name in {proc_root}/" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger ProcessID
pid Integer -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"/status"
fmtLostPid (NoStatusParent ProcessID
pid) = Builder
"missing:no ppid in {proc_root}/" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger ProcessID
pid Integer -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"/status"
fmtLostPid (NoExeFile ProcessID
pid) = Builder
"missing:{proc_root}/" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger ProcessID
pid Integer -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"/exe"
fmtLostPid (NoCmdLine ProcessID
pid) = Builder
"missing:{proc_root}/" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger ProcessID
pid Integer -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"/cmdline"
fmtLostPid (NoProc ProcessID
pid) = Builder
"missing:memory records for pid:" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger ProcessID
pid Integer -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
fmtLostPid (BadStatm ProcessID
pid) = Builder
"missing:invalid memory record in {proc_root}/" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger ProcessID
pid Integer -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"/statm"


haltLostPid :: LostPid -> IO a
haltLostPid :: forall a. LostPid -> IO a
haltLostPid LostPid
err = do
  Handle -> Text -> IO ()
Text.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Builder
"halting due to " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| LostPid -> Text
fmtLostPid LostPid
err Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
  IO a
forall a. IO a
exitFailure


exeInfo :: (MonadReader ProcRoot m, MonadIO m) => ProcessID -> m (Either LostPid ExeInfo)
exeInfo :: forall (m :: * -> *).
(MonadReader ProcRoot m, MonadIO m) =>
ProcessID -> m (Either LostPid ExeInfo)
exeInfo ProcessID
pid = do
  ProcRoot
link <- ProcRoot -> ProcessID -> m ProcRoot
forall (m :: * -> *).
MonadReader ProcRoot m =>
ProcRoot -> ProcessID -> m ProcRoot
pidPath ProcRoot
"exe" ProcessID
pid
  Either LostPid Text
linkText <- IO (Either LostPid Text) -> m (Either LostPid Text)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either LostPid Text) -> m (Either LostPid Text))
-> IO (Either LostPid Text) -> m (Either LostPid Text)
forall a b. (a -> b) -> a -> b
$ ProcessID -> ProcRoot -> IO (Either LostPid Text)
getSymbolicLinkText ProcessID
pid ProcRoot
link
  Either LostPid ExeInfo -> m (Either LostPid ExeInfo)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid ExeInfo -> m (Either LostPid ExeInfo))
-> Either LostPid ExeInfo -> m (Either LostPid ExeInfo)
forall a b. (a -> b) -> a -> b
$ (Text -> ExeInfo) -> Either LostPid Text -> Either LostPid ExeInfo
forall a b. (a -> b) -> Either LostPid a -> Either LostPid b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ExeInfo
parseExeInfo Either LostPid Text
linkText


getSymbolicLinkText :: ProcessID -> FilePath -> IO (Either LostPid Text)
getSymbolicLinkText :: ProcessID -> ProcRoot -> IO (Either LostPid Text)
getSymbolicLinkText ProcessID
pid ProcRoot
link = do
  let handledErr :: IOError -> Bool
handledErr IOError
e = IOError -> Bool
isDoesNotExistError IOError
e Bool -> Bool -> Bool
|| IOError -> Bool
isPermissionError IOError
e
      onIOE :: IOError -> IO (Either LostPid b)
onIOE IOError
e = if IOError -> Bool
handledErr IOError
e then Either LostPid b -> IO (Either LostPid b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LostPid -> Either LostPid b
forall a b. a -> Either a b
Left (LostPid -> Either LostPid b) -> LostPid -> Either LostPid b
forall a b. (a -> b) -> a -> b
$ ProcessID -> LostPid
NoExeFile ProcessID
pid) else IOError -> IO (Either LostPid b)
forall e a. Exception e => e -> IO a
throwIO IOError
e
  (IOError -> IO (Either LostPid Text))
-> IO (Either LostPid Text) -> IO (Either LostPid Text)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle IOError -> IO (Either LostPid Text)
forall {b}. IOError -> IO (Either LostPid b)
onIOE (IO (Either LostPid Text) -> IO (Either LostPid Text))
-> IO (Either LostPid Text) -> IO (Either LostPid Text)
forall a b. (a -> b) -> a -> b
$ do
    Text -> Either LostPid Text
forall a b. b -> Either a b
Right (Text -> Either LostPid Text)
-> (ProcRoot -> Text) -> ProcRoot -> Either LostPid Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcRoot -> Text
Text.pack (ProcRoot -> Either LostPid Text)
-> IO ProcRoot -> IO (Either LostPid Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProcRoot -> IO ProcRoot
getSymbolicLinkTarget ProcRoot
link


exists :: Text -> IO Bool
exists :: Text -> IO Bool
exists = ProcRoot -> IO Bool
doesFileExist (ProcRoot -> IO Bool) -> (Text -> ProcRoot) -> Text -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ProcRoot
Text.unpack


statusInfo :: (MonadReader ProcRoot m, MonadIO m) => ProcessID -> m (Either LostPid StatusInfo)
statusInfo :: forall (m :: * -> *).
(MonadReader ProcRoot m, MonadIO m) =>
ProcessID -> m (Either LostPid StatusInfo)
statusInfo ProcessID
pid = do
  let fromBadStatus :: BadStatus -> LostPid
fromBadStatus BadStatus
NoCmd = ProcessID -> LostPid
NoStatusCmd ProcessID
pid
      fromBadStatus BadStatus
NoParent = ProcessID -> LostPid
NoStatusParent ProcessID
pid
  ProcRoot
statusPath <- ProcRoot -> ProcessID -> m ProcRoot
forall (m :: * -> *).
MonadReader ProcRoot m =>
ProcRoot -> ProcessID -> m ProcRoot
pidPath ProcRoot
"status" ProcessID
pid
  (BadStatus -> LostPid)
-> Either BadStatus StatusInfo -> Either LostPid StatusInfo
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first BadStatus -> LostPid
fromBadStatus (Either BadStatus StatusInfo -> Either LostPid StatusInfo)
-> (Text -> Either BadStatus StatusInfo)
-> Text
-> Either LostPid StatusInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either BadStatus StatusInfo
parseStatusInfo (Text -> Either LostPid StatusInfo)
-> m Text -> m (Either LostPid StatusInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Text -> m Text
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ProcRoot -> IO Text
readUtf8Text ProcRoot
statusPath)


parseCmdline :: Text -> Maybe (NonEmpty Text)
parseCmdline :: Text -> Maybe (NonEmpty Text)
parseCmdline =
  let split' :: Text -> [Text]
split' = (Char -> Bool) -> Text -> [Text]
Text.split Char -> Bool
isNullOrSpace (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
Text.dropWhileEnd Char -> Bool
isNull
   in [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Text] -> Maybe (NonEmpty Text))
-> (Text -> [Text]) -> Text -> Maybe (NonEmpty Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
split'


nonExisting :: FilePath -> NonEmpty ProcessID -> IO [ProcessID]
nonExisting :: ProcRoot -> NonEmpty ProcessID -> IO [ProcessID]
nonExisting ProcRoot
root = (ProcessID -> IO Bool) -> [ProcessID] -> IO [ProcessID]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (IO Bool -> IO Bool)
-> (ProcessID -> IO Bool) -> ProcessID -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcRoot -> ProcessID -> IO Bool
pidExeExists ProcRoot
root) ([ProcessID] -> IO [ProcessID])
-> (NonEmpty ProcessID -> [ProcessID])
-> NonEmpty ProcessID
-> IO [ProcessID]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ProcessID -> [ProcessID]
forall a. NonEmpty a -> [a]
NE.toList


checkAllExist :: FilePath -> NonEmpty ProcessID -> IO (Either NotRun (NonEmpty ProcessID))
checkAllExist :: ProcRoot
-> NonEmpty ProcessID -> IO (Either NotRun (NonEmpty ProcessID))
checkAllExist ProcRoot
root NonEmpty ProcessID
pids =
  ProcRoot -> NonEmpty ProcessID -> IO [ProcessID]
nonExisting ProcRoot
root NonEmpty ProcessID
pids IO [ProcessID]
-> ([ProcessID] -> IO (Either NotRun (NonEmpty ProcessID)))
-> IO (Either NotRun (NonEmpty ProcessID))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [] -> Either NotRun (NonEmpty ProcessID)
-> IO (Either NotRun (NonEmpty ProcessID))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either NotRun (NonEmpty ProcessID)
 -> IO (Either NotRun (NonEmpty ProcessID)))
-> Either NotRun (NonEmpty ProcessID)
-> IO (Either NotRun (NonEmpty ProcessID))
forall a b. (a -> b) -> a -> b
$ NonEmpty ProcessID -> Either NotRun (NonEmpty ProcessID)
forall a b. b -> Either a b
Right NonEmpty ProcessID
pids
    ProcessID
x : [ProcessID]
xs -> Either NotRun (NonEmpty ProcessID)
-> IO (Either NotRun (NonEmpty ProcessID))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either NotRun (NonEmpty ProcessID)
 -> IO (Either NotRun (NonEmpty ProcessID)))
-> Either NotRun (NonEmpty ProcessID)
-> IO (Either NotRun (NonEmpty ProcessID))
forall a b. (a -> b) -> a -> b
$ NotRun -> Either NotRun (NonEmpty ProcessID)
forall a b. a -> Either a b
Left (NotRun -> Either NotRun (NonEmpty ProcessID))
-> NotRun -> Either NotRun (NonEmpty ProcessID)
forall a b. (a -> b) -> a -> b
$ NonEmpty ProcessID -> NotRun
MissingPids (NonEmpty ProcessID -> NotRun) -> NonEmpty ProcessID -> NotRun
forall a b. (a -> b) -> a -> b
$ ProcessID
x ProcessID -> [ProcessID] -> NonEmpty ProcessID
forall a. a -> [a] -> NonEmpty a
:| [ProcessID]
xs


allKnownProcs :: FilePath -> IO (Either NotRun (NonEmpty ProcessID))
allKnownProcs :: ProcRoot -> IO (Either NotRun (NonEmpty ProcessID))
allKnownProcs ProcRoot
root =
  let readIdsMaybe :: IO [ProcRoot] -> IO [ProcessID]
readIdsMaybe = ([ProcRoot] -> [ProcessID]) -> IO [ProcRoot] -> IO [ProcessID]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ProcRoot -> Maybe ProcessID) -> [ProcRoot] -> [ProcessID]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ProcRoot -> Maybe ProcessID
forall a. Read a => ProcRoot -> Maybe a
readMaybe)
      readProcessIDs :: IO [ProcessID]
readProcessIDs = IO [ProcRoot] -> IO [ProcessID]
readIdsMaybe (ProcRoot -> IO [ProcRoot]
listDirectory ProcRoot
root)
      orNoPids :: [a] -> IO (Either NotRun (NonEmpty a))
orNoPids = Either NotRun (NonEmpty a) -> IO (Either NotRun (NonEmpty a))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either NotRun (NonEmpty a) -> IO (Either NotRun (NonEmpty a)))
-> ([a] -> Either NotRun (NonEmpty a))
-> [a]
-> IO (Either NotRun (NonEmpty a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either NotRun (NonEmpty a)
-> (NonEmpty a -> Either NotRun (NonEmpty a))
-> Maybe (NonEmpty a)
-> Either NotRun (NonEmpty a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NotRun -> Either NotRun (NonEmpty a)
forall a b. a -> Either a b
Left NotRun
NoRecords) NonEmpty a -> Either NotRun (NonEmpty a)
forall a b. b -> Either a b
Right (Maybe (NonEmpty a) -> Either NotRun (NonEmpty a))
-> ([a] -> Maybe (NonEmpty a)) -> [a] -> Either NotRun (NonEmpty a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty
   in IO [ProcessID]
readProcessIDs IO [ProcessID] -> ([ProcessID] -> IO [ProcessID]) -> IO [ProcessID]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ProcessID -> IO Bool) -> [ProcessID] -> IO [ProcessID]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (ProcRoot -> ProcessID -> IO Bool
pidExeExists ProcRoot
root) IO [ProcessID]
-> ([ProcessID] -> IO (Either NotRun (NonEmpty ProcessID)))
-> IO (Either NotRun (NonEmpty ProcessID))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [ProcessID] -> IO (Either NotRun (NonEmpty ProcessID))
forall {a}. [a] -> IO (Either NotRun (NonEmpty a))
orNoPids


baseName :: Text -> Text
baseName :: Text -> Text
baseName = ProcRoot -> Text
Text.pack (ProcRoot -> Text) -> (Text -> ProcRoot) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
takeBaseName ShowS -> (Text -> ProcRoot) -> Text -> ProcRoot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ProcRoot
Text.unpack


readMemStats ::
  (MonadReader ProcRoot m, MonadIO m) =>
  ReportBud ->
  ProcessID ->
  m (Either LostPid ProcUsage)
readMemStats :: forall (m :: * -> *).
(MonadReader ProcRoot m, MonadIO m) =>
ReportBud -> ProcessID -> m (Either LostPid ProcUsage)
readMemStats ReportBud
bud ProcessID
pid = do
  ProcRoot
statmPath <- ProcRoot -> ProcessID -> m ProcRoot
forall (m :: * -> *).
MonadReader ProcRoot m =>
ProcRoot -> ProcessID -> m ProcRoot
pidPath ProcRoot
"statm" ProcessID
pid
  Bool
statmExists <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ ProcRoot -> IO Bool
doesFileExist ProcRoot
statmPath
  if
    | ReportBud -> Bool
rbHasSmaps ReportBud
bud -> ProcUsage -> Either LostPid ProcUsage
forall a b. b -> Either a b
Right (ProcUsage -> Either LostPid ProcUsage)
-> (Text -> ProcUsage) -> Text -> Either LostPid ProcUsage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ProcUsage
parseFromSmap (Text -> Either LostPid ProcUsage)
-> m Text -> m (Either LostPid ProcUsage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProcessID -> m Text
forall (m :: * -> *).
(MonadReader ProcRoot m, MonadIO m) =>
ProcessID -> m Text
readSmaps ProcessID
pid
    | Bool
statmExists -> do
        let readStatm' :: m Text
readStatm' = IO Text -> m Text
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ ProcRoot -> IO Text
readUtf8Text ProcRoot
statmPath
            orLostPid :: Maybe b -> Either LostPid b
orLostPid = Either LostPid b
-> (b -> Either LostPid b) -> Maybe b -> Either LostPid b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (LostPid -> Either LostPid b
forall a b. a -> Either a b
Left (LostPid -> Either LostPid b) -> LostPid -> Either LostPid b
forall a b. (a -> b) -> a -> b
$ ProcessID -> LostPid
BadStatm ProcessID
pid) b -> Either LostPid b
forall a b. b -> Either a b
Right
        Maybe ProcUsage -> Either LostPid ProcUsage
forall {b}. Maybe b -> Either LostPid b
orLostPid (Maybe ProcUsage -> Either LostPid ProcUsage)
-> (Text -> Maybe ProcUsage) -> Text -> Either LostPid ProcUsage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KernelVersion -> Text -> Maybe ProcUsage
parseFromStatm (ReportBud -> KernelVersion
rbKernel ReportBud
bud) (Text -> Either LostPid ProcUsage)
-> m Text -> m (Either LostPid ProcUsage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Text
readStatm'
    | Bool
otherwise -> Either LostPid ProcUsage -> m (Either LostPid ProcUsage)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid ProcUsage -> m (Either LostPid ProcUsage))
-> Either LostPid ProcUsage -> m (Either LostPid ProcUsage)
forall a b. (a -> b) -> a -> b
$ LostPid -> Either LostPid ProcUsage
forall a b. a -> Either a b
Left (LostPid -> Either LostPid ProcUsage)
-> LostPid -> Either LostPid ProcUsage
forall a b. (a -> b) -> a -> b
$ ProcessID -> LostPid
NoProc ProcessID
pid


readSmaps :: (MonadReader ProcRoot m, MonadIO m) => ProcessID -> m Text
readSmaps :: forall (m :: * -> *).
(MonadReader ProcRoot m, MonadIO m) =>
ProcessID -> m Text
readSmaps ProcessID
pid = do
  ProcRoot
smapPath <- ProcRoot -> ProcessID -> m ProcRoot
forall (m :: * -> *).
MonadReader ProcRoot m =>
ProcRoot -> ProcessID -> m ProcRoot
pidPath ProcRoot
"smaps" ProcessID
pid
  ProcRoot
rollupPath <- ProcRoot -> ProcessID -> m ProcRoot
forall (m :: * -> *).
MonadReader ProcRoot m =>
ProcRoot -> ProcessID -> m ProcRoot
pidPath ProcRoot
"smaps_rollup" ProcessID
pid
  Bool
hasSmaps <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ ProcRoot -> IO Bool
doesFileExist ProcRoot
smapPath
  Bool
hasRollup <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ ProcRoot -> IO Bool
doesFileExist ProcRoot
rollupPath
  if
    | Bool
hasRollup -> IO Text -> m Text
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ ProcRoot -> IO Text
readUtf8Text ProcRoot
rollupPath
    | Bool
hasSmaps -> IO Text -> m Text
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ ProcRoot -> IO Text
readUtf8Text ProcRoot
smapPath
    | Bool
otherwise -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
Text.empty


overallTotals :: [MemUsage] -> (Int, Int)
overallTotals :: [MemUsage] -> (Int, Int)
overallTotals [MemUsage]
cts =
  let step :: (Int, Int) -> MemUsage -> (Int, Int)
step (Int
private, Int
swap) MemUsage
ct = (Int
private Int -> Int -> Int
forall a. Num a => a -> a -> a
+ MemUsage -> Int
muPrivate MemUsage
ct, Int
swap Int -> Int -> Int
forall a. Num a => a -> a -> a
+ MemUsage -> Int
muSwap MemUsage
ct)
   in ((Int, Int) -> MemUsage -> (Int, Int))
-> (Int, Int) -> [MemUsage] -> (Int, Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int, Int) -> MemUsage -> (Int, Int)
step (Int
0, Int
0) [MemUsage]
cts


fmtMemBytes :: Int -> Text
fmtMemBytes :: Int -> Text
fmtMemBytes Int
x = Builder
"" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024 Int -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""


foldlEitherM ::
  (Foldable t, Monad m) =>
  (a -> m (Either b c)) ->
  t a ->
  m (Either b [c])
foldlEitherM :: forall (t :: * -> *) (m :: * -> *) a b c.
(Foldable t, Monad m) =>
(a -> m (Either b c)) -> t a -> m (Either b [c])
foldlEitherM a -> m (Either b c)
f t a
xs =
  let go :: Either b [c] -> a -> m (Either b [c])
go (Left b
err) a
_ = Either b [c] -> m (Either b [c])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either b [c] -> m (Either b [c]))
-> Either b [c] -> m (Either b [c])
forall a b. (a -> b) -> a -> b
$ b -> Either b [c]
forall a b. a -> Either a b
Left b
err
      go (Right [c]
acc) a
a =
        a -> m (Either b c)
f a
a m (Either b c)
-> (Either b c -> m (Either b [c])) -> m (Either b [c])
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left b
err -> Either b [c] -> m (Either b [c])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either b [c] -> m (Either b [c]))
-> Either b [c] -> m (Either b [c])
forall a b. (a -> b) -> a -> b
$ b -> Either b [c]
forall a b. a -> Either a b
Left b
err
          Right c
y -> Either b [c] -> m (Either b [c])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either b [c] -> m (Either b [c]))
-> Either b [c] -> m (Either b [c])
forall a b. (a -> b) -> a -> b
$ [c] -> Either b [c]
forall a b. b -> Either a b
Right (c
y c -> [c] -> [c]
forall a. a -> [a] -> [a]
: [c]
acc)
   in (Either b [c] -> a -> m (Either b [c]))
-> Either b [c] -> t a -> m (Either b [c])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM Either b [c] -> a -> m (Either b [c])
go ([c] -> Either b [c]
forall a b. b -> Either a b
Right []) t a
xs


foldlEitherM' ::
  (Foldable t, Monad m) =>
  (a -> m (Either b c)) ->
  t a ->
  m ([a], [c])
foldlEitherM' :: forall (t :: * -> *) (m :: * -> *) a b c.
(Foldable t, Monad m) =>
(a -> m (Either b c)) -> t a -> m ([a], [c])
foldlEitherM' a -> m (Either b c)
f t a
xs =
  let
    go :: ([a], [c]) -> a -> m ([a], [c])
go ([a]
as, [c]
cs) a
a =
      a -> m (Either b c)
f a
a m (Either b c) -> (Either b c -> m ([a], [c])) -> m ([a], [c])
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left b
_ -> ([a], [c]) -> m ([a], [c])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as, [c]
cs)
        Right c
c -> ([a], [c]) -> m ([a], [c])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a]
as, c
c c -> [c] -> [c]
forall a. a -> [a] -> [a]
: [c]
cs)
   in
    (([a], [c]) -> a -> m ([a], [c]))
-> ([a], [c]) -> t a -> m ([a], [c])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM ([a], [c]) -> a -> m ([a], [c])
go ([a]
forall a. Monoid a => a
mempty, [c]
forall a. Monoid a => a
mempty) t a
xs


haltErr :: Text -> IO a
haltErr :: forall a. Text -> IO a
haltErr Text
err = do
  Bool -> Text -> IO ()
errStrLn Bool
True Text
err
  IO a
forall a. IO a
exitFailure


errStrLn :: Bool -> Text -> IO ()
errStrLn :: Bool -> Text -> IO ()
errStrLn Bool
errOrWarn Text
txt = do
  let prefix :: Text
prefix = if Bool
errOrWarn then Text
"error: " else Text
"warning: "
  Handle -> Text -> IO ()
Text.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txt


-- | Functions that generate the report index
type Indexer index = (ProcessID, ProcName, ProcUsage) -> (index, ProcUsage)


{- | Index a @'ProcUsage'@ using the program name and process ID.

Each @ProcUsage@ remains distinct when added to a @MemUsage@
-}
withPid :: Indexer (ProcessID, ProcName)
withPid :: Indexer (ProcessID, Text)
withPid (ProcessID
pid, Text
name, ProcUsage
pp) = ((ProcessID
pid, Text
name), ProcUsage
pp)


{- | Index a @'ProcUsage'@ using just the program name

@ProcUsage's@ with the same @ProcName@ will be merged when added to a @MemUsage@
-}
dropId :: Indexer ProcName
dropId :: Indexer Text
dropId (ProcessID
_pid, Text
name, ProcUsage
pp) = (Text
name, ProcUsage
pp)


byPrintOrder ::
  (Ord c) =>
  (((c, MemUsage) -> Int) -> (c, MemUsage) -> (c, MemUsage) -> Ordering) ->
  PrintOrder ->
  (c, MemUsage) ->
  (c, MemUsage) ->
  Ordering
byPrintOrder :: forall c.
Ord c =>
(((c, MemUsage) -> Int)
 -> (c, MemUsage) -> (c, MemUsage) -> Ordering)
-> PrintOrder -> (c, MemUsage) -> (c, MemUsage) -> Ordering
byPrintOrder ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f PrintOrder
Swap = ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f (((c, MemUsage) -> Int)
 -> (c, MemUsage) -> (c, MemUsage) -> Ordering)
-> ((c, MemUsage) -> Int)
-> (c, MemUsage)
-> (c, MemUsage)
-> Ordering
forall a b. (a -> b) -> a -> b
$ MemUsage -> Int
muSwap (MemUsage -> Int)
-> ((c, MemUsage) -> MemUsage) -> (c, MemUsage) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c, MemUsage) -> MemUsage
forall a b. (a, b) -> b
snd
byPrintOrder ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f PrintOrder
Shared = ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f (((c, MemUsage) -> Int)
 -> (c, MemUsage) -> (c, MemUsage) -> Ordering)
-> ((c, MemUsage) -> Int)
-> (c, MemUsage)
-> (c, MemUsage)
-> Ordering
forall a b. (a -> b) -> a -> b
$ MemUsage -> Int
muShared (MemUsage -> Int)
-> ((c, MemUsage) -> MemUsage) -> (c, MemUsage) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c, MemUsage) -> MemUsage
forall a b. (a, b) -> b
snd
byPrintOrder ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f PrintOrder
Private = ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f (((c, MemUsage) -> Int)
 -> (c, MemUsage) -> (c, MemUsage) -> Ordering)
-> ((c, MemUsage) -> Int)
-> (c, MemUsage)
-> (c, MemUsage)
-> Ordering
forall a b. (a -> b) -> a -> b
$ MemUsage -> Int
muPrivate (MemUsage -> Int)
-> ((c, MemUsage) -> MemUsage) -> (c, MemUsage) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c, MemUsage) -> MemUsage
forall a b. (a, b) -> b
snd
byPrintOrder ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f PrintOrder
Count = ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f (((c, MemUsage) -> Int)
 -> (c, MemUsage) -> (c, MemUsage) -> Ordering)
-> ((c, MemUsage) -> Int)
-> (c, MemUsage)
-> (c, MemUsage)
-> Ordering
forall a b. (a -> b) -> a -> b
$ MemUsage -> Int
muCount (MemUsage -> Int)
-> ((c, MemUsage) -> MemUsage) -> (c, MemUsage) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c, MemUsage) -> MemUsage
forall a b. (a, b) -> b
snd


byPrintOrder' ::
  (Ord a) =>
  Bool ->
  Maybe PrintOrder ->
  (a, MemUsage) ->
  (a, MemUsage) ->
  Ordering
byPrintOrder' :: forall a.
Ord a =>
Bool
-> Maybe PrintOrder -> (a, MemUsage) -> (a, MemUsage) -> Ordering
byPrintOrder' Bool
reversed Maybe PrintOrder
mbOrder =
  let cmpUsage :: (b -> Int) -> b -> b -> Ordering
cmpUsage = if Bool
reversed then (b -> Int) -> b -> b -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing else (b -> Int) -> b -> b -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing'
      cmpName :: (b -> a) -> b -> b -> Ordering
cmpName = if Bool
reversed then (b -> a) -> b -> b -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing else (b -> a) -> b -> b -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing'
      byName :: (a, b) -> (a, b) -> Ordering
byName = ((a, b) -> a) -> (a, b) -> (a, b) -> Ordering
forall {b}. (b -> a) -> b -> b -> Ordering
cmpName (a, b) -> a
forall a b. (a, b) -> a
fst
      byUsage :: PrintOrder -> (a, MemUsage) -> (a, MemUsage) -> Ordering
byUsage = (((a, MemUsage) -> Int)
 -> (a, MemUsage) -> (a, MemUsage) -> Ordering)
-> PrintOrder -> (a, MemUsage) -> (a, MemUsage) -> Ordering
forall c.
Ord c =>
(((c, MemUsage) -> Int)
 -> (c, MemUsage) -> (c, MemUsage) -> Ordering)
-> PrintOrder -> (c, MemUsage) -> (c, MemUsage) -> Ordering
byPrintOrder ((a, MemUsage) -> Int)
-> (a, MemUsage) -> (a, MemUsage) -> Ordering
forall {b}. (b -> Int) -> b -> b -> Ordering
cmpUsage
   in ((a, MemUsage) -> (a, MemUsage) -> Ordering)
-> (PrintOrder -> (a, MemUsage) -> (a, MemUsage) -> Ordering)
-> Maybe PrintOrder
-> (a, MemUsage)
-> (a, MemUsage)
-> Ordering
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a, MemUsage) -> (a, MemUsage) -> Ordering
forall {b}. (a, b) -> (a, b) -> Ordering
byName PrintOrder -> (a, MemUsage) -> (a, MemUsage) -> Ordering
byUsage Maybe PrintOrder
mbOrder


comparing' :: (Ord a) => (b -> a) -> b -> b -> Ordering
comparing' :: forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing' b -> a
f b
a b
b = Down a -> Down a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> Down a
forall a. a -> Down a
Down (a -> Down a) -> a -> Down a
forall a b. (a -> b) -> a -> b
$ b -> a
f b
a) (a -> Down a
forall a. a -> Down a
Down (a -> Down a) -> a -> Down a
forall a b. (a -> b) -> a -> b
$ b -> a
f b
b)


memLT :: Mem -> (a, MemUsage) -> Bool
memLT :: forall a. Mem -> (a, MemUsage) -> Bool
memLT Mem
mem (a
_ignored, MemUsage
mu) = Mem -> Double
asFloat Mem
mem Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (MemUsage -> Int
muPrivate MemUsage
mu)


filterLT :: Maybe Mem -> [(a, MemUsage)] -> [(a, MemUsage)]
filterLT :: forall a. Maybe Mem -> [(a, MemUsage)] -> [(a, MemUsage)]
filterLT Maybe Mem
Nothing [(a, MemUsage)]
xs = [(a, MemUsage)]
xs
filterLT (Just Mem
mem) [(a, MemUsage)]
xs = ((a, MemUsage) -> Bool) -> [(a, MemUsage)] -> [(a, MemUsage)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Mem -> (a, MemUsage) -> Bool
forall a. Mem -> (a, MemUsage) -> Bool
memLT Mem
mem) [(a, MemUsage)]
xs