{-# 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,
  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 Data.Bifunctor (Bifunctor (..))
import Data.Functor ((<&>))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
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 (..), getChoices)
import System.MemInfo.Prelude
import System.MemInfo.Print (
  AsCmdName (..),
  fmtAsHeader,
  fmtMemUsage,
  fmtOverall,
 )
import System.MemInfo.Proc (
  BadStatus (..),
  ExeInfo (..),
  MemUsage (..),
  ProcUsage (..),
  StatusInfo (..),
  amass,
  parseExeInfo,
  parseFromSmap,
  parseFromStatm,
  parseStatusInfo,
 )
import System.MemInfo.SysInfo (
  ReportBud (..),
  fmtRamFlaws,
  fmtSwapFlaws,
  mkReportBud,
 )
import System.Posix.User (getEffectiveUserID)


{- | Print a report to @stdout@ displaying the memory usage of the programs
specified by @Choices@
-}
printProcs :: Choices -> IO ()
printProcs :: Choices -> IO ()
printProcs Choices
cs = do
  ReportBud
bud <- Choices -> IO ReportBud
verify Choices
cs
  let Choices
        { choiceShowSwap :: Choices -> Bool
choiceShowSwap = Bool
showSwap
        , choiceOnlyTotal :: Choices -> Bool
choiceOnlyTotal = Bool
onlyTotal
        , choiceWatchSecs :: Choices -> Maybe Natural
choiceWatchSecs = Maybe Natural
watchSecsMb
        , choiceByPid :: Choices -> Bool
choiceByPid = Bool
byPid
        } = Choices
cs
      printEachCmd :: Map a MemUsage -> IO ()
printEachCmd Map a MemUsage
totals = ReportBud -> Bool -> Bool -> Map a MemUsage -> IO ()
forall a.
AsCmdName a =>
ReportBud -> Bool -> Bool -> Map a MemUsage -> IO ()
printMemUsages ReportBud
bud Bool
showSwap Bool
onlyTotal Map a MemUsage
totals
      printTheTotal :: Map k MemUsage -> IO ()
printTheTotal = ReportBud -> Bool -> Bool -> Map k MemUsage -> IO ()
forall k. ReportBud -> Bool -> Bool -> Map k MemUsage -> IO ()
onlyPrintTotal ReportBud
bud Bool
showSwap Bool
onlyTotal
      showTotal :: Map a MemUsage -> IO ()
showTotal Map a MemUsage
cmds = if Bool
onlyTotal then Map a MemUsage -> IO ()
forall {k}. Map k MemUsage -> IO ()
printTheTotal Map a MemUsage
cmds else Map a MemUsage -> IO ()
forall {a}. AsCmdName a => Map a MemUsage -> IO ()
printEachCmd Map a MemUsage
cmds
      namer :: ProcNamer
