mem-info 0.2.0.0 → 0.3.0.0

raw patch · 8 files changed

+289/−61 lines, 8 filesdep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: bytestring

API changes (from Hackage documentation)

Files

• ChangeLog.md +12/−0
• mem-info.cabal +2/−2
• src/System/MemInfo.hs +18/−21
• src/System/MemInfo/Choices.hs +51/−4
• src/System/MemInfo/Print.hs +100/−14
• test/MemInfo/ChoicesSpec.hs +14/−5
• test/MemInfo/OrphanInstances.hs +8/−1
• test/MemInfo/PrintSpec.hs +84/−14

@@ -2,6 +2,18 @@  `mem-info` uses [PVP Versioning][1]. +## 0.3.0.0 -- 2024-03-17++- Extended the dependency bounds to allow all bytestring 0.12.x++- Remove the check for __root__ when no pids are specified++  - previously, an error occurred if no pids were specified without sudo+  - after this, all processes of the current user are shown++- Add an option -y (--output-style) that allows the output to be formatted as+  CSV with all values in KiB+ ## 0.2.0.0 -- 2024-01-28  - Simplify the output when the -d (--discriminate-by-pid) flag is used

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               mem-info-version:            0.2.0.0+version:            0.3.0.0 synopsis:           Print the core memory usage of programs description:   A utility to accurately report the core memory usage of programs.@@ -45,7 +45,7 @@   hs-source-dirs:   src   build-depends:     , base                  >=4.10   && <5-    , bytestring            >=0.10.8.2  && <0.11 || >=0.11.3.1 && <0.12.1+    , bytestring            >=0.10.8.2  && <0.11 || >=0.11.3.1 && <0.13     , containers            >=0.6.5  && <0.8     , directory             >=1.3.6  && <1.5     , filepath              >=1.4.2  && <1.6

@@ -59,6 +59,7 @@ 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@@ -69,13 +70,17 @@   (|++|),  ) import System.Exit (exitFailure)-import System.MemInfo.Choices (Choices (..), PrintOrder (..), getChoices)+import System.MemInfo.Choices (+  Choices (..),+  PrintOrder (..),+  Style (..),+  getChoices,+ ) import System.MemInfo.Prelude import System.MemInfo.Print (   AsCmdName (..),-  fmtAsHeader,   fmtMemUsage,-  fmtOverall,+  styleOutput,  ) import System.MemInfo.Proc (   BadStatus (..),@@ -95,7 +100,6 @@   fmtSwapFlaws,   mkReportBud,  )-import System.Posix.User (getEffectiveUserID)   {- | Print a report to @stdout@ displaying the memory usage of the programs@@ -117,13 +121,15 @@         , choiceWatchSecs = watchSecsMb         , choicePrintOrder = printOrder         , choiceReversed = reversed+        , choiceStyle = style         } = cs+      style' = fromMaybe Normal style       toList = sortBy (byPrintOrder' reversed printOrder) . Map.toList-      printEachCmd = printMemUsages bud showSwap onlyTotal . toList+      printEachCmd = printMemUsages bud style' 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) of+  case watchSecsMb of     Nothing -> readMemUsage' namer indexer bud >>= either haltLostPid showTotal     (Just spanSecs) -> do       let unfold = unfoldMemUsageAfter' namer indexer spanSecs@@ -133,17 +139,15 @@ printMemUsages ::   (AsCmdName a) =>   ReportBud ->+  Style ->   Bool ->   Bool ->   [(a, MemUsage)] ->   IO ()-printMemUsages bud showSwap onlyTotal totals = do-  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' totals-  when overallIsAccurate $ Text.putStrLn $ fmtOverall showSwap overall+printMemUsages bud style showSwap onlyTotal totals = do+  let overallIsAccurate = (showSwap && rbHasSwapPss bud) || rbHasPss bud+      output = styleOutput showSwap style overallIsAccurate totals+  mapM_ Text.putStrLn output   reportFlaws bud showSwap onlyTotal  @@ -324,7 +328,7 @@       thenMkBud = either (pure . Left) mkBud'   case pidsMb of     Just pids -> checkAllExist pids >>= thenMkBud-    Nothing -> whenRoot $ allKnownProcs >>= thenMkBud+    Nothing -> allKnownProcs >>= thenMkBud   procRoot :: String@@ -333,13 +337,6 @@  pidPath :: String -> ProcessID -> FilePath pidPath base pid = "" +| procRoot |++| toInteger pid |+ "/" +| base |+ ""---whenRoot :: IO (Either NotRun a) -> IO (Either NotRun a)-whenRoot action = do-  -- if choicePidsToShow is Nothing, must be running as root-  isRoot' <- (== 0) <$> getEffectiveUserID-  if isRoot' then action else pure $ Left NeedsRoot   {- | pidExists returns false for any ProcessID that does not exist or cannot

