{-# 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 :: KernelVersion -> Bool
fickleSharing KernelVersion
k = KernelVersion
k forall a. Ord a => a -> a -> Bool
>= (Natural
2, Natural
6, Natural
1) Bool -> Bool -> Bool
&& KernelVersion
k forall a. Ord a => a -> a -> Bool
<= (Natural
2, Natural
6, Natural
9)


-- | Determines the version of the Linux kernel on the current system.
readKernelVersion :: IO (Maybe KernelVersion)
readKernelVersion :: IO (Maybe KernelVersion)
readKernelVersion = Text -> Maybe KernelVersion
parseKernelVersion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Text
Text.readFile FilePath
kernelVersionPath


kernelVersionPath :: String
kernelVersionPath :: FilePath
kernelVersionPath = FilePath
"/proc/sys/kernel/osrelease"


-- | Parses @Text@ into a @'KernelVersion'@
parseKernelVersion :: Text -> Maybe KernelVersion
parseKernelVersion :: Text -> Maybe KernelVersion
parseKernelVersion =
  let unrecognized :: Maybe a
unrecognized = forall a. Maybe a
Nothing
      dec' :: Either a (a, Text) -> Maybe a
dec' (Right (a
x, Text
extra)) | Text -> Bool
Text.null Text
extra = forall a. a -> Maybe a
Just a
x
      dec' Either a (a, Text)
_ = forall a. Maybe a
unrecognized
      dec1st' :: Either a (a, b) -> Maybe a
dec1st' (Right (a
x, b
_)) = forall a. a -> Maybe a
Just a
x
      dec1st' Either a (a, b)
_ = forall a. Maybe a
unrecognized

      dec :: Text -> Maybe Natural
dec = forall {a} {a}. Either a (a, Text) -> Maybe a
dec' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => Reader a
Text.decimal
      dec1st :: Text -> Maybe Natural
dec1st = forall {a} {a} {b}. Either a (a, b) -> Maybe a
dec1st' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => Reader a
Text.decimal
      fromSplit :: [Text] -> Maybe KernelVersion
