mem-info 0.1.0.1 → 0.2.0.0

raw patch · 10 files changed

+303/−86 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• mem-info.cabal +5/−3
• src/System/MemInfo.hs +82/−35
• src/System/MemInfo/Choices.hs +64/−28
• src/System/MemInfo/Print.hs +8/−6
• test/MemInfo/ChoicesSpec.hs +58/−0
• test/MemInfo/OrphanInstances.hs +32/−0
• test/MemInfo/PrintSpec.hs +31/−14
• test/MemInfo/ProcSpec.hs +14/−0
• test/Spec.hs +2/−0

@@ -2,6 +2,13 @@  `mem-info` uses [PVP Versioning][1]. +## 0.2.0.0 -- 2024-01-28++- Simplify the output when the -d (--discriminate-by-pid) flag is used++- Add options -b (--order-by) and -r (--reverse) to change the ordering of the+  output+ ## 0.1.0.1 -- 2024-01-17  - Adjusted dependency bounds to remove any stale dependencies

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               mem-info-version:            0.1.0.1+version:            0.2.0.0 synopsis:           Print the core memory usage of programs description:   A utility to accurately report the core memory usage of programs.@@ -11,7 +11,7 @@    The package provides: -    * an executable command `printmem` that mimics `ps_mem`+    * an executable command `printmem` that is like `ps_mem` with extra features      * a library to enable core memory tracking on linux in haskell programs @@ -66,6 +66,7 @@   main-is:          Spec.hs   hs-source-dirs:   test   other-modules:+    MemInfo.ChoicesSpec     MemInfo.OrphanInstances     MemInfo.PrintSpec     MemInfo.ProcSpec@@ -80,8 +81,9 @@     , genvalidity-hspec     , genvalidity-text     , hashable-    , mem-info     , hspec+    , mem-info+    , optparse-applicative  >=0.18.1 && <0.19     , QuickCheck     , text     , unix

