{-# 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 = 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 = 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 forall {k}. Map k MemUsage -> IO ()
printTheTotal Map a MemUsage
cmds else 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) -> forall a.
Ord a =>
ProcNamer
-> Indexer a -> ReportBud -> IO (Either LostPid (Map a MemUsage))
readMemUsage' ProcNamer
namer Indexer (ProcessID, Text)
withPid ReportBud
bud forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. LostPid -> IO a
haltLostPid forall {a}. AsCmdName a => Map a MemUsage -> IO ()
showTotal
    (Maybe Natural
Nothing, Bool
_) -> forall a.
Ord a =>
ProcNamer
-> Indexer a -> ReportBud -> IO (Either LostPid (Map a MemUsage))
readMemUsage' ProcNamer
namer Indexer Text
dropId ReportBud
bud forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. LostPid -> IO a
haltLostPid 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 = 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
      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 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 = 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
      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 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 forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ forall a. AsCmdName a => Bool -> a -> MemUsage -> Text
fmtMemUsage Bool
showSwap a
name MemUsage
stats
  Text -> IO ()
Text.putStrLn forall a b. (a -> b) -> a -> b
$ Bool -> Text
fmtAsHeader Bool
showSwap
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {a}. AsCmdName a => (a, MemUsage) -> IO ()
print' forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map a MemUsage
totals
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
overallIsAccurate forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.putStrLn 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 forall a b. (a -> b) -> a -> b
$ 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map k MemUsage
totals
      printRawTotal :: Int -> IO ()
printRawTotal = Text -> IO ()
Text.putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text
fmtMemBytes
  if Bool
showSwap
    then do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ReportBud -> Bool
rbHasSwapPss ReportBud
bud) forall a b. (a -> b) -> a -> b
$ Int -> IO ()
printRawTotal Int
swap
      ReportBud -> Bool -> Bool -> IO ()
reportFlaws ReportBud
bud Bool
showSwap Bool
onlyTotal
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ ReportBud -> Maybe SwapFlaw
rbSwapFlaws ReportBud
bud) forall a. IO a
exitFailure
    else do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ReportBud -> Bool
rbHasPss ReportBud
bud) forall a b. (a -> b) -> a -> b
$ Int -> IO ()
printRawTotal Int
private
      ReportBud -> Bool -> Bool -> IO ()
reportFlaws ReportBud
bud Bool
showSwap Bool
onlyTotal
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ ReportBud -> Maybe RamFlaw
rbRamFlaws ReportBud
bud) 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 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 = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ProcessID]
pids) forall a b. (a -> b) -> a -> b
$ do
  let errMsg :: Text
errMsg = Builder
"some processes stopped:pids:" forall b. FromBuilder b => Builder -> Builder -> b
+| forall a. Integral a => a -> Integer
toInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ProcessID]
pids 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 = 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 forall a. Num a => a -> a -> a
* forall a. Num a => Integer -> a
fromInteger (forall a. Integral a => a -> Integer
toInteger seconds
spanSecs)
  Int -> IO ()
threadDelay Int
spanMicros
  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 {NonEmpty ProcessID
rbPids :: NonEmpty ProcessID
rbPids :: NonEmpty ProcessID
rbPids}
      dropStopped :: ReportBud -> [ProcessID] -> Maybe ReportBud
dropStopped ReportBud
t [] = forall a. a -> Maybe a
Just ReportBud
t
      dropStopped ReportBud {rbPids :: ReportBud -> NonEmpty ProcessID
rbPids = NonEmpty ProcessID
ps} [ProcessID]
stopped =
        NonEmpty ProcessID -> ReportBud
changePids forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.filter (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, []) = 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 -> forall a b. b -> Either a b
Right ((forall a. Ord a => Bool -> [(a, ProcUsage)] -> Map a MemUsage
amass Bool
hasPss (forall a b. (a -> b) -> [a] -> [b]
map Indexer a
mkCmd [(ProcessID, Text, ProcUsage)]
xs), [ProcessID]
stopped), ReportBud
updated)
        Maybe ReportBud
Nothing -> forall a b. a -> Either a b
Left [ProcessID]
stopped
  ([ProcessID], [(ProcessID, Text, ProcUsage)])
-> Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud)
nextState forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left NotRun
OddKernel) 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ LostPid -> NotRun
PidLost LostPid
noProc) forall a b. b -> Either a b
Right (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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. LostPid -> NotRun
PidLost) forall {k} {a}. Map k a -> Either NotRun (k, a)
fromMemUsage
  ProcNamer
nameFor ProcessID
pid forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left LostPid
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ LostPid -> NotRun
PidLost LostPid
err
    Right Text
_ ->
      NonEmpty ProcessID -> IO (Either NotRun ReportBud)
mkBud' (ProcessID
pid forall a. a -> [a] -> NonEmpty a
:| []) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left NotRun
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left NotRun
err
        Right ReportBud