fromSplit [Text
x] = (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Natural
dec Text
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Natural
0 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Natural
0
      fromSplit [Text
x, Text
y] = (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Natural
dec Text
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Maybe Natural
dec1st Text
y forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Natural
0
      fromSplit [Text
x, Text
y, Text
z] = (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Natural
dec Text
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Maybe Natural
dec Text
y forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Maybe Natural
dec1st Text
z
      fromSplit [Text]
_ = forall a. Maybe a
unrecognized
   in [Text] -> Maybe KernelVersion
fromSplit forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
Text.split (forall a. Eq a => a -> a -> Bool
== Char
'.')


-- | Gathers the inputs needed to generate a memory usage report
data ReportBud = ReportBud
  { ReportBud -> NonEmpty ProcessID
rbPids :: !(NonEmpty ProcessID)
  , ReportBud -> KernelVersion
rbKernel :: !KernelVersion
  , ReportBud -> Bool
rbHasPss :: !Bool
  , ReportBud -> Bool
rbHasSwapPss :: !Bool
  , ReportBud -> Bool
rbHasSmaps :: !Bool
  , ReportBud -> Maybe RamFlaw
rbRamFlaws :: Maybe RamFlaw
  , ReportBud -> Maybe SwapFlaw
rbSwapFlaws :: Maybe SwapFlaw
  }
  deriving (ReportBud -> ReportBud -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReportBud -> ReportBud -> Bool
$c/= :: ReportBud -> ReportBud -> Bool
== :: ReportBud -> ReportBud -> Bool
$c== :: ReportBud -> ReportBud -> Bool
Eq, Int -> ReportBud -> ShowS
[ReportBud] -> ShowS
ReportBud -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ReportBud] -> ShowS
$cshowList :: [ReportBud] -> ShowS
show :: ReportBud -> FilePath
$cshow :: ReportBud -> FilePath
showsPrec :: Int -> ReportBud -> ShowS
$cshowsPrec :: Int -> ReportBud -> ShowS
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 (RamFlaw -> RamFlaw -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RamFlaw -> RamFlaw -> Bool
$c/= :: RamFlaw -> RamFlaw -> Bool
== :: RamFlaw -> RamFlaw -> Bool
$c== :: RamFlaw -> RamFlaw -> Bool
Eq, Int -> RamFlaw -> ShowS
[RamFlaw] -> ShowS
RamFlaw -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [RamFlaw] -> ShowS
$cshowList :: [RamFlaw] -> ShowS
show :: RamFlaw -> FilePath
$cshow :: RamFlaw -> FilePath
showsPrec :: Int -> RamFlaw -> ShowS
$cshowsPrec :: Int -> RamFlaw -> ShowS
Show, Eq RamFlaw
RamFlaw -> RamFlaw -> Bool
RamFlaw -> RamFlaw -> Ordering
RamFlaw -> RamFlaw -> RamFlaw
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RamFlaw -> RamFlaw -> RamFlaw
$cmin :: RamFlaw -> RamFlaw -> RamFlaw
max :: RamFlaw -> RamFlaw -> RamFlaw
$cmax :: RamFlaw -> RamFlaw -> RamFlaw
>= :: RamFlaw -> RamFlaw -> Bool
$c>= :: RamFlaw -> RamFlaw -> Bool
> :: RamFlaw -> RamFlaw -> Bool
$c> :: RamFlaw -> RamFlaw -> Bool
<= :: RamFlaw -> RamFlaw -> Bool
$c<= :: RamFlaw -> RamFlaw -> Bool
< :: RamFlaw -> RamFlaw -> Bool
$c< :: RamFlaw -> RamFlaw -> Bool
compare :: RamFlaw -> RamFlaw -> Ordering
$ccompare :: RamFlaw -> RamFlaw -> Ordering
Ord)


-- | Provide @Text@ that explains the 'RamFlaw'
fmtRamFlaws :: RamFlaw -> Text
fmtRamFlaws :: RamFlaw -> Text
fmtRamFlaws RamFlaw
NoSharedMem =
  [Text] -> Text
Text.unlines
    [ Text
"shared memory is not reported by this system."
    , Text
"Values reported will be too large, and totals are not reported"
    ]
fmtRamFlaws RamFlaw
SomeSharedMem =
  [Text] -> Text
Text.unlines
    [ Text
"shared memory is not reported accurately by this system."
    , Text
"Values reported could be too large, and totals are not reported"
    ]
fmtRamFlaws RamFlaw
ExactForIsolatedMem =
  [Text] -> Text
Text.unlines
    [ Text
"shared memory is slightly over-estimated by this system"
    , Text
"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 (SwapFlaw -> SwapFlaw -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SwapFlaw -> SwapFlaw -> Bool
$c/= :: SwapFlaw -> SwapFlaw -> Bool
== :: SwapFlaw -> SwapFlaw -> Bool
$c== :: SwapFlaw -> SwapFlaw -> Bool
Eq, Int -> SwapFlaw -> ShowS
[SwapFlaw] -> ShowS
SwapFlaw -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [SwapFlaw] -> ShowS
$cshowList :: [SwapFlaw] -> ShowS
show :: SwapFlaw -> FilePath
$cshow :: SwapFlaw -> FilePath
showsPrec :: Int -> SwapFlaw -> ShowS
$cshowsPrec :: Int -> SwapFlaw -> ShowS
Show, Eq SwapFlaw
SwapFlaw -> SwapFlaw -> Bool
SwapFlaw -> SwapFlaw -> Ordering
SwapFlaw -> SwapFlaw -> SwapFlaw
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SwapFlaw -> SwapFlaw -> SwapFlaw
$cmin :: SwapFlaw -> SwapFlaw -> SwapFlaw
max :: SwapFlaw -> SwapFlaw -> SwapFlaw
$cmax :: SwapFlaw -> SwapFlaw -> SwapFlaw
>= :: SwapFlaw -> SwapFlaw -> Bool
$c>= :: SwapFlaw -> SwapFlaw -> Bool
> :: SwapFlaw -> SwapFlaw -> Bool
$c> :: SwapFlaw -> SwapFlaw -> Bool
<= :: SwapFlaw -> SwapFlaw -> Bool
$c<= :: SwapFlaw -> SwapFlaw -> Bool
< :: SwapFlaw -> SwapFlaw -> Bool
$c< :: SwapFlaw -> SwapFlaw -> Bool
compare :: SwapFlaw -> SwapFlaw -> Ordering
$ccompare :: SwapFlaw -> SwapFlaw -> Ordering
Ord)


-- | Provide @Text@ that explains the 'SwapFlaw'
fmtSwapFlaws :: SwapFlaw -> Text
fmtSwapFlaws :: SwapFlaw -> Text
fmtSwapFlaws SwapFlaw
NoSwap = Text
"swap is not reported by this system."
fmtSwapFlaws SwapFlaw
ExactForIsolatedSwap =
  [Text] -> Text
Text.unlines
    [ Text
"swap is over-estimated by this system"
    , Text
"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 :: ReportBud -> IO ReportBud
checkForFlaws ReportBud
bud = do
  let pid :: ProcessID
pid = forall a. NonEmpty a -> a
NE.head forall a b. (a -> b) -> a -> b
$ ReportBud -> NonEmpty ProcessID
rbPids ReportBud
bud
      version :: KernelVersion
version = ReportBud -> KernelVersion
rbKernel ReportBud
bud
      fickleShared :: Bool
fickleShared = KernelVersion -> Bool
fickleSharing KernelVersion
version
      ReportBud
        { rbHasPss :: ReportBud -> Bool
rbHasPss = Bool
hasPss
        , rbHasSmaps :: ReportBud -> Bool
rbHasSmaps = Bool
hasSmaps
        , rbHasSwapPss :: ReportBud -> Bool
rbHasSwapPss = Bool
hasSwapPss
        } = ReportBud
bud
  (Maybe RamFlaw
rbRamFlaws, Maybe SwapFlaw
rbSwapFlaws) <- case KernelVersion
version of
    (Natural
2, Natural
4, Natural
_) -> do
      let memInfoPath :: FilePath
memInfoPath = FilePath -> ProcessID -> FilePath
pidPath FilePath
"meminfo" ProcessID
pid
          alt :: (Maybe RamFlaw, Maybe SwapFlaw)
alt = (forall a. a -> Maybe a
Just RamFlaw
SomeSharedMem, forall a. a -> Maybe a
Just SwapFlaw
NoSwap)
          best :: (Maybe RamFlaw, Maybe SwapFlaw)
best = (forall a. a -> Maybe a
Just RamFlaw
ExactForIsolatedMem, forall a. a -> Maybe a
Just SwapFlaw
NoSwap)
          containsInact :: Text -> Bool
containsInact = Text -> Text -> Bool
Text.isInfixOf Text
"Inact_"
          checkInact :: Text -> (Maybe RamFlaw, Maybe SwapFlaw)
checkInact Text
x = if Text -> Bool
containsInact Text
x then (Maybe RamFlaw, Maybe SwapFlaw)
best else (Maybe RamFlaw, Maybe SwapFlaw)
alt
      FilePath -> IO Bool
doesFileExist FilePath
memInfoPath forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
False -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe RamFlaw, Maybe SwapFlaw)
alt
        Bool
_ -> Text -> (Maybe RamFlaw, Maybe SwapFlaw)
checkInact forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Text
readUtf8Text FilePath
memInfoPath
    (Natural
2, Natural
6, Natural
_) -> do
      let withSmaps :: (Maybe RamFlaw, Maybe SwapFlaw)
withSmaps = if Bool
hasPss then forall {a}. (Maybe a, Maybe SwapFlaw)
best else (Maybe RamFlaw, Maybe SwapFlaw)
alt
          alt :: (Maybe RamFlaw, Maybe SwapFlaw)
alt = (forall a. a -> Maybe a
Just RamFlaw
ExactForIsolatedMem, forall a. a -> Maybe a
Just SwapFlaw
ExactForIsolatedSwap)
          best :: (Maybe a, Maybe SwapFlaw)
best = (forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just SwapFlaw
ExactForIsolatedSwap)
          withNoSmaps :: Maybe RamFlaw
withNoSmaps = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ if Bool
fickleShared then RamFlaw
NoSharedMem else RamFlaw
SomeSharedMem
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Bool
hasSmaps then (Maybe RamFlaw, Maybe SwapFlaw)
withSmaps else (Maybe RamFlaw
withNoSmaps, forall a. a -> Maybe a
Just SwapFlaw
NoSwap)
    (Natural
major, Natural
_, Natural
_) | Natural
major forall a. Ord a => a -> a -> Bool
> Natural
2 Bool -> Bool -> Bool
&& Bool
hasSmaps -> do
      let alt :: (Maybe a, Maybe SwapFlaw)
alt = (forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just SwapFlaw
ExactForIsolatedSwap)
          best :: (Maybe a, Maybe a)
best = (forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Bool
hasSwapPss then forall {a} {a}. (Maybe a, Maybe a)
best else forall {a}. (Maybe a, Maybe SwapFlaw)
alt
    KernelVersion
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just RamFlaw
ExactForIsolatedMem, forall a. a -> Maybe a
Just SwapFlaw
NoSwap)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ReportBud
bud {Maybe RamFlaw
rbRamFlaws :: Maybe RamFlaw
rbRamFlaws :: Maybe RamFlaw
rbRamFlaws, Maybe SwapFlaw
rbSwapFlaws :: Maybe SwapFlaw
rbSwapFlaws :: Maybe SwapFlaw
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 :: NonEmpty ProcessID -> IO (Maybe ReportBud)
mkReportBud NonEmpty ProcessID
rbPids = do
  let firstPid :: ProcessID
firstPid = forall a. NonEmpty a -> a
NE.head NonEmpty ProcessID
rbPids
      smapsPath :: FilePath
smapsPath = FilePath -> ProcessID -> FilePath
pidPath FilePath
"smaps" ProcessID
firstPid
      hasPss :: Text -> Bool
hasPss = Text -> Text -> Bool
Text.isInfixOf Text
"Pss:"
      hasSwapPss :: Text -> Bool
hasSwapPss = Text -> Text -> Bool
Text.isInfixOf Text
"SwapPss:"
      memtypes :: Text -> (Bool, Bool)
memtypes Text
x = (Text -> Bool
hasPss Text
x, Text -> Bool
hasSwapPss Text
x)
  Bool
rbHasSmaps <- FilePath -> IO Bool
doesFileExist FilePath
smapsPath
  (Bool
rbHasPss, Bool
rbHasSwapPss) <- Text -> (Bool, Bool)
memtypes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Text
readUtf8Text FilePath
smapsPath
  IO (Maybe KernelVersion)
readKernelVersion forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe KernelVersion
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just KernelVersion
rbKernel ->
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
        ReportBud -> IO ReportBud
checkForFlaws forall a b. (a -> b) -> a -> b
$
          ReportBud
            { NonEmpty ProcessID
rbPids :: NonEmpty ProcessID
rbPids :: NonEmpty ProcessID
rbPids
            , KernelVersion
rbKernel :: KernelVersion
rbKernel :: KernelVersion
rbKernel
            , Bool
rbHasPss :: Bool
rbHasPss :: Bool
rbHasPss
            , Bool
rbHasSwapPss :: Bool
rbHasSwapPss :: Bool
rbHasSwapPss
            , Bool
rbHasSmaps :: Bool
rbHasSmaps :: Bool
rbHasSmaps
            , rbRamFlaws :: Maybe RamFlaw
rbRamFlaws = forall a. Maybe a
Nothing
            , rbSwapFlaws :: Maybe SwapFlaw
rbSwapFlaws = forall a. Maybe a
Nothing
            }


pidPath :: String -> ProcessID -> FilePath
pidPath :: FilePath -> ProcessID -> FilePath
pidPath FilePath
base ProcessID
pid = Builder
"/proc/" forall b. FromBuilder b => Builder -> Builder -> b
+| forall a. Integral a => a -> Integer
toInteger ProcessID
pid forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"/" forall b. FromBuilder b => Builder -> Builder -> b
+| FilePath
base forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""