{-# 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
  { StatusInfo -> Text
siName :: !Text
  , StatusInfo -> ProcessID
siParent :: !ProcessID
  }
  deriving (StatusInfo -> StatusInfo -> Bool
(StatusInfo -> StatusInfo -> Bool)
-> (StatusInfo -> StatusInfo -> Bool) -> Eq StatusInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StatusInfo -> StatusInfo -> Bool
== :: StatusInfo -> StatusInfo -> Bool
$c/= :: StatusInfo -> StatusInfo -> Bool
/= :: StatusInfo -> StatusInfo -> Bool
Eq, Int -> StatusInfo -> ShowS
[StatusInfo] -> ShowS
StatusInfo -> String
(Int -> StatusInfo -> ShowS)
-> (StatusInfo -> String)
-> ([StatusInfo] -> ShowS)
-> Show StatusInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StatusInfo -> ShowS
showsPrec :: Int -> StatusInfo -> ShowS
$cshow :: StatusInfo -> String
show :: StatusInfo -> String
$cshowList :: [StatusInfo] -> ShowS
showList :: [StatusInfo] -> ShowS
Show, (forall x. StatusInfo -> Rep StatusInfo x)
-> (forall x. Rep StatusInfo x -> StatusInfo) -> Generic StatusInfo
forall x. Rep StatusInfo x -> StatusInfo
forall x. StatusInfo -> Rep StatusInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StatusInfo -> Rep StatusInfo x
from :: forall x. StatusInfo -> Rep StatusInfo x
$cto :: forall x. Rep StatusInfo x -> StatusInfo
to :: forall x. Rep StatusInfo x -> StatusInfo
Generic)


instance Validity StatusInfo where
  validate :: StatusInfo -> Validation
validate StatusInfo {Text
siName :: StatusInfo -> Text
siName :: Text
siName, ProcessID
siParent :: StatusInfo -> ProcessID
siParent :: ProcessID
siParent} =
    let name' :: Text
name' = Text -> Text
Text.strip Text
siName
        nameOk :: Bool
nameOk = Text -> Int
Text.length Text
name' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Text
siName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name'
     in [Validation] -> Validation
forall a. Monoid a => [a] -> a
mconcat
          [ Bool -> String -> Validation
check Bool
nameOk String
"the process name"
          , String -> Integer -> Validation
forall a. Validity a => String -> a -> Validation
delve String
"the process ID" (Integer -> Validation) -> Integer -> Validation
forall a b. (a -> b) -> a -> b
$ ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger ProcessID
siParent
          ]


-- | Indicates why @'parseStatusInfo'@ failed
data BadStatus
  = NoCmd
  | NoParent
  deriving (BadStatus -> BadStatus -> Bool
(BadStatus -> BadStatus -> Bool)
-> (BadStatus -> BadStatus -> Bool) -> Eq BadStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BadStatus -> BadStatus -> Bool
== :: BadStatus -> BadStatus -> Bool
$c/= :: BadStatus -> BadStatus -> Bool
/= :: BadStatus -> BadStatus -> Bool
Eq, Int -> BadStatus -> ShowS
[BadStatus] -> ShowS
BadStatus -> String
(Int -> BadStatus -> ShowS)
-> (BadStatus -> String)
-> ([BadStatus] -> ShowS)
-> Show BadStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BadStatus -> ShowS
showsPrec :: Int -> BadStatus -> ShowS
$cshow :: BadStatus -> String
show :: BadStatus -> String
$cshowList :: [BadStatus] -> ShowS
showList :: [BadStatus] -> ShowS
Show)


-- | Parses the content of \/proc\/\<pid\>\/status into a @'StatusInfo'@
parseStatusInfo :: Text -> Either BadStatus StatusInfo
parseStatusInfo :: Text -> Either BadStatus StatusInfo
parseStatusInfo Text
content =
  let
    statusLines :: [Text]
statusLines = Text -> [Text]
Text.lines Text
content
    parseLine :: Text -> Text -> Maybe Text
parseLine Text
key Text
l = Text -> Text
Text.strip (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
Text.stripPrefix (Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":") Text
l
    mkStep :: Text -> Maybe Text -> Text -> Maybe Text
mkStep Text
prefix Maybe Text
acc Text
l = case Maybe Text
acc of
      Maybe Text
Nothing -> Text -> Text -> Maybe Text
parseLine Text
prefix Text
l
      Maybe Text
found -> Maybe Text
found
    name :: Either BadStatus Text
name = Either BadStatus Text
-> (Text -> Either BadStatus Text)
-> Maybe Text
-> Either BadStatus Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BadStatus -> Either BadStatus Text
forall a b. a -> Either a b
Left BadStatus
NoCmd) Text -> Either BadStatus Text
forall a b. b -> Either a b
Right Maybe Text
name'
    name' :: Maybe Text
name' = (Maybe Text -> Text -> Maybe Text)
-> Maybe Text -> [Text] -> Maybe Text
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Text -> Maybe Text -> Text -> Maybe Text
mkStep Text
"Name") Maybe Text
forall a. Maybe a
Nothing [Text]
statusLines
    ppidTxt :: Maybe Text
