mem-info 0.3.0.1 → 0.3.1.0

raw patch · 8 files changed

+242/−114 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• mem-info.cabal +1/−1
• src/System/MemInfo.hs +49/−35
• src/System/MemInfo/Choices.hs +103/−42
• src/System/MemInfo/Print.hs +21/−14
• src/System/MemInfo/SysInfo.hs +10/−9
• test/MemInfo/ChoicesSpec.hs +15/−11
• test/MemInfo/OrphanInstances.hs +35/−2

@@ -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

@@ -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.

@@ -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

@@ -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 "<pid1> [ -p pid2 ... -p pidN ]"-    <> help "Only show memory usage of the specified PIDs"+  some1 $+    option positiveNum $+      short 'p'+        <> long "pids"+        <> metavar "<pid1> [ -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 "<threshold>[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)

@@ -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

@@ -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}  

@@ -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

@@ -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