{-# 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 Data.List (sortBy)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Ord (Down (..), comparing)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Fmt (
listF,
(+|),
(|+),
(|++|),
)
import System.Exit (exitFailure)
import System.MemInfo.Choices (
Choices (..),
PrintOrder (..),
Style (..),
getChoices,
)
import System.MemInfo.Prelude
import System.MemInfo.Print (
AsCmdName (..),
fmtMemUsage,
styleOutput,
)
import System.MemInfo.Proc (
BadStatus (..),
ExeInfo (..),
MemUsage (..),
ProcUsage (..),
StatusInfo (..),
amass,
parseExeInfo,
parseFromSmap,
parseFromStatm,
parseStatusInfo,
)
import System.MemInfo.SysInfo (
ReportBud (..),
fmtRamFlaws,
fmtSwapFlaws,
mkReportBud,
)
printProcs :: Choices -> IO ()
printProcs :: Choices -> IO ()
printProcs cs :: Choices
cs@Choices {choiceByPid :: Choices -> Bool
choiceByPid = Bool
byPid} = do
ReportBud
bud <- Choices -> IO ReportBud
verify Choices
cs
if Bool
byPid
then Indexer (ProcessID, Text) -> ReportBud -> Choices -> IO ()
forall a.
(Ord a, AsCmdName a) =>
Indexer a -> ReportBud -> Choices -> IO ()
printProcs' Indexer (ProcessID, Text)
withPid ReportBud
bud Choices
cs
else Indexer Text -> ReportBud -> Choices -> IO ()
forall a.
(Ord a, AsCmdName a) =>
Indexer a -> ReportBud -> Choices -> IO ()
printProcs' Indexer Text
dropId ReportBud
bud Choices
cs
printProcs' :: (Ord a, AsCmdName a) => Indexer a -> ReportBud -> Choices -> IO ()
printProcs' :: forall a.
(Ord a, AsCmdName a) =>
Indexer a -> ReportBud -> Choices -> IO ()
printProcs' Indexer a
indexer ReportBud
bud Choices
cs = do
let Choices
{ choiceShowSwap :: Choices -> Bool
choiceShowSwap = Bool
showSwap
, choiceOnlyTotal :: Choices -> Bool
choiceOnlyTotal = Bool
onlyTotal
, choiceWatchSecs :: Choices -> Maybe Natural
choiceWatchSecs = Maybe Natural
watchSecsMb
, choicePrintOrder :: Choices -> Maybe PrintOrder
choicePrintOrder = Maybe PrintOrder
printOrder
, choiceReversed :: Choices -> Bool
choiceReversed = Bool
reversed
, choiceStyle :: Choices -> Maybe Style
choiceStyle = Maybe Style
style
} = Choices
cs
style' :: Style
style' = Style -> Maybe Style -> Style
forall a. a -> Maybe a -> a
fromMaybe Style
Normal Maybe Style
style
toList :: Map a MemUsage -> [(a, MemUsage)]
toList = ((a, MemUsage) -> (a, MemUsage) -> Ordering)
-> [(a, MemUsage)] -> [(a, MemUsage)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Bool
-> Maybe PrintOrder -> (a, MemUsage) -> (a, MemUsage) -> Ordering
forall a.
Ord a =>
Bool
-> Maybe PrintOrder -> (a, MemUsage) -> (a, MemUsage) -> Ordering
byPrintOrder' Bool
reversed Maybe PrintOrder
printOrder) ([(a, MemUsage)] -> [(a, MemUsage)])
-> (Map a MemUsage -> [(a, MemUsage)])
-> Map a MemUsage
-> [(a, MemUsage)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a MemUsage -> [(a, MemUsage)]
forall k a. Map k a -> [(k, a)]
Map.toList
printEachCmd :: Map a MemUsage -> IO ()
printEachCmd = ReportBud -> Style -> Bool -> Bool -> [(a, MemUsage)] -> IO ()
forall a.
AsCmdName a =>
ReportBud -> Style -> Bool -> Bool -> [(a, MemUsage)] -> IO ()
printMemUsages ReportBud
bud Style
style' Bool
showSwap Bool
onlyTotal ([(a, MemUsage)] -> IO ())
-> (Map a MemUsage -> [(a, MemUsage)]) -> Map a MemUsage -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a MemUsage -> [(a, MemUsage)]
toList
printTheTotal :: Map a MemUsage -> IO ()
printTheTotal = ReportBud -> Bool -> Bool -> [(a, MemUsage)] -> IO ()
forall k.
AsCmdName k =>
ReportBud -> Bool -> Bool -> [(k, MemUsage)] -> IO ()
onlyPrintTotal ReportBud
bud Bool
showSwap Bool
onlyTotal ([(a, MemUsage)] -> IO ())
-> (Map a MemUsage -> [(a, MemUsage)]) -> Map a MemUsage -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a MemUsage -> [(a, MemUsage)]
toList
showTotal :: Map a MemUsage -> IO ()
showTotal = if Bool
onlyTotal then Map a MemUsage -> IO ()
printTheTotal else Map a MemUsage -> IO ()
printEachCmd
namer :: ProcNamer
namer = if Choices -> Bool
choiceSplitArgs Choices
cs then ProcNamer
nameAsFullCmd else ProcNamer
nameFor
case Maybe Natural
watchSecsMb of
Maybe Natural
Nothing -> ProcNamer
-> Indexer a -> ReportBud -> IO (Either LostPid (Map a MemUsage))
forall a.
Ord a =>
ProcNamer
-> Indexer a -> ReportBud -> IO (Either LostPid (Map a MemUsage))
readMemUsage' ProcNamer
namer Indexer a
indexer ReportBud
bud IO (Either LostPid (Map a MemUsage))
-> (Either LostPid (Map a MemUsage) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (LostPid -> IO ())
-> (Map a MemUsage -> IO ())
-> Either LostPid (Map a MemUsage)
-> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either LostPid -> IO ()
forall a. LostPid -> IO a
haltLostPid Map a MemUsage -> IO ()
showTotal
(Just Natural
spanSecs) -> do
let unfold :: ReportBud
-> IO
(Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfold = ProcNamer
-> Indexer a
-> Natural
-> ReportBud
-> IO
(Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
forall a seconds.
(Ord a, AsCmdName a, Integral seconds) =>
ProcNamer
-> Indexer a
-> seconds
-> ReportBud
-> IO
(Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfoldMemUsageAfter' ProcNamer
namer Indexer a
indexer Natural
spanSecs
(ReportBud
-> IO
(Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud)))
-> ReportBud -> (Map a MemUsage -> IO ()) -> IO ()
forall c.
(Ord c, AsCmdName c) =>
(ReportBud
-> IO
(Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud)))
-> ReportBud -> (Map c MemUsage -> IO ()) -> IO ()
loopPrintMemUsages ReportBud
-> IO
(Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfold ReportBud
bud Map a MemUsage -> IO ()
showTotal
printMemUsages ::
(AsCmdName a) =>
ReportBud ->
Style ->
Bool ->
Bool ->
[(a, MemUsage)] ->
IO ()
printMemUsages :: forall a.
AsCmdName a =>
ReportBud -> Style -> Bool -> Bool -> [(a, MemUsage)] -> IO ()
printMemUsages ReportBud
bud Style
style Bool
showSwap Bool
onlyTotal [(a, MemUsage)]
totals = do
let overallIsAccurate :: Bool
overallIsAccurate = (Bool
showSwap Bool -> Bool -> Bool
&& ReportBud -> Bool
rbHasSwapPss ReportBud
bud) Bool -> Bool -> Bool
|| ReportBud -> Bool
rbHasPss ReportBud
bud
output :: [Text]
output = Bool -> Style -> Bool -> [(a, MemUsage)] -> [Text]
forall a.
AsCmdName a =>
Bool -> Style -> Bool -> [(a, MemUsage)] -> [Text]
styleOutput Bool
showSwap Style
style Bool
overallIsAccurate [(a, MemUsage)]
totals
(Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> IO ()
Text.putStrLn [Text]
output
ReportBud -> Bool -> Bool -> IO ()
reportFlaws ReportBud
bud Bool
showSwap Bool
onlyTotal
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 :: (AsCmdName k) => ReportBud -> Bool -> Bool -> [(k, MemUsage)] -> IO ()
onlyPrintTotal :: forall k.
AsCmdName k =>
ReportBud -> Bool -> Bool -> [(k, MemUsage)] -> IO ()
onlyPrintTotal ReportBud
bud Bool
showSwap Bool
onlyTotal [(k, MemUsage)]
totals = do
let (Int
private, Int
swap) = [MemUsage] -> (Int, Int)
overallTotals ([MemUsage] -> (Int, Int)) -> [MemUsage] -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ ((k, MemUsage) -> MemUsage) -> [(k, MemUsage)] -> [MemUsage]
forall a b. (a -> b) -> [a] -> [b]
map (k, MemUsage) -> MemUsage
forall a b. (a, b) -> b
snd [(k, MemUsage)]
totals
printRawTotal :: Int -> IO ()
printRawTotal = Text -> IO ()
Text.putStrLn (Text -> IO ()) -> (Int -> Text) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text
fmtMemBytes
if Bool
showSwap
then do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ReportBud -> Bool
rbHasSwapPss ReportBud
bud) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
printRawTotal Int
swap
ReportBud -> Bool -> Bool -> IO ()
reportFlaws ReportBud
bud Bool
showSwap Bool
onlyTotal
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe SwapFlaw -> Bool
forall a. Maybe a -> Bool
isJust (Maybe SwapFlaw -> Bool) -> Maybe SwapFlaw -> Bool
forall a b. (a -> b) -> a -> b
$ ReportBud -> Maybe SwapFlaw
rbSwapFlaws ReportBud
bud) IO ()
forall a. IO a
exitFailure
else do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ReportBud -> Bool
rbHasPss ReportBud
bud) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
printRawTotal Int
private
ReportBud -> Bool -> Bool -> IO ()
reportFlaws ReportBud
bud Bool
showSwap Bool
onlyTotal
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe RamFlaw -> Bool
forall a. Maybe a -> Bool
isJust (Maybe RamFlaw -> Bool) -> Maybe RamFlaw -> Bool
forall a b. (a -> b) -> a -> b
$ ReportBud -> Maybe RamFlaw
rbRamFlaws ReportBud
bud) IO ()
forall a. IO a
exitFailure
loopPrintMemUsages ::
(Ord c, AsCmdName c) =>
(ReportBud -> IO (Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud))) ->
ReportBud ->
(Map c MemUsage -> IO ()) ->
IO ()
loopPrintMemUsages :: forall c.
(Ord c, AsCmdName c) =>
(ReportBud
-> IO
(Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud)))
-> ReportBud -> (Map c MemUsage -> IO ()) -> IO ()
loopPrintMemUsages ReportBud
-> IO
(Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud))
unfold ReportBud
bud Map c MemUsage -> IO ()
showTotal = do
let clearScreen :: IO ()
clearScreen = 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 ProcName MemUsage, [ProcessID]), ReportBud))
unfoldMemUsageAfter :: forall seconds.
Integral seconds =>
seconds
-> ReportBud
-> IO
(Either [ProcessID] ((Map Text MemUsage, [ProcessID]), ReportBud))
unfoldMemUsageAfter = ProcNamer
-> Indexer Text
-> seconds
-> ReportBud
-> IO
(Either [ProcessID] ((Map Text MemUsage, [ProcessID]), ReportBud))
forall a seconds.
(Ord a, AsCmdName a, Integral seconds) =>
ProcNamer
-> Indexer a
-> seconds
-> ReportBud
-> IO
(Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfoldMemUsageAfter' ProcNamer
nameFor Indexer Text
dropId
unfoldMemUsageAfter' ::
(Ord a, AsCmdName a, Integral seconds) =>
ProcNamer ->
Indexer a ->
seconds ->
ReportBud ->
IO (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfoldMemUsageAfter' :: forall a seconds.
(Ord a, AsCmdName a, Integral seconds) =>
ProcNamer
-> Indexer a
-> seconds
-> ReportBud
-> IO
(Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfoldMemUsageAfter' ProcNamer
namer Indexer a
mkCmd seconds
spanSecs ReportBud
bud = do
let spanMicros :: Int
spanMicros = Int
1000000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Integer -> Int
forall a. Num a => Integer -> a
fromInteger (seconds -> Integer
forall a. Integral a => a -> Integer
toInteger seconds
spanSecs)
Int -> IO ()
threadDelay Int
spanMicros
ProcNamer
-> Indexer a
-> ReportBud
-> IO
(Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
forall a.
Ord a =>
ProcNamer
-> Indexer a
-> ReportBud
-> IO
(Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfoldMemUsage ProcNamer
namer Indexer a
mkCmd ReportBud
bud
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 (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
""
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)
byPrintOrder ::
(Ord c) =>
(((c, MemUsage) -> Int) -> (c, MemUsage) -> (c, MemUsage) -> Ordering) ->
PrintOrder ->
(c, MemUsage) ->
(c, MemUsage) ->
Ordering
byPrintOrder :: forall c.
Ord c =>
(((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering)
-> PrintOrder -> (c, MemUsage) -> (c, MemUsage) -> Ordering
byPrintOrder ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f PrintOrder
Swap = ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f (((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering)
-> ((c, MemUsage) -> Int)
-> (c, MemUsage)
-> (c, MemUsage)
-> Ordering
forall a b. (a -> b) -> a -> b
$ MemUsage -> Int
muSwap (MemUsage -> Int)
-> ((c, MemUsage) -> MemUsage) -> (c, MemUsage) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c, MemUsage) -> MemUsage
forall a b. (a, b) -> b
snd
byPrintOrder ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f PrintOrder
Shared = ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f (((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering)
-> ((c, MemUsage) -> Int)
-> (c, MemUsage)
-> (c, MemUsage)
-> Ordering
forall a b. (a -> b) -> a -> b
$ MemUsage -> Int
muShared (MemUsage -> Int)
-> ((c, MemUsage) -> MemUsage) -> (c, MemUsage) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c, MemUsage) -> MemUsage
forall a b. (a, b) -> b
snd
byPrintOrder ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f PrintOrder
Private = ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f (((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering)
-> ((c, MemUsage) -> Int)
-> (c, MemUsage)
-> (c, MemUsage)
-> Ordering
forall a b. (a -> b) -> a -> b
$ MemUsage -> Int
muPrivate (MemUsage -> Int)
-> ((c, MemUsage) -> MemUsage) -> (c, MemUsage) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c, MemUsage) -> MemUsage
forall a b. (a, b) -> b
snd
byPrintOrder ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f PrintOrder
Count = ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f (((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering)
-> ((c, MemUsage) -> Int)
-> (c, MemUsage)
-> (c, MemUsage)
-> Ordering
forall a b. (a -> b) -> a -> b
$ MemUsage -> Int
muCount (MemUsage -> Int)
-> ((c, MemUsage) -> MemUsage) -> (c, MemUsage) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c, MemUsage) -> MemUsage
forall a b. (a, b) -> b
snd
byPrintOrder' ::
(Ord a) =>
Bool ->
Maybe PrintOrder ->
(a, MemUsage) ->
(a, MemUsage) ->
Ordering
byPrintOrder' :: forall a.
Ord a =>
Bool
-> Maybe PrintOrder -> (a, MemUsage) -> (a, MemUsage) -> Ordering
byPrintOrder' Bool
reversed Maybe PrintOrder
mbOrder =
let cmpUsage :: (b -> Int) -> b -> b -> Ordering
cmpUsage = if Bool
reversed then (b -> Int) -> b -> b -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing else (b -> Int) -> b -> b -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing'
cmpName :: (b -> a) -> b -> b -> Ordering
cmpName = if Bool
reversed then (b -> a) -> b -> b -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing else (b -> a) -> b -> b -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing'
byName :: (a, b) -> (a, b) -> Ordering
byName = ((a, b) -> a) -> (a, b) -> (a, b) -> Ordering
forall {b}. (b -> a) -> b -> b -> Ordering
cmpName (a, b) -> a
forall a b. (a, b) -> a
fst
byUsage :: PrintOrder -> (a, MemUsage) -> (a, MemUsage) -> Ordering
byUsage = (((a, MemUsage) -> Int)
-> (a, MemUsage) -> (a, MemUsage) -> Ordering)
-> PrintOrder -> (a, MemUsage) -> (a, MemUsage) -> Ordering
forall c.
Ord c =>
(((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering)
-> PrintOrder -> (c, MemUsage) -> (c, MemUsage) -> Ordering
byPrintOrder ((a, MemUsage) -> Int)
-> (a, MemUsage) -> (a, MemUsage) -> Ordering
forall {b}. (b -> Int) -> b -> b -> Ordering
cmpUsage
in ((a, MemUsage) -> (a, MemUsage) -> Ordering)
-> (PrintOrder -> (a, MemUsage) -> (a, MemUsage) -> Ordering)
-> Maybe PrintOrder
-> (a, MemUsage)
-> (a, MemUsage)
-> Ordering
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a, MemUsage) -> (a, MemUsage) -> Ordering
forall {b}. (a, b) -> (a, b) -> Ordering
byName PrintOrder -> (a, MemUsage) -> (a, MemUsage) -> Ordering
byUsage Maybe PrintOrder
mbOrder
comparing' :: (Ord a) => (b -> a) -> b -> b -> Ordering
comparing' :: forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing' b -> a
f b
a b
b = Down a -> Down a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> Down a
forall a. a -> Down a
Down (a -> Down a) -> a -> Down a
forall a b. (a -> b) -> a -> b
$ b -> a
f b
a) (a -> Down a
forall a. a -> Down a
Down (a -> Down a) -> a -> Down a
forall a b. (a -> b) -> a -> b
$ b -> a
f b
b)