ppidTxt = (Maybe Text -> Text -> Maybe Text)
-> Maybe Text -> [Text] -> Maybe Text
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Text -> Maybe Text -> Text -> Maybe Text
mkStep Text
"PPid") Maybe Text
forall a. Maybe a
Nothing [Text]
statusLines
    parsePpid :: Text -> Maybe ProcessID
parsePpid = String -> Maybe ProcessID
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe ProcessID)
-> (Text -> String) -> Text -> Maybe ProcessID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack
    ppId :: Either BadStatus ProcessID
ppId = Either BadStatus ProcessID
-> (ProcessID -> Either BadStatus ProcessID)
-> Maybe ProcessID
-> Either BadStatus ProcessID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BadStatus -> Either BadStatus ProcessID
forall a b. a -> Either a b
Left BadStatus
NoParent) ProcessID -> Either BadStatus ProcessID
forall a b. b -> Either a b
Right (Maybe Text
ppidTxt Maybe Text -> (Text -> Maybe ProcessID) -> Maybe ProcessID
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe ProcessID
parsePpid)
   in
    Text -> ProcessID -> StatusInfo
StatusInfo (Text -> ProcessID -> StatusInfo)
-> Either BadStatus Text
-> Either BadStatus (ProcessID -> StatusInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either BadStatus Text
name Either BadStatus (ProcessID -> StatusInfo)
-> Either BadStatus ProcessID -> Either BadStatus StatusInfo
forall a b.
Either BadStatus (a -> b)
-> Either BadStatus a -> Either BadStatus b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either BadStatus ProcessID
ppId


-- | Parses the target of \/proc\/\<pid\>\/exe into a @'ExeInfo'@
parseExeInfo :: Text -> ExeInfo
parseExeInfo :: Text -> ExeInfo
parseExeInfo Text
x =
  let eiTarget :: Text
eiTarget = Text -> Text
takeTillNull Text
x
      eiDeleted :: Bool
eiDeleted = Text
delEnd Text -> Text -> Bool
`Text.isSuffixOf` Text
eiTarget
      withoutDeleted :: Text
withoutDeleted = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
delEnd Text
"" Text
eiTarget
      eiOriginal :: Text
eiOriginal = if Bool
eiDeleted then Text
withoutDeleted else Text
eiTarget
      takeTillNull :: Text -> Text
takeTillNull = (Char -> Bool) -> Text -> Text
Text.takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isNull)
   in ExeInfo {Bool
eiDeleted :: Bool
eiDeleted :: Bool
eiDeleted, Text
eiOriginal :: Text
eiOriginal :: Text
eiOriginal, Text
eiTarget :: Text
eiTarget :: Text
eiTarget}


delEnd :: Text
delEnd :: Text
delEnd = Text
" (deleted)"


