diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,6 +2,19 @@ `mem-info` uses [PVP Versioning][1]. +## 0.4.0.0 -- 2025-03-02 + +- Add option --proc-root + + Used to specify an alternate process root than the default, _/proc_. This + allows reporting of process status for other machines whose proc information + has been mounted or synced to a local filesystem + +- Breaking changes: + +* [ProcNamer][2] takes an additional argument that specifies the proc filesystem root + + ## 0.3.1.0 -- 2025-02-18 - Add option -m (--min-reported) @@ -42,3 +55,4 @@ * Initial version. [1]: https://pvp.haskell.org +[2]: https://hackage.haskell.org/package/mem-info-0.3.1.0/docs/System-MemInfo.html#t:ProcNamer 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.3.1.0 +version: 0.4.0.0 synopsis: Print the core memory usage of programs description: A utility to accurately report the core memory usage of programs. @@ -51,6 +51,7 @@ , filepath >=1.4.2 && <1.6 , fmt >=0.6.3 && <0.8 , hashable >=1.4.2 && <1.6 + , mtl >=2.0 && <2.3 || > 2.3 && <2.5 , optparse-applicative >=0.18.1 && <0.19 , text >=1.2.3 && <2.2 , unix >=2.7.2 && <2.9 @@ -67,7 +68,10 @@ hs-source-dirs: test other-modules: MemInfo.ChoicesSpec + MemInfo.Files.Root + MemInfo.Files.Smap MemInfo.OrphanInstances + MemInfo.MemInfoSpec MemInfo.PrintSpec MemInfo.ProcSpec MemInfo.SysInfoSpec @@ -76,6 +80,9 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fwarn-tabs build-depends: , base + , filepath + , containers + , directory , fmt , genvalidity , genvalidity-hspec @@ -86,6 +93,7 @@ , optparse-applicative >=0.18.1 && <0.19 , QuickCheck , text + , temporary >= 1.2 && < 1.4 , unix -- printmem is the printmem command diff --git a/src/System/MemInfo.hs b/src/System/MemInfo.hs --- a/src/System/MemInfo.hs +++ b/src/System/MemInfo.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} @@ -22,6 +23,7 @@ -- * Read /MemUsage/ readForOnePid, + readForOnePid', readMemUsage', readMemUsage, NotRun (..), @@ -54,6 +56,8 @@ AsCmdName (..), ) where +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (MonadReader (ask), runReaderT) import Data.Bifunctor (Bifunctor (..)) import Data.Functor ((<&>)) import Data.List (sortBy) @@ -67,7 +71,6 @@ listF, (+|), (|+), - (|++|), ) import System.Exit (exitFailure) import System.MemInfo.Choices ( @@ -76,6 +79,7 @@ PrintOrder (..), Style (..), asFloat, + defaultRoot, getChoices, ) import System.MemInfo.Prelude @@ -258,14 +262,26 @@ nextState <$> foldlEitherM' (readNameAndStats namer bud) pids --- | Load the @'MemUsage'@ of a program specified by its @ProcessID@ +{- | Like 'readForOnePid', but assumes the process file hierarchy +root is the linux default +-} readForOnePid :: ProcessID -> IO (Either NotRun (ProcName, MemUsage)) -readForOnePid pid = do - let mkBud' xs = mkReportBud xs <&> maybe (Left OddKernel) Right +readForOnePid = readForOnePid' defaultRoot + + +-- | Load the @'MemUsage'@ of a program specified by its @ProcessID@ +readForOnePid' :: + ProcRoot -> + -- | the root of the process file system; usually @/proc@ + ProcessID -> + -- | the ID of a valid process + IO (Either NotRun (ProcName, MemUsage)) +readForOnePid' root pid = do + let mkBud' xs = mkReportBud root xs <&> maybe (Left OddKernel) Right noProc = NoProc pid fromMemUsage x = maybe (Left $ PidLost noProc) Right (Map.lookupMin x) andFromUsage = either (Left . PidLost) fromMemUsage - nameFor pid >>= \case + nameFor root pid >>= \case Left err -> pure $ Left $ PidLost err Right _ -> mkBud' (pid :| []) >>= \case @@ -282,7 +298,7 @@ Fails if -- the system does not have the expected /proc filesystem memory records +- the system does not have the expected process filesystem memory records - any of the processes specified by @'ReportBud'@ are missing or inaccessible -} readMemUsage' :: @@ -301,13 +317,24 @@ ReportBud -> ProcessID -> IO (Either LostPid (ProcessID, ProcName, ProcUsage)) -readNameAndStats namer bud pid = do - namer pid >>= \case +readNameAndStats = readNameAndStats' + + +readNameAndStats' :: + ProcNamer -> + ReportBud -> + ProcessID -> + IO (Either LostPid (ProcessID, ProcName, ProcUsage)) +readNameAndStats' namer bud pid = do + let withProcRoot = flip runReaderT root + root = rbProcRoot bud + namer root pid >>= \case Left e -> pure $ Left e Right name -> - readMemStats bud pid >>= \case - Left e -> pure $ Left e - Right stats -> pure $ Right (pid, name, stats) + withProcRoot $ + readMemStats bud pid >>= \case + Left e -> pure $ Left e + Right stats -> pure $ Right (pid, name, stats) reportFlaws :: ReportBud -> Bool -> Bool -> IO () @@ -322,53 +349,56 @@ verify :: Choices -> IO ReportBud -verify cs = verify' (choicePidsToShow cs) >>= either (haltErr . fmtNotRun) pure +verify cs = verify' (choiceProcRoot cs) (choicePidsToShow cs) >>= either (haltErr . fmtNotRun) pure -verify' :: Maybe (NonEmpty ProcessID) -> IO (Either NotRun ReportBud) -verify' pidsMb = do - let mkBud' xs = mkReportBud xs <&> maybe (Left OddKernel) Right +verify' :: FilePath -> Maybe (NonEmpty ProcessID) -> IO (Either NotRun ReportBud) +verify' root pidsMb = do + let mkBud' xs = mkReportBud root xs <&> maybe (Left OddKernel) Right thenMkBud = either (pure . Left) mkBud' case pidsMb of - Just pids -> checkAllExist pids >>= thenMkBud - Nothing -> allKnownProcs >>= thenMkBud + Just pids -> checkAllExist root pids >>= thenMkBud + Nothing -> allKnownProcs root >>= thenMkBud -procRoot :: String -procRoot = "/proc/" +-- | The root of the process file hierarchy +type ProcRoot = FilePath -pidPath :: String -> ProcessID -> FilePath -pidPath base pid = "" +| procRoot |++| toInteger pid |+ "/" +| base |+ "" +pidPath :: (MonadReader ProcRoot m) => FilePath -> ProcessID -> m FilePath +pidPath base pid = ask >>= \root -> pure $ "" +| root |+ "/" +| toInteger pid |+ "/" +| base |+ "" {- | pidExists returns false for any ProcessID that does not exist or cannot be accessed -} -pidExeExists :: ProcessID -> IO Bool -pidExeExists = fmap (either (const False) (const True)) . exeInfo +pidExeExists :: FilePath -> ProcessID -> IO Bool +pidExeExists root pid = do + result <- flip runReaderT root $ exeInfo pid + pure $ either (const False) (const True) result -- | Obtain the @ProcName@ as the full cmd path nameAsFullCmd :: ProcNamer -nameAsFullCmd pid = do - let - err = NoCmdLine pid - recombine = Text.intercalate " " . NE.toList - orLostPid = maybe (Left err) (Right . recombine) - readCmdlinePath pid >>= (pure . orLostPid) . parseCmdline +nameAsFullCmd root pid = do + let withProcRoot = flip runReaderT root + err = NoCmdLine pid + recombine = Text.intercalate " " . NE.toList + orLostPid = maybe (Left err) (Right . recombine) + withProcRoot (readCmdlinePath pid) >>= (pure . orLostPid) . parseCmdline -readCmdlinePath :: ProcessID -> IO Text -readCmdlinePath pid = readUtf8Text $ pidPath "cmdline" pid +readCmdlinePath :: (MonadReader ProcRoot m, MonadIO m) => ProcessID -> m Text +readCmdlinePath pid = pidPath "cmdline" pid >>= liftIO . readUtf8Text {- | Obtain the @ProcName@ by examining the path linked by __{proc_root}\/pid\/exe__ -} nameFromExeOnly :: ProcNamer -nameFromExeOnly pid = do - let pickSuffix = \case +nameFromExeOnly root pid = do + let withProcRoot = flip runReaderT root + pickSuffix = \case Just (x :| _) -> do let addSuffix' b = x <> if b then " [updated]" else " [deleted]" Right . baseName . addSuffix' <$> exists x @@ -376,7 +406,7 @@ -- path, it's an error if it is Nothing -> pure $ Left $ NoCmdLine pid - exeInfo pid >>= \case + withProcRoot (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 @@ -387,30 +417,31 @@ exists orig >>= \wasUpdated -> if wasUpdated then pure $ Right $ baseName $ "" +| orig |+ " [updated]" - else readCmdlinePath pid >>= pickSuffix . parseCmdline + else withProcRoot (readCmdlinePath pid) >>= pickSuffix . parseCmdline -- | Functions that obtain a process name given its @pid@ -type ProcNamer = ProcessID -> IO (Either LostPid ProcName) +type ProcNamer = ProcRoot -> ProcessID -> IO (Either LostPid ProcName) {- | Obtain the @ProcName@ by examining the path linked by __{proc_root}\/pid\/exe__ or its parent's name if that is a better match -} nameFor :: ProcNamer -nameFor pid = - nameFromExeOnly pid - >>= either (pure . Left) (parentNameIfMatched pid) +nameFor root pid = + nameFromExeOnly root pid + >>= either (pure . Left) (parentNameIfMatched2 root pid) -parentNameIfMatched :: ProcessID -> Text -> IO (Either LostPid ProcName) -parentNameIfMatched pid candidate = do +parentNameIfMatched2 :: FilePath -> ProcessID -> Text -> IO (Either LostPid ProcName) +parentNameIfMatched2 root pid candidate = do let isMatch = flip Text.isPrefixOf candidate . siName - statusInfo pid >>= \case + withProcRoot = flip runReaderT root + withProcRoot (statusInfo pid) >>= \case Left err -> pure $ Left err Right si | isMatch si -> pure $ Right candidate Right si -> - nameFromExeOnly (siParent si) >>= \case + nameFromExeOnly root (siParent si) >>= \case Right n | n == candidate -> pure $ Right n _anyLostPid -> pure $ Right $ siName si @@ -461,25 +492,31 @@ exitFailure -exeInfo :: ProcessID -> IO (Either LostPid ExeInfo) +exeInfo :: (MonadReader ProcRoot m, MonadIO m) => ProcessID -> m (Either LostPid ExeInfo) exeInfo pid = do - let exePath = pidPath "exe" pid - handledErr e = isDoesNotExistError e || isPermissionError e + link <- pidPath "exe" pid + linkText <- liftIO $ getSymbolicLinkText pid link + pure $ fmap parseExeInfo linkText + + +getSymbolicLinkText :: ProcessID -> FilePath -> IO (Either LostPid Text) +getSymbolicLinkText pid link = do + let handledErr e = isDoesNotExistError e || isPermissionError e onIOE e = if handledErr e then pure (Left $ NoExeFile pid) else throwIO e handle onIOE $ do - Right . parseExeInfo . Text.pack <$> getSymbolicLinkTarget exePath + Right . Text.pack <$> getSymbolicLinkTarget link exists :: Text -> IO Bool exists = doesFileExist . Text.unpack -statusInfo :: ProcessID -> IO (Either LostPid StatusInfo) +statusInfo :: (MonadReader ProcRoot m, MonadIO m) => ProcessID -> m (Either LostPid StatusInfo) statusInfo pid = do - let statusPath = pidPath "status" pid - fromBadStatus NoCmd = NoStatusCmd pid + let fromBadStatus NoCmd = NoStatusCmd pid fromBadStatus NoParent = NoStatusParent pid - first fromBadStatus . parseStatusInfo <$> readUtf8Text statusPath + statusPath <- pidPath "status" pid + first fromBadStatus . parseStatusInfo <$> liftIO (readUtf8Text statusPath) parseCmdline :: Text -> Maybe (NonEmpty Text) @@ -488,50 +525,55 @@ in nonEmpty . split' -nonExisting :: NonEmpty ProcessID -> IO [ProcessID] -nonExisting = filterM (fmap not . pidExeExists) . NE.toList +nonExisting :: FilePath -> NonEmpty ProcessID -> IO [ProcessID] +nonExisting root = filterM (fmap not . pidExeExists root) . NE.toList -checkAllExist :: NonEmpty ProcessID -> IO (Either NotRun (NonEmpty ProcessID)) -checkAllExist pids = - nonExisting pids >>= \case +checkAllExist :: FilePath -> NonEmpty ProcessID -> IO (Either NotRun (NonEmpty ProcessID)) +checkAllExist root pids = + nonExisting root pids >>= \case [] -> pure $ Right pids x : xs -> pure $ Left $ MissingPids $ x :| xs -allKnownProcs :: IO (Either NotRun (NonEmpty ProcessID)) -allKnownProcs = +allKnownProcs :: FilePath -> IO (Either NotRun (NonEmpty ProcessID)) +allKnownProcs root = let readIdsMaybe = fmap (mapMaybe readMaybe) - readProcessIDs = readIdsMaybe (listDirectory procRoot) - orNoPids = maybe (Left NoRecords) Right . nonEmpty - in readProcessIDs >>= filterM pidExeExists >>= pure . orNoPids + readProcessIDs = readIdsMaybe (listDirectory root) + orNoPids = pure . maybe (Left NoRecords) Right . nonEmpty + in readProcessIDs >>= filterM (pidExeExists root) >>= orNoPids baseName :: Text -> Text baseName = Text.pack . takeBaseName . Text.unpack -readMemStats :: ReportBud -> ProcessID -> IO (Either LostPid ProcUsage) +readMemStats :: + (MonadReader ProcRoot m, MonadIO m) => + ReportBud -> + ProcessID -> + m (Either LostPid ProcUsage) readMemStats bud pid = do - statmExists <- doesFileExist $ pidPath "statm" pid + statmPath <- pidPath "statm" pid + statmExists <- liftIO $ doesFileExist statmPath if | rbHasSmaps bud -> Right . parseFromSmap <$> readSmaps pid | statmExists -> do - let readStatm' = readUtf8Text $ pidPath "statm" pid + let readStatm' = liftIO $ readUtf8Text statmPath orLostPid = maybe (Left $ BadStatm pid) Right orLostPid . parseFromStatm (rbKernel bud) <$> readStatm' | otherwise -> pure $ Left $ NoProc pid -readSmaps :: ProcessID -> IO Text +readSmaps :: (MonadReader ProcRoot m, MonadIO m) => ProcessID -> m Text readSmaps pid = do - let smapPath = pidPath "smaps" pid - rollupPath = pidPath "smaps_rollup" pid - hasSmaps <- doesFileExist smapPath - hasRollup <- doesFileExist rollupPath + smapPath <- pidPath "smaps" pid + rollupPath <- pidPath "smaps_rollup" pid + hasSmaps <- liftIO $ doesFileExist smapPath + hasRollup <- liftIO $ doesFileExist rollupPath if - | hasRollup -> readUtf8Text rollupPath - | hasSmaps -> readUtf8Text smapPath + | hasRollup -> liftIO $ readUtf8Text rollupPath + | hasSmaps -> liftIO $ readUtf8Text smapPath | otherwise -> pure Text.empty 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 @@ -22,6 +22,7 @@ memReader, cmdInfo, getChoices, + defaultRoot, ) where import Data.Fixed (Deci) @@ -43,7 +44,10 @@ optional, readerError, short, + showDefault, + str, switch, + value, ) import Options.Applicative.NonEmpty (some1) import System.MemInfo.Prelude @@ -61,6 +65,7 @@ , choiceByPid :: !Bool , choiceShowSwap :: !Bool , choiceReversed :: !Bool + , choiceProcRoot :: !FilePath , choiceWatchSecs :: !(Maybe Natural) , choicePidsToShow :: !(Maybe (NonEmpty ProcessID)) , choicePrintOrder :: !(Maybe PrintOrder) @@ -83,6 +88,7 @@ <*> parseDiscriminateByPid <*> parseShowSwap <*> parseReversed + <*> parseRoot <*> optional parseWatchPeriodSecs <*> optional parseChoicesPidsToShow <*> optional parsePrintOrder @@ -132,6 +138,15 @@ <> help "Show by process rather than by program" +parseRoot :: Parser FilePath +parseRoot = + option str $ + long "proc-root" + <> help "the root directory of the process file hierachy" + <> value defaultRoot + <> showDefault + + parseShowSwap :: Parser Bool parseShowSwap = switch $ @@ -270,3 +285,7 @@ (num, rest) <- rational (Text.stripStart x) (power, extra) <- powerReader rest pure (Mem power num, extra) + + +defaultRoot :: FilePath +defaultRoot = "/proc" diff --git a/src/System/MemInfo/Prelude.hs b/src/System/MemInfo/Prelude.hs --- a/src/System/MemInfo/Prelude.hs +++ b/src/System/MemInfo/Prelude.hs @@ -51,9 +51,13 @@ import Data.Text.Encoding (decodeUtf8) import Numeric.Natural (Natural) import System.Directory ( + doesDirectoryExist, doesFileExist, + getPermissions, getSymbolicLinkTarget, listDirectory, + readable, + searchable, ) import System.FilePath (takeBaseName) import System.IO (stderr) diff --git a/src/System/MemInfo/SysInfo.hs b/src/System/MemInfo/SysInfo.hs --- a/src/System/MemInfo/SysInfo.hs +++ b/src/System/MemInfo/SysInfo.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -36,6 +37,7 @@ fickleSharing, ) where +import Control.Monad ((>=>)) import qualified Data.List.NonEmpty as NE import qualified Data.Text as Text import qualified Data.Text.IO as Text @@ -58,12 +60,12 @@ -- | Determines the version of the Linux kernel on the current system. -readKernelVersion :: IO (Maybe KernelVersion) -readKernelVersion = parseKernelVersion <$> Text.readFile kernelVersionPath +readKernelVersion :: FilePath -> IO (Maybe KernelVersion) +readKernelVersion = fmap parseKernelVersion . Text.readFile . kernelVersionPath -kernelVersionPath :: String -kernelVersionPath = "/proc/sys/kernel/osrelease" +kernelVersionPath :: FilePath -> FilePath +kernelVersionPath root = "" +| root |+ "/sys/kernel/osrelease" -- | Parses @Text@ into a @'KernelVersion'@ @@ -93,6 +95,7 @@ , rbHasSmaps :: !Bool , rbRamFlaws :: !(Maybe RamFlaw) , rbSwapFlaws :: !(Maybe SwapFlaw) + , rbProcRoot :: !FilePath } deriving (Eq, Show) @@ -151,35 +154,30 @@ -} checkForFlaws :: ReportBud -> IO ReportBud checkForFlaws bud = do - let pid = NE.head $ rbPids bud - version = rbKernel bud - fickleShared = fickleSharing version + let memInfoPath = meminfoPathOf (rbProcRoot bud) ReportBud { rbHasPss = hasPss , rbHasSmaps = hasSmaps , rbHasSwapPss = hasSwapPss + , rbKernel = version } = bud (rbRamFlaws, rbSwapFlaws) <- case version of (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 >>= \hasMemInfo -> - if hasMemInfo - then pure alt - else checkInact <$> readUtf8Text memInfoPath + let hasInact = Text.isInfixOf "Inact_" <$> readUtf8Text memInfoPath + andHasInact x = if x then hasInact else pure False + memInfoMem x = if x then SomeSharedMem else ExactForIsolatedMem + mkFlawPair x = (Just $ memInfoMem x, Just NoSwap) + isInactPresent = doesFileExist >=> andHasInact + mkFlawPair <$> isInactPresent 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) + pure $ + if + | hasSmaps && hasPss -> (Nothing, Just ExactForIsolatedSwap) + | hasSmaps -> (Just ExactForIsolatedMem, Just ExactForIsolatedSwap) + | fickleSharing version -> (Just NoSharedMem, Just NoSwap) + | otherwise -> (Just SomeSharedMem, Just NoSwap) (major, _minor, _patch) | major > 2 && hasSmaps -> do - let alt = (Nothing, Just ExactForIsolatedSwap) - best = (Nothing, Nothing) - pure $ if hasSwapPss then best else alt + pure (Nothing, if hasSwapPss then Nothing else Just ExactForIsolatedSwap) _other -> pure (Just ExactForIsolatedMem, Just NoSwap) pure $ bud {rbRamFlaws, rbSwapFlaws} @@ -188,32 +186,57 @@ Generates values for the other fields by inspecting the system -The result is @Nothing@ only when the @KernelVersion@ cannot be determined +The result is @Nothing@ when either + +- the process root is not accessible +- the @KernelVersion@ cannot be determined -} -mkReportBud :: NonEmpty ProcessID -> IO (Maybe ReportBud) -mkReportBud rbPids = do +mkReportBud :: FilePath -> NonEmpty ProcessID -> IO (Maybe ReportBud) +mkReportBud rbProcRoot rbPids = do let firstPid = NE.head rbPids - smapsPath = pidPath "smaps" firstPid + smapsPath = pidPath rbProcRoot "smaps" firstPid hasPss = Text.isInfixOf "Pss:" hasSwapPss = Text.isInfixOf "SwapPss:" memtypes x = (hasPss x, hasSwapPss x) - rbHasSmaps <- doesFileExist smapsPath - (rbHasPss, rbHasSwapPss) <- memtypes <$> readUtf8Text smapsPath - readKernelVersion >>= \case - Nothing -> pure Nothing - Just rbKernel -> - fmap Just $ - checkForFlaws $ - ReportBud - { rbPids - , rbKernel - , rbHasPss - , rbHasSwapPss - , rbHasSmaps - , rbRamFlaws = Nothing - , rbSwapFlaws = Nothing - } + rootAccessible <- canAccessRoot rbProcRoot + if not rootAccessible + then pure Nothing + else do + rbHasSmaps <- doesFileExist smapsPath + (rbHasPss, rbHasSwapPss) <- + if rbHasSmaps + then memtypes <$> readUtf8Text smapsPath + else pure (False, False) + readKernelVersion rbProcRoot >>= \case + Nothing -> pure Nothing + Just rbKernel -> + fmap Just $ + checkForFlaws $ + ReportBud + { rbPids + , rbKernel + , rbHasPss + , rbHasSwapPss + , rbHasSmaps + , rbRamFlaws = Nothing + , rbSwapFlaws = Nothing + , rbProcRoot + } -pidPath :: String -> ProcessID -> FilePath -pidPath base pid = "/proc/" +| toInteger pid |+ "/" +| base |+ "" +pidPath :: FilePath -> FilePath -> ProcessID -> FilePath +pidPath root base pid = "" +| root |+ "/" +| toInteger pid |+ "/" +| base |+ "" + + +meminfoPathOf :: FilePath -> FilePath +meminfoPathOf root = "" +| root |+ "/meminfo" + + +canAccessRoot :: FilePath -> IO Bool +canAccessRoot root = do + doesRootExist <- doesDirectoryExist root + if not doesRootExist + then pure False + else do + p <- getPermissions root + pure $ readable p && searchable p diff --git a/test/MemInfo/Files/Root.hs b/test/MemInfo/Files/Root.hs new file mode 100644 --- /dev/null +++ b/test/MemInfo/Files/Root.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +module MemInfo.Files.Root ( + -- * functions + useTmp, + writeRootedFile, + initRoot, + clearDirectory, +) where + +import Data.Text (Text) +import qualified Data.Text.IO as Text +import Fmt ((+|), (|+)) +import System.Directory ( + createDirectoryIfMissing, + listDirectory, + removePathForcibly, + ) +import System.FilePath (takeDirectory, ()) +import System.IO.Temp (withSystemTempDirectory) +import System.MemInfo.SysInfo ( + KernelVersion, + ) + + +useTmp :: (FilePath -> IO a) -> IO a +useTmp = withSystemTempDirectory "mem-info" + + +writeRootedFile :: FilePath -> FilePath -> Text -> IO () +writeRootedFile root path txt = do + let target = root path + createDirectoryIfMissing True $ takeDirectory target + Text.writeFile target txt + + +initRoot :: FilePath -> KernelVersion -> IO () +initRoot root version = do + clearDirectory root + writeRootedFile root "sys/kernel/osrelease" $ fmtKernelVersion version + + +clearDirectory :: FilePath -> IO () +clearDirectory fp = listDirectory fp >>= mapM_ removePathForcibly + + +fmtKernelVersion :: KernelVersion -> Text +fmtKernelVersion (major, minor, patch) = + "" +| toInteger major |+ "." +| toInteger minor |+ "." +| toInteger patch |+ "" diff --git a/test/MemInfo/Files/Smap.hs b/test/MemInfo/Files/Smap.hs new file mode 100644 --- /dev/null +++ b/test/MemInfo/Files/Smap.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE OverloadedStrings #-} + +module MemInfo.Files.Smap ( + -- * data types + + -- * functions + genSmapLine, + genBaseSmap', + genBaseSmap, + genWithPss, +) where + +import Data.GenValidity (GenValid (..)) +import Data.Hashable (hash) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Word (Word16) +import Fmt ((+|), (|+)) +import MemInfo.OrphanInstances () +import System.MemInfo.Proc (ProcUsage (..)) +import Test.QuickCheck + + +genSmapLine :: Text -> Gen (Int, Text) +genSmapLine prefix = do + x <- genValid :: Gen Word16 + let txt = "" +| prefix |+ ": " +| x |+ " kB" + pure (fromIntegral x, txt) + + +genBaseSmap :: Gen (ProcUsage, Text) +genBaseSmap = do + (pp, txt, _) <- genBaseSmap' + pure (pp, txt) + + +ppZero :: ProcUsage +ppZero = + ProcUsage + { puPrivate = 0 + , puShared = 0 + , puSharedHuge = 0 + , puSwap = 0 + , puMemId = 0 + } + + +genBaseSmap' :: Gen (ProcUsage, Text, Int) +genBaseSmap' = do + (clean, cleanTxt) <- genSmapLine "Private_Clean" + (dirty, dirtyTxt) <- genSmapLine "Private_Dirty" + (sharedClean, shCleanTxt) <- genSmapLine "Shared_Clean" + (sharedDirty, shDirtyTxt) <- genSmapLine "Shared_Dirty" + (privateHuge, phTxt) <- genSmapLine "Private_Hugetlb" + (sharedHuge, shTxt) <- genSmapLine "Shared_Hugetlb" + (swap, swapTxt) <- genSmapLine "Swap" + let pp = + ppZero + { puPrivate = clean + dirty + privateHuge + , puMemId = hash content + , puSwap = swap + , puSharedHuge = sharedHuge + , puShared = sharedClean + sharedDirty + } + content = + Text.unlines + [ phTxt + , dirtyTxt + , cleanTxt + , swapTxt + , shTxt + , shCleanTxt + , shDirtyTxt + ] + pure (pp, content, privateHuge) + + +genWithPss :: Gen (ProcUsage, Text) +genWithPss = genBaseSmap' >>= genAppendPss + + +genAppendPss :: (ProcUsage, Text, Int) -> Gen (ProcUsage, Text) +genAppendPss (pp, initial, puPrivateHuge) = do + (pss, txt) <- genSmapLine "Pss" + let content = initial <> "\n" <> txt + newShared = pss - (puPrivate pp - puPrivateHuge) + pure (pp {puShared = newShared, puMemId = hash content}, content) diff --git a/test/MemInfo/MemInfoSpec.hs b/test/MemInfo/MemInfoSpec.hs new file mode 100644 --- /dev/null +++ b/test/MemInfo/MemInfoSpec.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : MemInfo.SysInfoSpec +Copyright : (c) 2023 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 +-} +module MemInfo.MemInfoSpec (spec) where + +import Data.GenValidity (GenValid (..)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Word (Word16) +import Fmt (blockMapF, build, fmt, (+|), (|+)) +import MemInfo.Files.Root (initRoot, useTmp, writeRootedFile) +import MemInfo.Files.Smap (genBaseSmap) +import MemInfo.OrphanInstances () +import System.Directory (createDirectoryIfMissing, createFileLink) +import System.FilePath (takeDirectory, ()) +import System.MemInfo (readForOnePid', readMemUsage) +import System.MemInfo.Proc (MemUsage, amass) +import System.MemInfo.SysInfo ( + KernelVersion, + mkReportBud, + ) +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Monadic (PropertyM, assert, monadicIO, pick, run) + + +spec :: Spec +spec = do + describe "module System.MemInfo.MemProc" $ around useTmp $ do + context "the proc fs stores mem info in //smap" $ do + context "and has 1 non-root process" $ do + context "readForOnePid'" $ do + it "should generate the correct report" prop_ReadOneSmapProcPid + context "readMemUsage'" $ do + it "should generate the correct report" prop_ReadSmapProcMemUsage + + +prop_ReadSmapProcMemUsage :: FilePath -> Property +prop_ReadSmapProcMemUsage root = monadicIO $ do + let fakeProc = "/usr/bin/true" + (wantedUsage, smapsTxt) <- pick genBaseSmap + let asReport = amass True [(fakeProc, wantedUsage)] + writeFiles = writeSmapProcFiles root smapsTxt fakeProc + verifyReadMemUsage root asReport gen3xKernel writeFiles + + +verifyReadMemUsage :: + FilePath -> + Map Text MemUsage -> + Gen KernelVersion -> + (Word16 -> IO ()) -> + PropertyM IO () +verifyReadMemUsage root expected genKernel writeFiles = do + thePid <- pick genValidProcId + version <- pick genKernel + -- some matches are incomplete, that's ok, the test should fail if they fai + Right procMap <- run $ do + initRoot root version + writeFiles thePid + Just bud <- mkReportBud root (fromIntegral thePid :| []) + readMemUsage bud + assert (expected == procMap) + + +prop_ReadOneSmapProcPid :: FilePath -> Property +prop_ReadOneSmapProcPid root = monadicIO $ do + let fakeProc = "/usr/bin/true" + (wantedUsage, smapsTxt) <- pick genBaseSmap + let asReport = amass True [(fakeProc, wantedUsage)] + writeFiles = writeSmapProcFiles root smapsTxt fakeProc + verifyReadForOnePid root asReport gen3xKernel writeFiles + + +verifyReadForOnePid :: + FilePath -> + Map Text MemUsage -> + Gen KernelVersion -> + (Word16 -> IO ()) -> + PropertyM IO () +verifyReadForOnePid root expected genKernel writeFiles = do + thePid <- pick genValidProcId + version <- pick genKernel + -- this match is incomplete, that's ok, the test fails if the run produces a Left + Right (theProc, theUsage) <- run $ do + initRoot root version + writeFiles thePid + readForOnePid' root $ fromIntegral thePid + assert (Map.lookup theProc expected == Just theUsage) + + +gen3xKernel :: Gen KernelVersion +gen3xKernel = do + patch <- genValid + minor <- genValid + pure (3, minor, patch) + + +writeSmapProcFiles :: FilePath -> Text -> Text -> Word16 -> IO () +writeSmapProcFiles root txt procName thePid = do + let fakeParent = "/sbin/fake" + writeRootedExeAndCmdLine root fakeParent 1 + writeRootedExeAndCmdLine root procName thePid + writeRootedFakeStatus root procName thePid 1 + writeRootedFile root ("" +| thePid |+ "/smaps") txt + + +genValidProcId :: Gen Word16 +genValidProcId = genValid `suchThat` (> 1) + + +writeRootedExeAndCmdLine :: FilePath -> Text -> Word16 -> IO () +writeRootedExeAndCmdLine root fakeProc procId = do + writeRootedFile root ("" +| procId |+ "/cmdline") fakeProc + writeRootedExeLink root ("" +| procId |+ "/exe") fakeProc + + +writeRootedFakeStatus :: FilePath -> Text -> Word16 -> Word16 -> IO () +writeRootedFakeStatus root fakeProc procId parentId = do + let txt = fmt $ blockMapF $ statusInfoFields fakeProc parentId + statusPath = "" +| procId |+ "/status" + writeRootedFile root statusPath txt + + +statusInfoFields :: Text -> Word16 -> [(Text, Text)] +statusInfoFields fakeProc parentId = + [ ("Name", fakeProc) + , ("PPid", fmt $ build $ toInteger parentId) + ] + + +writeRootedExeLink :: FilePath -> FilePath -> Text -> IO () +writeRootedExeLink root path link = do + let target = root path + createDirectoryIfMissing True $ takeDirectory target + createFileLink (Text.unpack link) target diff --git a/test/MemInfo/OrphanInstances.hs b/test/MemInfo/OrphanInstances.hs --- a/test/MemInfo/OrphanInstances.hs +++ b/test/MemInfo/OrphanInstances.hs @@ -27,6 +27,7 @@ Power, PrintOrder, Style, + defaultRoot, ) import System.MemInfo.Proc (ExeInfo (..), StatusInfo) import System.Posix.Types (CPid (..), ProcessID) @@ -106,6 +107,7 @@ <*> genValid <*> genValid <*> genValid + <*> pure defaultRoot <*> genPositiveMb <*> genPids <*> genValid diff --git a/test/MemInfo/ProcSpec.hs b/test/MemInfo/ProcSpec.hs --- a/test/MemInfo/ProcSpec.hs +++ b/test/MemInfo/ProcSpec.hs @@ -7,7 +7,9 @@ Maintainer : Tim Emiola SPDX-License-Identifier: BSD3 -} -module MemInfo.ProcSpec (spec) where +module MemInfo.ProcSpec ( + spec, +) where import Data.Hashable (hash) import Data.Maybe (isNothing) @@ -15,6 +17,7 @@ import qualified Data.Text as Text import Data.Word (Word16) import Fmt (blockMapF, build, fmt, (+|), (|+)) +import MemInfo.Files.Smap (genBaseSmap, genSmapLine, genWithPss) import MemInfo.OrphanInstances () import Numeric.Natural (Natural) import System.MemInfo.Proc @@ -176,65 +179,16 @@ } -genSmapLine :: Text -> Gen (Int, Text) -genSmapLine prefix = do - x <- genValid :: Gen Word16 - let txt = "" +| prefix |+ ": " +| x |+ " kB" - pure (fromIntegral x, txt) - - genSmap :: Gen (ProcUsage, Text) -genSmap = oneof [genBaseSmap, genWithSwapPss, genWithPss] +genSmap = oneof [genBaseSmap, genWithSwapPss, genWithPss, genWithPss >>= genAppendSwapPss] genWithSwapPss :: Gen (ProcUsage, Text) -genWithSwapPss = do - (pp, without) <- genBaseSmap - (swapPss, txt) <- genSmapLine "SwapPss" - let content = without <> "\n" <> txt - pure (pp {puSwap = swapPss, puMemId = hash content}, content) - - -genWithPss :: Gen (ProcUsage, Text) -genWithPss = do - (pp, without, puPrivateHuge) <- genBaseSmap' - (pss, txt) <- genSmapLine "Pss" - let content = without <> "\n" <> txt - newShared = pss - (puPrivate pp - puPrivateHuge) - pure (pp {puShared = newShared, puMemId = hash content}, content) - - -genBaseSmap :: Gen (ProcUsage, Text) -genBaseSmap = do - (pp, txt, _) <- genBaseSmap' - pure (pp, txt) +genWithSwapPss = genBaseSmap >>= genAppendSwapPss -genBaseSmap' :: Gen (ProcUsage, Text, Int) -genBaseSmap' = do - (clean, cleanTxt) <- genSmapLine "Private_Clean" - (dirty, dirtyTxt) <- genSmapLine "Private_Dirty" - (sharedClean, shCleanTxt) <- genSmapLine "Shared_Clean" - (sharedDirty, shDirtyTxt) <- genSmapLine "Shared_Dirty" - (privateHuge, phTxt) <- genSmapLine "Private_Hugetlb" - (sharedHuge, shTxt) <- genSmapLine "Shared_Hugetlb" - (swap, swapTxt) <- genSmapLine "Swap" - let pp = - ppZero - { puPrivate = clean + dirty + privateHuge - , puMemId = hash content - , puSwap = swap - , puSharedHuge = sharedHuge - , puShared = sharedClean + sharedDirty - } - content = - Text.unlines - [ phTxt - , dirtyTxt - , cleanTxt - , swapTxt - , shTxt - , shCleanTxt - , shDirtyTxt - ] - pure (pp, content, privateHuge) +genAppendSwapPss :: (ProcUsage, Text) -> Gen (ProcUsage, Text) +genAppendSwapPss (pp, initial) = do + (swapPss, txt) <- genSmapLine "SwapPss" + let content = initial <> "\n" <> txt + pure (pp {puSwap = swapPss, puMemId = hash content}, content) diff --git a/test/MemInfo/SysInfoSpec.hs b/test/MemInfo/SysInfoSpec.hs --- a/test/MemInfo/SysInfoSpec.hs +++ b/test/MemInfo/SysInfoSpec.hs @@ -1,5 +1,5 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} {- | Module : MemInfo.SysInfoSpec @@ -9,22 +9,62 @@ -} module MemInfo.SysInfoSpec (spec) where +import Control.Monad (when) import Data.GenValidity (GenValid (..)) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text) -import Data.Word (Word8) +import qualified Data.Text as Text +import Data.Word (Word16, Word8) import Fmt (build, fmt, (+|), (|+)) +import MemInfo.Files.Root (initRoot, useTmp, writeRootedFile) +import MemInfo.Files.Smap (genBaseSmap, genSmapLine, genWithPss) import MemInfo.OrphanInstances () -import System.MemInfo.SysInfo (KernelVersion, parseKernelVersion) +import System.MemInfo.SysInfo ( + KernelVersion, + RamFlaw (..), + ReportBud (..), + SwapFlaw (..), + mkReportBud, + parseKernelVersion, + ) import Test.Hspec import Test.QuickCheck +import Test.QuickCheck.Monadic (PropertyM, assert, monadicIO, pick, run) spec :: Spec spec = describe "module System.MemInfo.SysInfo" $ do describe "parseKernelVersion" $ do it "should parse values from Text successfully" prop_roundtripKernelVersion + mkReportBudSpec +mkReportBudSpec :: Spec +mkReportBudSpec = do + describe "mkReportBud" $ around useTmp $ do + context "when the kernel is 2.4.x" $ do + context "and there is no Inact_ ram" $ do + it "generates the expected ReportBud" (prop_With24Kernel True) + context "and there is Inact_ ram" $ do + it "generates the expected ReportBud" (prop_With24Kernel False) + context "when the kernel is earlier than 2.4" $ do + it "generates the expected ReportBud" prop_With22Kernel + context "when the kernel is a special 2.6 kernel" $ do + it "generates the expected ReportBud" prop_WithSpecial26Kernel + context "when the kernel is a later 2.6 kernel with no smap support" $ do + it "generates the expected ReportBud" prop_WithNoSmap26Kernel + context "when the kernel is a later 2.6 kernel with smap support" $ do + context "and there are smap files but no Pss" $ do + it "generates the expected ReportBud" $ prop_WithSmaps26Kernel False + context "and there are smap files but with Pss" $ do + it "generates the expected ReportBud" $ prop_WithSmaps26Kernel True + context "when the kernel is later than 3.x" $ do + context "and there are smap files" $ do + it "generates the expected ReportBud" $ prop_WithAfter3xKernel True + context "and there are no smap files" $ do + it "generates the expected ReportBud" $ prop_WithAfter3xKernel False + + prop_roundtripKernelVersion :: Property prop_roundtripKernelVersion = within 5000000 $ @@ -71,3 +111,152 @@ fromSingle = do x <- genValid :: Gen Word8 pure ((fromIntegral x, 0, 0), fmt $ build x) + + +prop_WithAfter3xKernel :: Bool -> FilePath -> Property +prop_WithAfter3xKernel hasPss root = monadicIO $ do + let withFlaws x = + x + { rbRamFlaws = if hasPss then Nothing else Just ExactForIsolatedMem + , rbSwapFlaws = Just $ if hasPss then ExactForIsolatedSwap else NoSwap + , rbHasSmaps = hasPss + } + writeSmaps txt thePid = + when hasPss $ writeRootedFile root ("" +| thePid |+ "/smaps") txt + genKernel = do + patch <- genValid + minor <- genValid + pure (3, minor, patch) + + (_ignored, smapsTxt) <- pick genBaseSmap + verifyMkReportBud root withFlaws genKernel $ writeSmaps smapsTxt + + +prop_With24Kernel :: Bool -> FilePath -> Property +prop_With24Kernel hasInactRam root = monadicIO $ do + let withFlaws x = + x + { rbRamFlaws = Just $ if hasInactRam then SomeSharedMem else ExactForIsolatedMem + , rbSwapFlaws = Just NoSwap + } + genKernel = do + patch <- genValid + pure (2, 4, patch) + writeMemInfo txt _unused = writeRootedFile root "meminfo" txt + + memInfoTxt <- pick $ genMemInfoLines hasInactRam + verifyMkReportBud root withFlaws genKernel $ writeMemInfo memInfoTxt + + +prop_WithSmaps26Kernel :: Bool -> FilePath -> Property +prop_WithSmaps26Kernel hasPss root = monadicIO $ do + let withFlaws x = + x + { rbRamFlaws = if hasPss then Nothing else Just ExactForIsolatedMem + , rbSwapFlaws = Just ExactForIsolatedSwap + , rbHasSmaps = True + , rbHasPss = hasPss + } + writeSmaps txt thePid = + writeRootedFile root ("" +| thePid |+ "/smaps") txt + genKernel = do + patch <- chooseInteger (10, 100) + pure (2, 6, fromIntegral patch) + genSmap = if hasPss then genWithPss else genBaseSmap + + (_ignored, smapsTxt) <- pick genSmap + verifyMkReportBud root withFlaws genKernel $ writeSmaps smapsTxt + + +prop_WithSpecial26Kernel :: FilePath -> Property +prop_WithSpecial26Kernel root = monadicIO $ do + let withFlaws x = + x + { rbRamFlaws = Just NoSharedMem + , rbSwapFlaws = Just NoSwap + } + genKernel = do + patch <- chooseInteger (1, 9) + pure (2, 6, fromIntegral patch) + + verifyMkReportBud root withFlaws genKernel $ const $ pure () + + +prop_WithNoSmap26Kernel :: FilePath -> Property +prop_WithNoSmap26Kernel root = monadicIO $ do + let withFlaws x = + x + { rbRamFlaws = Just SomeSharedMem + , rbSwapFlaws = Just NoSwap + } + genKernel = do + patch <- chooseInteger (10, 100) + pure (2, 6, fromIntegral patch) + + verifyMkReportBud root withFlaws genKernel $ const $ pure () + + +genMemInfoLines :: Bool -> Gen Text +genMemInfoLines hasInact = do + -- reference: http://darenmatthews.com/blog/?p=2092 + (_unused1, memTotalTxt) <- genSmapLine "MemTotal" + (_unused2, memFreeTxt) <- genSmapLine "MemFree" + (_unused3, buffersTxt) <- genSmapLine "Buffers" + (_unused4, inactTxt) <- genSmapLine "Inact_Target" -- or Inact_{Clean,Dirty} + let baselines = [memTotalTxt, memFreeTxt, buffersTxt] + ls = if hasInact then baselines <> [inactTxt] else baselines + pure $ Text.unlines ls + + +prop_With22Kernel :: FilePath -> Property +prop_With22Kernel root = monadicIO $ do + let withFlaws x = + x + { rbRamFlaws = Just ExactForIsolatedMem + , rbSwapFlaws = Just NoSwap + } + genKernel = do + patch <- genValid + pure (2, 2, patch) + verifyMkReportBud root withFlaws genKernel $ const $ pure () + + +verifyMkReportBud :: + FilePath -> + (ReportBud -> ReportBud) -> + Gen KernelVersion -> + (Word16 -> IO ()) -> + PropertyM IO () +verifyMkReportBud root changeBud genKernel writeFiles = do + (thePid, version, want) <- pick $ genExpectedBud changeBud genKernel root + bud <- run $ do + initRoot root version + writeFiles thePid + mkReportBud root (fromIntegral thePid :| []) + assert (bud == Just want) + + +genExpectedBud :: + (ReportBud -> ReportBud) -> + Gen KernelVersion -> + FilePath -> + Gen (Word16, KernelVersion, ReportBud) +genExpectedBud changeBud genKernel root = do + thePid <- genValidProcId + rbKernel <- genKernel + let theBud = + ReportBud + { rbPids = fromIntegral thePid :| [] + , rbKernel + , rbHasPss = False + , rbHasSwapPss = False + , rbHasSmaps = False + , rbRamFlaws = Nothing + , rbSwapFlaws = Nothing + , rbProcRoot = root + } + pure (thePid, rbKernel, changeBud theBud) + + +genValidProcId :: Gen Word16 +genValidProcId = genValid `suchThat` (> 1)