@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}  {- | Module      : System.MemInfo.Choices@@ -13,17 +14,19 @@ -} module System.MemInfo.Choices (   Choices (..),+  Style (..),   PrintOrder (..),   cmdInfo,   getChoices, ) where +import qualified Data.Text as Text import GHC.Generics (Generic) import Options.Applicative (   Parser,   ParserInfo,   ReadM,-  auto,+  eitherReader,   execParser,   help,   helper,@@ -55,6 +58,7 @@   , choiceWatchSecs :: !(Maybe Natural)   , choicePidsToShow :: !(Maybe (NonEmpty ProcessID))   , choicePrintOrder :: !(Maybe PrintOrder)+  , choiceStyle :: !(Maybe Style)   }   deriving (Eq, Show, Generic) @@ -75,6 +79,7 @@     <*> optional parseWatchPeriodSecs     <*> optional parseChoicesPidsToShow     <*> optional parsePrintOrder+    <*> optional parseStyle   parseChoicesPidsToShow :: Parser (NonEmpty ProcessID)@@ -143,15 +148,15 @@       | i > 0 = pure i       | otherwise = readerError "Value must be greater than 0"    in-    auto >>= checkPositive+    autoOrNotAllowed >>= checkPositive   parsePrintOrder :: Parser PrintOrder parsePrintOrder =-  option auto+  option autoIgnoreCase     $ short 'b'     <> long "order-by"-    <> metavar "<Private | Swap | Shared | Count>"+    <> metavar "< private | swap | shared | count >"     <> help "Orders the output by ascending values of the given field"  @@ -162,3 +167,45 @@   | Shared   | Count   deriving (Eq, Show, Read, Generic)+++parseStyle :: Parser Style+parseStyle =+  option autoIgnoreCase+    $ short 'y'+    <> long "output-style"+    <> metavar "< [normal] | csv >"+    <> help (Text.unpack styleHelp)+++styleHelp :: Text+styleHelp =+  Text.unlines+    [ "Determines how the output report is presented;"+    , "'normal' is the default and is the same as if this option was omitted;"+    , "'csv' outputs the usage and header rows in csv format, with all values in KiB and no 'total' row."+    , "With 'csv', the --total (-t) flag is ignored"+    ]+++-- | Determines the format style of the output+data Style+  = Csv+  | Normal+  deriving (Eq, Show, Read, Generic)+++autoIgnoreCase :: (Read a) => ReadM a+autoIgnoreCase =+  let toTitle' = Text.unpack . Text.toTitle . Text.pack+   in eitherReader $ readOrNotAllowed toTitle'+++autoOrNotAllowed :: (Read a) => ReadM a+autoOrNotAllowed = eitherReader $ readOrNotAllowed id+++readOrNotAllowed :: (Read a) => (String -> String) -> String -> Either String a+readOrNotAllowed f x = case readEither $ f x of+  Left _ -> Left $ "value '" ++ x ++ "' is not permitted"+  right -> right