namer = if Choices -> Bool
choiceSplitArgs Choices
cs then ProcNamer
nameAsFullCmd else ProcNamer
nameFor
  case (Maybe Natural
watchSecsMb, Bool
byPid) of
    (Maybe Natural
Nothing, Bool
True) -> ProcNamer
-> Indexer (ProcessID, Text)
-> ReportBud
-> IO (Either LostPid (Map (ProcessID, Text) MemUsage))
forall a.
Ord a =>
ProcNamer
-> Indexer a -> ReportBud -> IO (Either LostPid (Map a MemUsage))
readMemUsage' ProcNamer
namer Indexer (ProcessID, Text)
withPid ReportBud
bud IO (Either LostPid (Map (ProcessID, Text) MemUsage))
-> (Either LostPid (Map (ProcessID, Text) 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 (ProcessID, Text) MemUsage -> IO ())
-> Either LostPid (Map (ProcessID, Text) MemUsage)
-> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either LostPid -> IO ()
forall a. LostPid -> IO a
haltLostPid Map (ProcessID, Text) MemUsage -> IO ()
forall {a}. AsCmdName a => Map a MemUsage -> IO ()
showTotal
    (Maybe Natural
Nothing, Bool
_) -> 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
namer Indexer Text
dropId ReportBud
bud IO (Either LostPid (Map Text MemUsage))
-> (Either LostPid (Map Text 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 Text MemUsage -> IO ())
-> Either LostPid (Map Text MemUsage)
-> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either LostPid -> IO ()
forall a. LostPid -> IO a
haltLostPid Map Text MemUsage -> IO ()
forall {a}. AsCmdName a => Map a MemUsage -> IO ()
showTotal
    (Just Natural
spanSecs, Bool
True) -> do
      let unfold :: ReportBud
-> IO
     (Either
        [ProcessID]
        ((Map (ProcessID, Text) MemUsage, [ProcessID]), ReportBud))
unfold = ProcNamer
-> Indexer (ProcessID, Text)
-> Natural
-> ReportBud
-> IO
     (Either
        [ProcessID]
        ((Map (ProcessID, Text) MemUsage, [ProcessID]), ReportBud))
forall a seconds.
(Ord a, Integral seconds) =>
ProcNamer
-> Indexer a
-> seconds
-> ReportBud
-> IO
     (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfoldMemUsageAfter' ProcNamer
namer Indexer (ProcessID, Text)
withPid Natural
spanSecs
      (ReportBud
 -> IO
      (Either
         [ProcessID]
         ((Map (ProcessID, Text) MemUsage, [ProcessID]), ReportBud)))
-> ReportBud -> (Map (ProcessID, Text) 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 (ProcessID, Text) MemUsage, [ProcessID]), ReportBud))
unfold ReportBud
bud Map (ProcessID, Text) MemUsage -> IO ()
forall {a}. AsCmdName a => Map a MemUsage -> IO ()
showTotal
    (Just Natural
spanSecs, Bool
_) -> do
      let unfold :: ReportBud
-> IO
     (Either [ProcessID] ((Map Text MemUsage, [ProcessID]), ReportBud))
unfold = ProcNamer
-> Indexer Text
-> Natural
-> ReportBud
-> IO
     (Either [ProcessID] ((Map Text MemUsage, [ProcessID]), ReportBud))
forall a seconds.
(Ord a, Integral seconds) =>
ProcNamer
-> Indexer a
-> seconds
-> ReportBud
-> IO
     (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfoldMemUsageAfter' ProcNamer
namer Indexer Text
dropId Natural
spanSecs
      (ReportBud
 -> IO
      (Either [ProcessID] ((Map Text MemUsage, [ProcessID]), ReportBud)))
-> ReportBud -> (Map Text 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 Text MemUsage, [ProcessID]), ReportBud))
unfold ReportBud
bud Map Text MemUsage -> IO ()
forall {a}. AsCmdName a => Map a MemUsage -> IO ()
showTotal


printMemUsages :: AsCmdName a => ReportBud -> Bool -> Bool -> Map a MemUsage -> IO ()
printMemUsages :: forall a.
AsCmdName a =>
ReportBud -> Bool -> Bool -> Map a MemUsage -> IO ()
printMemUsages ReportBud
bud Bool
showSwap Bool
onlyTotal Map a MemUsage
totals = do
  let overall :: (Int, Int)
overall = [MemUsage] -> (Int, Int)
overallTotals ([MemUsage] -> (Int, Int)) -> [MemUsage] -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ Map a MemUsage -> [MemUsage]
forall k a. Map k a -> [a]
Map.elems Map a MemUsage
totals
      overallIsAccurate :: Bool
overallIsAccurate = (Bool
showSwap Bool -> Bool -> Bool
&& ReportBud -> Bool
rbHasSwapPss ReportBud
bud) Bool -> Bool -> Bool
|| ReportBud -> Bool
rbHasPss ReportBud
bud
      print' :: (a, MemUsage) -> IO ()
print' (a
name, MemUsage
stats) = 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
stats
  Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Text