-- | Represents the information about a process obtained from \/proc\/\<pid\>\/exe
data ExeInfo = ExeInfo
  { ExeInfo -> Text
eiTarget :: !Text
  -- ^ the path that the link \/proc\/\<pid\>\/exe resolves to
  , ExeInfo -> Text
eiOriginal :: !Text
  -- ^ a sanitized form of eiTarget; it removes the / (deleted)/ suffix
  , ExeInfo -> Bool
eiDeleted :: !Bool
  -- ^ does eiTarget end with /(deleted)/?
  }
  deriving (ExeInfo -> ExeInfo -> Bool
(ExeInfo -> ExeInfo -> Bool)
-> (ExeInfo -> ExeInfo -> Bool) -> Eq ExeInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ExeInfo -> ExeInfo -> Bool
== :: ExeInfo -> ExeInfo -> Bool
$c/= :: ExeInfo -> ExeInfo -> Bool
/= :: ExeInfo -> ExeInfo -> Bool
Eq, Int -> ExeInfo -> ShowS
[ExeInfo] -> ShowS
ExeInfo -> String
(Int -> ExeInfo -> ShowS)
-> (ExeInfo -> String) -> ([ExeInfo] -> ShowS) -> Show ExeInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExeInfo -> ShowS
showsPrec :: Int -> ExeInfo -> ShowS
$cshow :: ExeInfo -> String
show :: ExeInfo -> String
$cshowList :: [ExeInfo] -> ShowS
showList :: [ExeInfo] -> ShowS
Show, (forall x. ExeInfo -> Rep ExeInfo x)
-> (forall x. Rep ExeInfo x -> ExeInfo) -> Generic ExeInfo
forall x. Rep ExeInfo x -> ExeInfo
forall x. ExeInfo -> Rep ExeInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ExeInfo -> Rep ExeInfo x
from :: forall x. ExeInfo -> Rep ExeInfo x
$cto :: forall x. Rep ExeInfo x -> ExeInfo
to :: forall x. Rep ExeInfo x -> ExeInfo
Generic)


instance Validity ExeInfo where
  validate :: ExeInfo -> Validation
validate ExeInfo
ei | ExeInfo -> Bool
eiDeleted ExeInfo
ei = Bool -> String -> Validation
check (ExeInfo -> Text
eiOriginal ExeInfo
ei Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
delEnd Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== ExeInfo -> Text
eiTarget ExeInfo
ei) String
"target is actually deleted"
  validate ExeInfo
ei = Bool -> String -> Validation
check (ExeInfo -> Text
eiOriginal ExeInfo
ei Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== ExeInfo -> Text
eiTarget ExeInfo
ei) String
"target is not deleted"


-- | Combine @'ProcUsage'@, grouping them by the effective program name
amass ::
  Ord a =>
  Bool ->
  [(a, ProcUsage)] ->
  Map a MemUsage
amass :: forall a. Ord a => Bool -> [(a, ProcUsage)] -> Map a MemUsage
amass Bool
hasPss = (SubTotal -> MemUsage) -> Map a SubTotal -> Map a MemUsage
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Bool -> SubTotal -> MemUsage
fromSubTotal Bool
hasPss) (Map a SubTotal -> Map a MemUsage)
-> ([(a, ProcUsage)] -> Map a SubTotal)
-> [(a, ProcUsage)]
-> Map a MemUsage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map a SubTotal -> (a, ProcUsage) -> Map a SubTotal)
-> Map a SubTotal -> [(a, ProcUsage)] -> Map a SubTotal
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Bool -> Map a SubTotal -> (a, ProcUsage) -> Map a SubTotal
forall a.
Ord a =>
Bool -> Map a SubTotal -> (a, ProcUsage) -> Map a SubTotal
incrSubTotals Bool
hasPss) Map a SubTotal
forall a. Monoid a => a
mempty


fromSubTotal :: Bool -> SubTotal -> MemUsage
fromSubTotal :: Bool -> SubTotal -> MemUsage
fromSubTotal Bool
hasPss SubTotal
st =
  let reducedPrivate :: Int
reducedPrivate = SubTotal -> Int
stPrivate SubTotal
st Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` SubTotal -> Int
stCount SubTotal
st
      areThreads :: Bool
areThreads = SubTotal -> Bool
threadsNotProcs SubTotal
st
      reducedShared :: Int
reducedShared = SubTotal -> Int
stShared SubTotal
st Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` SubTotal -> Int
stCount SubTotal
st
      newPrivate :: Int
newPrivate = if Bool
areThreads then Int
reducedPrivate else SubTotal -> Int
stPrivate SubTotal
st
      newShared :: Int
newShared = if Bool
areThreads Bool -> Bool -> Bool
&& Bool
hasPss then Int
reducedShared else SubTotal -> Int
stShared SubTotal
st
   in MemUsage
        { muShared :: Int
muShared = Int
newShared Int -> Int -> Int
forall a. Num a => a -> a -> a
+ SubTotal -> Int
stSharedHuge SubTotal
st
        , muPrivate :: Int
muPrivate = Int
newPrivate Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
newShared Int -> Int -> Int
forall a. Num a => a -> a -> a
+ SubTotal -> Int
stSharedHuge SubTotal
st
        , muSwap :: Int
muSwap = SubTotal -> Int
stSwap SubTotal
st
        , muCount :: Int
muCount = SubTotal -> Int
stCount SubTotal
st
        }