@@ -56,8 +56,10 @@  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.Ord (Down (..), comparing) import qualified Data.Text as Text import qualified Data.Text.IO as Text import Fmt (@@ -67,7 +69,7 @@   (|++|),  ) import System.Exit (exitFailure)-import System.MemInfo.Choices (Choices (..), getChoices)+import System.MemInfo.Choices (Choices (..), PrintOrder (..), getChoices) import System.MemInfo.Prelude import System.MemInfo.Print (   AsCmdName (..),@@ -100,53 +102,64 @@ specified by @Choices@ -} printProcs :: Choices -> IO ()-printProcs cs = do+printProcs cs@Choices {choiceByPid = byPid} = do   bud <- verify cs+  if byPid+    then printProcs' withPid bud cs+    else printProcs' dropId bud cs+++printProcs' :: (Ord a, AsCmdName a) => Indexer a -> ReportBud -> Choices -> IO ()+printProcs' indexer bud cs = do   let Choices         { choiceShowSwap = showSwap         , choiceOnlyTotal = onlyTotal         , choiceWatchSecs = watchSecsMb-        , choiceByPid = byPid+        , choicePrintOrder = printOrder+        , choiceReversed = reversed         } = cs-      printEachCmd totals = printMemUsages bud showSwap onlyTotal totals-      printTheTotal = onlyPrintTotal bud showSwap onlyTotal-      showTotal cmds = if onlyTotal then printTheTotal cmds else printEachCmd cmds+      toList = sortBy (byPrintOrder' reversed printOrder) . Map.toList+      printEachCmd = printMemUsages bud showSwap onlyTotal . toList+      printTheTotal = onlyPrintTotal bud showSwap onlyTotal . toList+      showTotal = if onlyTotal then printTheTotal else printEachCmd       namer = if choiceSplitArgs cs then nameAsFullCmd else nameFor-  case (watchSecsMb, byPid) of-    (Nothing, True) -> readMemUsage' namer withPid bud >>= either haltLostPid showTotal-    (Nothing, _) -> readMemUsage' namer dropId bud >>= either haltLostPid showTotal-    (Just spanSecs, True) -> do-      let unfold = unfoldMemUsageAfter' namer withPid spanSecs-      loopPrintMemUsages unfold bud showTotal-    (Just spanSecs, _) -> do-      let unfold = unfoldMemUsageAfter' namer dropId spanSecs+  case (watchSecsMb) of+    Nothing -> readMemUsage' namer indexer bud >>= either haltLostPid showTotal+    (Just spanSecs) -> do+      let unfold = unfoldMemUsageAfter' namer indexer spanSecs       loopPrintMemUsages unfold bud showTotal  -printMemUsages :: AsCmdName a => ReportBud -> Bool -> Bool -> Map a MemUsage -> IO ()+printMemUsages ::+  (AsCmdName a) =>+  ReportBud ->+  Bool ->+  Bool ->+  [(a, MemUsage)] ->+  IO () printMemUsages bud showSwap onlyTotal totals = do-  let overall = overallTotals $ Map.elems totals+  let overall = overallTotals $ map snd totals       overallIsAccurate = (showSwap && rbHasSwapPss bud) || rbHasPss bud       print' (name, stats) = Text.putStrLn $ fmtMemUsage showSwap name stats   Text.putStrLn $ fmtAsHeader showSwap-  mapM_ print' $ Map.toList totals+  mapM_ print' totals   when overallIsAccurate $ Text.putStrLn $ fmtOverall showSwap overall   reportFlaws bud showSwap onlyTotal   -- | Print the program name and memory usage, optionally hiding the swap size-printUsage' :: AsCmdName a => (a, MemUsage) -> Bool -> IO ()+printUsage' :: (AsCmdName a) => (a, MemUsage) -> Bool -> IO () printUsage' (name, mu) showSwap = Text.putStrLn $ fmtMemUsage showSwap name mu   -- | Like @'printUsage''@, but alway shows the swap size-printUsage :: AsCmdName a => (a, MemUsage) -> IO ()+printUsage :: (AsCmdName a) => (a, MemUsage) -> IO () printUsage = flip printUsage' True  -onlyPrintTotal :: ReportBud -> Bool -> Bool -> Map k MemUsage -> IO ()+onlyPrintTotal :: (AsCmdName k) => ReportBud -> Bool -> Bool -> [(k, MemUsage)] -> IO () onlyPrintTotal bud showSwap onlyTotal totals = do-  let (private, swap) = overallTotals $ Map.elems totals+  let (private, swap) = overallTotals $ map snd totals       printRawTotal = Text.putStrLn . fmtMemBytes   if showSwap     then do@@ -190,18 +203,18 @@ type ProcName = Text  --- | Like @'unfoldMemUsageAfter''@, but uses the default 'ProcName' and 'Indexer'+-- | Like @'unfoldMemUsageAfter''@, but uses the default 'ProcNamer' and 'Indexer' unfoldMemUsageAfter ::   (Integral seconds) =>   seconds ->   ReportBud ->-  IO (Either [ProcessID] ((Map Text MemUsage, [ProcessID]), ReportBud))+  IO (Either [ProcessID] ((Map ProcName MemUsage, [ProcessID]), ReportBud)) unfoldMemUsageAfter = unfoldMemUsageAfter' nameFor dropId   -- | Like @'unfoldMemUsage'@ but computes the @'MemUsage's@ after a delay unfoldMemUsageAfter' ::-  (Ord a, Integral seconds) =>+  (Ord a, AsCmdName a, Integral seconds) =>   ProcNamer ->   Indexer a ->   seconds ->@@ -266,7 +279,7 @@ - any of the processes specified by @'ReportBud'@ are missing or inaccessible -} readMemUsage' ::-  Ord a =>+  (Ord a) =>   ProcNamer ->   Indexer a ->   ReportBud ->@@ -487,7 +500,9 @@       orNoPids = maybe (Left NoRecords) Right    in readNaturals (listDirectory procRoot)         >>= filterM pidExeExists-        >>= pure . orNoPids . nonEmpty+        >>= pure+        . orNoPids+        . nonEmpty   baseName :: Text -> Text@@ -498,12 +513,12 @@ readMemStats bud pid = do   statmExists <- doesFileExist $ pidPath "statm" pid   if-      | rbHasSmaps bud -> Right . parseFromSmap <$> readSmaps pid-      | statmExists -> do-          let readStatm' = readUtf8Text $ pidPath "statm" pid-              orLostPid = maybe (Left $ BadStatm pid) Right-          orLostPid . parseFromStatm (rbKernel bud) <$> readStatm'-      | otherwise -> pure $ Left $ NoProc pid+    | rbHasSmaps bud -> Right . parseFromSmap <$> readSmaps pid+    | statmExists -> do+        let readStatm' = readUtf8Text $ pidPath "statm" pid+            orLostPid = maybe (Left $ BadStatm pid) Right+        orLostPid . parseFromStatm (rbKernel bud) <$> readStatm'+    | otherwise -> pure $ Left $ NoProc pid   readSmaps :: ProcessID -> IO Text@@ -513,9 +528,9 @@   hasSmaps <- doesFileExist smapPath   hasRollup <- doesFileExist rollupPath   if-      | hasRollup -> readUtf8Text rollupPath-      | hasSmaps -> readUtf8Text smapPath-      | otherwise -> pure Text.empty+    | hasRollup -> readUtf8Text rollupPath+    | hasSmaps -> readUtf8Text smapPath+    | otherwise -> pure Text.empty   overallTotals :: [MemUsage] -> (Int, Int)@@ -587,3 +602,35 @@ -} dropId :: Indexer ProcName dropId (_pid, name, pp) = (name, pp)+++byPrintOrder ::+  (Ord c) =>+  (((c, MemUsage) -> Int) -> (c, MemUsage) -> (c, MemUsage) -> Ordering) ->+  PrintOrder ->+  (c, MemUsage) ->+  (c, MemUsage) ->+  Ordering+byPrintOrder f Swap = f $ muSwap . snd+byPrintOrder f Shared = f $ muShared . snd+byPrintOrder f Private = f $ muPrivate . snd+byPrintOrder f Count = f $ muCount . snd+++byPrintOrder' ::+  (Ord a) =>+  Bool ->+  Maybe PrintOrder ->+  (a, MemUsage) ->+  (a, MemUsage) ->+  Ordering+byPrintOrder' reversed mbOrder =+  let cmpUsage = if reversed then comparing else comparing'+      cmpName = if reversed then comparing else comparing'+      byName = cmpName fst+      byUsage = byPrintOrder cmpUsage+   in maybe byName byUsage mbOrder+++comparing' :: (Ord a) => (b -> a) -> b -> b -> Ordering+comparing' f a b = compare (Down $ f a) (Down $ f b)