fmtAsHeader Bool
showSwap
  ((a, MemUsage) -> IO ()) -> [(a, MemUsage)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (a, MemUsage) -> IO ()
forall {a}. AsCmdName a => (a, MemUsage) -> IO ()
print' ([(a, MemUsage)] -> IO ()) -> [(a, MemUsage)] -> IO ()
forall a b. (a -> b) -> a -> b
$ Map a MemUsage -> [(a, MemUsage)]
forall k a. Map k a -> [(k, a)]
Map.toList Map a MemUsage
totals
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
overallIsAccurate (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> (Int, Int) -> Text
fmtOverall Bool
showSwap (Int, Int)
overall
  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 :: ReportBud -> Bool -> Bool -> Map k MemUsage -> IO ()
onlyPrintTotal :: forall k. ReportBud -> Bool -> Bool -> Map k MemUsage -> IO ()
onlyPrintTotal ReportBud
bud Bool
showSwap Bool
onlyTotal Map 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
$ Map k MemUsage -> [MemUsage]
forall k a. Map k a -> [a]
Map.elems Map 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 = FilePath -> IO ()
putStrLn FilePath
"\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 'ProcName' and 'Indexer'
unfoldMemUsageAfter ::
  (Integral seconds) =>
  seconds ->
  ReportBud ->
  IO (Either [ProcessID] ((Map Text 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, 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, Integral seconds) =>
  ProcNamer ->
  Indexer a ->
  seconds ->
  ReportBud ->
  IO (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfoldMemUsageAfter' :: forall a seconds.
(Ord 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


-- | Load the @'MemUsage'@ of a program specified by its @ProcessID@
readForOnePid :: ProcessID -> IO (Either NotRun (ProcName, MemUsage))
readForOnePid :: ProcessID -> IO (Either NotRun (Text, MemUsage))
readForOnePid ProcessID
pid = do
  let mkBud' :: NonEmpty ProcessID -> IO (Either NotRun ReportBud)
mkBud' NonEmpty ProcessID
xs = NonEmpty ProcessID -> IO (Maybe ReportBud)
mkReportBud 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 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 /proc 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
namer ReportBud
bud ProcessID
pid = do
  ProcNamer
namer 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 ->
      ReportBud -> ProcessID -> IO (Either LostPid ProcUsage)
readMemStats ReportBud
bud ProcessID
pid IO (Either LostPid ProcUsage)
-> (Either LostPid ProcUsage
    -> 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 ProcUsage
stats -> 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
$ (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 = Maybe (NonEmpty ProcessID) -> IO (Either NotRun ReportBud)
verify' (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' :: Maybe (NonEmpty ProcessID) -> IO (Either NotRun ReportBud)
verify' :: Maybe (NonEmpty ProcessID) -> IO (Either NotRun ReportBud)
verify' Maybe (NonEmpty ProcessID)
pidsMb = do
  let mkBud' :: NonEmpty ProcessID -> IO (Either NotRun ReportBud)
mkBud' NonEmpty ProcessID
xs = NonEmpty ProcessID -> IO (Maybe ReportBud)
mkReportBud 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 -> NonEmpty ProcessID -> IO (Either NotRun (NonEmpty ProcessID))
checkAllExist 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 -> IO (Either NotRun ReportBud) -> IO (Either NotRun ReportBud)
forall a. IO (Either NotRun a) -> IO (Either NotRun a)
whenRoot (IO (Either NotRun ReportBud) -> IO (Either NotRun ReportBud))
-> IO (Either NotRun ReportBud) -> IO (Either NotRun ReportBud)
forall a b. (a -> b) -> a -> b
$ IO (Either NotRun (NonEmpty ProcessID))
allKnownProcs 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


procRoot :: String
procRoot :: FilePath
procRoot = FilePath
"/proc/"


pidPath :: String -> ProcessID -> FilePath
pidPath :: FilePath -> ProcessID -> FilePath
pidPath FilePath
base ProcessID
pid = Builder
"" Builder -> Builder -> FilePath
forall b. FromBuilder b => Builder -> Builder -> b
+| FilePath
procRoot FilePath -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> 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
+| FilePath
base FilePath -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""


whenRoot :: IO (Either NotRun a) -> IO (Either NotRun a)
whenRoot :: forall a. IO (Either NotRun a) -> IO (Either NotRun a)
whenRoot IO (Either NotRun a)
action = do
  -- if choicePidsToShow is Nothing, must be running as root
  Bool
isRoot' <- (UserID -> UserID -> Bool
forall a. Eq a => a -> a -> Bool
== UserID
0) (UserID -> Bool) -> IO UserID -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UserID
getEffectiveUserID
  if Bool
isRoot' then IO (Either NotRun a)
action else Either NotRun a -> IO (Either NotRun a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either NotRun a -> IO (Either NotRun a))
-> Either NotRun a -> IO (Either NotRun a)
forall a b. (a -> b) -> a -> b
$ NotRun -> Either NotRun a
forall a b. a -> Either a b
Left NotRun
NeedsRoot


{- | pidExists returns false for any ProcessID that does not exist or cannot
be accessed
-}
pidExeExists :: ProcessID -> IO Bool
pidExeExists :: ProcessID -> IO Bool
pidExeExists = (Either LostPid ExeInfo -> Bool)
-> IO (Either LostPid ExeInfo) -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((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)) (IO (Either LostPid ExeInfo) -> IO Bool)
-> (ProcessID -> IO (Either LostPid ExeInfo))
-> ProcessID
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessID -> IO (Either LostPid ExeInfo)
exeInfo


-- | Obtain the @ProcName@ as the full cmd path
nameAsFullCmd :: ProcNamer
nameAsFullCmd :: ProcNamer
nameAsFullCmd ProcessID
pid = do
  let cmdlinePath :: FilePath
cmdlinePath = FilePath -> ProcessID -> FilePath
pidPath FilePath
"cmdline" ProcessID
pid
      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)
  FilePath -> IO Text
readUtf8Text FilePath
cmdlinePath 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


{- | Obtain the @ProcName@ by examining the path linked by
__{proc_root}\/pid\/exe__
-}
nameFromExeOnly :: ProcNamer
nameFromExeOnly :: ProcNamer
nameFromExeOnly ProcessID
pid = do
  ProcessID -> IO (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
    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
>>= \case
        Bool
True -> 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]"
        Bool
_ -> do
          let cmdlinePath :: FilePath
cmdlinePath = FilePath -> ProcessID -> FilePath
pidPath FilePath
"cmdline" ProcessID
pid
          FilePath -> IO Text
readUtf8Text FilePath
cmdlinePath IO Text
-> (Text -> Maybe (NonEmpty Text)) -> IO (Maybe (NonEmpty Text))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> Maybe (NonEmpty Text)
parseCmdline IO (Maybe (NonEmpty Text))
-> (Maybe (NonEmpty 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
            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
    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


-- | Functions that obtain a process name given its @pid@
type ProcNamer = 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 ProcessID
pid =
  ProcNamer
nameFromExeOnly 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) (ProcessID -> Text -> IO (Either LostPid Text)
parentNameIfMatched ProcessID
pid)


parentNameIfMatched :: ProcessID -> Text -> IO (Either LostPid ProcName)
parentNameIfMatched :: ProcessID -> Text -> IO (Either LostPid Text)
parentNameIfMatched 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
  ProcessID -> IO (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 (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
_ -> 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 -> FilePath
(Int -> NotRun -> ShowS)
-> (NotRun -> FilePath) -> ([NotRun] -> ShowS) -> Show NotRun
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NotRun -> ShowS
showsPrec :: Int -> NotRun -> ShowS
$cshow :: NotRun -> FilePath
show :: NotRun -> FilePath
$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 -> FilePath
(Int -> LostPid -> ShowS)
-> (LostPid -> FilePath) -> ([LostPid] -> ShowS) -> Show LostPid
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LostPid -> ShowS
showsPrec :: Int -> LostPid -> ShowS
$cshow :: LostPid -> FilePath
show :: LostPid -> FilePath
$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 :: ProcessID -> IO (Either LostPid ExeInfo)
exeInfo :: ProcessID -> IO (Either LostPid ExeInfo)
exeInfo ProcessID
pid = do
  let exePath :: FilePath
exePath = FilePath -> ProcessID -> FilePath
pidPath FilePath
"exe" ProcessID
pid
      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 ExeInfo))
-> IO (Either LostPid ExeInfo) -> IO (Either LostPid ExeInfo)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle IOError -> IO (Either LostPid ExeInfo)
forall {b}. IOError -> IO (Either LostPid b)
onIOE (IO (Either LostPid ExeInfo) -> IO (Either LostPid ExeInfo))
-> IO (Either LostPid ExeInfo) -> IO (Either LostPid ExeInfo)
forall a b. (a -> b) -> a -> b
$ do
    ExeInfo -> Either LostPid ExeInfo
forall a b. b -> Either a b
Right (ExeInfo -> Either LostPid ExeInfo)
-> (FilePath -> ExeInfo) -> FilePath -> Either LostPid ExeInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ExeInfo
parseExeInfo (Text -> ExeInfo) -> (FilePath -> Text) -> FilePath -> ExeInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
Text.pack (FilePath -> Either LostPid ExeInfo)
-> IO FilePath -> IO (Either LostPid ExeInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
getSymbolicLinkTarget FilePath
exePath


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


statusInfo :: ProcessID -> IO (Either LostPid StatusInfo)
statusInfo :: ProcessID -> IO (Either LostPid StatusInfo)
statusInfo ProcessID
pid = do
  let statusPath :: FilePath
statusPath = FilePath -> ProcessID -> FilePath
pidPath FilePath
"status" ProcessID
pid
      fromBadStatus :: BadStatus -> LostPid
fromBadStatus BadStatus
NoCmd = ProcessID -> LostPid
NoStatusCmd ProcessID
pid
      fromBadStatus BadStatus
NoParent = ProcessID -> LostPid
NoStatusParent 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)
-> IO Text -> IO (Either LostPid StatusInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Text
readUtf8Text FilePath
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 :: NonEmpty ProcessID -> IO [ProcessID]
nonExisting :: NonEmpty ProcessID -> IO [ProcessID]
nonExisting = (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
. ProcessID -> IO Bool
pidExeExists) ([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 :: NonEmpty ProcessID -> IO (Either NotRun (NonEmpty ProcessID))
checkAllExist :: NonEmpty ProcessID -> IO (Either NotRun (NonEmpty ProcessID))
checkAllExist NonEmpty ProcessID
pids =
  NonEmpty ProcessID -> IO [ProcessID]
nonExisting 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 :: IO (Either NotRun (NonEmpty ProcessID))
allKnownProcs :: IO (Either NotRun (NonEmpty ProcessID))
allKnownProcs =
  let readNaturals :: IO [FilePath] -> IO [ProcessID]
readNaturals = ([FilePath] -> [ProcessID]) -> IO [FilePath] -> IO [ProcessID]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath -> Maybe ProcessID) -> [FilePath] -> [ProcessID]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FilePath -> Maybe ProcessID
forall a. Read a => FilePath -> Maybe a
readMaybe)
      orNoPids :: Maybe b -> Either NotRun b
orNoPids = Either NotRun b
-> (b -> Either NotRun b) -> Maybe b -> Either NotRun b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NotRun -> Either NotRun b
forall a b. a -> Either a b
Left NotRun
NoRecords) b -> Either NotRun b
forall a b. b -> Either a b
Right
   in IO [FilePath] -> IO [ProcessID]
readNaturals (FilePath -> IO [FilePath]
listDirectory FilePath
procRoot)
        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 ProcessID -> IO Bool
pidExeExists
        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
>>= 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)))
-> ([ProcessID] -> Either NotRun (NonEmpty ProcessID))
-> [ProcessID]
-> IO (Either NotRun (NonEmpty ProcessID))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (NonEmpty ProcessID) -> Either NotRun (NonEmpty ProcessID)
forall {b}. Maybe b -> Either NotRun b
orNoPids (Maybe (NonEmpty ProcessID) -> Either NotRun (NonEmpty ProcessID))
-> ([ProcessID] -> Maybe (NonEmpty ProcessID))
-> [ProcessID]
-> Either NotRun (NonEmpty ProcessID)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ProcessID] -> Maybe (NonEmpty ProcessID)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty


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


readMemStats :: ReportBud -> ProcessID -> IO (Either LostPid ProcUsage)
readMemStats :: ReportBud -> ProcessID -> IO (Either LostPid ProcUsage)
readMemStats ReportBud
bud ProcessID
pid = do
  Bool
statmExists <- FilePath -> IO Bool
doesFileExist (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> ProcessID -> FilePath
pidPath FilePath
"statm" ProcessID
pid
  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)
-> IO Text -> IO (Either LostPid ProcUsage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProcessID -> IO Text
readSmaps ProcessID
pid
      | Bool
statmExists -> do
          let readStatm' :: IO Text
readStatm' = FilePath -> IO Text
readUtf8Text (FilePath -> IO Text) -> FilePath -> IO Text
forall a b. (a -> b) -> a -> b
$ FilePath -> ProcessID -> FilePath
pidPath FilePath
"statm" ProcessID
pid
              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)
-> IO Text -> IO (Either LostPid ProcUsage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Text
readStatm'
      | Bool
otherwise -> Either LostPid ProcUsage -> IO (Either LostPid ProcUsage)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid ProcUsage -> IO (Either LostPid ProcUsage))
-> Either LostPid ProcUsage -> IO (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 :: ProcessID -> IO Text
readSmaps :: ProcessID -> IO Text
readSmaps ProcessID
pid = do
  let smapPath :: FilePath
smapPath = FilePath -> ProcessID -> FilePath
pidPath FilePath
"smaps" ProcessID
pid
      rollupPath :: FilePath
rollupPath = FilePath -> ProcessID -> FilePath
pidPath FilePath
"smaps_rollup" ProcessID
pid
  Bool
hasSmaps <- FilePath -> IO Bool
doesFileExist FilePath
smapPath
  Bool
hasRollup <- FilePath -> IO Bool
doesFileExist FilePath
rollupPath
  if
      | Bool
hasRollup -> FilePath -> IO Text
readUtf8Text FilePath
rollupPath
      | Bool
hasSmaps -> FilePath -> IO Text
readUtf8Text FilePath
smapPath
      | Bool
otherwise -> Text -> IO Text
forall a. a -> IO 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)