@@ -1,5 +1,8 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}  {- | Module      : System.MemInfo.Print@@ -14,10 +17,13 @@   fmtAsHeader,   fmtOverall,   fmtMemUsage,+  styleOutput, ) where +import Data.Proxy (Proxy (..)) import qualified Data.Text as Text import Fmt (+  build,   fixedF,   padBothF,   padLeftF,@@ -28,10 +34,16 @@   (|++|),   (||+),  )+import System.MemInfo.Choices (Style (..)) import System.MemInfo.Prelude import System.MemInfo.Proc (MemUsage (..))  +-- | Generate the output for a given report using the specified style+styleOutput :: (AsCmdName a) => Bool -> Style -> Bool -> [(a, MemUsage)] -> [Text]+styleOutput showSwap style isAccurate = outputOf isAccurate (printStyle style showSwap)++ {- | Generates the text of a row displaying the metrics for a single command in the memory report -}@@ -44,14 +56,26 @@     all' = padl $ muPrivate ct     swap' = padl $ muSwap ct     name' = cmdWithCount name $ muCount ct-    ram = "" +| private |+ " + " +| shared |+ " = " +| all' |+ ""-    label = "" +| name' |+ ""+    ram = private |+ " + " +| shared |+ " = " +| all'+    numbers = if showSwap then ram +| swap' else ram    in-    if showSwap-      then ram <> ("" +| swap' |+ "\t") <> label-      else ram <> "\t" <> label+    numbers |+ "\t" +| name' |+ ""  +fmtMemUsageCsv :: (AsCmdName a) => Bool -> a -> MemUsage -> Text+fmtMemUsageCsv showSwap name ct =+  let+    private = build $ muPrivate ct - muShared ct+    shared = build $ muShared ct+    all' = build $ muPrivate ct+    swap' = build $ muSwap ct+    name' = cmdWithCount name $ muCount ct+    ram = private |+ "," +| shared |+ "," +| all' |+ ","+    numbers = if showSwap then ram +| swap' |+ "," else ram+   in+    numbers +| name' |+ ""++ -- | Generates the text showing the overall memory in the memory report fmtOverall :: Bool -> (Int, Int) -> Text fmtOverall showSwap (private, swap) =@@ -89,17 +113,19 @@    in go  -hdrPrivate, hdrShared, hdrRamUsed, hdrSwapUsed, hdrProgram :: Text+hdrPrivate, hdrShared, hdrRamUsed, hdrSwapUsed, hdrProgram, hdrCount, hdrPid :: Text hdrPrivate = "Private" hdrShared = "Shared" hdrRamUsed = "RAM Used" hdrSwapUsed = "Swap Used" hdrProgram = "Program"+hdrCount = "(# processes)"+hdrPid = "[pid]"   -- | Generates the text of the printed header of the memory report-fmtAsHeader :: Bool -> Text-fmtAsHeader showSwap =+fmtAsHeader :: Bool -> Bool -> Text+fmtAsHeader hasPid showSwap =   let     padb = padBothF columnWidth ' '     padr = padRightF columnWidth ' '@@ -107,16 +133,31 @@     private = padb hdrPrivate     shared = padb hdrShared     all' = padl hdrRamUsed-    name' = padr hdrProgram+    nameExt = if hasPid then hdrPid else hdrCount+    name' = padr $ hdrProgram <> " " <> nameExt     swap' = padl hdrSwapUsed-    ram = "" +| private |+ " + " +| shared |+ " = " +| all' |+ ""-    label = "" +| name' |+ ""+    ram = private |+ " + " +| shared |+ " = " +| all'+    numbers = if showSwap then ram +| swap' else ram    in-    if showSwap-      then ram <> ("" +| swap' |+ "\t") <> label-      else ram <> "\t" <> label+    numbers |+ "\t" +| name' |+ ""  +-- | Generates the text of the printed header of the memory report+fmtAsHeaderCsv :: Bool -> Bool -> Text+fmtAsHeaderCsv hasPid showSwap =+  let+    private = build hdrPrivate+    shared = build hdrShared+    all' = build hdrRamUsed+    nameExt = if hasPid then hdrPid else hdrCount+    name' = build $ hdrProgram <> " " <> nameExt+    swap' = build hdrSwapUsed+    ram = private |+ "," +| shared |+ "," +| all' |+ ","+    numbers = if showSwap then ram +| swap' |+ "," else ram+   in+    numbers +| name' |+ ""++ {- | Identifies a type as a label to use to index programs in the report output @@ -131,11 +172,56 @@   cmdWithCount :: a -> Int -> Text  +  -- Indicate if pid or process count should shown in the hdr+  hdrHasPid :: Proxy a -> Bool++ instance AsCmdName Text where   asCmdName = id   cmdWithCount cmd count = "" +| asCmdName cmd |+ " (" +| count |+ ")"+  hdrHasPid _ = False   instance AsCmdName (ProcessID, Text) where   asCmdName (pid, name) = "" +| name |+ " [" +| toInteger pid |+ "]"   cmdWithCount cmd _count = "" +| asCmdName cmd |+ ""+  hdrHasPid _ = True+++overallTotals :: [MemUsage] -> (Int, Int)+overallTotals cts =+  let step (private, swap) ct = (private + muPrivate ct, swap + muSwap ct)+   in foldl' step (0, 0) cts+++data Printers a = Printers+  { psUsage :: a -> MemUsage -> Text+  , psHeader :: Text+  , psOverall :: (Int, Int) -> Maybe Text+  }+++printStyle :: forall a. (AsCmdName a) => Style -> Bool -> Printers a+printStyle style showSwap =+  let usageFmt Normal = fmtMemUsage+      usageFmt Csv = fmtMemUsageCsv+      headerFmt Normal = fmtAsHeader (hdrHasPid @a Proxy)+      headerFmt Csv = fmtAsHeaderCsv (hdrHasPid @a Proxy)+      overallFmt Normal x = Just $ fmtOverall showSwap x+      overallFmt Csv _ = Nothing+   in Printers+        { psUsage = usageFmt style showSwap+        , psOverall = overallFmt style+        , psHeader = headerFmt style showSwap+        }+++outputOf :: (AsCmdName a) => Bool -> Printers a -> [(a, MemUsage)] -> [Text]+outputOf isAccurate style usages =+  let Printers {psUsage, psHeader, psOverall} = style+      overall = psOverall $ overallTotals $ map snd usages+      headerAndRows = [psHeader] <> map (uncurry psUsage) usages+   in case overall of+        Nothing -> headerAndRows+        Just _ | not isAccurate -> headerAndRows+        Just o -> headerAndRows <> [o]

