mem-info 0.3.1.0 → 0.4.0.0

raw patch · 12 files changed

+712/−178 lines, 12 filesdep +mtldep +temporarydep ~containersdep ~directorydep ~filepathPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl, temporary

Dependency ranges changed: containers, directory, filepath

API changes (from Hackage documentation)

Files

• ChangeLog.md +14/−0
• mem-info.cabal +9/−1
• src/System/MemInfo.hs +113/−71
• src/System/MemInfo/Choices.hs +19/−0
• src/System/MemInfo/Prelude.hs +4/−0
• src/System/MemInfo/SysInfo.hs +69/−46
• test/MemInfo/Files/Root.hs +49/−0
• test/MemInfo/Files/Smap.hs +87/−0
• test/MemInfo/MemInfoSpec.hs +143/−0
• test/MemInfo/OrphanInstances.hs +2/−0
• test/MemInfo/ProcSpec.hs +11/−57
• test/MemInfo/SysInfoSpec.hs +192/−3

@@ -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

@@ -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

@@ -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  

@@ -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"

@@ -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)

@@ -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

@@ -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 |+ ""

@@ -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)

@@ -0,0 +1,143 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module      : MemInfo.SysInfoSpec+Copyright   : (c) 2023 Tim Emiola+Maintainer  : Tim Emiola <adetokunbo@emio.la>+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 <proc>/<id>/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

@@ -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

@@ -7,7 +7,9 @@ Maintainer  : Tim Emiola <adetokunbo@emio.la> 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)

@@ -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)