{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module System.MemInfo (
getChoices,
printProcs,
readForOnePid,
readMemUsage',
readMemUsage,
NotRun (..),
LostPid (..),
unfoldMemUsage,
unfoldMemUsageAfter',
unfoldMemUsageAfter,
ProcNamer,
nameFromExeOnly,
nameFor,
nameAsFullCmd,
ProcName,
Indexer,
dropId,
withPid,
printUsage',
printUsage,
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)
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
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
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
type ProcName = Text
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
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
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
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
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
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)
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
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
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
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
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
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
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
type ProcNamer = ProcessID -> IO (Either LostPid ProcName)
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
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"
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
type Indexer index = (ProcessID, ProcName, ProcUsage) -> (index, ProcUsage)
withPid :: Indexer (ProcessID, ProcName)
withPid :: Indexer (ProcessID, Text)
withPid (ProcessID
pid, Text
name, ProcUsage
pp) = ((ProcessID
pid, Text
name), ProcUsage
pp)
dropId :: Indexer ProcName
dropId :: Indexer Text
dropId (ProcessID
_pid, Text
name, ProcUsage
pp) = (Text
name, ProcUsage
pp)