bud -> ReportBud -> IO (Either LostPid (Map Text MemUsage))
readMemUsage ReportBud
bud forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> 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 = 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 = forall a. Ord a => Bool -> [(a, ProcUsage)] -> Map a MemUsage
amass (ReportBud -> Bool
rbHasPss ReportBud
bud) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Indexer a
mkCmd [(ProcessID, Text, ProcUsage)]
cmds
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(ProcessID, Text, ProcUsage)] -> Map a MemUsage
amass' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left LostPid
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left LostPid
e
    Right Text
name ->
      ReportBud -> ProcessID -> IO (Either LostPid ProcUsage)
readMemStats ReportBud
bud ProcessID
pid forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left LostPid
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left LostPid
e
        Right ProcUsage
stats -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. SwapFlaw -> Text
fmtSwapFlaws
      reportRam :: RamFlaw -> IO ()
reportRam = Bool -> Text -> IO ()
errStrLn Bool
onlyTotal 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
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
showSwap forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) SwapFlaw -> IO ()
reportSwap Maybe SwapFlaw
swap
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
onlyTotal Bool -> Bool -> Bool
&& Bool
showSwap) forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (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) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Text -> IO a
haltErr forall b c a. (b -> c) -> (a -> b) -> a -> c
. NotRun -> Text
fmtNotRun) 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 forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left NotRun
OddKernel) forall a b. b -> Either a b
Right
      thenMkBud :: Either NotRun (NonEmpty ProcessID) -> IO (Either NotRun ReportBud)
thenMkBud = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 -> forall a. IO (Either NotRun a) -> IO (Either NotRun a)
whenRoot forall a b. (a -> b) -> a -> b
$ IO (Either NotRun (NonEmpty ProcessID))
allKnownProcs 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
"" forall b. FromBuilder b => Builder -> Builder -> b
+| FilePath
procRoot forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|++| forall a. Integral a => a -> Integer
toInteger ProcessID
pid forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"/" forall b. FromBuilder b => Builder -> Builder -> b
+| FilePath
base 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' <- (forall a. Eq a => a -> a -> Bool
== UserID
0) 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 forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Bool
False) (forall a b. a -> b -> a
const Bool
True)) 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
" " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NE.toList
      orLostPid :: Maybe (NonEmpty Text) -> Either LostPid Text
orLostPid = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left LostPid
err) (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Text -> Text
recombine)
  FilePath -> IO Text
readUtf8Text FilePath
cmdlinePath forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (NonEmpty Text) -> Either LostPid Text
orLostPid) 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right ExeInfo
i | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ ExeInfo -> Bool
eiDeleted ExeInfo
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Text
baseName 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Text
baseName forall a b. (a -> b) -> a -> b
$ Builder
"" forall b. FromBuilder b => Builder -> Builder -> b
+| Text
orig 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 forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> Maybe (NonEmpty Text)
parseCmdline 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 forall a. Semigroup a => a -> a -> a
<> if Bool
b then Text
" [updated]" else Text
" [deleted]"
              forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
baseName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Text
addSuffix' 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ProcessID -> LostPid
NoCmdLine ProcessID
pid
    Left LostPid
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Text -> Bool
Text.isPrefixOf Text
candidate forall b c a. (b -> c) -> (a -> b) -> a -> c
. StatusInfo -> Text
siName
  ProcessID -> IO (Either LostPid StatusInfo)
statusInfo ProcessID
pid forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left LostPid
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left LostPid
err
    Right StatusInfo
si | StatusInfo -> Bool
isMatch StatusInfo
si -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Text
candidate
    Right StatusInfo
si ->
      ProcNamer
nameFromExeOnly (StatusInfo -> ProcessID
siParent StatusInfo
si) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right Text
n | Text
n forall a. Eq a => a -> a -> Bool
== Text
candidate -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Text
n
        Either LostPid Text
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NotRun -> NotRun -> Bool
$c/= :: NotRun -> NotRun -> Bool
== :: NotRun -> NotRun -> Bool
$c== :: NotRun -> NotRun -> Bool
Eq, Int -> NotRun -> ShowS
[NotRun] -> ShowS
NotRun -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [NotRun] -> ShowS
$cshowList :: [NotRun] -> ShowS
show :: NotRun -> FilePath
$cshow :: NotRun -> FilePath
showsPrec :: Int -> NotRun -> ShowS
$cshowsPrec :: Int -> 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: " forall b. FromBuilder b => Builder -> Builder -> b
+| forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
listF (forall a. Integral a => a -> Integer
toInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty ProcessID
pids) 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LostPid -> LostPid -> Bool
$c/= :: LostPid -> LostPid -> Bool
== :: LostPid -> LostPid -> Bool
$c== :: LostPid -> LostPid -> Bool
Eq, Int -> LostPid -> ShowS
[LostPid] -> ShowS
LostPid -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [LostPid] -> ShowS
$cshowList :: [LostPid] -> ShowS
show :: LostPid -> FilePath
$cshow :: LostPid -> FilePath
showsPrec :: Int -> LostPid -> ShowS
$cshowsPrec :: Int -> LostPid -> ShowS
Show)