@@ -1,3 +1,7 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+ {- | Module      : System.MemInfo.Choices Copyright   : (c) 2022 Tim Emiola@@ -9,10 +13,12 @@ -} module System.MemInfo.Choices (   Choices (..),+  PrintOrder (..),   cmdInfo,   getChoices, ) where +import GHC.Generics (Generic) import Options.Applicative (   Parser,   ParserInfo,@@ -45,10 +51,12 @@   , choiceOnlyTotal :: !Bool   , choiceByPid :: !Bool   , choiceShowSwap :: !Bool+  , choiceReversed :: !Bool   , choiceWatchSecs :: !(Maybe Natural)   , choicePidsToShow :: !(Maybe (NonEmpty ProcessID))+  , choicePrintOrder :: !(Maybe PrintOrder)   }-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)   -- | Specifies a command line that when parsed will provide 'Choices'@@ -63,59 +71,69 @@     <*> parseOnlyTotal     <*> parseDiscriminateByPid     <*> parseShowSwap+    <*> parseReversed     <*> optional parseWatchPeriodSecs     <*> optional parseChoicesPidsToShow+    <*> optional parsePrintOrder   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"++ 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@@ -126,3 +144,21 @@       | otherwise = readerError "Value must be greater than 0"    in     auto >>= checkPositive+++parsePrintOrder :: Parser PrintOrder+parsePrintOrder =+  option auto+    $ 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+data PrintOrder+  = Swap+  | Private+  | Shared+  | Count+  deriving (Eq, Show, Read, Generic)