-- | Represents the measured memory usage of a program
data MemUsage = MemUsage
  { MemUsage -> Int
muShared :: !Int
  -- ^ the total shared memory in use
  , MemUsage -> Int
muPrivate :: !Int
  -- ^ the total private memory in use
  , MemUsage -> Int
muCount :: !Int
  -- ^ the number of processes running as the program
  , MemUsage -> Int
muSwap :: !Int
  -- ^ the total swap memory in use
  }
  deriving (MemUsage -> MemUsage -> Bool
(MemUsage -> MemUsage -> Bool)
-> (MemUsage -> MemUsage -> Bool) -> Eq MemUsage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MemUsage -> MemUsage -> Bool
== :: MemUsage -> MemUsage -> Bool
$c/= :: MemUsage -> MemUsage -> Bool
/= :: MemUsage -> MemUsage -> Bool
Eq, Int -> MemUsage -> ShowS
[MemUsage] -> ShowS
MemUsage -> String
(Int -> MemUsage -> ShowS)
-> (MemUsage -> String) -> ([MemUsage] -> ShowS) -> Show MemUsage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MemUsage -> ShowS
showsPrec :: Int -> MemUsage -> ShowS
$cshow :: MemUsage -> String
show :: MemUsage -> String
$cshowList :: [MemUsage] -> ShowS
showList :: [MemUsage] -> ShowS
Show)


incrSubTotals ::
  Ord a =>
  Bool ->
  Map a SubTotal ->
  (a, ProcUsage) ->
  Map a SubTotal
incrSubTotals :: forall a.
Ord a =>
Bool -> Map a SubTotal -> (a, ProcUsage) -> Map a SubTotal
incrSubTotals Bool
hasPss Map a SubTotal
acc (a
cmd, ProcUsage
mem) =
  let combinePrivate :: a -> a -> a
combinePrivate a
next a
prev | Bool
hasPss = a
next a -> a -> a
forall a. Num a => a -> a -> a
+ a
prev
      combinePrivate a
next a
prev = a -> a -> a
forall a. Ord a => a -> a -> a
max a
next a
prev
      nextSt :: SubTotal
nextSt =
        SubTotal
          { stShared :: Int
stShared = ProcUsage -> Int
puShared ProcUsage
mem
          , stSharedHuge :: Int
stSharedHuge = ProcUsage -> Int
puSharedHuge ProcUsage
mem
          , stCount :: Int
stCount = Int
1
          , stPrivate :: Int
stPrivate = ProcUsage -> Int
puPrivate ProcUsage
mem
          , stSwap :: Int
stSwap = ProcUsage -> Int
puSwap ProcUsage
mem
          , stMemIds :: Set Int
stMemIds = Int -> Set Int
forall a. a -> Set a
Set.singleton (Int -> Set Int) -> Int -> Set Int
forall a b. (a -> b) -> a -> b
$ ProcUsage -> Int
puMemId ProcUsage
mem
          }
      update' :: SubTotal -> SubTotal -> SubTotal
update' SubTotal
next SubTotal
prev =
        SubTotal
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 (SubTotal -> SubTotal -> SubTotal)
-> a -> SubTotal -> Map a SubTotal -> Map a SubTotal
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith SubTotal -> SubTotal -> SubTotal
update' a
cmd SubTotal
nextSt Map a SubTotal
acc


