packages feed

mem-info (empty) → 0.1.0.0

raw patch · 16 files changed

+2130/−0 lines, 16 filesdep +QuickCheckdep +basedep +bytestringsetup-changed

Dependencies added: QuickCheck, base, bytestring, containers, directory, filepath, fmt, genvalidity, genvalidity-hspec, genvalidity-text, hashable, hspec, mem-info, optparse-applicative, text, unix, validity, validity-text

Files

+ ChangeLog.md view
@@ -0,0 +1,9 @@+# Revision history for mem-info++`mem-info` uses [PVP Versioning][1].++## 0.1.0.0 -- 2024-01-16++* Initial version.++[1]: https://pvp.haskell.org
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2023, Tim Emiola++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Tim Emiola nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple+++main = defaultMain
+ exe/PrintMem.hs view
@@ -0,0 +1,15 @@+{- |+Module      : PrintMem+Copyright   : (c) 2022 Tim Emiola+Maintainer  : Tim Emiola <adetokunbo@emio.la>+SPDX-License-Identifier: BSD3++A command that computes and prints the memory usage of some processes+-}+module Main (main) where++import System.MemInfo (getChoices, printProcs)+++main :: IO ()+main = getChoices >>= printProcs
+ mem-info.cabal view
@@ -0,0 +1,100 @@+cabal-version:      3.0+name:               mem-info+version:            0.1.0.0+synopsis:           Print the core memory usage of programs+description:+  A utility to accurately report the core memory usage of programs.++  This is a clone of+  [ps_mem](https://github.com/pixelb/ps_mem/blob/master/README.md), which is+  written in python++  The package provides:++    * an executable command `printmem` that mimics `ps_mem`++    * a library to enable core memory tracking on linux in haskell programs++  See the [README](https://github.com/adetokunbo/mem-info/blob/master/README.md)+  for further details++license:            BSD-3-Clause+license-file:       LICENSE+author:             Tim Emiola+maintainer:         adetokunbo@emio.la+category:           Command Line Tools, system+homepage:           https://github.com/adetokunbo/mem-info#readme+bug-reports:        https://github.com/adetokunbo/mem-info/issues+build-type:         Simple+extra-source-files: ChangeLog.md++source-repository head+  type:     git+  location: https://github.com/adetokunbo/mem-info.git++library+  exposed-modules:+    System.MemInfo+    System.MemInfo.Choices+    System.MemInfo.Print+    System.MemInfo.Proc+    System.MemInfo.SysInfo+  other-modules:+    System.MemInfo.Prelude++  hs-source-dirs:   src+  build-depends:+    , base                  >=4.10   && <5+    , bytestring            >=0.11.4 && <0.12+    , containers            >=0.6.5  && <0.8+    , directory             >=1.3.6  && <1.5+    , filepath              >=1.4.2  && <1.6+    , fmt                   >=0.6.3  && <0.8+    , hashable              >=1.4.2  && <1.6+    , optparse-applicative  >=0.18.1 && <0.19+    , text                  >=1.2.3  && <2.2+    , unix                  >=2.7.2  && <2.9+    , validity              >=0.12.0 && <0.14+    , validity-text         >=0.3.1  && <0.4.1++  default-language: Haskell2010+  ghc-options:+    -Wall -Wincomplete-uni-patterns -Wpartial-fields -fwarn-tabs++test-suite test+  type:             exitcode-stdio-1.0+  main-is:          Spec.hs+  hs-source-dirs:   test+  other-modules:+    MemInfo.OrphanInstances+    MemInfo.PrintSpec+    MemInfo.ProcSpec+    MemInfo.SysInfoSpec++  default-language: Haskell2010+  ghc-options:      -threaded -rtsopts -with-rtsopts=-N -Wall -fwarn-tabs+  build-depends:+    , base+    , fmt+    , genvalidity+    , genvalidity-hspec+    , genvalidity-text+    , hashable+    , mem-info+    , hspec              >=2.1 && <2.11+    , QuickCheck+    , text+    , unix++-- printmem is the printmem command+executable printmem+  main-is:          PrintMem.hs+  hs-source-dirs:   exe+  default-language: Haskell2010+  build-depends:+    , base         >=4.14 && <5+    , mem-info++  ghc-options:      -threaded -rtsopts -with-rtsopts=-N+  ghc-options:+    -Wall -Wincomplete-uni-patterns -Wpartial-fields -fwarn-tabs
+ src/System/MemInfo.hs view
@@ -0,0 +1,589 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- |+Module      : System.MemInfo+Copyright   : (c) 2023 Tim Emiola+Maintainer  : Tim Emiola <adetokunbo@emio.la>+SPDX-License-Identifier: BSD3++Implements __printmem__, a command that computes the memory usage of some+processes+-}+module System.MemInfo (+  -- * Implement __printmem__+  getChoices,+  printProcs,++  -- * Read /MemUsage/+  readForOnePid,+  readMemUsage',+  readMemUsage,+  NotRun (..),+  LostPid (..),++  -- * Stream /MemUsage/ periodically+  unfoldMemUsage,+  unfoldMemUsageAfter',+  unfoldMemUsageAfter,++  -- * Obtain the process/program name+  ProcNamer,+  nameFromExeOnly,+  nameFor,+  nameAsFullCmd,++  -- * Index by pid or name+  ProcName,+  Indexer,+  dropId,+  withPid,++  -- * Print /MemUsage/+  printUsage',+  printUsage,++  -- * Convenient re-exports+  mkReportBud,+  ProcessID,+  AsCmdName (..),+) where++import Data.Bifunctor (Bifunctor (..))+import Data.Functor ((<&>))+import qualified Data.List.NonEmpty as NE+import qualified Data.Map.Strict as Map+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Fmt (+  listF,+  (+|),+  (|+),+  (|++|),+ )+import System.Exit (exitFailure)+import System.MemInfo.Choices (Choices (..), getChoices)+import System.MemInfo.Prelude+import System.MemInfo.Print (+  AsCmdName (..),+  fmtAsHeader,+  fmtMemUsage,+  fmtOverall,+ )+import System.MemInfo.Proc (+  BadStatus (..),+  ExeInfo (..),+  MemUsage (..),+  ProcUsage (..),+  StatusInfo (..),+  amass,+  parseExeInfo,+  parseFromSmap,+  parseFromStatm,+  parseStatusInfo,+ )+import System.MemInfo.SysInfo (+  ReportBud (..),+  fmtRamFlaws,+  fmtSwapFlaws,+  mkReportBud,+ )+import System.Posix.User (getEffectiveUserID)+++{- | Print a report to @stdout@ displaying the memory usage of the programs+specified by @Choices@+-}+printProcs :: Choices -> IO ()+printProcs cs = do+  bud <- verify cs+  let Choices+        { choiceShowSwap = showSwap+        , choiceOnlyTotal = onlyTotal+        , choiceWatchSecs = watchSecsMb+        , choiceByPid = byPid+        } = cs+      printEachCmd totals = printMemUsages bud showSwap onlyTotal totals+      printTheTotal = onlyPrintTotal bud showSwap onlyTotal+      showTotal cmds = if onlyTotal then printTheTotal cmds else printEachCmd cmds+      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+      loopPrintMemUsages unfold bud showTotal+++printMemUsages :: AsCmdName a => ReportBud -> Bool -> Bool -> Map a MemUsage -> IO ()+printMemUsages bud showSwap onlyTotal totals = do+  let overall = overallTotals $ Map.elems 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+  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' (name, mu) showSwap = Text.putStrLn $ fmtMemUsage showSwap name mu+++-- | Like @'printUsage''@, but alway shows the swap size+printUsage :: AsCmdName a => (a, MemUsage) -> IO ()+printUsage = flip printUsage' True+++onlyPrintTotal :: ReportBud -> Bool -> Bool -> Map k MemUsage -> IO ()+onlyPrintTotal bud showSwap onlyTotal totals = do+  let (private, swap) = overallTotals $ Map.elems totals+      printRawTotal = Text.putStrLn . fmtMemBytes+  if showSwap+    then do+      when (rbHasSwapPss bud) $ printRawTotal swap+      reportFlaws bud showSwap onlyTotal+      when (isJust $ rbSwapFlaws bud) exitFailure+    else do+      when (rbHasPss bud) $ printRawTotal private+      reportFlaws bud showSwap onlyTotal+      when (isJust $ rbRamFlaws bud) exitFailure+++loopPrintMemUsages ::+  (Ord c, AsCmdName c) =>+  (ReportBud -> IO (Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud))) ->+  ReportBud ->+  (Map c MemUsage -> IO ()) ->+  IO ()+loopPrintMemUsages unfold bud showTotal = do+  let clearScreen = putStrLn "\o033c"+      warnHalting = errStrLn False "halting: all monitored processes have stopped"+      handleNext (Left stopped) = do+        warnStopped stopped+        warnHalting+      handleNext (Right ((total, stopped), updated)) = do+        clearScreen+        warnStopped stopped+        showTotal total+        go updated+      go initial = unfold initial >>= handleNext+  go bud+++warnStopped :: [ProcessID] -> IO ()+warnStopped pids = unless (null pids) $ do+  let errMsg = "some processes stopped:pids:" +| toInteger <$> pids |+ ""+  errStrLn False errMsg+++-- | The name of a process or program in the memory report.+type ProcName = Text+++-- | Like @'unfoldMemUsageAfter''@, but uses the default 'ProcName' and 'Indexer'+unfoldMemUsageAfter ::+  (Integral seconds) =>+  seconds ->+  ReportBud ->+  IO (Either [ProcessID] ((Map Text MemUsage, [ProcessID]), ReportBud))+unfoldMemUsageAfter = unfoldMemUsageAfter' nameFor dropId+++-- | Like @'unfoldMemUsage'@ but computes the @'MemUsage's@ after a delay+unfoldMemUsageAfter' ::+  (Ord a, Integral seconds) =>+  ProcNamer ->+  Indexer a ->+  seconds ->+  ReportBud ->+  IO (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))+unfoldMemUsageAfter' namer mkCmd spanSecs bud = do+  let spanMicros = 1000000 * fromInteger (toInteger spanSecs)+  threadDelay spanMicros+  unfoldMemUsage namer mkCmd bud+++{- | Unfold @'MemUsage's@ specified by a @'ReportBud'@++The @ProcessID@ of stopped processes are reported, both as part of intermediate+invocations (via the @[ProcessID]@ in the @Right@), and in the final one (as the+value of the @Left@).+-}+unfoldMemUsage ::+  (Ord a) =>+  ProcNamer ->+  Indexer a ->+  ReportBud ->+  IO (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))+unfoldMemUsage namer mkCmd bud = do+  let changePids rbPids = bud {rbPids}+      dropStopped t [] = Just t+      dropStopped ReportBud {rbPids = ps} stopped =+        changePids <$> nonEmpty (NE.filter (`notElem` stopped) ps)+      ReportBud {rbPids = pids, rbHasPss = hasPss} = bud+      nextState (stopped, []) = Left stopped+      nextState (stopped, xs) = case dropStopped bud stopped of+        Just updated -> Right ((amass hasPss (map mkCmd xs), stopped), updated)+        Nothing -> Left stopped+  nextState <$> foldlEitherM' (readNameAndStats namer bud) pids+++-- | Load the @'MemUsage'@ of a program specified by its @ProcessID@+readForOnePid :: ProcessID -> IO (Either NotRun (ProcName, MemUsage))+readForOnePid pid = do+  let mkBud' xs = mkReportBud 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+    Left err -> pure $ Left $ PidLost err+    Right _ ->+      mkBud' (pid :| []) >>= \case+        Left err -> pure $ Left err+        Right bud -> readMemUsage bud <&> andFromUsage+++-- | Like @'readMemUsage''@ but uses the default 'ProcNamer' and 'Indexer'+readMemUsage :: ReportBud -> IO (Either LostPid (Map ProcName MemUsage))+readMemUsage = readMemUsage' nameFor dropId+++{- | Loads the @'MemUsage'@ specified by a @'ReportBud'@++Fails if++- the system does not have the expected /proc filesystem memory records+- any of the processes specified by @'ReportBud'@ are missing or inaccessible+-}+readMemUsage' ::+  Ord a =>+  ProcNamer ->+  Indexer a ->+  ReportBud ->+  IO (Either LostPid (Map a MemUsage))+readMemUsage' namer mkCmd bud = do+  let amass' cmds = amass (rbHasPss bud) $ map mkCmd cmds+  fmap amass' <$> foldlEitherM (readNameAndStats namer bud) (rbPids bud)+++readNameAndStats ::+  ProcNamer ->+  ReportBud ->+  ProcessID ->+  IO (Either LostPid (ProcessID, ProcName, ProcUsage))+readNameAndStats namer bud pid = do+  namer 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)+++reportFlaws :: ReportBud -> Bool -> Bool -> IO ()+reportFlaws bud showSwap onlyTotal = do+  let reportSwap = errStrLn onlyTotal . fmtSwapFlaws+      reportRam = errStrLn onlyTotal . fmtRamFlaws+      (ram, swap) = (rbRamFlaws bud, rbSwapFlaws bud)+  -- when showSwap, report swap flaws+  -- unless (showSwap and onlyTotal), show ram flaws+  when showSwap $ maybe (pure ()) reportSwap swap+  unless (onlyTotal && showSwap) $ maybe (pure ()) reportRam ram+++verify :: Choices -> IO ReportBud+verify cs = verify' (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+      thenMkBud = either (pure . Left) mkBud'+  case pidsMb of+    Just pids -> checkAllExist pids >>= thenMkBud+    Nothing -> whenRoot $ allKnownProcs >>= thenMkBud+++procRoot :: String+procRoot = "/proc/"+++pidPath :: String -> ProcessID -> FilePath+pidPath base pid = "" +| procRoot |++| toInteger pid |+ "/" +| base |+ ""+++whenRoot :: IO (Either NotRun a) -> IO (Either NotRun a)+whenRoot action = do+  -- if choicePidsToShow is Nothing, must be running as root+  isRoot' <- (== 0) <$> getEffectiveUserID+  if isRoot' then action else pure $ Left NeedsRoot+++{- | pidExists returns false for any ProcessID that does not exist or cannot+be accessed+-}+pidExeExists :: ProcessID -> IO Bool+pidExeExists = fmap (either (const False) (const True)) . exeInfo+++-- | Obtain the @ProcName@ as the full cmd path+nameAsFullCmd :: ProcNamer+nameAsFullCmd pid = do+  let cmdlinePath = pidPath "cmdline" pid+      err = NoCmdLine pid+      recombine = Text.intercalate " " . NE.toList+      orLostPid = maybe (Left err) (Right . recombine)+  readUtf8Text cmdlinePath >>= (pure . orLostPid) . parseCmdline+++{- | Obtain the @ProcName@ by examining the path linked by+__{proc_root}\/pid\/exe__+-}+nameFromExeOnly :: ProcNamer+nameFromExeOnly pid = do+  exeInfo pid >>= \case+    Right i | not $ eiDeleted i -> pure $ Right $ baseName $ eiOriginal i+    -- when the exe bud ends with (deleted), the version of the exe used to+    -- invoke the process has been removed from the filesystem. Sometimes it has+    -- been updated; examining both the original bud and the version in+    -- cmdline help determine what occurred+    Right ExeInfo {eiOriginal = orig} ->+      exists orig >>= \case+        True -> pure $ Right $ baseName $ "" +| orig |+ " [updated]"+        _ -> do+          let cmdlinePath = pidPath "cmdline" pid+          readUtf8Text cmdlinePath <&> parseCmdline >>= \case+            Just (x :| _) -> do+              let addSuffix' b = x <> if b then " [updated]" else " [deleted]"+              Right . baseName . addSuffix' <$> exists x+            -- args should not be empty when {pid_root}/exe resolves to a+            -- path, it's an error if it is+            Nothing -> pure $ Left $ NoCmdLine pid+    Left e -> pure $ Left e+++-- | Functions that obtain a process name given its @pid@+type ProcNamer = 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)+++parentNameIfMatched :: ProcessID -> Text -> IO (Either LostPid ProcName)+parentNameIfMatched pid candidate = do+  let isMatch = flip Text.isPrefixOf candidate . siName+  statusInfo pid >>= \case+    Left err -> pure $ Left err+    Right si | isMatch si -> pure $ Right candidate+    Right si ->+      nameFromExeOnly (siParent si) >>= \case+        Right n | n == candidate -> pure $ Right n+        _ -> pure $ Right $ siName si+++-- | Represents errors that prevent a report from being generated+data NotRun+  = PidLost LostPid+  | MissingPids (NonEmpty ProcessID)+  | NeedsRoot+  | OddKernel+  | NoRecords+  deriving (Eq, Show)+++fmtNotRun :: NotRun -> Text+fmtNotRun NeedsRoot = "run as root when no pids are specified using -p"+fmtNotRun (PidLost x) = fmtLostPid x+fmtNotRun OddKernel = "unrecognized kernel version"+fmtNotRun (MissingPids pids) = "no records available for: " +| listF (toInteger <$> pids) |+ ""+fmtNotRun NoRecords = "could not find any process records"+++{- | Represents reasons a specified @pid@ may not have memory+records.+-}+data LostPid+  = NoExeFile ProcessID+  | NoStatusCmd ProcessID+  | NoStatusParent ProcessID+  | NoCmdLine ProcessID+  | BadStatm ProcessID+  | NoProc ProcessID+  deriving (Eq, Show)+++fmtLostPid :: LostPid -> Text+fmtLostPid (NoStatusCmd pid) = "missing:no name in {proc_root}/" +| toInteger pid |+ "/status"+fmtLostPid (NoStatusParent pid) = "missing:no ppid in {proc_root}/" +| toInteger pid |+ "/status"+fmtLostPid (NoExeFile pid) = "missing:{proc_root}/" +| toInteger pid |+ "/exe"+fmtLostPid (NoCmdLine pid) = "missing:{proc_root}/" +| toInteger pid |+ "/cmdline"+fmtLostPid (NoProc pid) = "missing:memory records for pid:" +| toInteger pid |+ ""+fmtLostPid (BadStatm pid) = "missing:invalid memory record in {proc_root}/" +| toInteger pid |+ "/statm"+++haltLostPid :: LostPid -> IO a+haltLostPid err = do+  Text.hPutStrLn stderr $ "halting due to " +| fmtLostPid err |+ ""+  exitFailure+++exeInfo :: ProcessID -> IO (Either LostPid ExeInfo)+exeInfo pid = do+  let exePath = pidPath "exe" pid+      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+++exists :: Text -> IO Bool+exists = doesFileExist . Text.unpack+++statusInfo :: ProcessID -> IO (Either LostPid StatusInfo)+statusInfo pid = do+  let statusPath = pidPath "status" pid+      fromBadStatus NoCmd = NoStatusCmd pid+      fromBadStatus NoParent = NoStatusParent pid+  first fromBadStatus . parseStatusInfo <$> readUtf8Text statusPath+++parseCmdline :: Text -> Maybe (NonEmpty Text)+parseCmdline =+  let split' = Text.split isNullOrSpace . Text.strip . Text.dropWhileEnd isNull+   in nonEmpty . split'+++nonExisting :: NonEmpty ProcessID -> IO [ProcessID]+nonExisting = filterM (fmap not . pidExeExists) . NE.toList+++checkAllExist :: NonEmpty ProcessID -> IO (Either NotRun (NonEmpty ProcessID))+checkAllExist pids =+  nonExisting pids >>= \case+    [] -> pure $ Right pids+    x : xs -> pure $ Left $ MissingPids $ x :| xs+++allKnownProcs :: IO (Either NotRun (NonEmpty ProcessID))+allKnownProcs =+  let readNaturals = fmap (mapMaybe readMaybe)+      orNoPids = maybe (Left NoRecords) Right+   in readNaturals (listDirectory procRoot)+        >>= filterM pidExeExists+        >>= pure . orNoPids . nonEmpty+++baseName :: Text -> Text+baseName = Text.pack . takeBaseName . Text.unpack+++readMemStats :: ReportBud -> ProcessID -> IO (Either LostPid ProcUsage)+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+++readSmaps :: ProcessID -> IO Text+readSmaps pid = do+  let smapPath = pidPath "smaps" pid+      rollupPath = pidPath "smaps_rollup" pid+  hasSmaps <- doesFileExist smapPath+  hasRollup <- doesFileExist rollupPath+  if+      | hasRollup -> readUtf8Text rollupPath+      | hasSmaps -> readUtf8Text smapPath+      | otherwise -> pure Text.empty+++overallTotals :: [MemUsage] -> (Int, Int)+overallTotals cts =+  let step (private, swap) ct = (private + muPrivate ct, swap + muSwap ct)+   in foldl' step (0, 0) cts+++fmtMemBytes :: Int -> Text+fmtMemBytes x = "" +| x * 1024 |+ ""+++foldlEitherM ::+  (Foldable t, Monad m) =>+  (a -> m (Either b c)) ->+  t a ->+  m (Either b [c])+foldlEitherM f xs =+  let go (Left err) _ = pure $ Left err+      go (Right acc) a =+        f a >>= \case+          Left err -> pure $ Left err+          Right y -> pure $ Right (y : acc)+   in foldlM go (Right []) xs+++foldlEitherM' ::+  (Foldable t, Monad m) =>+  (a -> m (Either b c)) ->+  t a ->+  m ([a], [c])+foldlEitherM' f xs =+  let+    go (as, cs) a =+      f a >>= \case+        Left _ -> pure (a : as, cs)+        Right c -> pure (as, c : cs)+   in+    foldlM go (mempty, mempty) xs+++haltErr :: Text -> IO a+haltErr err = do+  errStrLn True err+  exitFailure+++errStrLn :: Bool -> Text -> IO ()+errStrLn errOrWarn txt = do+  let prefix = if errOrWarn then "error: " else "warning: "+  Text.hPutStrLn stderr $ prefix <> txt+++-- | Functions that generate the report index+type Indexer index = (ProcessID, ProcName, ProcUsage) -> (index, ProcUsage)+++{- | Index a @'ProcUsage'@ using the program name and process ID.++Each @ProcUsage@ remains distinct when added to a @MemUsage@+-}+withPid :: Indexer (ProcessID, ProcName)+withPid (pid, name, pp) = ((pid, name), pp)+++{- | Index a @'ProcUsage'@ using just the program name++@ProcUsage's@ with the same @ProcName@ will be merged when added to a @MemUsage@+-}+dropId :: Indexer ProcName+dropId (_pid, name, pp) = (name, pp)
+ src/System/MemInfo/Choices.hs view
@@ -0,0 +1,128 @@+{- |+Module      : System.MemInfo.Choices+Copyright   : (c) 2022 Tim Emiola+Maintainer  : Tim Emiola <adetokunbo@emio.la>+SPDX-License-Identifier: BSD3++This module defines the command line flags used to control the behavior of the+__printmem__ command+-}+module System.MemInfo.Choices (+  Choices (..),+  cmdInfo,+  getChoices,+) where++import Options.Applicative (+  Parser,+  ParserInfo,+  ReadM,+  auto,+  execParser,+  help,+  helper,+  info,+  long,+  metavar,+  option,+  optional,+  readerError,+  short,+  switch,+ )+import Options.Applicative.NonEmpty (some1)+import System.MemInfo.Prelude+++-- | Parses the command line arguments.+getChoices :: IO Choices+getChoices = execParser cmdInfo+++-- | Represents the user-specified choices extracted from the command line+data Choices = Choices+  { choiceSplitArgs :: !Bool+  , choiceOnlyTotal :: !Bool+  , choiceByPid :: !Bool+  , choiceShowSwap :: !Bool+  , choiceWatchSecs :: !(Maybe Natural)+  , choicePidsToShow :: !(Maybe (NonEmpty ProcessID))+  }+  deriving (Eq, Show)+++-- | Specifies a command line that when parsed will provide 'Choices'+cmdInfo :: ParserInfo Choices+cmdInfo = info (helper <*> parseChoices) mempty+++parseChoices :: Parser Choices+parseChoices =+  Choices+    <$> parseSplitArgs+    <*> parseOnlyTotal+    <*> parseDiscriminateByPid+    <*> parseShowSwap+    <*> optional parseWatchPeriodSecs+    <*> optional parseChoicesPidsToShow+++parseChoicesPidsToShow :: Parser (NonEmpty ProcessID)+parseChoicesPidsToShow =+  some1 $+    option positiveNum $+      short 'p'+        <> long "pids"+        <> metavar "<pid1> [ -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"+++parseOnlyTotal :: Parser Bool+parseOnlyTotal =+  switch $+    short 't'+      <> long "total"+      <> help "Only show the total value"+++parseDiscriminateByPid :: Parser Bool+parseDiscriminateByPid =+  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"+++parseWatchPeriodSecs :: Parser Natural+parseWatchPeriodSecs =+  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+positiveNum =+  let+    checkPositive i+      | i > 0 = pure i+      | otherwise = readerError "Value must be greater than 0"+   in+    auto >>= checkPositive
+ src/System/MemInfo/Prelude.hs view
@@ -0,0 +1,76 @@+{- |+Module      : System.MemInfo.Prelude+Copyright   : (c) 2022 Tim Emiola+Maintainer  : Tim Emiola <adetokunbo@emio.la>+SPDX-License-Identifier: BSD3++Imports and re-export commonly-used functions and data types+-}+module System.MemInfo.Prelude (+  -- * functions+  isNull,+  isNullOrSpace,+  readUtf8Text,++  -- * module re-exports+  module Control.Concurrent,+  module Control.Exception,+  module Control.Monad,+  module Data.Char,+  module Data.Foldable,+  module Data.Hashable,+  module Data.List,+  module Data.List.NonEmpty,+  module Data.Maybe,+  module Data.Map.Strict,+  module Data.Set,+  module Data.Text,+  module Data.Text.Encoding,+  module Numeric.Natural,+  module System.FilePath,+  module System.Directory,+  module System.IO.Error,+  module System.IO,+  module System.Posix.Types,+  module Text.Read,+) where++import Control.Concurrent (threadDelay)+import Control.Exception (handle, throwIO)+import Control.Monad (filterM, unless, when)+import qualified Data.ByteString as BS+import Data.Char (isSpace)+import Data.Foldable (foldlM)+import Data.Hashable (hash)+import Data.List (foldl')+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)+import Data.Map.Strict (Map)+import Data.Maybe (isJust, mapMaybe)+import Data.Set (Set)+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8)+import Numeric.Natural (Natural)+import System.Directory (+  doesFileExist,+  getSymbolicLinkTarget,+  listDirectory,+ )+import System.FilePath (takeBaseName)+import System.IO (stderr)+import System.IO.Error (isDoesNotExistError, isPermissionError)+import System.Posix.Types (CPid (..), ProcessID)+import Text.Read (readEither, readMaybe)+++-- | @True@ for the @null@ char+isNull :: Char -> Bool+isNull = (== '\0')+++-- | @True@ for the @null@ char or any space+isNullOrSpace :: Char -> Bool+isNullOrSpace x = isSpace x || isNull x+++readUtf8Text :: FilePath -> IO Text+readUtf8Text = fmap decodeUtf8 . BS.readFile
+ src/System/MemInfo/Print.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++{- |+Module      : System.MemInfo.Print+Copyright   : (c) 2022 Tim Emiola+Maintainer  : Tim Emiola <adetokunbo@emio.la>+SPDX-License-Identifier: BSD3++This module provides functions that format the output of the __printmem__ command+-}+module System.MemInfo.Print (+  AsCmdName (..),+  fmtAsHeader,+  fmtOverall,+  fmtMemUsage,+) where++import qualified Data.Text as Text+import Fmt (+  fixedF,+  padBothF,+  padLeftF,+  padRightF,+  (+|),+  (+||),+  (|+),+  (|++|),+  (||+),+ )+import System.MemInfo.Prelude+import System.MemInfo.Proc (MemUsage (..))+++{- | 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 showSwap name ct =+  let+    padl = padLeftF columnWidth ' ' . fmtMem+    private = padl $ muPrivate ct - muShared ct+    shared = padl $ muShared ct+    all' = padl $ muPrivate ct+    swap' = padl $ muSwap ct+    name' = cmdWithCount name $ muCount ct+    ram = "" +| private |+ " + " +| shared |+ " = " +| all' |+ ""+    label = "" +| name' |+ ""+   in+    if showSwap+      then ram <> ("" +| swap' |+ "\t") <> label+      else ram <> "\t" <> label+++-- | Generates the text showing the overall memory in the memory report+fmtOverall :: Bool -> (Int, Int) -> Text+fmtOverall showSwap (private, swap) =+  let+    rimLength = if showSwap then 46 else 36+    gapLength = 26+    top = Text.replicate rimLength "-"+    gap = Text.replicate gapLength " "+    bottom = Text.replicate rimLength "="+    padl = padLeftF columnWidth ' ' . fmtMem+    withSwap = "" +| gap |++| padl private |++| padl swap |+ ""+    noSwap = "" +| gap |++| padl private |+ ""+    out = if showSwap then withSwap else noSwap+   in+    Text.unlines [top, out, bottom]+++data Power = Ki | Mi | Gi | Ti deriving (Eq, Show, Ord, Enum, Bounded)+++fmtMem :: Int -> Text+fmtMem = fmtMem' Ki . fromIntegral+++columnWidth :: Int+columnWidth = 10+++fmtMem' :: Power -> Float -> Text+fmtMem' =+  let doFmt p x = "" +| fixedF 1 x |+ " " +|| p ||+ "B"+      go p x | p == maxBound = doFmt p x+      go p x | x > 1000 = fmtMem' (succ p) (x / 1024)+      go p x = doFmt p x+   in go+++hdrPrivate, hdrShared, hdrRamUsed, hdrSwapUsed, hdrProgram :: Text+hdrPrivate = "Private"+hdrShared = "Shared"+hdrRamUsed = "RAM Used"+hdrSwapUsed = "Swap Used"+hdrProgram = "Program"+++-- | Generates the text of the printed header of the memory report+fmtAsHeader :: Bool -> Text+fmtAsHeader showSwap =+  let+    padb = padBothF columnWidth ' '+    padr = padRightF columnWidth ' '+    padl = padLeftF columnWidth ' '+    private = padb hdrPrivate+    shared = padb hdrShared+    all' = padl hdrRamUsed+    name' = padr hdrProgram+    swap' = padl hdrSwapUsed+    ram = "" +| private |+ " + " +| shared |+ " = " +| all' |+ ""+    label = "" +| name' |+ ""+   in+    if showSwap+      then ram <> ("" +| swap' |+ "\t") <> label+      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++The label is also used to group related processes under a single program+-}+class AsCmdName a where+  -- Convert the label to text to print in the report output+  asCmdName :: a -> Text+++instance AsCmdName Text where+  asCmdName = id+++instance AsCmdName (ProcessID, Text) where+  asCmdName (pid, name) = "" +| name |+ " [" +| toInteger pid |+ "]"
+ src/System/MemInfo/Proc.hs view
@@ -0,0 +1,355 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++{- |+Module      : System.MemInfo.Proc+Copyright   : (c) 2022 Tim Emiola+Maintainer  : Tim Emiola <adetokunbo@emio.la>+SPDX-License-Identifier: BSD3++This module provides types that model data from files in the @Linux proc+filesystem@ that track memory usage, combinators for parsing the files contents,+and for grouping the results.+-}+module System.MemInfo.Proc (+  -- * Combine process memory metrics+  MemUsage (..),+  amass,++  -- * Parse process memory metrics+  ProcUsage (..),+  parseFromSmap,+  parseFromStatm,++  -- * Parse \/proc\/\<pid\>\/exe+  ExeInfo (..),+  parseExeInfo,++  -- * Parse \/proc\/<pid\>\/status+  parseStatusInfo,+  StatusInfo (..),+  BadStatus (..),+) where++import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text as Text+import Data.Validity (Validity (..), check, delve)+import Data.Validity.Text ()+import GHC.Generics (Generic)+import System.MemInfo.Prelude+import System.MemInfo.SysInfo (KernelVersion, fickleSharing)+++-- | Represents the information about a process obtained from /proc/<pid>/status+data StatusInfo = StatusInfo+  { siName :: !Text+  , siParent :: !ProcessID+  }+  deriving (Eq, Show, Generic)+++instance Validity StatusInfo where+  validate StatusInfo {siName, siParent} =+    let name' = Text.strip siName+        nameOk = Text.length name' > 0 && siName == name'+     in mconcat+          [ check nameOk "the process name"+          , delve "the process ID" $ toInteger siParent+          ]+++-- | Indicates why @'parseStatusInfo'@ failed+data BadStatus+  = NoCmd+  | NoParent+  deriving (Eq, Show)+++-- | Parses the content of \/proc\/\<pid\>\/status into a @'StatusInfo'@+parseStatusInfo :: Text -> Either BadStatus StatusInfo+parseStatusInfo content =+  let+    statusLines = Text.lines content+    parseLine key l = Text.strip <$> Text.stripPrefix (key <> ":") l+    mkStep prefix acc l = case acc of+      Nothing -> parseLine prefix l+      found -> found+    name = maybe (Left NoCmd) Right name'+    name' = foldl' (mkStep "Name") Nothing statusLines+    ppidTxt = foldl' (mkStep "PPid") Nothing statusLines+    parsePpid = readMaybe . Text.unpack+    ppId = maybe (Left NoParent) Right (ppidTxt >>= parsePpid)+   in+    StatusInfo <$> name <*> ppId+++-- | Parses the target of \/proc\/\<pid\>\/exe into a @'ExeInfo'@+parseExeInfo :: Text -> ExeInfo+parseExeInfo x =+  let eiTarget = takeTillNull x+      eiDeleted = delEnd `Text.isSuffixOf` eiTarget+      withoutDeleted = Text.replace delEnd "" eiTarget+      eiOriginal = if eiDeleted then withoutDeleted else eiTarget+      takeTillNull = Text.takeWhile (not . isNull)+   in ExeInfo {eiDeleted, eiOriginal, eiTarget}+++delEnd :: Text+delEnd = " (deleted)"+++-- | Represents the information about a process obtained from \/proc\/\<pid\>\/exe+data ExeInfo = ExeInfo+  { eiTarget :: !Text+  -- ^ the path that the link \/proc\/\<pid\>\/exe resolves to+  , eiOriginal :: !Text+  -- ^ a sanitized form of eiTarget; it removes the / (deleted)/ suffix+  , eiDeleted :: !Bool+  -- ^ does eiTarget end with /(deleted)/?+  }+  deriving (Eq, Show, Generic)+++instance Validity ExeInfo where+  validate ei | eiDeleted ei = check (eiOriginal ei <> delEnd == eiTarget ei) "target is actually deleted"+  validate ei = check (eiOriginal ei == eiTarget ei) "target is not deleted"+++-- | Combine @'ProcUsage'@, grouping them by the effective program name+amass ::+  Ord a =>+  Bool ->+  [(a, ProcUsage)] ->+  Map a MemUsage+amass hasPss = Map.map (fromSubTotal hasPss) . foldl' (incrSubTotals hasPss) mempty+++fromSubTotal :: Bool -> SubTotal -> MemUsage+fromSubTotal hasPss st =+  let reducedPrivate = stPrivate st `div` stCount st+      areThreads = threadsNotProcs st+      reducedShared = stShared st `div` stCount st+      newPrivate = if areThreads then reducedPrivate else stPrivate st+      newShared = if areThreads && hasPss then reducedShared else stShared st+   in MemUsage+        { muShared = newShared + stSharedHuge st+        , muPrivate = newPrivate + newShared + stSharedHuge st+        , muSwap = stSwap st+        , muCount = stCount st+        }+++-- | Represents the measured memory usage of a program+data MemUsage = MemUsage+  { muShared :: !Int+  -- ^ the total shared memory in use+  , muPrivate :: !Int+  -- ^ the total private memory in use+  , muCount :: !Int+  -- ^ the number of processes running as the program+  , muSwap :: !Int+  -- ^ the total swap memory in use+  }+  deriving (Eq, Show)+++incrSubTotals ::+  Ord a =>+  Bool ->+  Map a SubTotal ->+  (a, ProcUsage) ->+  Map a SubTotal+incrSubTotals hasPss acc (cmd, mem) =+  let combinePrivate next prev | hasPss = next + prev+      combinePrivate next prev = max next prev+      nextSt =+        SubTotal+          { stShared = puShared mem+          , stSharedHuge = puSharedHuge mem+          , stCount = 1+          , stPrivate = puPrivate mem+          , stSwap = puSwap mem+          , stMemIds = Set.singleton $ puMemId mem+          }+      update' next prev =+        prev+          { stShared = stShared next + stShared prev+          , stSharedHuge = max (stSharedHuge next) (stSharedHuge prev)+          , stPrivate = combinePrivate (stPrivate next) (stPrivate prev)+          , stCount = stCount next + stCount prev+          , stSwap = stSwap next + stSwap prev+          , stMemIds = Set.union (stMemIds next) (stMemIds prev)+          }+   in Map.insertWith update' cmd nextSt acc+++data SubTotal = SubTotal+  { stShared :: !Int+  , stSharedHuge :: !Int+  , stPrivate :: !Int+  , stCount :: !Int+  , stSwap :: !Int+  , stMemIds :: !(Set Int)+  }+  deriving (Eq, Show)+++-- If a process is invoked with clone using flags CLONE_VM and not CLONE_THREAD+-- it will share the same memory space as it's parent; this needs to accounted+-- for+--+-- This is detected by computing the memId has the hash of lines for the proc+-- read from its smaps file.+threadsNotProcs :: SubTotal -> Bool+threadsNotProcs cs = Set.size (stMemIds cs) == 1 && stCount cs > 1+++-- | Represents the memory metrics for a single process+data ProcUsage = ProcUsage+  { puPrivate :: !Int+  , puShared :: !Int+  , puSharedHuge :: !Int+  , puSwap :: !Int+  , puMemId :: !Int+  }+  deriving (Eq, Show)+++-- value used as page size when @MemStat@ is calcuated from statm+pageSizeKiB :: Int+pageSizeKiB = 4+++-- | Parse @'ProcUsage'@ from the contents of \/proc\/\<pid\>\/statm+parseFromStatm :: KernelVersion -> Text -> Maybe ProcUsage+parseFromStatm version content =+  let+    parseWord w (Just acc) = (\x -> Just (x : acc)) =<< readMaybe (Text.unpack w)+    parseWord _ Nothing = Nothing+    parseMetrics = foldr parseWord (Just mempty)+    withMemId = ppZero {puMemId = hash content}+    fromRss rss _shared+      | fickleSharing version = withMemId {puPrivate = rss * pageSizeKiB}+    fromRss rss shared =+      withMemId+        { puShared = shared * pageSizeKiB+        , puPrivate = (rss - shared) * pageSizeKiB+        }+    fromRss' (_size : rss : shared : _xs) = Just $ fromRss rss shared+    fromRss' _ = Nothing+   in+    parseMetrics (Text.words content) >>= fromRss'+++ppZero :: ProcUsage+ppZero =+  ProcUsage+    { puPrivate = 0+    , puShared = 0+    , puSharedHuge = 0+    , puSwap = 0+    , puMemId = 0+    }+++-- | Parse @'ProcUsage'@ from the contents of \/proc\/\<pid\>\/smap+parseFromSmap :: Text -> ProcUsage+parseFromSmap = fromSmap . parseSmapStats+++parseSmapStats :: Text -> SmapStats+parseSmapStats content =+  let noMemId = foldl' incrSmapStats ssZero $ Text.lines content+   in noMemId {ssMemId = hash content}+++fromSmap :: SmapStats -> ProcUsage+fromSmap ss =+  let pssTweak = ssPssCount ss `div` 2 -- add ~0.5 per line to counter truncation+      pssShared = ssPss ss + pssTweak - ssPrivate ss+   in ProcUsage+        { puSwap = if ssHasSwapPss ss then ssSwapPss ss else ssSwap ss+        , puShared = if ssHasPss ss then pssShared else ssShared ss+        , puSharedHuge = ssSharedHuge ss+        , puPrivate = ssPrivate ss + ssPrivateHuge ss+        , puMemId = ssMemId ss+        }+++-- | Represents per-process data read from \/proc\/\<pid\>\/smap+data SmapStats = SmapStats+  { ssPss :: !Int+  , ssPssCount :: !Int+  , ssSwap :: !Int+  , ssSwapPss :: !Int+  , ssPrivate :: !Int+  , ssPrivateHuge :: !Int+  , ssSharedHuge :: !Int+  , ssShared :: !Int+  , ssMemId :: !Int+  , ssHasPss :: !Bool+  , ssHasSwapPss :: !Bool+  }+  deriving (Eq, Show)+++ssZero :: SmapStats+ssZero =+  SmapStats+    { ssPss = 0+    , ssPssCount = 0+    , ssSwap = 0+    , ssSwapPss = 0+    , ssPrivate = 0+    , ssPrivateHuge = 0+    , ssSharedHuge = 0+    , ssShared = 0+    , ssHasSwapPss = False+    , ssHasPss = False+    , ssMemId = 0+    }+++-- Q: is it worth the dependency to replace this with lens from a lens package ?+incrPss+  , incrSwap+  , incrSwapPss+  , incrPrivate+  , incrPrivateHuge+  , incrShared+  , incrSharedHuge ::+    SmapStats -> Maybe Int -> SmapStats+incrPss ms = maybe ms $ \n -> ms {ssPss = n + ssPss ms}+incrSwap ms = maybe ms $ \n -> ms {ssSwap = n + ssSwap ms}+incrSwapPss ms = maybe ms $ \n -> ms {ssSwapPss = n + ssSwapPss ms}+incrPrivate ms = maybe ms $ \n -> ms {ssPrivate = n + ssPrivate ms}+incrShared ms = maybe ms $ \n -> ms {ssShared = n + ssShared ms}+incrPrivateHuge ms = maybe ms $ \n -> ms {ssPrivateHuge = n + ssPrivateHuge ms}+incrSharedHuge ms = maybe ms $ \n -> ms {ssSharedHuge = n + ssSharedHuge ms}+++incrSmapStats :: SmapStats -> Text -> SmapStats+incrSmapStats acc l =+  if+      | Text.isPrefixOf "Private_Hugetlb:" l -> incrPrivateHuge acc $ smapValMb l+      | Text.isPrefixOf "Shared_Hugetlb:" l -> incrSharedHuge acc $ smapValMb l+      | Text.isPrefixOf "Shared" l -> incrShared acc $ smapValMb l+      | Text.isPrefixOf "Private" l -> incrPrivate acc $ smapValMb l+      | Text.isPrefixOf "Pss:" l ->+          let acc' = acc {ssHasPss = True, ssPssCount = 1 + ssPssCount acc}+           in incrPss acc' $ smapValMb l+      | Text.isPrefixOf "Swap:" l -> incrSwap acc $ smapValMb l+      | Text.isPrefixOf "SwapPss:" l -> incrSwapPss (acc {ssHasSwapPss = True}) $ smapValMb l+      | otherwise -> acc+++smapValMb :: Read a => Text -> Maybe a+smapValMb l =+  let memWords = Text.words l+      readVal (_ : x : _) = readMaybe $ Text.unpack x+      readVal _ = Nothing+   in readVal memWords
+ src/System/MemInfo/SysInfo.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++{- |+Module      : System.MemInfo.SysInfo+Copyright   : (c) 2022 Tim Emiola+Maintainer  : Tim Emiola <adetokunbo@emio.la>+SPDX-License-Identifier: BSD3++This module provides data types that++- define memory reports (cf @'ReportBud'@) and++- provide info about the system where the report will run (cf @'KernelVersion'@,+@'SwapFlaw'@ and @'RamFlaw'@).++along with functions that use these types.+-}+module System.MemInfo.SysInfo (+  -- * define reports+  ReportBud (..),+  mkReportBud,++  -- * indicate calculation flaws+  RamFlaw (..),+  SwapFlaw (..),+  checkForFlaws,+  fmtRamFlaws,+  fmtSwapFlaws,++  -- * system kernel version+  KernelVersion,+  parseKernelVersion,+  readKernelVersion,+  fickleSharing,+) where++import qualified Data.List.NonEmpty as NE+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import qualified Data.Text.Read as Text+import Fmt ((+|), (|+))+import System.MemInfo.Prelude+++-- | Represents a version of @Linux@ kernel+type KernelVersion = (Natural, Natural, Natural)+++{- | On linux kernels before smaps became available, there was no reliable way to+determine how much of a processes memory was shared++http://lkml.org/lkml/2005/7/6/250+-}+fickleSharing :: KernelVersion -> Bool+fickleSharing k = k >= (2, 6, 1) && k <= (2, 6, 9)+++-- | Determines the version of the Linux kernel on the current system.+readKernelVersion :: IO (Maybe KernelVersion)+readKernelVersion = parseKernelVersion <$> Text.readFile kernelVersionPath+++kernelVersionPath :: String+kernelVersionPath = "/proc/sys/kernel/osrelease"+++-- | Parses @Text@ into a @'KernelVersion'@+parseKernelVersion :: Text -> Maybe KernelVersion+parseKernelVersion =+  let unrecognized = Nothing+      dec' (Right (x, extra)) | Text.null extra = Just x+      dec' _ = unrecognized+      dec1st' (Right (x, _)) = Just x+      dec1st' _ = unrecognized++      dec = dec' . Text.decimal+      dec1st = dec1st' . Text.decimal+      fromSplit [x] = (,,) <$> dec x <*> pure 0 <*> pure 0+      fromSplit [x, y] = (,,) <$> dec x <*> dec1st y <*> pure 0+      fromSplit [x, y, z] = (,,) <$> dec x <*> dec y <*> dec1st z+      fromSplit _ = unrecognized+   in fromSplit . Text.split (== '.')+++-- | Gathers the inputs needed to generate a memory usage report+data ReportBud = ReportBud+  { rbPids :: !(NonEmpty ProcessID)+  , rbKernel :: !KernelVersion+  , rbHasPss :: !Bool+  , rbHasSwapPss :: !Bool+  , rbHasSmaps :: !Bool+  , rbRamFlaws :: Maybe RamFlaw+  , rbSwapFlaws :: Maybe SwapFlaw+  }+  deriving (Eq, Show)+++-- | Describes inaccuracies in the RAM calculation+data RamFlaw+  = -- | no shared mem is reported+    NoSharedMem+  | -- | some shared mem not reported+    SomeSharedMem+  | -- | accurate only considering each process in isolation+    ExactForIsolatedMem+  deriving (Eq, Show, Ord)+++-- | Provide @Text@ that explains the 'RamFlaw'+fmtRamFlaws :: RamFlaw -> Text+fmtRamFlaws NoSharedMem =+  Text.unlines+    [ "shared memory is not reported by this system."+    , "Values reported will be too large, and totals are not reported"+    ]+fmtRamFlaws SomeSharedMem =+  Text.unlines+    [ "shared memory is not reported accurately by this system."+    , "Values reported could be too large, and totals are not reported"+    ]+fmtRamFlaws ExactForIsolatedMem =+  Text.unlines+    [ "shared memory is slightly over-estimated by this system"+    , "for each program, so totals are not reported."+    ]+++-- | Describes inaccuracies in the swap measurement+data SwapFlaw+  = -- | not available+    NoSwap+  | -- | accurate only considering each process in isolation+    ExactForIsolatedSwap+  deriving (Eq, Show, Ord)+++-- | Provide @Text@ that explains the 'SwapFlaw'+fmtSwapFlaws :: SwapFlaw -> Text+fmtSwapFlaws NoSwap = "swap is not reported by this system."+fmtSwapFlaws ExactForIsolatedSwap =+  Text.unlines+    [ "swap is over-estimated by this system"+    , "for each program, so totals are not reported."+    ]+++{- | Examine the target system for @'RamFlaw's@ and @'SwapFlaw's@, and update+@bud@ reflect the findings.+-}+checkForFlaws :: ReportBud -> IO ReportBud+checkForFlaws bud = do+  let pid = NE.head $ rbPids bud+      version = rbKernel bud+      fickleShared = fickleSharing version+      ReportBud+        { rbHasPss = hasPss+        , rbHasSmaps = hasSmaps+        , rbHasSwapPss = hasSwapPss+        } = bud+  (rbRamFlaws, rbSwapFlaws) <- case version of+    (2, 4, _) -> 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 >>= \case+        False -> pure alt+        _ -> checkInact <$> readUtf8Text memInfoPath+    (2, 6, _) -> 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)+    (major, _, _) | major > 2 && hasSmaps -> do+      let alt = (Nothing, Just ExactForIsolatedSwap)+          best = (Nothing, Nothing)+      pure $ if hasSwapPss then best else alt+    _ -> pure (Just ExactForIsolatedMem, Just NoSwap)+  pure $ bud {rbRamFlaws, rbSwapFlaws}+++{- | Construct a @ReportBud@ from some @ProcessIDs@++Generates values for the other fields by inspecting the system++The result is @Nothing@ only when the @KernelVersion@ cannot be determined+-}+mkReportBud :: NonEmpty ProcessID -> IO (Maybe ReportBud)+mkReportBud rbPids = do+  let firstPid = NE.head rbPids+      smapsPath = pidPath "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+            }+++pidPath :: String -> ProcessID -> FilePath+pidPath base pid = "/proc/" +| toInteger pid |+ "/" +| base |+ ""
+ test/MemInfo/OrphanInstances.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK prune not-home #-}++{- |+Module      : MemInfo.OrphanInstances+Copyright   : (c) 2022 Tim Emiola+Maintainer  : Tim Emiola <adetokunbo@emio.la>+SPDX-License-Identifier: BSD3+-}+module MemInfo.OrphanInstances where++import Data.GenValidity (GenValid (..))+import Data.GenValidity.Text ()+import System.MemInfo.Proc (ExeInfo (..), StatusInfo)+import System.Posix.Types (CPid (..), ProcessID)+import Test.Validity (Validity)+++instance GenValid ExeInfo where+  genValid = do+    eiDeleted <- genValid+    eiOriginal <- genValid+    let eiTarget = if eiDeleted then eiOriginal <> " (deleted)" else eiOriginal+    pure $ ExeInfo {eiDeleted, eiOriginal, eiTarget}+++deriving anyclass instance GenValid StatusInfo+++deriving newtype instance Validity ProcessID+++deriving newtype instance GenValid ProcessID
+ test/MemInfo/PrintSpec.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module      : MemInfo.ProcSpec+Copyright   : (c) 2023 Tim Emiola+Maintainer  : Tim Emiola <adetokunbo@emio.la>+SPDX-License-Identifier: BSD3+-}+module MemInfo.PrintSpec (spec) where++import Data.Text (Text)+import qualified Data.Text as Text+import System.MemInfo.Print (fmtAsHeader, fmtMemUsage, fmtOverall)+import System.MemInfo.Proc (MemUsage (..))+import System.Posix.Types (ProcessID)+import Test.Hspec+++spec :: Spec+spec = describe "module System.MemInfo.Print" $ do+  fmtAsHeaderSpec+  fmtOverallSpec+  fmtMemUsageSpec+++fmtAsHeaderSpec :: Spec+fmtAsHeaderSpec = describe "fmtAsHeader" $ do+  describe "when swap is not required" $ do+    it "does not show it" $+      fmtAsHeader False `shouldBe` headerNoSwap++  describe "when swap is required" $ do+    it "does show it" $+      fmtAsHeader True `shouldBe` headerSwap+++headerNoSwap :: Text+headerNoSwap = "  Private  +   Shared   =   RAM Used\tProgram   "+++headerSwap :: Text+headerSwap = "  Private  +   Shared   =   RAM Used Swap Used\tProgram   "+++fmtOverallSpec :: Spec+fmtOverallSpec = describe "fmtOverall" $ do+  describe "when swap is not required" $ do+    it "does not show it" $+      fmtOverall False (1, 1) `shouldBe` sampleNoSwapOverall+  describe "when swap is required" $ do+    it "does show it" $+      fmtOverall True (1, 1) `shouldBe` sampleSwapOverall+++sampleNoSwapOverall :: Text+sampleNoSwapOverall =+  Text.unlines+    [ "------------------------------------"+    , "                             1.0 KiB"+    , "===================================="+    ]+++sampleSwapOverall :: Text+sampleSwapOverall =+  Text.unlines+    [ "----------------------------------------------"+    , "                             1.0 KiB   1.0 KiB"+    , "=============================================="+    ]+++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 swap is required" $ do+    it "does not show" $+      fmtMemUsage True sampleName sampleTotal `shouldBe` sampleTotalSwap+++sampleName :: (ProcessID, Text)+sampleName = (100, "TestCommand")+++sampleTotal :: MemUsage+sampleTotal =+  MemUsage+    { muShared = 1+    , muPrivate = 2+    , muCount = 3+    , muSwap = 4+    }+++sampleTotalNoSwap :: Text+sampleTotalNoSwap = "   1.0 KiB +    1.0 KiB =    2.0 KiB\tTestCommand [100] (3)"+++sampleTotalSwap :: Text+sampleTotalSwap = "   1.0 KiB +    1.0 KiB =    2.0 KiB   4.0 KiB\tTestCommand [100] (3)"
+ test/MemInfo/ProcSpec.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++{- |+Module      : MemInfo.ProcSpec+Copyright   : (c) 2023 Tim Emiola+Maintainer  : Tim Emiola <adetokunbo@emio.la>+SPDX-License-Identifier: BSD3+-}+module MemInfo.ProcSpec (spec) where++import Data.Hashable (hash)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Word (Word16)+import Fmt (blockMapF, build, fmt, (+|), (|+))+import MemInfo.OrphanInstances ()+import Numeric.Natural (Natural)+import System.MemInfo.Proc+import Test.Hspec+import Test.QuickCheck+import Test.Validity (GenValid (..), forAllValid)+import Test.Validity.GenValidity (genValidSpec)+++spec :: Spec+spec = describe "module System.MemInfo.Proc" $ do+  genValidSpec @ExeInfo+  exeInfoSpec+  statusInfoSpec+  fromStatmSpec+  fromSmapSpec+++exeInfoSpec :: Spec+exeInfoSpec = describe "parseExeInfo" $ do+  it "should parse all valid values successfully" $ do+    forAllValid $ \ei -> ei == parseExeInfo (eiTarget ei)+++genOthers :: Gen [(Text, Word16)]+genOthers = do+  keys <- sublistOf otherStatusFields `suchThat` (not . null)+  vals <- vectorOf (length keys) arbitrary+  pure $ zip keys vals+++statusInfoSpec :: Spec+statusInfoSpec = describe "parseStatusInfo" $ do+  it "should parse all valid values successfully" $ do+    forAll genStatusInfoContent $ \(si, txt) -> Right si == parseStatusInfo txt+++genProcStatus :: StatusInfo -> Gen [(Text, Text)]+genProcStatus status = do+  others <- fmap (fmap (\(x, y) -> (x, fmt $ build y))) genOthers+  pure $ others <> asFields status+++genStatusInfoContent :: Gen (StatusInfo, Text)+genStatusInfoContent = do+  si <- genValid+  txt <- fmt . blockMapF <$> genProcStatus si+  pure (si, txt)+++asFields :: StatusInfo -> [(Text, Text)]+asFields si =+  [ ("Name", siName si)+  , ("PPid", fmt $ build $ toInteger $ siParent si)+  ]+++otherStatusFields :: [Text]+otherStatusFields = ["Uid", "Gid", "FDSize", "Ngid", "Threads", "Cpus_allowed"]+++fromStatmSpec :: Spec+fromStatmSpec = describe "parseFromStatm" $ do+  describe "when using a kernel version with unknown sharing" $ do+    it "should parse values to ProcUsage successfully" prop_roundtripStatmNotShared+  describe "when using a kernel version with known sharing" $ do+    it "should parse values to ProcUsage successfully" prop_roundtripStatmShared+++fromSmapSpec :: Spec+fromSmapSpec = describe "parseFromSmap" $ do+  it "should parse values to ProcUsage successfully" prop_roundtripSmap+++prop_roundtripStatmShared :: Property+prop_roundtripStatmShared =+  discardAfter 5000000 $+    forAll genSharedStatm $+      \(pp, txt) -> Just pp == parseFromStatm sharedKernel txt+++prop_roundtripStatmNotShared :: Property+prop_roundtripStatmNotShared =+  forAll genNoSharedStatm $+    \(pp, txt) -> Just pp == parseFromStatm badSharedKernel txt+++prop_roundtripSmap :: Property+prop_roundtripSmap = forAll genSmap $ \(pp, txt) -> pp == parseFromSmap txt+++badSharedKernel :: (Natural, Natural, Natural)+badSharedKernel = (2, 6, 1)+++sharedKernel :: (Natural, Natural, Natural)+sharedKernel = (2, 7, 1)+++statmNoShared :: Word16 -> Text+statmNoShared rss = "0 " +| toInteger rss |+ " 1 2 3 4"+++genNoSharedStatm :: Gen (ProcUsage, Text)+genNoSharedStatm = do+  rssKb <- genValid+  let content = statmNoShared rssKb+      pp =+        ppZero+          { puPrivate = fromIntegral rssKb * pageSizeKiB+          , puMemId = hash content+          }+  pure (pp, content)+++statmShared :: Word16 -> Word16 -> Text+statmShared rss shared = "0 " +| toInteger rss |+ " " +| toInteger shared |+ " 1 2 3"+++genSharedStatm :: Gen (ProcUsage, Text)+genSharedStatm = do+  rssKb <- genValid `suchThat` (> 1) :: Gen Word16+  sharedKb <- genValid `suchThat` (< rssKb) :: Gen Word16+  let content = statmShared rssKb sharedKb+      pp =+        ppZero+          { puPrivate = fromIntegral (rssKb - sharedKb) * pageSizeKiB+          , puMemId = hash content+          , puShared = fromIntegral sharedKb * pageSizeKiB+          }+  pure (pp, content)+++pageSizeKiB :: Int+pageSizeKiB = 4+++ppZero :: ProcUsage+ppZero =+  ProcUsage+    { puPrivate = 0+    , puShared = 0+    , puSharedHuge = 0+    , puSwap = 0+    , puMemId = 0+    }+++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]+++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)+++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)
+ test/MemInfo/SysInfoSpec.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++{- |+Module      : MemInfo.SysInfoSpec+Copyright   : (c) 2023 Tim Emiola+Maintainer  : Tim Emiola <adetokunbo@emio.la>+SPDX-License-Identifier: BSD3+-}+module MemInfo.SysInfoSpec (spec) where++import Data.GenValidity (GenValid (..))+import Data.Text (Text)+import Data.Word (Word8)+import Fmt (build, fmt, (+|), (|+))+import MemInfo.OrphanInstances ()+import System.MemInfo.SysInfo (KernelVersion, parseKernelVersion)+import Test.Hspec+import Test.QuickCheck+++spec :: Spec+spec = describe "module System.MemInfo.SysInfo" $ do+  describe "parseKernelVersion" $ do+    it "should parse values from Text successfully" prop_roundtripKernelVersion+++prop_roundtripKernelVersion :: Property+prop_roundtripKernelVersion =+  within 5000000 $+    forAll genOsRelease $+      \(version, txt) -> Just version == parseKernelVersion txt+++genOsRelease :: Gen (KernelVersion, Text)+genOsRelease = oneof [fromSingle, fromDouble, fromTriple]+++fromTriple :: Gen (KernelVersion, Text)+fromTriple = do+  let toN = fromIntegral+      txt a b c = "" +| a |+ "." +| b |+ "." +| c |+ ""+  (x, y, z) <- genValid :: Gen (Word8, Word8, Word8)+  zSuffixed <- someWithSuffix z+  pure ((toN x, toN y, toN z), txt x y zSuffixed)+++fromDouble :: Gen (KernelVersion, Text)+fromDouble = do+  (x, y) <- genValid :: Gen (Word8, Word8)+  ySuffixed <- someWithSuffix y+  let toN = fromIntegral+      txt a b = "" +| a |+ "." +| b |+ ""+  pure ((toN x, toN y, 0), txt x ySuffixed)+++suffixes :: [Text]+suffixes = ["-pre", "b", "-kali", "-test"]+++someWithSuffix :: Word8 -> Gen Text+someWithSuffix w = do+  addSuffix <- genValid+  s <- elements suffixes+  if addSuffix+    then pure $ "" +| w |+ "" +| s |+ ""+    else pure $ fmt $ build w+++fromSingle :: Gen (KernelVersion, Text)+fromSingle = do+  x <- genValid :: Gen Word8+  pure ((fromIntegral x, 0, 0), fmt $ build x)
+ test/Spec.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import qualified MemInfo.PrintSpec as Print+import qualified MemInfo.ProcSpec as Proc+import qualified MemInfo.SysInfoSpec as SysInfo+import System.IO (+  BufferMode (..),+  hSetBuffering,+  stderr,+  stdout,+ )+import Test.Hspec+++main :: IO ()+main = do+  hSetBuffering stdout NoBuffering+  hSetBuffering stderr NoBuffering+  hspec $ do+    Proc.spec+    Print.spec+    SysInfo.spec