-- | Common types and operations for cgroup controllers.
module System.CGroup.V1.Controller (
  -- * cgroup controllers
  Controller (..),
  resolveCGroupController,
  resolveCGroupController',
) where

import Control.Monad (guard)
import Data.Foldable (find)
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import Path
import System.CGroup.Types (Mount (..), RawCGroup (..), parseCGroups, parseFile, parseMountInfo)

-- | A cgroup (v1) controller path for a specific subsystem
newtype Controller a = Controller {forall a. Controller a -> Path Abs Dir
unController :: Path Abs Dir}
  deriving (Controller a -> Controller a -> Bool
(Controller a -> Controller a -> Bool)
-> (Controller a -> Controller a -> Bool) -> Eq (Controller a)
forall a. Controller a -> Controller a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Controller a -> Controller a -> Bool
$c/= :: forall a. Controller a -> Controller a -> Bool
== :: Controller a -> Controller a -> Bool
$c== :: forall a. Controller a -> Controller a -> Bool
Eq, Eq (Controller a)
Eq (Controller a)
-> (Controller a -> Controller a -> Ordering)
-> (Controller a -> Controller a -> Bool)
-> (Controller a -> Controller a -> Bool)
-> (Controller a -> Controller a -> Bool)
-> (Controller a -> Controller a -> Bool)
-> (Controller a -> Controller a -> Controller a)
-> (Controller a -> Controller a -> Controller a)
-> Ord (Controller a)
Controller a -> Controller a -> Bool
Controller a -> Controller a -> Ordering
Controller a -> Controller a -> Controller a
forall a. Eq (Controller a)
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
forall a. Controller a -> Controller a -> Bool
forall a. Controller a -> Controller a -> Ordering
forall a. Controller a -> Controller a -> Controller a
min :: Controller a -> Controller a -> Controller a
$cmin :: forall a. Controller a -> Controller a -> Controller a
max :: Controller a -> Controller a -> Controller a
$cmax :: forall a. Controller a -> Controller a -> Controller a
>= :: Controller a -> Controller a -> Bool
$c>= :: forall a. Controller a -> Controller a -> Bool
> :: Controller a -> Controller a -> Bool
$c> :: forall a. Controller a -> Controller a -> Bool
<= :: Controller a -> Controller a -> Bool
$c<= :: forall a. Controller a -> Controller a -> Bool
< :: Controller a -> Controller a -> Bool
$c< :: forall a. Controller a -> Controller a -> Bool
compare :: Controller a -> Controller a -> Ordering
$ccompare :: forall a. Controller a -> Controller a -> Ordering
Ord, Int -> Controller a -> ShowS
[Controller a] -> ShowS
Controller a -> String
(Int -> Controller a -> ShowS)
-> (Controller a -> String)
-> ([Controller a] -> ShowS)
-> Show (Controller a)
forall a. Int -> Controller a -> ShowS
forall a. [Controller a] -> ShowS
forall a. Controller a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Controller a] -> ShowS
$cshowList :: forall a. [Controller a] -> ShowS
show :: Controller a -> String
$cshow :: forall a. Controller a -> String
showsPrec :: Int -> Controller a -> ShowS
$cshowsPrec :: forall a. Int -> Controller a -> ShowS
Show)

-- | Resolve a cgroup (v1) controller by name, as viewed by the current process
--
-- see cgroups(7): \/proc\/self\/cgroup is a file that contains information about
-- control groups applied to this process
--
-- see proc(5): \/proc\/self\/mountinfo is a file that contains information about
-- mounts available to this process
--
-- Throws an Exception when the controller is not able to be found, or when
-- running outside of a cgroup
resolveCGroupController :: Text -> IO (Controller a)
resolveCGroupController :: forall a. Text -> IO (Controller a)
resolveCGroupController Text
controller = do
  Path Abs File
cgroupPath <- String -> IO (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile String
"/proc/self/cgroup"
  Path Abs File
mountinfoPath <- String -> IO (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile String
"/proc/self/mountinfo"
  Path Abs File -> Path Abs File -> Text -> IO (Controller a)
forall a.
Path Abs File -> Path Abs File -> Text -> IO (Controller a)
resolveCGroupController' Path Abs File
cgroupPath Path Abs File
mountinfoPath Text
controller

-- | Resolve a cgroup controller by name, under the given cgroup and
-- mountinfo paths
--
-- Throws an Exception when the controller is not able to be found, or when
-- running outside of a cgroup
resolveCGroupController' :: Path Abs File -> Path Abs File -> Text -> IO (Controller a)
resolveCGroupController' :: forall a.
Path Abs File -> Path Abs File -> Text -> IO (Controller a)
resolveCGroupController' Path Abs File
cgroupPath Path Abs File
mountinfoPath Text
controllerName = do
  [RawCGroup]
cgroups <- Parser [RawCGroup] -> Path Abs File -> IO [RawCGroup]
forall a b. Parser a -> Path b File -> IO a
parseFile Parser [RawCGroup]
parseCGroups Path Abs File
cgroupPath
  [Mount]
mounts <- Parser [Mount] -> Path Abs File -> IO [Mount]
forall a b. Parser a -> Path b File -> IO a
parseFile Parser [Mount]
parseMountInfo Path Abs File
mountinfoPath
  RawCGroup
cgroup <- IO RawCGroup
-> (RawCGroup -> IO RawCGroup) -> Maybe RawCGroup -> IO RawCGroup
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO RawCGroup
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Couldn't find cgroup for controller") RawCGroup -> IO RawCGroup
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [RawCGroup] -> Maybe RawCGroup
findMatchingCGroup Text
controllerName [RawCGroup]
cgroups)
  Path Abs Dir
resolved <- IO (Path Abs Dir)
-> (Path Abs Dir -> IO (Path Abs Dir))
-> Maybe (Path Abs Dir)
-> IO (Path Abs Dir)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO (Path Abs Dir)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Couldn't find mount for cgroup") Path Abs Dir -> IO (Path Abs Dir)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> RawCGroup -> [Mount] -> Maybe (Path Abs Dir)
resolveControllerMountPath Text
controllerName RawCGroup
cgroup [Mount]
mounts)
  Controller a -> IO (Controller a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir -> Controller a
forall a. Path Abs Dir -> Controller a
Controller Path Abs Dir
resolved)