@@ -10,11 +10,13 @@  import Data.GenValidity (GenValid (..)) import qualified Data.List.NonEmpty as NE+import Data.Text (Text)+import qualified Data.Text as Text 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)+import Test.QuickCheck (Gen, Property, elements, forAll, suchThat)   spec :: Spec@@ -31,11 +33,16 @@ genCmdLine :: Gen (Choices, [String]) genCmdLine = do   choices <- genValid `suchThat` ((/= Just 0) . choiceWatchSecs)-  pure (choices, cmdlineOf choices)+  changeCase <- genChangeCase+  pure (choices, cmdlineOf (Text.unpack . changeCase . Text.pack) choices)  -cmdlineOf :: Choices -> [String]-cmdlineOf c =+genChangeCase :: (Gen (Text -> Text))+genChangeCase = elements [id, Text.toLower, Text.toUpper]+++cmdlineOf :: (String -> String) -> Choices -> [String]+cmdlineOf changeCase c =   let     splitArgs = if choiceSplitArgs c then ("-s" :) else id     onlyTotal = if choiceOnlyTotal c then ("-t" :) else id@@ -46,7 +53,8 @@     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+    printOrder = maybe id (\x -> (("-b " ++ changeCase (show x)) :)) $ choicePrintOrder c+    style = maybe id (\x -> (("-y " ++ changeCase (show x)) :)) $ choiceStyle c    in     reversed       $ printOrder@@ -55,4 +63,5 @@       $ onlyTotal       $ byPid       $ showSwap+      $ style       $ watchSecs mempty

@@ -20,7 +20,7 @@ import Data.GenValidity (GenValid (..)) import Data.GenValidity.Text () import Data.List.NonEmpty (nonEmpty)-import System.MemInfo.Choices (Choices (..), PrintOrder)+import System.MemInfo.Choices (Choices (..), PrintOrder, Style) import System.MemInfo.Proc (ExeInfo (..), StatusInfo) import System.Posix.Types (CPid (..), ProcessID) import Test.QuickCheck (Gen, frequency, suchThat)@@ -58,6 +58,12 @@ deriving anyclass instance GenValid PrintOrder  +deriving instance Validity Style+++deriving instance GenValid Style++ instance GenValid Choices where   genValid =     let genPositiveMb = frequency [(1, pure Nothing), (5, Just <$> genPositive)]@@ -70,4 +76,5 @@           <*> genValid           <*> genPositiveMb           <*> genPids+          <*> genValid           <*> genValid