@@ -10,7 +10,7 @@ This module provides functions that format the output of the __printmem__ command -} module System.MemInfo.Print (-  AsCmdName (..),+  AsCmdName (asCmdName),   fmtAsHeader,   fmtOverall,   fmtMemUsage,@@ -35,7 +35,7 @@ {- | Generates the text of a row displaying the metrics for a single command in the memory report -}-fmtMemUsage :: AsCmdName a => Bool -> a -> MemUsage -> Text+fmtMemUsage :: (AsCmdName a) => Bool -> a -> MemUsage -> Text fmtMemUsage showSwap name ct =   let     padl = padLeftF columnWidth ' ' . fmtMem@@ -117,10 +117,6 @@       else ram <> "\t" <> label  -cmdWithCount :: AsCmdName a => a -> Int -> Text-cmdWithCount cmd count = "" +| asCmdName cmd |+ " (" +| count |+ ")"-- {- | Identifies a type as a label to use to index programs in the report output @@ -131,9 +127,15 @@   asCmdName :: a -> Text  +  -- Add a count of processes using that label to the label+  cmdWithCount :: a -> Int -> Text++ instance AsCmdName Text where   asCmdName = id+  cmdWithCount cmd count = "" +| asCmdName cmd |+ " (" +| count |+ ")"   instance AsCmdName (ProcessID, Text) where   asCmdName (pid, name) = "" +| name |+ " [" +| toInteger pid |+ "]"+  cmdWithCount cmd _count = "" +| asCmdName cmd |+ ""

@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module      : MemInfo.ChoicesSpec+Copyright   : (c) 2023 Tim Emiola+Maintainer  : Tim Emiola <adetokunbo@emio.la>+SPDX-License-Identifier: BSD3+-}+module MemInfo.ChoicesSpec where++import Data.GenValidity (GenValid (..))+import qualified Data.List.NonEmpty as NE+import MemInfo.OrphanInstances ()+import Options.Applicative (defaultPrefs, execParserPure, getParseResult)+import System.MemInfo.Choices (Choices (..), cmdInfo)+import Test.Hspec+import Test.QuickCheck (Gen, Property, forAll, suchThat)+++spec :: Spec+spec = describe "module System.MemInfo.Choices" $ do+  it "should parse a Choices from the command line ok" prop_roundtripParseChoices+++prop_roundtripParseChoices :: Property+prop_roundtripParseChoices =+  forAll genCmdLine+    $ \(choices, args) -> Just choices == getParseResult (execParserPure defaultPrefs cmdInfo args)+++genCmdLine :: Gen (Choices, [String])+genCmdLine = do+  choices <- genValid `suchThat` ((/= Just 0) . choiceWatchSecs)+  pure (choices, cmdlineOf choices)+++cmdlineOf :: Choices -> [String]+cmdlineOf c =+  let+    splitArgs = if choiceSplitArgs c then ("-s" :) else id+    onlyTotal = if choiceOnlyTotal c then ("-t" :) else id+    byPid = if choiceByPid c then ("-d" :) else id+    reversed = if choiceReversed c then ("-r" :) else id+    showSwap = if choiceShowSwap c then ("-S" :) else id+    watchSecs = maybe id (\x -> (("-w " ++ show x) :)) $ choiceWatchSecs c+    onePid x = "-p " ++ show x+    manyPids xs = (map onePid (NE.toList xs) ++)+    pidsToShow = maybe id manyPids $ choicePidsToShow c+    printOrder = maybe id (\x -> (("-b " ++ show x) :)) $ choicePrintOrder c+   in+    reversed+      $ printOrder+      $ pidsToShow+      $ splitArgs+      $ onlyTotal+      $ byPid+      $ showSwap+      $ watchSecs mempty

@@ -19,8 +19,12 @@  import Data.GenValidity (GenValid (..)) import Data.GenValidity.Text ()+import Data.List.NonEmpty (nonEmpty)+import System.MemInfo.Choices (Choices (..), PrintOrder) import System.MemInfo.Proc (ExeInfo (..), StatusInfo) import System.Posix.Types (CPid (..), ProcessID)+import Test.QuickCheck (Gen, frequency, suchThat)+import Test.QuickCheck.Gen (listOf) import Test.Validity (Validity)  @@ -32,6 +36,10 @@     pure $ ExeInfo {eiDeleted, eiOriginal, eiTarget}  +genPositive :: (GenValid a, Num a, Ord a) => Gen a+genPositive = genValid `suchThat` (> 0)++ deriving anyclass instance GenValid StatusInfo  @@ -39,3 +47,27 @@   deriving newtype instance GenValid ProcessID+++deriving instance Validity Choices+++deriving instance Validity PrintOrder+++deriving anyclass instance GenValid PrintOrder+++instance GenValid Choices where+  genValid =+    let genPositiveMb = frequency [(1, pure Nothing), (5, Just <$> genPositive)]+        genPids = nonEmpty <$> listOf genPositive+     in Choices+          <$> genValid+          <*> genValid+          <*> genValid+          <*> genValid+          <*> genValid+          <*> genPositiveMb+          <*> genPids+          <*> genValid

@@ -1,7 +1,8 @@+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}  {- |-Module      : MemInfo.ProcSpec+Module      : MemInfo.PrintSpec Copyright   : (c) 2023 Tim Emiola Maintainer  : Tim Emiola <adetokunbo@emio.la> SPDX-License-Identifier: BSD3@@ -72,32 +73,48 @@  fmtMemUsageSpec :: Spec fmtMemUsageSpec = describe "fmtMemUsage" $ do-  describe "when swap is not required" $ do-    it "does not show it" $-      fmtMemUsage False sampleName sampleTotal `shouldBe` sampleTotalNoSwap+  describe "when displaying by-pid" $ do+    let usage = sampleUsage' 1+    describe "and swap is not required" $ do+      it "does not show it" $+        fmtMemUsage False biName usage `shouldBe` sampleTotalNoSwap -  describe "when swap is required" $ do-    it "does not show" $-      fmtMemUsage True sampleName sampleTotal `shouldBe` sampleTotalSwap+    describe "when swap is required" $ do+      it "shows it" $+        fmtMemUsage True biName usage `shouldBe` sampleTotalSwap +  describe "when displaying by-name" $ do+    let usage = sampleUsage' 3+    describe "and swap is not required" $ do+      it "does not show it" $+        fmtMemUsage False monoName usage `shouldBe` sampleTotalNoSwapMono -sampleName :: (ProcessID, Text)-sampleName = (100, "TestCommand") +monoName :: Text+monoName = "by-name-cmd" -sampleTotal :: MemUsage-sampleTotal =++biName :: (ProcessID, Text)+biName = (100, "by-id-and-name-cmd")+++sampleUsage' :: Int -> MemUsage+sampleUsage' muCount =   MemUsage     { muShared = 1     , muPrivate = 2-    , muCount = 3+    , muCount     , muSwap = 4     }  +sampleTotalNoSwapMono :: Text+sampleTotalNoSwapMono = "   1.0 KiB +    1.0 KiB =    2.0 KiB\tby-name-cmd (3)"++ sampleTotalNoSwap :: Text-sampleTotalNoSwap = "   1.0 KiB +    1.0 KiB =    2.0 KiB\tTestCommand [100] (3)"+sampleTotalNoSwap = "   1.0 KiB +    1.0 KiB =    2.0 KiB\tby-id-and-name-cmd [100]"   sampleTotalSwap :: Text-sampleTotalSwap = "   1.0 KiB +    1.0 KiB =    2.0 KiB   4.0 KiB\tTestCommand [100] (3)"+sampleTotalSwap = "   1.0 KiB +    1.0 KiB =    2.0 KiB   4.0 KiB\tby-id-and-name-cmd [100]"

@@ -10,6 +10,7 @@ module MemInfo.ProcSpec (spec) where  import Data.Hashable (hash)+import Data.Maybe (isNothing) import Data.Text (Text) import qualified Data.Text as Text import Data.Word (Word16)@@ -82,7 +83,10 @@   describe "when using a kernel version with known sharing" $ do     it "should parse values to ProcUsage successfully" prop_roundtripStatmShared +  describe "When the statm content is invalid" $ do+    it "should not parse values to ProcUsage successfully" prop_roundtripInvalidStatm + fromSmapSpec :: Spec fromSmapSpec = describe "parseFromSmap" $ do   it "should parse values to ProcUsage successfully" prop_roundtripSmap@@ -101,6 +105,12 @@     \(pp, txt) -> Just pp == parseFromStatm badSharedKernel txt  +prop_roundtripInvalidStatm :: Property+prop_roundtripInvalidStatm =+  forAll genNoSharedStatm $+    \(_, txt) -> isNothing $ parseFromStatm badSharedKernel $ invalidateStatm txt++ prop_roundtripSmap :: Property prop_roundtripSmap = forAll genSmap $ \(pp, txt) -> pp == parseFromSmap txt @@ -127,6 +137,10 @@           , puMemId = hash content           }   pure (pp, content)+++invalidateStatm :: Text -> Text+invalidateStatm = Text.replace " " "-"   statmShared :: Word16 -> Word16 -> Text

@@ -2,6 +2,7 @@  module Main where +import qualified MemInfo.ChoicesSpec as Choices import qualified MemInfo.PrintSpec as Print import qualified MemInfo.ProcSpec as Proc import qualified MemInfo.SysInfoSpec as SysInfo@@ -19,6 +20,7 @@   hSetBuffering stdout NoBuffering   hSetBuffering stderr NoBuffering   hspec $ do+    Choices.spec     Proc.spec     Print.spec     SysInfo.spec