diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 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.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 diff --git a/src/System/MemInfo.hs b/src/System/MemInfo.hs --- a/src/System/MemInfo.hs +++ b/src/System/MemInfo.hs @@ -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) 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,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 " [ -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" + + 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 "" + <> 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) 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 @@ -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 |+ "" diff --git a/test/MemInfo/ChoicesSpec.hs b/test/MemInfo/ChoicesSpec.hs new file mode 100644 --- /dev/null +++ b/test/MemInfo/ChoicesSpec.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : MemInfo.ChoicesSpec +Copyright : (c) 2023 Tim Emiola +Maintainer : Tim Emiola +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 diff --git a/test/MemInfo/OrphanInstances.hs b/test/MemInfo/OrphanInstances.hs --- a/test/MemInfo/OrphanInstances.hs +++ b/test/MemInfo/OrphanInstances.hs @@ -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 diff --git a/test/MemInfo/PrintSpec.hs b/test/MemInfo/PrintSpec.hs --- a/test/MemInfo/PrintSpec.hs +++ b/test/MemInfo/PrintSpec.hs @@ -1,7 +1,8 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {- | -Module : MemInfo.ProcSpec +Module : MemInfo.PrintSpec Copyright : (c) 2023 Tim Emiola Maintainer : Tim Emiola 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]" diff --git a/test/MemInfo/ProcSpec.hs b/test/MemInfo/ProcSpec.hs --- a/test/MemInfo/ProcSpec.hs +++ b/test/MemInfo/ProcSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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