diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,6 +2,14 @@ `mem-info` uses [PVP Versioning][1]. +## 0.3.1.0 -- 2025-02-18 + +- Add option -m (--min-reported) + + This filters out processes with low memory by specifying a lower bound for + output. Correct filter amounts are specified as quantities along with a unit; + one of KiB, MiB, GiB or TiB + ## 0.3.0.1 -- 2025-01-17 - Fix test data generation in QuickCheck test diff --git a/mem-info.cabal b/mem-info.cabal --- a/mem-info.cabal +++ b/mem-info.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: mem-info -version: 0.3.0.1 +version: 0.3.1.0 synopsis: Print the core memory usage of programs description: A utility to accurately report the core memory usage of programs. diff --git a/src/System/MemInfo.hs b/src/System/MemInfo.hs --- a/src/System/MemInfo.hs +++ b/src/System/MemInfo.hs @@ -72,8 +72,10 @@ import System.Exit (exitFailure) import System.MemInfo.Choices ( Choices (..), + Mem (..), PrintOrder (..), Style (..), + asFloat, getChoices, ) import System.MemInfo.Prelude @@ -122,11 +124,12 @@ , choicePrintOrder = printOrder , choiceReversed = reversed , choiceStyle = style + , choiceMinMemory = mem } = cs style' = fromMaybe Normal style - toList = sortBy (byPrintOrder' reversed printOrder) . Map.toList + toList = filterLT mem . sortBy (byPrintOrder' reversed printOrder) . Map.toList printEachCmd = printMemUsages bud style' showSwap onlyTotal . toList - printTheTotal = onlyPrintTotal bud showSwap onlyTotal . toList + printTheTotal = onlyPrintTotal bud showSwap onlyTotal . Map.toList showTotal = if onlyTotal then printTheTotal else printEachCmd namer = if choiceSplitArgs cs then nameAsFullCmd else nameFor case watchSecsMb of @@ -349,37 +352,42 @@ -- | Obtain the @ProcName@ as the full cmd path nameAsFullCmd :: ProcNamer nameAsFullCmd pid = do - let cmdlinePath = pidPath "cmdline" pid - err = NoCmdLine pid - recombine = Text.intercalate " " . NE.toList - orLostPid = maybe (Left err) (Right . recombine) - readUtf8Text cmdlinePath >>= (pure . orLostPid) . parseCmdline + let + err = NoCmdLine pid + recombine = Text.intercalate " " . NE.toList + orLostPid = maybe (Left err) (Right . recombine) + readCmdlinePath pid >>= (pure . orLostPid) . parseCmdline +readCmdlinePath :: ProcessID -> IO Text +readCmdlinePath pid = readUtf8Text $ pidPath "cmdline" pid + + {- | Obtain the @ProcName@ by examining the path linked by __{proc_root}\/pid\/exe__ -} nameFromExeOnly :: ProcNamer nameFromExeOnly pid = do + let pickSuffix = \case + Just (x :| _) -> do + let addSuffix' b = x <> if b then " [updated]" else " [deleted]" + Right . baseName . addSuffix' <$> exists x + -- args should not be empty when {pid_root}/exe resolves to a + -- path, it's an error if it is + Nothing -> pure $ Left $ NoCmdLine pid + exeInfo pid >>= \case + Left e -> pure $ Left e Right i | not $ eiDeleted i -> pure $ Right $ baseName $ eiOriginal i -- when the exe bud ends with (deleted), the version of the exe used to -- invoke the process has been removed from the filesystem. Sometimes it has -- been updated; examining both the original bud and the version in -- cmdline help determine what occurred Right ExeInfo {eiOriginal = orig} -> - exists orig >>= \case - True -> pure $ Right $ baseName $ "" +| orig |+ " [updated]" - _ -> do - let cmdlinePath = pidPath "cmdline" pid - readUtf8Text cmdlinePath <&> parseCmdline >>= \case - Just (x :| _) -> do - let addSuffix' b = x <> if b then " [updated]" else " [deleted]" - Right . baseName . addSuffix' <$> exists x - -- args should not be empty when {pid_root}/exe resolves to a - -- path, it's an error if it is - Nothing -> pure $ Left $ NoCmdLine pid - Left e -> pure $ Left e + exists orig >>= \wasUpdated -> + if wasUpdated + then pure $ Right $ baseName $ "" +| orig |+ " [updated]" + else readCmdlinePath pid >>= pickSuffix . parseCmdline -- | Functions that obtain a process name given its @pid@ @@ -404,13 +412,13 @@ Right si -> nameFromExeOnly (siParent si) >>= \case Right n | n == candidate -> pure $ Right n - _ -> pure $ Right $ siName si + _anyLostPid -> pure $ Right $ siName si -- | Represents errors that prevent a report from being generated data NotRun - = PidLost LostPid - | MissingPids (NonEmpty ProcessID) + = PidLost !LostPid + | MissingPids !(NonEmpty ProcessID) | NeedsRoot | OddKernel | NoRecords @@ -429,12 +437,12 @@ records. -} data LostPid - = NoExeFile ProcessID - | NoStatusCmd ProcessID - | NoStatusParent ProcessID - | NoCmdLine ProcessID - | BadStatm ProcessID - | NoProc ProcessID + = NoExeFile !ProcessID + | NoStatusCmd !ProcessID + | NoStatusParent !ProcessID + | NoCmdLine !ProcessID + | BadStatm !ProcessID + | NoProc !ProcessID deriving (Eq, Show) @@ -493,13 +501,10 @@ allKnownProcs :: IO (Either NotRun (NonEmpty ProcessID)) allKnownProcs = - let readNaturals = fmap (mapMaybe readMaybe) - orNoPids = maybe (Left NoRecords) Right - in readNaturals (listDirectory procRoot) - >>= filterM pidExeExists - >>= pure - . orNoPids - . nonEmpty + let readIdsMaybe = fmap (mapMaybe readMaybe) + readProcessIDs = readIdsMaybe (listDirectory procRoot) + orNoPids = maybe (Left NoRecords) Right . nonEmpty + in readProcessIDs >>= filterM pidExeExists >>= pure . orNoPids baseName :: Text -> Text @@ -631,3 +636,12 @@ comparing' :: (Ord a) => (b -> a) -> b -> b -> Ordering comparing' f a b = compare (Down $ f a) (Down $ f b) + + +memLT :: Mem -> (a, MemUsage) -> Bool +memLT mem (_ignored, mu) = asFloat mem < fromIntegral (muPrivate mu) + + +filterLT :: Maybe Mem -> [(a, MemUsage)] -> [(a, MemUsage)] +filterLT Nothing xs = xs +filterLT (Just mem) xs = filter (memLT mem) xs diff --git a/src/System/MemInfo/Choices.hs b/src/System/MemInfo/Choices.hs --- a/src/System/MemInfo/Choices.hs +++ b/src/System/MemInfo/Choices.hs @@ -16,11 +16,17 @@ Choices (..), Style (..), PrintOrder (..), + Power (..), + Mem (..), + asFloat, + memReader, cmdInfo, getChoices, ) where +import Data.Fixed (Deci) import qualified Data.Text as Text +import Data.Text.Read (Reader, rational) import GHC.Generics (Generic) import Options.Applicative ( Parser, @@ -59,6 +65,7 @@ , choicePidsToShow :: !(Maybe (NonEmpty ProcessID)) , choicePrintOrder :: !(Maybe PrintOrder) , choiceStyle :: !(Maybe Style) + , choiceMinMemory :: !(Maybe Mem) } deriving (Eq, Show, Generic) @@ -80,65 +87,66 @@ <*> optional parseChoicesPidsToShow <*> optional parsePrintOrder <*> optional parseStyle + <*> optional parseMinReported parseChoicesPidsToShow :: Parser (NonEmpty ProcessID) parseChoicesPidsToShow = - some1 - $ option positiveNum - $ short 'p' - <> long "pids" - <> metavar " [ -p pid2 ... -p pidN ]" - <> help "Only show memory usage of the specified PIDs" + some1 $ + option positiveNum $ + short 'p' + <> long "pids" + <> metavar " [ -p pid2 ... -p pidN ]" + <> help "Only show memory usage of the specified PIDs" parseSplitArgs :: Parser Bool parseSplitArgs = - switch - $ short 's' - <> long "split-args" - <> help "Show and separate by all command line arguments" + switch $ + short 's' + <> long "split-args" + <> help "Show and separate by all command line arguments" parseOnlyTotal :: Parser Bool parseOnlyTotal = - switch - $ short 't' - <> long "total" - <> help "Only show the total value" + switch $ + short 't' + <> long "total" + <> help "Only show the total value" parseReversed :: Parser Bool parseReversed = - switch - $ short 'r' - <> long "reverse" - <> help "Reverses the output order so that output descends on the sorting field" + switch $ + short 'r' + <> long "reverse" + <> help "Reverses the output order so that output descends on the sorting field" parseDiscriminateByPid :: Parser Bool parseDiscriminateByPid = - switch - $ short 'd' - <> long "discriminate-by-pid" - <> help "Show by process rather than by program" + switch $ + short 'd' + <> long "discriminate-by-pid" + <> help "Show by process rather than by program" parseShowSwap :: Parser Bool parseShowSwap = - switch - $ short 'S' - <> long "show_swap" - <> help "Show swap information" + switch $ + short 'S' + <> long "show_swap" + <> help "Show swap information" parseWatchPeriodSecs :: Parser Natural parseWatchPeriodSecs = - option positiveNum - $ short 'w' - <> long "watch" - <> metavar "N" - <> help "Measure and show memory every N seconds (N > 0)" + option positiveNum $ + short 'w' + <> long "watch" + <> metavar "N" + <> help "Measure and show memory every N seconds (N > 0)" positiveNum :: (Read a, Ord a, Num a) => ReadM a @@ -153,11 +161,11 @@ parsePrintOrder :: Parser PrintOrder parsePrintOrder = - option autoIgnoreCase - $ short 'b' - <> long "order-by" - <> metavar "< private | swap | shared | count >" - <> help "Orders the output by ascending values of the given field" + option autoIgnoreCase $ + short 'b' + <> long "order-by" + <> metavar "< private | swap | shared | count >" + <> help "Orders the output by ascending values of the given field" -- | Determines the order in which @MemUsages@ in a report are printed out @@ -169,13 +177,22 @@ deriving (Eq, Show, Read, Generic) +parseMinReported :: Parser Mem +parseMinReported = + option (eitherReader $ fromReader memReader) $ + short 'm' + <> long "min-reported" + <> metavar "[K|M|G|T]iB, e.g 1.1KiB | 2MiB | 4.0GiB" + <> help "Specifies a minimum below which memory values are omitted" + + parseStyle :: Parser Style parseStyle = - option autoIgnoreCase - $ short 'y' - <> long "output-style" - <> metavar "< [normal] | csv >" - <> help (Text.unpack styleHelp) + option autoIgnoreCase $ + short 'y' + <> long "output-style" + <> metavar "< [normal] | csv >" + <> help (Text.unpack styleHelp) styleHelp :: Text @@ -207,5 +224,49 @@ readOrNotAllowed :: (Read a) => (String -> String) -> String -> Either String a readOrNotAllowed f x = case readEither $ f x of - Left _ -> Left $ "value '" ++ x ++ "' is not permitted" + Left _ignored -> Left $ "value '" ++ x ++ "' is not permitted" right -> right + + +fromReader :: Reader a -> String -> Either String a +fromReader reader = fmap fst . reader . Text.pack + + +-- | Represents the power in memory quanity unit +data Power = Ki | Mi | Gi | Ti + deriving + (Eq, Read, Show, Ord, Enum, Bounded, Generic) + + +floatingFactor :: Power -> Double +floatingFactor Ki = 1.0 +floatingFactor Mi = 1024.0 +floatingFactor Gi = 1024.0 ** 2 +floatingFactor Ti = 1024.0 ** 3 + + +powerReader :: Text -> Either String (Power, Text) +powerReader x = + let (want, extra) = Text.splitAt 3 $ Text.stripStart x + go "Ki" = Right (Ki, extra) + go "Mi" = Right (Mi, extra) + go "Gi" = Right (Gi, extra) + go "Ti" = Right (Ti, extra) + go _other = Left "invalid Power" + in go $ Text.take 2 want + + +-- | Represents an amount of memory +data Mem = Mem !Power !Deci + deriving (Eq, Show, Ord, Generic) + + +asFloat :: Mem -> Double +asFloat (Mem pow x) = realToFrac x * floatingFactor pow + + +memReader :: Text -> Either String (Mem, Text) +memReader x = do + (num, rest) <- rational (Text.stripStart x) + (power, extra) <- powerReader rest + pure (Mem power num, extra) diff --git a/src/System/MemInfo/Print.hs b/src/System/MemInfo/Print.hs --- a/src/System/MemInfo/Print.hs +++ b/src/System/MemInfo/Print.hs @@ -2,6 +2,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} {-# LANGUAGE TypeApplications #-} {- | @@ -14,6 +15,7 @@ -} module System.MemInfo.Print ( AsCmdName (asCmdName), + fmtMem, fmtAsHeader, fmtOverall, fmtMemUsage, @@ -34,7 +36,11 @@ (|++|), (||+), ) -import System.MemInfo.Choices (Style (..)) +import System.MemInfo.Choices ( + Mem (..), + Power (..), + Style (..), + ) import System.MemInfo.Prelude import System.MemInfo.Proc (MemUsage (..)) @@ -50,7 +56,7 @@ fmtMemUsage :: (AsCmdName a) => Bool -> a -> MemUsage -> Text fmtMemUsage showSwap name ct = let - padl = padLeftF columnWidth ' ' . fmtMem + padl = padLeftF columnWidth ' ' . fmtMemKb private = padl $ muPrivate ct - muShared ct shared = padl $ muShared ct all' = padl $ muPrivate ct @@ -85,7 +91,7 @@ top = Text.replicate rimLength "-" gap = Text.replicate gapLength " " bottom = Text.replicate rimLength "=" - padl = padLeftF columnWidth ' ' . fmtMem + padl = padLeftF columnWidth ' ' . fmtMemKb withSwap = "" +| gap |++| padl private |++| padl swap |+ "" noSwap = "" +| gap |++| padl private |+ "" out = if showSwap then withSwap else noSwap @@ -93,24 +99,25 @@ Text.unlines [top, out, bottom] -data Power = Ki | Mi | Gi | Ti deriving (Eq, Show, Ord, Enum, Bounded) - - -fmtMem :: Int -> Text -fmtMem = fmtMem' Ki . fromIntegral +fmtMemKb :: Int -> Text +fmtMemKb = fmtMem . Mem Ki . fromIntegral columnWidth :: Int columnWidth = 10 -fmtMem' :: Power -> Float -> Text -fmtMem' = - let doFmt p x = "" +| fixedF 1 x |+ " " +|| p ||+ "B" - go p x | p == maxBound = doFmt p x - go p x | x > 1000 = fmtMem' (succ p) (x / 1024) - go p x = doFmt p x +doFmt :: Power -> Double -> Text +doFmt = + let doFmt' p x = "" +| fixedF 1 x |+ " " +|| p ||+ "B" + go p x | p == maxBound = doFmt' p x + go p x | x >= 1024 = doFmt (succ p) (x / 1024.0) + go p x = doFmt' p x in go + + +fmtMem :: Mem -> Text +fmtMem (Mem p x) = doFmt p $ realToFrac x hdrPrivate, hdrShared, hdrRamUsed, hdrSwapUsed, hdrProgram, hdrCount, hdrPid :: Text diff --git a/src/System/MemInfo/SysInfo.hs b/src/System/MemInfo/SysInfo.hs --- a/src/System/MemInfo/SysInfo.hs +++ b/src/System/MemInfo/SysInfo.hs @@ -91,8 +91,8 @@ , rbHasPss :: !Bool , rbHasSwapPss :: !Bool , rbHasSmaps :: !Bool - , rbRamFlaws :: Maybe RamFlaw - , rbSwapFlaws :: Maybe SwapFlaw + , rbRamFlaws :: !(Maybe RamFlaw) + , rbSwapFlaws :: !(Maybe SwapFlaw) } deriving (Eq, Show) @@ -160,26 +160,27 @@ , rbHasSwapPss = hasSwapPss } = bud (rbRamFlaws, rbSwapFlaws) <- case version of - (2, 4, _) -> do + (2, 4, _patch) -> do let memInfoPath = pidPath "meminfo" pid alt = (Just SomeSharedMem, Just NoSwap) best = (Just ExactForIsolatedMem, Just NoSwap) containsInact = Text.isInfixOf "Inact_" checkInact x = if containsInact x then best else alt - doesFileExist memInfoPath >>= \case - False -> pure alt - _ -> checkInact <$> readUtf8Text memInfoPath - (2, 6, _) -> do + doesFileExist memInfoPath >>= \hasMemInfo -> + if hasMemInfo + then pure alt + else checkInact <$> readUtf8Text memInfoPath + (2, 6, _patch) -> do let withSmaps = if hasPss then best else alt alt = (Just ExactForIsolatedMem, Just ExactForIsolatedSwap) best = (Nothing, Just ExactForIsolatedSwap) withNoSmaps = Just $ if fickleShared then NoSharedMem else SomeSharedMem pure $ if hasSmaps then withSmaps else (withNoSmaps, Just NoSwap) - (major, _, _) | major > 2 && hasSmaps -> do + (major, _minor, _patch) | major > 2 && hasSmaps -> do let alt = (Nothing, Just ExactForIsolatedSwap) best = (Nothing, Nothing) pure $ if hasSwapPss then best else alt - _ -> pure (Just ExactForIsolatedMem, Just NoSwap) + _other -> pure (Just ExactForIsolatedMem, Just NoSwap) pure $ bud {rbRamFlaws, rbSwapFlaws} diff --git a/test/MemInfo/ChoicesSpec.hs b/test/MemInfo/ChoicesSpec.hs --- a/test/MemInfo/ChoicesSpec.hs +++ b/test/MemInfo/ChoicesSpec.hs @@ -15,6 +15,7 @@ import MemInfo.OrphanInstances () import Options.Applicative (defaultPrefs, execParserPure, getParseResult) import System.MemInfo.Choices (Choices (..), cmdInfo) +import System.MemInfo.Print (fmtMem) import Test.Hspec import Test.QuickCheck (Gen, Property, elements, forAll, suchThat) @@ -26,8 +27,8 @@ prop_roundtripParseChoices :: Property prop_roundtripParseChoices = - forAll genCmdLine - $ \(choices, args) -> Just choices == getParseResult (execParserPure defaultPrefs cmdInfo args) + forAll genCmdLine $ + \(choices, args) -> Just choices == getParseResult (execParserPure defaultPrefs cmdInfo args) genCmdLine :: Gen (Choices, [String]) @@ -44,6 +45,7 @@ cmdlineOf :: (String -> String) -> Choices -> [String] cmdlineOf changeCase c = let + removeSpace = Text.replace " " "" splitArgs = if choiceSplitArgs c then ("-s" :) else id onlyTotal = if choiceOnlyTotal c then ("-t" :) else id byPid = if choiceByPid c then ("-d" :) else id @@ -55,13 +57,15 @@ pidsToShow = maybe id manyPids $ choicePidsToShow c printOrder = maybe id (\x -> (("-b " ++ changeCase (show x)) :)) $ choicePrintOrder c style = maybe id (\x -> (("-y " ++ changeCase (show x)) :)) $ choiceStyle c + limitMem = maybe id (\x -> (("-m " ++ Text.unpack (removeSpace $ fmtMem x)) :)) $ choiceMinMemory c in - reversed - $ printOrder - $ pidsToShow - $ splitArgs - $ onlyTotal - $ byPid - $ showSwap - $ style - $ watchSecs mempty + reversed $ + printOrder $ + pidsToShow $ + splitArgs $ + onlyTotal $ + byPid $ + showSwap $ + style $ + watchSecs $ + limitMem mempty diff --git a/test/MemInfo/OrphanInstances.hs b/test/MemInfo/OrphanInstances.hs --- a/test/MemInfo/OrphanInstances.hs +++ b/test/MemInfo/OrphanInstances.hs @@ -17,13 +17,20 @@ -} module MemInfo.OrphanInstances where +import Data.Fixed (Deci) import Data.GenValidity (GenValid (..)) import Data.GenValidity.Text () import Data.List.NonEmpty (nonEmpty) -import System.MemInfo.Choices (Choices (..), PrintOrder, Style) +import System.MemInfo.Choices ( + Choices (..), + Mem (..), + Power, + PrintOrder, + Style, + ) import System.MemInfo.Proc (ExeInfo (..), StatusInfo) import System.Posix.Types (CPid (..), ProcessID) -import Test.QuickCheck (Gen, frequency, suchThat) +import Test.QuickCheck (Gen, chooseInt, elements, frequency, suchThat) import Test.QuickCheck.Gen (listOf) import Test.Validity (Validity) @@ -40,6 +47,13 @@ genPositive = genValid `suchThat` (> 0) +gen2Dp :: Gen Deci +gen2Dp = do + dps <- fromIntegral <$> chooseInt (10, 99) + strength <- elements [1.0, 10.0, 100.0] + pure $ (dps / 10.0) * strength + + deriving anyclass instance GenValid StatusInfo @@ -64,10 +78,28 @@ deriving instance GenValid Style +deriving instance Validity Power + + +deriving instance GenValid Power + + +deriving instance Validity Mem + + +deriving instance GenValid Mem + + instance GenValid Choices where genValid = let genPositiveMb = frequency [(1, pure Nothing), (5, Just <$> genPositive)] genPids = nonEmpty <$> listOf genPositive + genValidMem = Mem <$> genValid <*> gen2Dp + genOptionalMem = + frequency + [ (1, pure Nothing) + , (5, Just <$> genValidMem) + ] in Choices <$> genValid <*> genValid @@ -78,3 +110,4 @@ <*> genPids <*> genValid <*> genValid + <*> genOptionalMem