data SubTotal = SubTotal
  { SubTotal -> Int
stShared :: !Int
  , SubTotal -> Int
stSharedHuge :: !Int
  , SubTotal -> Int
stPrivate :: !Int
  , SubTotal -> Int
stCount :: !Int
  , SubTotal -> Int
stSwap :: !Int
  , SubTotal -> Set Int
stMemIds :: !(Set Int)
  }
  deriving (SubTotal -> SubTotal -> Bool
(SubTotal -> SubTotal -> Bool)
-> (SubTotal -> SubTotal -> Bool) -> Eq SubTotal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SubTotal -> SubTotal -> Bool
== :: SubTotal -> SubTotal -> Bool
$c/= :: SubTotal -> SubTotal -> Bool
/= :: SubTotal -> SubTotal -> Bool
Eq, Int -> SubTotal -> ShowS
[SubTotal] -> ShowS
SubTotal -> String
(Int -> SubTotal -> ShowS)
-> (SubTotal -> String) -> ([SubTotal] -> ShowS) -> Show SubTotal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SubTotal -> ShowS
showsPrec :: Int -> SubTotal -> ShowS
$cshow :: SubTotal -> String
show :: SubTotal -> String
$cshowList :: [SubTotal] -> ShowS
showList :: [SubTotal] -> ShowS
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 :: SubTotal -> Bool
threadsNotProcs SubTotal
cs = Set Int -> Int
forall a. Set a -> Int
Set.size (SubTotal -> Set Int
stMemIds SubTotal
cs) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& SubTotal -> Int
stCount SubTotal
cs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1


-- | Represents the memory metrics for a single process
data ProcUsage = ProcUsage
  { ProcUsage -> Int
puPrivate :: !Int
  , ProcUsage -> Int
puShared :: !Int
  , ProcUsage -> Int
puSharedHuge :: !Int
  , ProcUsage -> Int
puSwap :: !Int
  , ProcUsage -> Int
puMemId :: !Int
  }
  deriving (ProcUsage -> ProcUsage -> Bool
(ProcUsage -> ProcUsage -> Bool)
-> (ProcUsage -> ProcUsage -> Bool) -> Eq ProcUsage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProcUsage -> ProcUsage -> Bool
== :: ProcUsage -> ProcUsage -> Bool
$c/= :: ProcUsage -> ProcUsage -> Bool
/= :: ProcUsage -> ProcUsage -> Bool
Eq, Int -> ProcUsage -> ShowS
[ProcUsage] -> ShowS
ProcUsage -> String
(Int -> ProcUsage -> ShowS)
-> (ProcUsage -> String)
-> ([ProcUsage] -> ShowS)
-> Show ProcUsage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProcUsage -> ShowS
showsPrec :: Int -> ProcUsage -> ShowS
$cshow :: ProcUsage -> String
show :: ProcUsage -> String
$cshowList :: [ProcUsage] -> ShowS
showList :: [ProcUsage] -> ShowS
Show)


-- value used as page size when @MemStat@ is calcuated from statm
pageSizeKiB :: Int
pageSizeKiB :: Int
pageSizeKiB = Int
4


-- | Parse @'ProcUsage'@ from the contents of \/proc\/\<pid\>\/statm
parseFromStatm :: KernelVersion -> Text -> Maybe ProcUsage
parseFromStatm :: KernelVersion -> Text -> Maybe ProcUsage
parseFromStatm KernelVersion
version Text
content =
  let
    parseWord :: Text -> Maybe [a] -> Maybe [a]
parseWord Text
w (Just [a]
acc) = (\a
x -> [a] -> Maybe [a]
forall a. a -> Maybe a
Just (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc)) (a -> Maybe [a]) -> Maybe a -> Maybe [a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
w)
    parseWord Text
_ Maybe [a]
Nothing = Maybe [a]
forall a. Maybe a
Nothing
    parseMetrics :: [Text] -> Maybe [Int]
parseMetrics = (Text -> Maybe [Int] -> Maybe [Int])
-> Maybe [Int] -> [Text] -> Maybe [Int]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Text -> Maybe [Int] -> Maybe [Int]
forall {a}. Read a => Text -> Maybe [a] -> Maybe [a]
parseWord ([Int] -> Maybe [Int]
forall a. a -> Maybe a
Just [Int]
forall a. Monoid a => a
mempty)
    withMemId :: ProcUsage
withMemId = ProcUsage
ppZero {puMemId = hash content}
    fromRss :: Int -> Int -> ProcUsage
fromRss Int
rss Int
_shared
      | KernelVersion -> Bool
fickleSharing KernelVersion
version = ProcUsage
withMemId {puPrivate = rss * pageSizeKiB}
    fromRss Int
rss Int
shared =
      ProcUsage
withMemId
        { puShared = shared * pageSizeKiB
        , puPrivate = (rss - shared) * pageSizeKiB
        }
    fromRss' :: [Int] -> Maybe ProcUsage
fromRss' (Int
_size : Int
rss : Int
shared : [Int]
_xs) = ProcUsage -> Maybe ProcUsage
forall a. a -> Maybe a
Just (ProcUsage -> Maybe ProcUsage) -> ProcUsage -> Maybe ProcUsage
forall a b. (a -> b) -> a -> b
$ Int -> Int -> ProcUsage
fromRss Int
rss Int
shared
    fromRss' [Int]