-- | Find a cgroup for a specific controller (cgroups v1)
findMatchingCGroup :: Text -> [RawCGroup] -> Maybe RawCGroup
findMatchingCGroup :: Text -> [RawCGroup] -> Maybe RawCGroup
findMatchingCGroup Text
controllerName = (RawCGroup -> Bool) -> [RawCGroup] -> Maybe RawCGroup
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find RawCGroup -> Bool
containsController
  where
    containsController :: RawCGroup -> Bool
    containsController :: RawCGroup -> Bool
containsController = (Text
controllerName Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) ([Text] -> Bool) -> (RawCGroup -> [Text]) -> RawCGroup -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawCGroup -> [Text]
rawCGroupControllers

-- | Find a Mount matching a controller name and cgroup, returning the absolute
-- resolved path of a controller
resolveControllerMountPath :: Text -> RawCGroup -> [Mount] -> Maybe (Path Abs Dir)
resolveControllerMountPath :: Text -> RawCGroup -> [Mount] -> Maybe (Path Abs Dir)
resolveControllerMountPath Text
controllerName RawCGroup
cgroup = (Mount -> Maybe (Path Abs Dir)) -> [Mount] -> Maybe (Path Abs Dir)
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMaybe (Text -> RawCGroup -> Mount -> Maybe (Path Abs Dir)
tryResolveMount Text
controllerName RawCGroup
cgroup)

firstMaybe :: (a -> Maybe b) -> [a] -> Maybe b
firstMaybe :: forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMaybe a -> Maybe b
f = [b] -> Maybe b
forall a. [a] -> Maybe a
listToMaybe ([b] -> Maybe b) -> ([a] -> [b]) -> [a] -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe b) -> [a] -> [b]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe a -> Maybe b
f

-- | Attempt to match a cgroup controller to a mount, returning the absolute
-- resolved path of the controller
--
-- Returns Nothing if the mount does not match the cgroup controller
--
-- A matching mount must have a filesystem type of "cgroup" and contain the
-- controller name within its "super options".
--
-- Per cgroups(7), the cgroup path is relative to a mount root in the process's
-- mount hierarchy. Notably, a mount root /is not the same as its mount point/.
-- A mount point is the path at which the mount is visible to the process.
--
-- As such, we need to look for a mount whose mount root either..
--
-- - ..exactly matches our cgroup's path, in which case we directly return the
--   mount's mount path; OR
--
-- - ..is a prefix of our cgroup's path, in which case we return the relative
--   path from the mount root appended to the mount's mount path
tryResolveMount :: Text -> RawCGroup -> Mount -> Maybe (Path Abs Dir)
tryResolveMount :: Text -> RawCGroup -> Mount -> Maybe (Path Abs Dir)
tryResolveMount Text
controllerName RawCGroup
cgroup Mount
mount = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
"cgroup" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Mount -> Text
mountFilesystemType Mount
mount)
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
controllerName Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Mount -> [Text]
mountSuperOptions Mount
mount)
  Path Abs Dir
mountRootAsPath <- String -> Maybe (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir (Text -> String
Text.unpack (Mount -> Text
mountRoot Mount
mount))
  Path Abs Dir
mountPointAsPath <- String -> Maybe (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir (Text -> String
Text.unpack (Mount -> Text
mountPoint Mount
mount))
  if RawCGroup -> Path Abs Dir
rawCGroupPath RawCGroup
cgroup Path Abs Dir -> Path Abs Dir -> Bool
forall a. Eq a => a -> a -> Bool
== Path Abs Dir
mountRootAsPath
    then Path Abs Dir -> Maybe (Path Abs Dir)
forall a. a -> Maybe a
Just Path Abs Dir
mountPointAsPath
    else do
      Path Rel Dir
rel <- Path Abs Dir -> Path Abs Dir -> Maybe (Path Rel Dir)
forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix Path Abs Dir
mountRootAsPath (RawCGroup -> Path Abs Dir
rawCGroupPath RawCGroup
cgroup)
      Path Abs Dir -> Maybe (Path Abs Dir)
forall a. a -> Maybe a
Just (Path Abs Dir
mountPointAsPath Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
rel)