module System.CGroup.V1.Controller (
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)
newtype Controller a = Controller {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
$cp1Ord :: forall a. Eq (Controller a)
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)
resolveCGroupController :: Text -> IO (Controller a)
resolveCGroupController :: 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
resolveCGroupController' :: Path Abs File -> Path Abs File -> Text -> IO (Controller a)
resolveCGroupController' :: 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)
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
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 :: (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
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)