_ = Maybe ProcUsage
forall a. Maybe a
Nothing
   in
    [Text] -> Maybe [Int]
parseMetrics (Text -> [Text]
Text.words Text
content) Maybe [Int] -> ([Int] -> Maybe ProcUsage) -> Maybe ProcUsage
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Int] -> Maybe ProcUsage
fromRss'


ppZero :: ProcUsage
ppZero :: ProcUsage
ppZero =
  ProcUsage
    { puPrivate :: Int
puPrivate = Int
0
    , puShared :: Int
puShared = Int
0
    , puSharedHuge :: Int
puSharedHuge = Int
0
    , puSwap :: Int
puSwap = Int
0
    , puMemId :: Int
puMemId = Int
0
    }


-- | Parse @'ProcUsage'@ from the contents of \/proc\/\<pid\>\/smap
parseFromSmap :: Text -> ProcUsage
parseFromSmap :: Text -> ProcUsage
parseFromSmap = SmapStats -> ProcUsage
fromSmap (SmapStats -> ProcUsage)
-> (Text -> SmapStats) -> Text -> ProcUsage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SmapStats
parseSmapStats


parseSmapStats :: Text -> SmapStats
parseSmapStats :: Text -> SmapStats
parseSmapStats Text
content =
  let noMemId :: SmapStats
noMemId = (SmapStats -> Text -> SmapStats)
-> SmapStats -> [Text] -> SmapStats
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SmapStats -> Text -> SmapStats
incrSmapStats SmapStats
ssZero ([Text] -> SmapStats) -> [Text] -> SmapStats
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
Text.lines Text
content
   in SmapStats
noMemId {ssMemId = hash content}


fromSmap :: SmapStats -> ProcUsage
fromSmap :: SmapStats -> ProcUsage
fromSmap SmapStats
ss =
  let pssTweak :: Int
pssTweak = SmapStats -> Int
ssPssCount SmapStats
ss Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2 -- add ~0.5 per line to counter truncation
      pssShared :: Int
pssShared = SmapStats -> Int
ssPss SmapStats
ss Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
pssTweak Int -> Int -> Int
forall a. Num a => a -> a -> a
- SmapStats -> Int
ssPrivate SmapStats
ss
   in ProcUsage
        { puSwap :: Int
puSwap = if SmapStats -> Bool
ssHasSwapPss SmapStats
ss then SmapStats -> Int
ssSwapPss SmapStats
ss else SmapStats -> Int
ssSwap SmapStats
ss
        , puShared :: Int
puShared = if SmapStats -> Bool
ssHasPss SmapStats
ss then Int
pssShared else SmapStats -> Int
ssShared SmapStats
ss
        , puSharedHuge :: Int
puSharedHuge = SmapStats -> Int
ssSharedHuge SmapStats
ss
        , puPrivate :: Int
puPrivate = SmapStats -> Int
ssPrivate SmapStats
ss Int -> Int -> Int
forall a. Num a => a -> a -> a
+ SmapStats -> Int
ssPrivateHuge SmapStats
ss
        , puMemId :: Int
puMemId = SmapStats -> Int
ssMemId SmapStats
ss
        }