@@ -11,7 +11,8 @@  import Data.Text (Text) import qualified Data.Text as Text-import System.MemInfo.Print (fmtAsHeader, fmtMemUsage, fmtOverall)+import System.MemInfo.Choices (Style (Csv, Normal))+import System.MemInfo.Print (fmtAsHeader, fmtMemUsage, fmtOverall, styleOutput) import System.MemInfo.Proc (MemUsage (..)) import System.Posix.Types (ProcessID) import Test.Hspec@@ -22,34 +23,103 @@   fmtAsHeaderSpec   fmtOverallSpec   fmtMemUsageSpec+  styleOutputSpec  +styleOutputSpec :: Spec+styleOutputSpec = describe "styleOutput" $ do+  describe "when accurate and swap shown" $ do+    let count = 6+        usage = sampleUsage' count+        styleOutput' s = styleOutput True s True+    describe "when style is csv" $ do+      let style = Csv+      describe "when discriminating by pid" $ do+        let want =+              [ "Private,Shared,RAM Used,Swap Used,Program [pid]"+              , "1,1,2,4,by-id-and-name-cmd [100]"+              ]+        it "should generate the expected output" $ do+          styleOutput' style [(biName, usage)] `shouldBe` want++      describe "not discriminating by pid" $ do+        let want =+              [ "Private,Shared,RAM Used,Swap Used,Program (# processes)"+              , "1,1,2,4,by-name-cmd (6)"+              ]+        it "should generate the expected output" $ do+          styleOutput' style [(monoName, usage)] `shouldBe` want++  describe "when accurate and no swap shown" $ do+    let count = 6+        usage = sampleUsage' count+        styleOutput' s = styleOutput False s True+    describe "when style is normal" $ do+      let style = Normal+          wantedSummary =+            Text.unlines+              [ "------------------------------------"+              , "                             2.0 KiB"+              , "===================================="+              ]+      describe "when discriminating by pid" $ do+        let want =+              [ "  Private  +   Shared   =   RAM Used\tProgram [pid]"+              , "   1.0 KiB +    1.0 KiB =    2.0 KiB\tby-id-and-name-cmd [100]"+              , wantedSummary+              ]+        it "should generate the expected output" $ do+          styleOutput' style [(biName, usage)] `shouldBe` want++      describe "not discriminating by pid" $ do+        let want =+              [ "  Private  +   Shared   =   RAM Used\tProgram (# processes)"+              , "   1.0 KiB +    1.0 KiB =    2.0 KiB\tby-name-cmd (6)"+              , wantedSummary+              ]+        it "should generate the expected output" $ do+          styleOutput' style [(monoName, usage)] `shouldBe` want++ fmtAsHeaderSpec :: Spec fmtAsHeaderSpec = describe "fmtAsHeader" $ do-  describe "when swap is not required" $ do-    it "does not show it" $-      fmtAsHeader False `shouldBe` headerNoSwap+  describe "when discriminating by pid" $ do+    let byPid = True+    describe "when swap is not required" $ do+      it "does not show it" $ do+        fmtAsHeader byPid False `shouldBe` headerNoSwap -  describe "when swap is required" $ do-    it "does show it" $-      fmtAsHeader True `shouldBe` headerSwap+    describe "when swap is required" $ do+      it "does show it" $ do+        fmtAsHeader byPid True `shouldBe` headerSwap +  describe "when not discriminating by pid" $ do+    let byPid = False+        withProcCount = Text.replace "[pid]" "(# processes)"+    describe "when swap is not required" $ do+      it "does not show it" $ do+        fmtAsHeader byPid False `shouldBe` withProcCount headerNoSwap +    describe "when swap is required" $ do+      it "does show it" $ do+        fmtAsHeader byPid True `shouldBe` withProcCount headerSwap++ headerNoSwap :: Text-headerNoSwap = "  Private  +   Shared   =   RAM Used\tProgram   "+headerNoSwap = "  Private  +   Shared   =   RAM Used\tProgram [pid]"   headerSwap :: Text-headerSwap = "  Private  +   Shared   =   RAM Used Swap Used\tProgram   "+headerSwap = "  Private  +   Shared   =   RAM Used Swap Used\tProgram [pid]"   fmtOverallSpec :: Spec fmtOverallSpec = describe "fmtOverall" $ do   describe "when swap is not required" $ do-    it "does not show it" $+    it "does not show it" $ do       fmtOverall False (1, 1) `shouldBe` sampleNoSwapOverall   describe "when swap is required" $ do-    it "does show it" $+    it "does show it" $ do       fmtOverall True (1, 1) `shouldBe` sampleSwapOverall  @@ -76,17 +146,17 @@   describe "when displaying by-pid" $ do     let usage = sampleUsage' 1     describe "and swap is not required" $ do-      it "does not show it" $+      it "does not show it" $ do         fmtMemUsage False biName usage `shouldBe` sampleTotalNoSwap      describe "when swap is required" $ do-      it "shows it" $+      it "shows it" $ do         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" $+      it "does not show it" $ do         fmtMemUsage False monoName usage `shouldBe` sampleTotalNoSwapMono