diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 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.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 diff --git a/src/System/MemInfo.hs b/src/System/MemInfo.hs --- a/src/System/MemInfo.hs +++ b/src/System/MemInfo.hs @@ -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 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 @@ -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 "" + <> 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 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 @@ -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] diff --git a/test/MemInfo/ChoicesSpec.hs b/test/MemInfo/ChoicesSpec.hs --- a/test/MemInfo/ChoicesSpec.hs +++ b/test/MemInfo/ChoicesSpec.hs @@ -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 diff --git a/test/MemInfo/OrphanInstances.hs b/test/MemInfo/OrphanInstances.hs --- a/test/MemInfo/OrphanInstances.hs +++ b/test/MemInfo/OrphanInstances.hs @@ -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 diff --git a/test/MemInfo/PrintSpec.hs b/test/MemInfo/PrintSpec.hs --- a/test/MemInfo/PrintSpec.hs +++ b/test/MemInfo/PrintSpec.hs @@ -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