-- | Represents per-process data read from \/proc\/\<pid\>\/smap
data SmapStats = SmapStats
  { SmapStats -> Int
ssPss :: !Int
  , SmapStats -> Int
ssPssCount :: !Int
  , SmapStats -> Int
ssSwap :: !Int
  , SmapStats -> Int
ssSwapPss :: !Int
  , SmapStats -> Int
ssPrivate :: !Int
  , SmapStats -> Int
ssPrivateHuge :: !Int
  , SmapStats -> Int
ssSharedHuge :: !Int
  , SmapStats -> Int
ssShared :: !Int
  , SmapStats -> Int
ssMemId :: !Int
  , SmapStats -> Bool
ssHasPss :: !Bool
  , SmapStats -> Bool
ssHasSwapPss :: !Bool
  }
  deriving (SmapStats -> SmapStats -> Bool
(SmapStats -> SmapStats -> Bool)
-> (SmapStats -> SmapStats -> Bool) -> Eq SmapStats
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SmapStats -> SmapStats -> Bool
== :: SmapStats -> SmapStats -> Bool
$c/= :: SmapStats -> SmapStats -> Bool
/= :: SmapStats -> SmapStats -> Bool
Eq, Int -> SmapStats -> ShowS
[SmapStats] -> ShowS
SmapStats -> String
(Int -> SmapStats -> ShowS)
-> (SmapStats -> String)
-> ([SmapStats] -> ShowS)
-> Show SmapStats
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SmapStats -> ShowS
showsPrec :: Int -> SmapStats -> ShowS
$cshow :: SmapStats -> String
show :: SmapStats -> String
$cshowList :: [SmapStats] -> ShowS
showList :: [SmapStats] -> ShowS
Show)