fmtLostPid :: LostPid -> Text
fmtLostPid :: LostPid -> Text
fmtLostPid (NoStatusCmd ProcessID
pid) = Builder
"missing:no name in {proc_root}/" forall b. FromBuilder b => Builder -> Builder -> b
+| forall a. Integral a => a -> Integer
toInteger ProcessID
pid forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"/status"
fmtLostPid (NoStatusParent ProcessID
pid) = Builder
"missing:no ppid in {proc_root}/" forall b. FromBuilder b => Builder -> Builder -> b
+| forall a. Integral a => a -> Integer
toInteger ProcessID
pid forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"/status"
fmtLostPid (NoExeFile ProcessID
pid) = Builder
"missing:{proc_root}/" forall b. FromBuilder b => Builder -> Builder -> b
+| forall a. Integral a => a -> Integer
toInteger ProcessID
pid forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"/exe"
fmtLostPid (NoCmdLine ProcessID
pid) = Builder
"missing:{proc_root}/" forall b. FromBuilder b => Builder -> Builder -> b
+| forall a. Integral a => a -> Integer
toInteger ProcessID
pid forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"/cmdline"
fmtLostPid (NoProc ProcessID
pid) = Builder
"missing:memory records for pid:" forall b. FromBuilder b => Builder -> Builder -> b
+| forall a. Integral a => a -> Integer
toInteger ProcessID
pid forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
fmtLostPid (BadStatm ProcessID
pid) = Builder
"missing:invalid memory record in {proc_root}/" forall b. FromBuilder b => Builder -> Builder -> b
+| forall a. Integral a => a -> Integer
toInteger ProcessID
pid 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 forall a b. (a -> b) -> a -> b
$ Builder
"halting due to " forall b. FromBuilder b => Builder -> Builder -> b
+| LostPid -> Text
fmtLostPid LostPid
err forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
  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 forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ProcessID -> LostPid
NoExeFile ProcessID
pid) else forall e a. Exception e => e -> IO a
throwIO IOError
e
  forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle forall {b}. IOError -> IO (Either LostPid b)
onIOE forall a b. (a -> b) -> a -> b
$ do
    forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ExeInfo
parseExeInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
Text.pack 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 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
  forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first BadStatus -> LostPid
fromBadStatus forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either BadStatus StatusInfo
parseStatusInfo 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
Text.dropWhileEnd Char -> Bool
isNull
   in forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
split'


nonExisting :: NonEmpty ProcessID -> IO [ProcessID]
nonExisting :: NonEmpty ProcessID -> IO [ProcessID]
nonExisting = forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessID -> IO Bool
pidExeExists) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right NonEmpty ProcessID
pids
    ProcessID
x : [ProcessID]
xs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ NonEmpty ProcessID -> NotRun
MissingPids forall a b. (a -> b) -> a -> b
$ ProcessID
x 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a. Read a => FilePath -> Maybe a
readMaybe)
      orNoPids :: Maybe b -> Either NotRun b
orNoPids = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left NotRun
NoRecords) forall a b. b -> Either a b
Right
   in IO [FilePath] -> IO [ProcessID]
readNaturals (FilePath -> IO [FilePath]
listDirectory FilePath
procRoot)
        forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ProcessID -> IO Bool
pidExeExists
        forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. Maybe b -> Either NotRun b
orNoPids forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe (NonEmpty a)
nonEmpty


baseName :: Text -> Text
baseName :: Text -> Text
baseName = FilePath -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
takeBaseName 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 forall a b. (a -> b) -> a -> b
$ FilePath -> ProcessID -> FilePath
pidPath FilePath
"statm" ProcessID
pid
  if
      | ReportBud -> Bool
rbHasSmaps ReportBud
bud -> forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ProcUsage
parseFromSmap 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 forall a b. (a -> b) -> a -> b
$ FilePath -> ProcessID -> FilePath
pidPath FilePath
"statm" ProcessID
pid
              orLostPid :: Maybe b -> Either LostPid b
orLostPid = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ProcessID -> LostPid
BadStatm ProcessID
pid) forall a b. b -> Either a b
Right
          forall {b}. Maybe b -> Either LostPid b
orLostPid forall b c a. (b -> c) -> (a -> b) -> a -> c
. KernelVersion -> Text -> Maybe ProcUsage
parseFromStatm (ReportBud -> KernelVersion
rbKernel ReportBud
bud) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Text
readStatm'
      | Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left 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 -> 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 forall a. Num a => a -> a -> a
+ MemUsage -> Int
muPrivate MemUsage
ct, Int
swap forall a. Num a => a -> a -> a
+ MemUsage -> Int
muSwap MemUsage
ct)
   in 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
"" forall b. FromBuilder b => Builder -> Builder -> b
+| Int
x forall a. Num a => a -> a -> a
* Int
1024 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
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left b
err
      go (Right [c]
acc) a
a =
        a -> m (Either b c)
f a
a forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left b
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left b
err
          Right c
y -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (c
y forall a. a -> [a] -> [a]
: [c]
acc)
   in 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 (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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left b
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a forall a. a -> [a] -> [a]
: [a]
as, [c]
cs)
        Right c
c -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a]
as, c
c forall a. a -> [a] -> [a]
: [c]
cs)
   in
    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 (forall a. Monoid a => a
mempty, 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
  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 forall a b. (a -> b) -> a -> b
$ Text
prefix 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)