{-# LANGUAGE TemplateHaskell #-}
module System.CGroup.V2.CGroup (
CGroup (..),
resolveCGroup,
resolveCGroup',
) where
import Data.Foldable (find)
import qualified Data.Text as Text
import Path
import System.CGroup.Types (Mount (..), RawCGroup (..), parseCGroups, parseFile, parseMountInfo)
data CGroup = CGroup
{
CGroup -> Path Abs Dir
cgroupRoot :: Path Abs Dir
,
CGroup -> Path Rel Dir
cgroupLeaf :: Path Rel Dir
}
deriving (CGroup -> CGroup -> Bool
(CGroup -> CGroup -> Bool)
-> (CGroup -> CGroup -> Bool) -> Eq CGroup
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CGroup -> CGroup -> Bool
$c/= :: CGroup -> CGroup -> Bool
== :: CGroup -> CGroup -> Bool
$c== :: CGroup -> CGroup -> Bool
Eq, Eq CGroup
Eq CGroup
-> (CGroup -> CGroup -> Ordering)
-> (CGroup -> CGroup -> Bool)
-> (CGroup -> CGroup -> Bool)
-> (CGroup -> CGroup -> Bool)
-> (CGroup -> CGroup -> Bool)
-> (CGroup -> CGroup -> CGroup)
-> (CGroup -> CGroup -> CGroup)
-> Ord CGroup
CGroup -> CGroup -> Bool
CGroup -> CGroup -> Ordering
CGroup -> CGroup -> CGroup
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 :: CGroup -> CGroup -> CGroup
$cmin :: CGroup -> CGroup -> CGroup
max :: CGroup -> CGroup -> CGroup
$cmax :: CGroup -> CGroup -> CGroup
>= :: CGroup -> CGroup -> Bool
$c>= :: CGroup -> CGroup -> Bool
> :: CGroup -> CGroup -> Bool
$c> :: CGroup -> CGroup -> Bool
<= :: CGroup -> CGroup -> Bool
$c<= :: CGroup -> CGroup -> Bool
< :: CGroup -> CGroup -> Bool
$c< :: CGroup -> CGroup -> Bool
compare :: CGroup -> CGroup -> Ordering
$ccompare :: CGroup -> CGroup -> Ordering
$cp1Ord :: Eq CGroup
Ord, Int -> CGroup -> ShowS
[CGroup] -> ShowS
CGroup -> String
(Int -> CGroup -> ShowS)
-> (CGroup -> String) -> ([CGroup] -> ShowS) -> Show CGroup
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CGroup] -> ShowS
$cshowList :: [CGroup] -> ShowS
show :: CGroup -> String
$cshow :: CGroup -> String
showsPrec :: Int -> CGroup -> ShowS
$cshowsPrec :: Int -> CGroup -> ShowS
Show)
resolveCGroup :: IO CGroup
resolveCGroup :: IO CGroup
resolveCGroup = 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 -> IO CGroup
resolveCGroup' Path Abs File
cgroupPath Path Abs File
mountinfoPath
resolveCGroup' :: Path Abs File -> Path Abs File -> IO CGroup
resolveCGroup' :: Path Abs File -> Path Abs File -> IO CGroup
resolveCGroup' Path Abs File
cgroupPath Path Abs File
mountinfoPath = 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
case [RawCGroup]
cgroups of
[RawCGroup Text
"0" [] Path Abs Dir
cgroupLeafAbs] -> do
[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
Mount
cgroupRootMount <- IO Mount -> (Mount -> IO Mount) -> Maybe Mount -> IO Mount
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO Mount
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Couldn't find cgroup hierarchy root mount") Mount -> IO Mount
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Mount] -> Maybe Mount
findCGroupHierarchyRootMount [Mount]
mounts)
Path Abs Dir
mountPointAsPath <- String -> IO (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir (Text -> String
Text.unpack (Mount -> Text
mountPoint Mount
cgroupRootMount))
case Path Abs Dir -> String
fromAbsDir Path Abs Dir
cgroupLeafAbs of
String
"/" ->
CGroup -> IO CGroup
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( CGroup :: Path Abs Dir -> Path Rel Dir -> CGroup
CGroup
{ cgroupRoot :: Path Abs Dir
cgroupRoot = Path Abs Dir
mountPointAsPath
, cgroupLeaf :: Path Rel Dir
cgroupLeaf = $(mkRelDir ".")
}
)
String
_ -> do
Path Rel Dir
cgroupLeafRel <- String -> IO (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 (Path Abs Dir -> String
fromAbsDir Path Abs Dir
cgroupLeafAbs))
CGroup -> IO CGroup
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( CGroup :: Path Abs Dir -> Path Rel Dir -> CGroup
CGroup
{ cgroupRoot :: Path Abs Dir
cgroupRoot = Path Abs Dir
mountPointAsPath
, cgroupLeaf :: Path Rel Dir
cgroupLeaf = Path Rel Dir
cgroupLeafRel
}
)
[RawCGroup]
_ -> String -> IO CGroup
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Found incompatible cgroups: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [RawCGroup] -> String
forall a. Show a => a -> String
show [RawCGroup]
cgroups)
findCGroupHierarchyRootMount :: [Mount] -> Maybe Mount
findCGroupHierarchyRootMount :: [Mount] -> Maybe Mount
findCGroupHierarchyRootMount = (Mount -> Bool) -> [Mount] -> Maybe Mount
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"cgroup2") (Text -> Bool) -> (Mount -> Text) -> Mount -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mount -> Text
mountFilesystemType)