ssZero :: SmapStats
ssZero :: SmapStats
ssZero =
  SmapStats
    { ssPss :: Int
ssPss = Int
0
    , ssPssCount :: Int
ssPssCount = Int
0
    , ssSwap :: Int
ssSwap = Int
0
    , ssSwapPss :: Int
ssSwapPss = Int
0
    , ssPrivate :: Int
ssPrivate = Int
0
    , ssPrivateHuge :: Int
ssPrivateHuge = Int
0
    , ssSharedHuge :: Int
ssSharedHuge = Int
0
    , ssShared :: Int
ssShared = Int
0
    , ssHasSwapPss :: Bool
ssHasSwapPss = Bool
False
    , ssHasPss :: Bool
ssHasPss = Bool
False
    , ssMemId :: Int
ssMemId = Int
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 :: SmapStats -> Maybe Int -> SmapStats
incrPss SmapStats
ms = SmapStats -> (Int -> SmapStats) -> Maybe Int -> SmapStats
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SmapStats
ms ((Int -> SmapStats) -> Maybe Int -> SmapStats)
-> (Int -> SmapStats) -> Maybe Int -> SmapStats
forall a b. (a -> b) -> a -> b
$ \Int
n -> SmapStats
ms {ssPss = n + ssPss ms}
incrSwap :: SmapStats -> Maybe Int -> SmapStats
incrSwap SmapStats
ms = SmapStats -> (Int -> SmapStats) -> Maybe Int -> SmapStats
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SmapStats
ms ((Int -> SmapStats) -> Maybe Int -> SmapStats)
-> (Int -> SmapStats) -> Maybe Int -> SmapStats
forall a b. (a -> b) -> a -> b
$ \Int
n -> SmapStats
ms {ssSwap = n + ssSwap ms}
incrSwapPss :: SmapStats -> Maybe Int -> SmapStats
incrSwapPss SmapStats
ms = SmapStats -> (Int -> SmapStats) -> Maybe Int -> SmapStats
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SmapStats
ms ((Int -> SmapStats) -> Maybe Int -> SmapStats)
-> (Int -> SmapStats) -> Maybe Int -> SmapStats
forall a b. (a -> b) -> a -> b
$ \Int
n -> SmapStats
ms {ssSwapPss = n + ssSwapPss ms}
incrPrivate :: SmapStats -> Maybe Int -> SmapStats
incrPrivate SmapStats
ms = SmapStats -> (Int -> SmapStats) -> Maybe Int -> SmapStats
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SmapStats
ms ((Int -> SmapStats) -> Maybe Int -> SmapStats)
-> (Int -> SmapStats) -> Maybe Int -> SmapStats
forall a b. (a -> b) -> a -> b
$ \Int
n -> SmapStats
ms {ssPrivate = n + ssPrivate ms}
incrShared :: SmapStats -> Maybe Int -> SmapStats
incrShared SmapStats
ms = SmapStats -> (Int -> SmapStats) -> Maybe Int -> SmapStats
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SmapStats
ms ((Int -> SmapStats) -> Maybe Int -> SmapStats)
-> (Int -> SmapStats) -> Maybe Int -> SmapStats
forall a b. (a -> b) -> a -> b
$ \Int
n -> SmapStats
ms {ssShared = n + ssShared ms}
incrPrivateHuge :: SmapStats -> Maybe Int -> SmapStats
incrPrivateHuge SmapStats
ms = SmapStats -> (Int -> SmapStats) -> Maybe Int -> SmapStats
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SmapStats
ms ((Int -> SmapStats) -> Maybe Int -> SmapStats)
-> (Int -> SmapStats) -> Maybe Int -> SmapStats
forall a b. (a -> b) -> a -> b
$ \Int
n -> SmapStats
ms {ssPrivateHuge = n + ssPrivateHuge ms}
incrSharedHuge :: SmapStats -> Maybe Int -> SmapStats
incrSharedHuge SmapStats
ms = SmapStats -> (Int -> SmapStats) -> Maybe Int -> SmapStats
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SmapStats
ms ((Int -> SmapStats) -> Maybe Int -> SmapStats)
-> (Int -> SmapStats) -> Maybe Int -> SmapStats
forall a b. (a -> b) -> a -> b
$ \Int
n -> SmapStats
ms {ssSharedHuge = n + ssSharedHuge ms}


incrSmapStats :: SmapStats -> Text -> SmapStats
incrSmapStats :: SmapStats -> Text -> SmapStats
incrSmapStats SmapStats
acc Text
l =
  if
      | Text -> Text -> Bool
Text.isPrefixOf Text
"Private_Hugetlb:" Text
l -> SmapStats -> Maybe Int -> SmapStats
incrPrivateHuge SmapStats
acc (Maybe Int -> SmapStats) -> Maybe Int -> SmapStats
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Int
forall a. Read a => Text -> Maybe a
smapValMb Text
l
      | Text -> Text -> Bool
Text.isPrefixOf Text
"Shared_Hugetlb:" Text
l -> SmapStats -> Maybe Int -> SmapStats
incrSharedHuge SmapStats
acc (Maybe Int -> SmapStats) -> Maybe Int -> SmapStats
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Int
forall a. Read a => Text -> Maybe a
smapValMb Text
l
      | Text -> Text -> Bool
Text.isPrefixOf Text
"Shared" Text
l -> SmapStats -> Maybe Int -> SmapStats
incrShared SmapStats
acc (Maybe Int -> SmapStats) -> Maybe Int -> SmapStats
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Int
forall a. Read a => Text -> Maybe a
smapValMb Text
l
      | Text -> Text -> Bool
Text.isPrefixOf Text
"Private" Text
l -> SmapStats -> Maybe Int -> SmapStats
incrPrivate SmapStats
acc (Maybe Int -> SmapStats) -> Maybe Int -> SmapStats
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Int
forall a. Read a => Text -> Maybe a
smapValMb Text
l
      | Text -> Text -> Bool
Text.isPrefixOf Text
"Pss:" Text
l ->
          let acc' :: SmapStats
acc' = SmapStats
acc {ssHasPss = True, ssPssCount = 1 + ssPssCount acc}
           in SmapStats -> Maybe Int -> SmapStats
incrPss SmapStats
acc' (Maybe Int -> SmapStats) -> Maybe Int -> SmapStats
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Int
forall a. Read a => Text -> Maybe a
smapValMb Text
l
      | Text -> Text -> Bool
Text.isPrefixOf Text
"Swap:" Text
l -> SmapStats -> Maybe Int -> SmapStats
incrSwap SmapStats
acc (Maybe Int -> SmapStats) -> Maybe Int -> SmapStats
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Int
forall a. Read a => Text -> Maybe a
smapValMb Text
l
      | Text -> Text -> Bool
Text.isPrefixOf Text
"SwapPss:" Text
l -> SmapStats -> Maybe Int -> SmapStats
incrSwapPss (SmapStats
acc {ssHasSwapPss = True}) (Maybe Int -> SmapStats) -> Maybe Int -> SmapStats
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Int
forall a. Read a => Text -> Maybe a
smapValMb Text
l
      | Bool
otherwise -> SmapStats
acc


smapValMb :: Read a => Text -> Maybe a
smapValMb :: forall a. Read a => Text -> Maybe a
smapValMb Text
l =
  let memWords :: [Text]
memWords = Text -> [Text]
Text.words Text
l
      readVal :: [Text] -> Maybe a
readVal (Text
_ : Text
x : [Text]
_) = String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe a) -> String -> Maybe a
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
x
      readVal [Text]
_ = Maybe a
forall a. Maybe a
Nothing
   in [Text] -> Maybe a
forall {a}. Read a => [Text] -> Maybe a
readVal [Text]
memWords