diff --git a/CHANGELOG.md b/CHANGELOG.md index bd9999d..fc92757 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for cgroup-rts-threads +## 0.2.0.0 + +- Adds support for cgroups v2 + ## 0.1.0.0 - Initial release diff --git a/cgroup-rts-threads.cabal b/cgroup-rts-threads.cabal index 31ede4e..6dbabb3 100644 --- a/cgroup-rts-threads.cabal +++ b/cgroup-rts-threads.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: cgroup-rts-threads -version: 0.1.0.0 +version: 0.2.0.0 synopsis: A container-/cgroup-aware substitute for the GHC RTS `-N` flag @@ -40,15 +40,17 @@ library -- cabal-fmt: expand src exposed-modules: Control.Concurrent.CGroup - System.CGroup - System.CGroup.CPU - System.CGroup.Controller - System.CGroup.Controller.Internal + System.CGroup.Types + System.CGroup.V1.CPU + System.CGroup.V1.Controller + System.CGroup.V2.CGroup + System.CGroup.V2.CPU build-depends: - , base >=4.13 && <5 - , megaparsec >=8 && <10 - , path >=0.7 && <0.10 + , base >=4.13 && <5 + , directory ^>=1.3.4.0 + , megaparsec >=8 && <10 + , path >=0.7 && <0.10 , text hs-source-dirs: src @@ -59,8 +61,10 @@ test-suite test hs-source-dirs: test main-is: Main.hs other-modules: - System.CGroup.CPUSpec - System.CGroup.ControllerSpec + System.CGroup.V1.CPUSpec + System.CGroup.V1.ControllerSpec + System.CGroup.V2.CGroupSpec + System.CGroup.V2.CPUSpec build-depends: , base diff --git a/src/Control/Concurrent/CGroup.hs b/src/Control/Concurrent/CGroup.hs index 8dada23..0cf7ee1 100644 --- a/src/Control/Concurrent/CGroup.hs +++ b/src/Control/Concurrent/CGroup.hs @@ -5,8 +5,11 @@ module Control.Concurrent.CGroup ( ) where import Control.Exception (Exception (..), SomeAsyncException (SomeAsyncException), SomeException, catch, throwIO) +import qualified Data.Ratio as Ratio import GHC.Conc (getNumProcessors, setNumCapabilities) -import System.CGroup.CPU (CPUQuota (..), getCPUQuota, resolveCPUController) +import System.CGroup.Types (CPUQuota (..)) +import qualified System.CGroup.V1.CPU as V1 +import qualified System.CGroup.V2.CPU as V2 -- | A container-/cgroup-aware substitute for GHC's RTS @-N@ flag. -- @@ -20,24 +23,20 @@ import System.CGroup.CPU (CPUQuota (..), getCPUQuota, resolveCPUController) -- -- See 'CPUQuota' initRTSThreads :: IO () -initRTSThreads = - initRTSThreadsFromCGroup - `safeCatch` (\(_ :: SomeException) -> defaultInitRTSThreads) +initRTSThreads = do + quota <- + V1.getProcessCPUQuota + `fallback` V2.getProcessEffectiveCPUQuota + `fallback` pure NoQuota + initRTSThreadsFromQuota quota --- | Uses the current process' cgroup cpu quota to set the number of runtime --- threads. --- --- Throws an Exception when the current process is not running within a cgroup. -initRTSThreadsFromCGroup :: IO () -initRTSThreadsFromCGroup = do - cpuController <- resolveCPUController - cgroupCpuQuota <- getCPUQuota cpuController - case cgroupCpuQuota of - NoQuota -> defaultInitRTSThreads - CPUQuota quota period -> do - procs <- getNumProcessors - let capabilities = clamp 1 procs (quota `div` period) - setNumCapabilities capabilities +-- | Use a CPU quota to set the number of runtime threads. +initRTSThreadsFromQuota :: CPUQuota -> IO () +initRTSThreadsFromQuota NoQuota = defaultInitRTSThreads +initRTSThreadsFromQuota (CPUQuota ratio) = do + procs <- getNumProcessors + let capabilities = clamp 1 procs (Ratio.numerator ratio `div` Ratio.denominator ratio) + setNumCapabilities capabilities -- | Set number of runtime threads to the number of available processors. This -- matches the behavior of GHC's RTS @-N@ flag. @@ -57,3 +56,7 @@ isSyncException e = case fromException (toException e) of Just (SomeAsyncException _) -> False Nothing -> True + +-- | Return the result of the first successful action +fallback :: IO a -> IO a -> IO a +fallback a b = a `safeCatch` (\(_ :: SomeException) -> b) diff --git a/src/System/CGroup.hs b/src/System/CGroup.hs deleted file mode 100644 index fe5a1d0..0000000 --- a/src/System/CGroup.hs +++ /dev/null @@ -1,7 +0,0 @@ --- | CGroup controller types and operations (re-exported from System.CGroup.*) -module System.CGroup ( - module X, -) where - -import System.CGroup.CPU as X -import System.CGroup.Controller as X diff --git a/src/System/CGroup/CPU.hs b/src/System/CGroup/CPU.hs deleted file mode 100644 index 8869e50..0000000 --- a/src/System/CGroup/CPU.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | Types and operations for the CPU CGroup controller. -module System.CGroup.CPU ( - -- * The CPU cgroup controller - CPU, - resolveCPUController, - - -- * Operations on the CPU controller - CPUQuota (..), - getCPUQuota, -) where - -import Control.Monad ((<=<)) -import Path -import System.CGroup.Controller (Controller (..), resolveCGroupController) - --- | The "cpu" cgroup controller -data CPU - --- | Resolve the CPU cgroup controller for the current process --- --- Throws an Exception if the CPU controller is not able to be found, or when --- running outside of a cgroup -resolveCPUController :: IO (Controller CPU) -resolveCPUController = resolveCGroupController "cpu" - --- | A CPU quota is the amount of CPU time our process can use relative to the --- scheduler period --- --- For example: --- --- @ --- | cpu.cfs_quota_us | cpu.cfs_period_us | description | --- | ---------------- | ----------------- | ----------- | --- | 100000 | 100000 | (1) | --- | 200000 | 100000 | (2) | --- | 50000 | 100000 | (3) | --- | -1 | 100000 | (4) | --- @ --- --- (1): we can use up to a single CPU core --- --- (2): we can use up to two CPU cores --- --- (3): the scheduler will give us a single CPU core for up to 50% of the time --- --- (4): we can use all available CPU resources (there is no quota) -data CPUQuota - = NoQuota - | -- | cpu.cfs_quota_us, cpu.cfs_period_us - CPUQuota Int Int - deriving (Eq, Ord, Show) - --- | Read a CGroup configuration value from its file -readCGroupInt :: Path b File -> IO Int -readCGroupInt = readIO <=< (readFile . toFilePath) - --- | Get the CPU quota within the given cgroup CPU controller -getCPUQuota :: Controller CPU -> IO CPUQuota -getCPUQuota (Controller root) = do - quota <- readCGroupInt (root cpuQuotaPath) - case quota of - (-1) -> pure NoQuota - _ -> CPUQuota quota <$> readCGroupInt (root cpuPeriodPath) - --- Path to the "cpu quota" file --- --- When this file contains "-1", there is no quota set -cpuQuotaPath :: Path Rel File -cpuQuotaPath = $(mkRelFile "cpu.cfs_quota_us") - --- Path to the "cpu period" file -cpuPeriodPath :: Path Rel File -cpuPeriodPath = $(mkRelFile "cpu.cfs_period_us") diff --git a/src/System/CGroup/Controller.hs b/src/System/CGroup/Controller.hs deleted file mode 100644 index a814bc6..0000000 --- a/src/System/CGroup/Controller.hs +++ /dev/null @@ -1,9 +0,0 @@ --- | Common types and operations for CGroup controllers. -module System.CGroup.Controller ( - -- * CGroup Controllers - Controller (..), - resolveCGroupController, - resolveCGroupController', -) where - -import System.CGroup.Controller.Internal (Controller (..), resolveCGroupController, resolveCGroupController') diff --git a/src/System/CGroup/Controller/Internal.hs b/src/System/CGroup/Controller/Internal.hs deleted file mode 100644 index 6d473e0..0000000 --- a/src/System/CGroup/Controller/Internal.hs +++ /dev/null @@ -1,239 +0,0 @@ --- | Internal types and functions for cgroup controllers -module System.CGroup.Controller.Internal ( - -- * CGroup Controllers - Controller (..), - resolveCGroupController, - resolveCGroupController', - - -- * CGroups - CGroup (..), - - -- * Mounts - Mount (..), - - -- * Internal intermediate operations - findMatchingCGroup, - resolveControllerMountPath, - tryResolveMount, - parseMountInfo, - parseCGroups, - Parser, -) where - -import Control.Exception (throwIO) -import Control.Monad (guard) -import Data.Char (isSpace) -import Data.Foldable (find) -import Data.Maybe (listToMaybe, mapMaybe) -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.IO as TIO -import Data.Void (Void) -import Path -import Text.Megaparsec (Parsec, eof, manyTill, optional, parse, skipMany, some, takeWhile1P, takeWhileP) -import Text.Megaparsec.Char (char) -import qualified Text.Megaparsec.Char.Lexer as L - --- | A CGroup controller path for a specific subsystem -newtype Controller a = Controller {unController :: Path Abs Dir} - deriving (Eq, Ord, Show) - --- | Resolve a CGroup 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 controller = do - cgroupPath <- parseAbsFile "/proc/self/cgroup" - mountinfoPath <- parseAbsFile "/proc/self/mountinfo" - resolveCGroupController' cgroupPath mountinfoPath 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' cgroupPath mountinfoPath controllerName = do - cgroups <- parseFile parseCGroups cgroupPath - mounts <- parseFile parseMountInfo mountinfoPath - cgroup <- maybe (fail "Couldn't find cgroup for controller") pure (findMatchingCGroup controllerName cgroups) - resolved <- maybe (fail "Couldn't find mount for cgroup") pure (resolveControllerMountPath controllerName cgroup mounts) - - pure (Controller resolved) - --- | Parse a file -parseFile :: Parser a -> Path b File -> IO a -parseFile parser file = either throwIO pure . parse parser (toFilePath file) =<< TIO.readFile (toFilePath file) - --- | Find a CGroup matching a controller name --- --- For cgroups version 1, we use @containsController@ to explicitly look for the controller within a cgroup --- --- For cgroups version 2, we use @emptyControllers@ to find a cgroup without any controllers --- --- see cgroups(7): \/proc\/[pid]\/cgroup section -findMatchingCGroup :: Text -> [CGroup] -> Maybe CGroup -findMatchingCGroup controllerName = find (\group -> containsController group || emptyControllers group) - where - containsController :: CGroup -> Bool - containsController = (controllerName `elem`) . controlGroupControllers - - emptyControllers :: CGroup -> Bool - emptyControllers = null . controlGroupControllers - --- | Find a Mount matching a controller name and cgroup, returning the absolute --- resolved path of a controller -resolveControllerMountPath :: Text -> CGroup -> [Mount] -> Maybe (Path Abs Dir) -resolveControllerMountPath controllerName cgroup = firstMaybe (tryResolveMount controllerName cgroup) - -firstMaybe :: (a -> Maybe b) -> [a] -> Maybe b -firstMaybe f = listToMaybe . mapMaybe 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 -> CGroup -> Mount -> Maybe (Path Abs Dir) -tryResolveMount controllerName cgroup mount = do - guard ("cgroup" == mountFilesystemType mount) - guard (controllerName `elem` mountSuperOptions mount) - if controlGroupPath cgroup == mountRoot mount - then Just (mountPoint mount) - else do - rel <- stripProperPrefix (mountRoot mount) (controlGroupPath cgroup) - Just (mountPoint mount rel) - ------ - --- | A cgroup, as viewed within \/proc\/[pid]\/cgroup --- --- see cgroups(7): \/proc\/[pid]\/cgroup section -data CGroup = CGroup - { controlGroupControllers :: [Text] - , controlGroupPath :: Path Abs Dir - } - deriving (Show) - --- | Parse an entire \/proc\/[pid]\/cgroup file into a list of cgroups -parseCGroups :: Parser [CGroup] -parseCGroups = some parseSingleCGroup <* eof - --- | Parse a single cgroup line within \/proc\/[pid]\/cgroup --- --- hierarchyID:list,of,controllers:path --- --- In cgroups version 1, a comma-separated list of controllers exists within each group --- --- In cgroups version 2, the "controllers" section is always an empty string --- --- see cgroups(7): \/proc\/[pid]\/cgroup section -parseSingleCGroup :: Parser CGroup -parseSingleCGroup = - CGroup - <$ takeUntil1P ':' -- ignore hierarchy ID number - <*> (splitOnIgnoreEmpty "," <$> takeUntilP ':') -- comma-separated list of controllers - <*> (parseIntoAbsDir =<< takeUntil1P '\n') -- path - --- return the prefix of the input until reaching the supplied character. --- the character is also consumed as part of this parser. --- --- this parser succeeds even when the character does not exist in the input -takeUntilP :: Char -> Parser Text -takeUntilP c = takeWhileP Nothing (/= c) <* optional (char c) - --- like 'takeUntilP', but expects a non-empty prefix before the character -takeUntil1P :: Char -> Parser Text -takeUntil1P c = takeWhile1P Nothing (/= c) <* optional (char c) - --- Data.Text.splitOn, but returns empty list on empty haystack, rather than [""] --- --- >>> Data.Text.splitOn "foo" "" --- [""] --- --- >>> splitOnIgnoreEmpty "foo" "" --- [] -splitOnIgnoreEmpty :: Text -> Text -> [Text] -splitOnIgnoreEmpty _ "" = [] -splitOnIgnoreEmpty s str = Text.splitOn s str - --------------- - --- | A mount, as viewed within \/proc\/[pid]\/mountinfo --- --- see proc(5): \/proc\/[pid]\/mountinfo section -data Mount = Mount - { mountId :: Text - , mountParentId :: Text - , mountStDev :: Text - , mountRoot :: Path Abs Dir - , mountPoint :: Path Abs Dir - , mountOptions :: Text - , mountTags :: [Text] - , mountFilesystemType :: Text - , mountSource :: Text - , mountSuperOptions :: [Text] - } - deriving (Show) - --- | Parse an entire \/proc\/[pid]\/mountinfo file into a list of mounts -parseMountInfo :: Parser [Mount] -parseMountInfo = some parseSingleMount <* eof - --- | Parse a single mount line within \/proc\/[pid]\/mountinfo --- --- Fields are space-separated --- --- see proc(5): \/proc\/[pid]\/mountinfo section -parseSingleMount :: Parser Mount -parseSingleMount = - Mount - <$> field -- id - <*> field -- parent id - <*> field -- st_dev - <*> (parseIntoAbsDir =<< field) -- mount root - <*> (parseIntoAbsDir =<< field) -- mount point - <*> field -- mount options - <*> field `manyTill` separator -- optional mount tags, terminated by "-" - <*> field -- filesystem type - <*> field -- mount source - <*> (splitOnIgnoreEmpty "," <$> field) -- super options - <* optional (char '\n') - --- | Megaparsec Parser -type Parser = Parsec Void Text - --- a field in the mountinfo file, terminated by whitespace -field :: Parser Text -field = lexeme $ takeWhile1P Nothing (not . isSpace) - --- separator after optional mount tags ("-") -separator :: Parser Char -separator = lexeme $ char '-' - -lexeme :: Parser a -> Parser a -lexeme = L.lexeme (skipMany (char ' ')) - -parseIntoAbsDir :: Text -> Parser (Path Abs Dir) -parseIntoAbsDir = either (fail . show) pure . parseAbsDir . Text.unpack diff --git a/src/System/CGroup/Types.hs b/src/System/CGroup/Types.hs new file mode 100644 index 0000000..dbe27c0 --- /dev/null +++ b/src/System/CGroup/Types.hs @@ -0,0 +1,175 @@ +-- | Parsers and types related to cgroups and mounts +module System.CGroup.Types ( + -- * CPU quotas + CPUQuota (..), + + -- * raw cgroups as viewed in \/proc\/$PID\/cgroup + RawCGroup (..), + parseCGroups, + + -- * mounts as viewed in \/proc\/$PID\/mountinfo + Mount (..), + parseMountInfo, + + -- * Parser type + Parser, + parseFile, +) where + +import Control.Exception (throwIO) +import Data.Char (isSpace) +import Data.Ratio +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as TIO +import Data.Void (Void) +import Path +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L + +---------- CPU quotas + +-- | A CPU quota is the ratio of CPU time our process can use relative to the +-- scheduler period +-- +-- For example: +-- +-- @ +-- | ratio | description | +-- | ---------------- | ----------- | +-- | 100000 / 100000 | (1) | +-- | 200000 / 100000 | (2) | +-- | 50000 / 100000 | (3) | +-- | max / 100000 | (4) | +-- @ +-- +-- (1): we can use up to a single CPU core +-- +-- (2): we can use up to two CPU cores +-- +-- (3): the scheduler will give us a single CPU core for up to 50% of the time +-- +-- (4): we can use all available CPU resources (there is no quota) +data CPUQuota + = CPUQuota (Ratio Int) + | NoQuota + deriving (Eq, Ord, Show) + +---------- Raw cgroups + +-- | A cgroup, as viewed within \/proc\/[pid]\/cgroup +-- +-- see cgroups(7): \/proc\/[pid]\/cgroup section +data RawCGroup = RawCGroup + { rawCGroupId :: Text + , rawCGroupControllers :: [Text] + , rawCGroupPath :: Path Abs Dir + } + deriving (Show) + +-- | Parse an entire \/proc\/[pid]\/cgroup file into a list of cgroups +parseCGroups :: Parser [RawCGroup] +parseCGroups = some parseSingleCGroup <* eof + +-- | Parse a single cgroup line within \/proc\/[pid]\/cgroup +-- +-- hierarchyID:list,of,controllers:path +-- +-- In cgroups version 1, a comma-separated list of controllers exists within each group +-- +-- In cgroups version 2, the "controllers" section is always an empty string +-- +-- see cgroups(7): \/proc\/[pid]\/cgroup section +parseSingleCGroup :: Parser RawCGroup +parseSingleCGroup = + RawCGroup + <$> takeUntil1P ':' -- hierarchy ID number + <*> (splitOnIgnoreEmpty "," <$> takeUntilP ':') -- comma-separated list of controllers + <*> (parseIntoAbsDir =<< takeUntil1P '\n') -- path + +-- return the prefix of the input until reaching the supplied character. +-- the character is also consumed as part of this parser. +-- +-- this parser succeeds even when the character does not exist in the input +takeUntilP :: Char -> Parser Text +takeUntilP c = takeWhileP Nothing (/= c) <* optional (char c) + +-- like 'takeUntilP', but expects a non-empty prefix before the character +takeUntil1P :: Char -> Parser Text +takeUntil1P c = takeWhile1P Nothing (/= c) <* optional (char c) + +-- Data.Text.splitOn, but returns empty list on empty haystack, rather than [""] +-- +-- >>> Data.Text.splitOn "foo" "" +-- [""] +-- +-- >>> splitOnIgnoreEmpty "foo" "" +-- [] +splitOnIgnoreEmpty :: Text -> Text -> [Text] +splitOnIgnoreEmpty _ "" = [] +splitOnIgnoreEmpty s str = Text.splitOn s str + +---------- Mounts + +-- | A mount, as viewed within \/proc\/[pid]\/mountinfo +-- +-- see proc(5): \/proc\/[pid]\/mountinfo section +data Mount = Mount + { mountId :: Text + , mountParentId :: Text + , mountStDev :: Text + , mountRoot :: Text + , mountPoint :: Text + , mountOptions :: Text + , mountTags :: [Text] + , mountFilesystemType :: Text + , mountSource :: Text + , mountSuperOptions :: [Text] + } + deriving (Show) + +-- | Parse an entire \/proc\/[pid]\/mountinfo file into a list of mounts +parseMountInfo :: Parser [Mount] +parseMountInfo = some parseSingleMount <* eof + +-- | Parse a single mount line within \/proc\/[pid]\/mountinfo +-- +-- Fields are space-separated +-- +-- see proc(5): \/proc\/[pid]\/mountinfo section +parseSingleMount :: Parser Mount +parseSingleMount = + Mount + <$> field -- id + <*> field -- parent id + <*> field -- st_dev + <*> field -- mount root + <*> field -- mount point + <*> field -- mount options + <*> field `manyTill` separator -- optional mount tags, terminated by "-" + <*> field -- filesystem type + <*> field -- mount source + <*> (splitOnIgnoreEmpty "," <$> field) -- super options + <* optional (char '\n') + +-- a field in the mountinfo file, terminated by whitespace +field :: Parser Text +field = lexeme $ takeWhile1P Nothing (not . isSpace) + +-- separator after optional mount tags ("-") +separator :: Parser Char +separator = lexeme $ char '-' + +lexeme :: Parser a -> Parser a +lexeme = L.lexeme (skipMany (char ' ')) + +parseIntoAbsDir :: Text -> Parser (Path Abs Dir) +parseIntoAbsDir = either (fail . show) pure . parseAbsDir . Text.unpack + +-- | Megaparsec Parser +type Parser = Parsec Void Text + +-- | Parse a file +parseFile :: Parser a -> Path b File -> IO a +parseFile parser file = either throwIO pure . parse parser (toFilePath file) =<< TIO.readFile (toFilePath file) diff --git a/src/System/CGroup/V1/CPU.hs b/src/System/CGroup/V1/CPU.hs new file mode 100644 index 0000000..fca4449 --- /dev/null +++ b/src/System/CGroup/V1/CPU.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Types and operations for the CPU cgroup controller. +module System.CGroup.V1.CPU ( + -- * Operations on the CPU controller + getProcessCPUQuota, + getCPUQuota, + CPUQuota (..), + + -- * The CPU cgroup controller + CPU, + resolveCPUController, +) where + +import Control.Monad ((<=<)) +import Data.Ratio ((%)) +import Path +import System.CGroup.Types (CPUQuota (..)) +import System.CGroup.V1.Controller (Controller (..), resolveCGroupController) + +-- | The "cpu" cgroup controller +data CPU + +-- | Resolve the CPU cgroup controller for the current process +-- +-- Throws an Exception if the CPU controller is not able to be found, or when +-- running outside of a cgroup +resolveCPUController :: IO (Controller CPU) +resolveCPUController = resolveCGroupController "cpu" + +-- | Get the current process' CPU quota +getProcessCPUQuota :: IO CPUQuota +getProcessCPUQuota = getCPUQuota =<< resolveCPUController + +-- | Read "cpu.cfs_quota_us" and "cpu.cfs_period_us" files into a CPUQuota. +-- +-- For example: +-- +-- @ +-- | cpu.cfs_quota_us | cpu.cfs_period_us | CPUQuota | +-- | ---------------- | ----------------- | ---------------- | +-- | 100000 | 100000 | CPUQuota (1 % 1) | +-- | 200000 | 100000 | CPUQuota (2 % 1) | +-- | 50000 | 100000 | CPUQuota (1 % 2) | +-- | -1 | 100000 | NoQuota | +-- @ +getCPUQuota :: Controller CPU -> IO CPUQuota +getCPUQuota (Controller root) = do + quota <- readCGroupInt (root cpuQuotaPath) + period <- readCGroupInt (root cpuPeriodPath) + case quota of + (-1) -> pure NoQuota + _ -> pure (CPUQuota (quota % period)) + +-- | Read a cgroup configuration value from its file +readCGroupInt :: Path b File -> IO Int +readCGroupInt = readIO <=< (readFile . toFilePath) + +-- | Path to the "cpu quota" file +-- +-- When this file contains "-1", there is no quota set +cpuQuotaPath :: Path Rel File +cpuQuotaPath = $(mkRelFile "cpu.cfs_quota_us") + +-- | Path to the "cpu period" file +cpuPeriodPath :: Path Rel File +cpuPeriodPath = $(mkRelFile "cpu.cfs_period_us") diff --git a/src/System/CGroup/V1/Controller.hs b/src/System/CGroup/V1/Controller.hs new file mode 100644 index 0000000..7451dc0 --- /dev/null +++ b/src/System/CGroup/V1/Controller.hs @@ -0,0 +1,94 @@ +-- | 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 {unController :: Path Abs Dir} + deriving (Eq, Ord, 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 controller = do + cgroupPath <- parseAbsFile "/proc/self/cgroup" + mountinfoPath <- parseAbsFile "/proc/self/mountinfo" + resolveCGroupController' cgroupPath mountinfoPath 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' cgroupPath mountinfoPath controllerName = do + cgroups <- parseFile parseCGroups cgroupPath + mounts <- parseFile parseMountInfo mountinfoPath + cgroup <- maybe (fail "Couldn't find cgroup for controller") pure (findMatchingCGroup controllerName cgroups) + resolved <- maybe (fail "Couldn't find mount for cgroup") pure (resolveControllerMountPath controllerName cgroup mounts) + pure (Controller resolved) + +-- | Find a cgroup for a specific controller (cgroups v1) +findMatchingCGroup :: Text -> [RawCGroup] -> Maybe RawCGroup +findMatchingCGroup controllerName = find containsController + where + containsController :: RawCGroup -> Bool + containsController = (controllerName `elem`) . 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 controllerName cgroup = firstMaybe (tryResolveMount controllerName cgroup) + +firstMaybe :: (a -> Maybe b) -> [a] -> Maybe b +firstMaybe f = listToMaybe . mapMaybe 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 controllerName cgroup mount = do + guard ("cgroup" == mountFilesystemType mount) + guard (controllerName `elem` mountSuperOptions mount) + mountRootAsPath <- parseAbsDir (Text.unpack (mountRoot mount)) + mountPointAsPath <- parseAbsDir (Text.unpack (mountPoint mount)) + if rawCGroupPath cgroup == mountRootAsPath + then Just mountPointAsPath + else do + rel <- stripProperPrefix mountRootAsPath (rawCGroupPath cgroup) + Just (mountPointAsPath rel) diff --git a/src/System/CGroup/V2/CGroup.hs b/src/System/CGroup/V2/CGroup.hs new file mode 100644 index 0000000..19418f5 --- /dev/null +++ b/src/System/CGroup/V2/CGroup.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Common types and operations for cgroups (v2) +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) + +-- | A cgroup (under cgroups v2) +data CGroup = CGroup + { -- | The root of the cgroup hierarchy + cgroupRoot :: Path Abs Dir + , -- | A specific cgroup's relative path from the cgroup hierarchy root + cgroupLeaf :: Path Rel Dir + } + deriving (Eq, Ord, Show) + +-- | Resolve the cgroup (v2) used for 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 cgroup is unable to be found, or when the +-- current process is not running under cgroups v2 +resolveCGroup :: IO CGroup +resolveCGroup = do + cgroupPath <- parseAbsFile "/proc/self/cgroup" + mountinfoPath <- parseAbsFile "/proc/self/mountinfo" + resolveCGroup' cgroupPath mountinfoPath + +-- | Resolve a cgroup (v2) from the given cgroup and mountinfo files +-- +-- Throws an Exception when the cgroup is unable to be found, or when the +-- provided paths do not construct a valid cgroup +resolveCGroup' :: Path Abs File -> Path Abs File -> IO CGroup +resolveCGroup' cgroupPath mountinfoPath = do + cgroups <- parseFile parseCGroups cgroupPath + case cgroups of + -- expect to find a cgroup with hierarchy ID 0 and an empty list of controllers + [RawCGroup "0" [] cgroupLeafAbs] -> do + mounts <- parseFile parseMountInfo mountinfoPath + cgroupRootMount <- maybe (fail "Couldn't find cgroup hierarchy root mount") pure (findCGroupHierarchyRootMount mounts) + mountPointAsPath <- parseAbsDir (Text.unpack (mountPoint cgroupRootMount)) + + case fromAbsDir cgroupLeafAbs of + "/" -> + pure + ( CGroup + { cgroupRoot = mountPointAsPath + , cgroupLeaf = $(mkRelDir ".") + } + ) + _ -> do + -- Drop the leading '/' from the cgroup path + cgroupLeafRel <- parseRelDir (drop 1 (fromAbsDir cgroupLeafAbs)) + pure + ( CGroup + { cgroupRoot = mountPointAsPath + , cgroupLeaf = cgroupLeafRel + } + ) + _ -> fail ("Found incompatible cgroups: " <> show cgroups) + +-- | Find the cgroups v2 hierarchy root. +-- +-- We expect to find a mount with the filesystem type "cgroup2" +findCGroupHierarchyRootMount :: [Mount] -> Maybe Mount +findCGroupHierarchyRootMount = find ((== "cgroup2") . mountFilesystemType) diff --git a/src/System/CGroup/V2/CPU.hs b/src/System/CGroup/V2/CPU.hs new file mode 100644 index 0000000..472c00b --- /dev/null +++ b/src/System/CGroup/V2/CPU.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Types and operations for CPU-related data within a cgroup. +module System.CGroup.V2.CPU ( + getProcessEffectiveCPUQuota, + getEffectiveCPUQuota, + getCPUQuota, + CPUQuota (..), +) where + +import Data.Ratio +import Path +import System.CGroup.Types (CPUQuota (..)) +import System.CGroup.V2.CGroup +import System.Directory (doesFileExist) + +-- | Get the current process' effective CPU quota +-- +-- See 'getEffectiveCPUQuota' +getProcessEffectiveCPUQuota :: IO CPUQuota +getProcessEffectiveCPUQuota = getEffectiveCPUQuota =<< resolveCGroup + +-- | Compute the "effective CPU quota" fr a cgroup, which may be smaller than +-- the given cgroup's individual quota. +-- +-- When a parent (or grandparent, etc) of this cgroup has a lower cpu quota, +-- the lower quota is returned instead. +getEffectiveCPUQuota :: CGroup -> IO CPUQuota +getEffectiveCPUQuota cgroup = do + quotas <- cpuQuotasUntilRoot cgroup + pure (foldr min NoQuota quotas) + +-- | Read this specific cgroup's "cpu.max" file into a CPUQuota. +-- +-- For example: +-- +-- @ +-- | cpu.max | quota | +-- | -------------- | ---------------- | +-- | 100000 100000 | CPUQuota (1 % 1) | +-- | 200000 100000 | CPUQuota (2 % 1) | +-- | 50000 100000 | CPUQuota (1 % 2) | +-- | max 100000 | NoQuota | +-- @ +-- +-- +-- Returns NoQuota for the root cgroup, or when the cpu controller is not enabled in this cgroup. +-- +-- __Most often, you'll want to use 'getEffectiveCPUQuota' instead.__ +getCPUQuota :: CGroup -> IO CPUQuota +getCPUQuota cgroup = do + let path = cgroupRoot cgroup cgroupLeaf cgroup cpuMaxPath + exists <- doesFileExist (toFilePath path) + if not exists + then pure NoQuota + else do + content <- readFile (toFilePath path) + case words content of + ["max", _] -> pure NoQuota + [numText, denText] -> do + num <- readIO numText + den <- readIO denText + pure (CPUQuota (num % den)) + _ -> fail "Couldn't parse cpu.max" + +-- | Get the parent cgroup. Returns Nothing when the provided cgroup is the root +-- cgroup. +getParentCGroup :: CGroup -> Maybe CGroup +getParentCGroup cgroup = + if cgroupLeaf cgroup == parent (cgroupLeaf cgroup) + then Nothing + else Just cgroup{cgroupLeaf = parent (cgroupLeaf cgroup)} + +-- | Return all CPU quotas from all parent cgroups +cpuQuotasUntilRoot :: CGroup -> IO [CPUQuota] +cpuQuotasUntilRoot = traverse getCPUQuota . cgroupsUntilRoot + +-- | Return the list of cgroups up to but excluding the root cgroup +cgroupsUntilRoot :: CGroup -> [CGroup] +cgroupsUntilRoot = iterateMaybe getParentCGroup + +-- | like 'iterate', but terminated when @Nothing@ is returned by the provided +-- function +iterateMaybe :: (a -> Maybe a) -> a -> [a] +iterateMaybe f x = x : maybe [] (iterateMaybe f) (f x) + +cpuMaxPath :: Path Rel File +cpuMaxPath = $(mkRelFile "cpu.max") diff --git a/test/Main.hs b/test/Main.hs index 3ecb882..24b143e 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -2,8 +2,10 @@ module Main ( main, ) where -import qualified System.CGroup.CPUSpec as CPUSpec -import qualified System.CGroup.ControllerSpec as ControllerSpec +import qualified System.CGroup.V1.CPUSpec as V1.CPUSpec +import qualified System.CGroup.V1.ControllerSpec as V1.ControllerSpec +import qualified System.CGroup.V2.CGroupSpec as V2.CGroupSpec +import qualified System.CGroup.V2.CPUSpec as V2.CPUSpec import Test.Hspec.Core.Runner (hspec) import Test.Hspec.Core.Spec (Spec) @@ -12,5 +14,7 @@ main = hspec tests tests :: Spec tests = do - CPUSpec.tests - ControllerSpec.tests + V1.CPUSpec.tests + V1.ControllerSpec.tests + V2.CGroupSpec.tests + V2.CPUSpec.tests diff --git a/test/System/CGroup/CPUSpec.hs b/test/System/CGroup/V1/CPUSpec.hs similarity index 60% rename from test/System/CGroup/CPUSpec.hs rename to test/System/CGroup/V1/CPUSpec.hs index 4690149..a361884 100644 --- a/test/System/CGroup/CPUSpec.hs +++ b/test/System/CGroup/V1/CPUSpec.hs @@ -1,11 +1,12 @@ -module System.CGroup.CPUSpec ( +module System.CGroup.V1.CPUSpec ( tests, ) where import Control.Monad.IO.Class (liftIO) +import Data.Ratio ((%)) import Path.IO (resolveDir') -import System.CGroup.CPU -import System.CGroup.Controller (Controller (..)) +import System.CGroup.V1.CPU +import System.CGroup.V1.Controller (Controller (..)) import Test.Hspec.Core.Spec (Spec, describe, it) import Test.Hspec.Expectations (shouldBe) @@ -13,11 +14,11 @@ tests :: Spec tests = do describe "getCPUQuota" $ do it "should return CPUQuota when there is a quota" $ do - controller <- resolveDir' "test/System/CGroup/testdata-cpu/quota" + controller <- resolveDir' "test/System/CGroup/V1/testdata-cpu/quota" quota <- liftIO $ getCPUQuota (Controller controller) - quota `shouldBe` CPUQuota 1 2 + quota `shouldBe` CPUQuota (1 % 2) it "should return NoQuota when there is no quota" $ do - controller <- resolveDir' "test/System/CGroup/testdata-cpu/noquota" + controller <- resolveDir' "test/System/CGroup/V1/testdata-cpu/noquota" quota <- liftIO $ getCPUQuota (Controller controller) quota `shouldBe` NoQuota diff --git a/test/System/CGroup/ControllerSpec.hs b/test/System/CGroup/V1/ControllerSpec.hs similarity index 54% rename from test/System/CGroup/ControllerSpec.hs rename to test/System/CGroup/V1/ControllerSpec.hs index f09e3bf..40c7d21 100644 --- a/test/System/CGroup/ControllerSpec.hs +++ b/test/System/CGroup/V1/ControllerSpec.hs @@ -1,11 +1,11 @@ -module System.CGroup.ControllerSpec ( +module System.CGroup.V1.ControllerSpec ( tests, ) where import Control.Monad.IO.Class (liftIO) import Path import Path.IO (resolveFile') -import System.CGroup.Controller +import System.CGroup.V1.Controller import System.Info (os) import Test.Hspec.Core.Spec (Spec, describe, it) import Test.Hspec.Expectations (shouldBe) @@ -15,37 +15,29 @@ tests :: Spec tests = exceptOnWindows $ do describe "resolveGroupController" $ do it "should work on a real world example" $ do - cgroup <- resolveFile' "test/System/CGroup/testdata-controller/realworld/cgroup" - mountinfo <- resolveFile' "test/System/CGroup/testdata-controller/realworld/mountinfo" + cgroup <- resolveFile' "test/System/CGroup/V1/testdata-controller/realworld/cgroup" + mountinfo <- resolveFile' "test/System/CGroup/V1/testdata-controller/realworld/mountinfo" expected <- parseAbsDir "/sys/fs/cgroup/cpu" controller <- liftIO $ resolveCGroupController' cgroup mountinfo "cpu" controller `shouldBe` Controller expected it "should resolve a direct mount root" $ do - cgroup <- resolveFile' "test/System/CGroup/testdata-controller/direct/cgroup" - mountinfo <- resolveFile' "test/System/CGroup/testdata-controller/direct/mountinfo" + cgroup <- resolveFile' "test/System/CGroup/V1/testdata-controller/direct/cgroup" + mountinfo <- resolveFile' "test/System/CGroup/V1/testdata-controller/direct/mountinfo" expected <- parseAbsDir "/sys/fs/cgroup/cpu" controller <- liftIO $ resolveCGroupController' cgroup mountinfo "cpu" controller `shouldBe` Controller expected it "should resolve subdirectories of a mount root" $ do - cgroup <- resolveFile' "test/System/CGroup/testdata-controller/indirect/cgroup" - mountinfo <- resolveFile' "test/System/CGroup/testdata-controller/indirect/mountinfo" + cgroup <- resolveFile' "test/System/CGroup/V1/testdata-controller/indirect/cgroup" + mountinfo <- resolveFile' "test/System/CGroup/V1/testdata-controller/indirect/mountinfo" expected <- parseAbsDir "/sys/fs/cgroup/cpu/subdir" controller <- liftIO $ resolveCGroupController' cgroup mountinfo "cpu" controller `shouldBe` Controller expected - it "should work for cgroups v2" $ do - cgroup <- resolveFile' "test/System/CGroup/testdata-controller/cgroupsv2/cgroup" - mountinfo <- resolveFile' "test/System/CGroup/testdata-controller/cgroupsv2/mountinfo" - expected <- parseAbsDir "/sys/fs/cgroup/cpu" - - controller <- liftIO $ resolveCGroupController' cgroup mountinfo "cpu" - controller `shouldBe` Controller expected - exceptOnWindows :: Applicative f => f () -> f () exceptOnWindows act | os == "mingw32" = pure () diff --git a/test/System/CGroup/testdata-controller/direct/cgroup b/test/System/CGroup/V1/testdata-controller/direct/cgroup similarity index 100% rename from test/System/CGroup/testdata-controller/direct/cgroup rename to test/System/CGroup/V1/testdata-controller/direct/cgroup diff --git a/test/System/CGroup/testdata-controller/cgroupsv2/mountinfo b/test/System/CGroup/V1/testdata-controller/direct/mountinfo similarity index 100% rename from test/System/CGroup/testdata-controller/cgroupsv2/mountinfo rename to test/System/CGroup/V1/testdata-controller/direct/mountinfo diff --git a/test/System/CGroup/testdata-controller/indirect/cgroup b/test/System/CGroup/V1/testdata-controller/indirect/cgroup similarity index 100% rename from test/System/CGroup/testdata-controller/indirect/cgroup rename to test/System/CGroup/V1/testdata-controller/indirect/cgroup diff --git a/test/System/CGroup/testdata-controller/direct/mountinfo b/test/System/CGroup/V1/testdata-controller/indirect/mountinfo similarity index 100% rename from test/System/CGroup/testdata-controller/direct/mountinfo rename to test/System/CGroup/V1/testdata-controller/indirect/mountinfo diff --git a/test/System/CGroup/testdata-controller/realworld/cgroup b/test/System/CGroup/V1/testdata-controller/realworld/cgroup similarity index 100% rename from test/System/CGroup/testdata-controller/realworld/cgroup rename to test/System/CGroup/V1/testdata-controller/realworld/cgroup diff --git a/test/System/CGroup/testdata-controller/realworld/mountinfo b/test/System/CGroup/V1/testdata-controller/realworld/mountinfo similarity index 100% rename from test/System/CGroup/testdata-controller/realworld/mountinfo rename to test/System/CGroup/V1/testdata-controller/realworld/mountinfo diff --git a/test/System/CGroup/testdata-cpu/noquota/cpu.cfs_period_us b/test/System/CGroup/V1/testdata-cpu/noquota/cpu.cfs_period_us similarity index 100% rename from test/System/CGroup/testdata-cpu/noquota/cpu.cfs_period_us rename to test/System/CGroup/V1/testdata-cpu/noquota/cpu.cfs_period_us diff --git a/test/System/CGroup/testdata-cpu/noquota/cpu.cfs_quota_us b/test/System/CGroup/V1/testdata-cpu/noquota/cpu.cfs_quota_us similarity index 100% rename from test/System/CGroup/testdata-cpu/noquota/cpu.cfs_quota_us rename to test/System/CGroup/V1/testdata-cpu/noquota/cpu.cfs_quota_us diff --git a/test/System/CGroup/testdata-cpu/quota/cpu.cfs_period_us b/test/System/CGroup/V1/testdata-cpu/quota/cpu.cfs_period_us similarity index 100% rename from test/System/CGroup/testdata-cpu/quota/cpu.cfs_period_us rename to test/System/CGroup/V1/testdata-cpu/quota/cpu.cfs_period_us diff --git a/test/System/CGroup/testdata-cpu/quota/cpu.cfs_quota_us b/test/System/CGroup/V1/testdata-cpu/quota/cpu.cfs_quota_us similarity index 100% rename from test/System/CGroup/testdata-cpu/quota/cpu.cfs_quota_us rename to test/System/CGroup/V1/testdata-cpu/quota/cpu.cfs_quota_us diff --git a/test/System/CGroup/V2/CGroupSpec.hs b/test/System/CGroup/V2/CGroupSpec.hs new file mode 100644 index 0000000..8ad9518 --- /dev/null +++ b/test/System/CGroup/V2/CGroupSpec.hs @@ -0,0 +1,38 @@ +module System.CGroup.V2.CGroupSpec ( + tests, +) where + +import Control.Monad.IO.Class (liftIO) +import Path +import Path.IO (resolveFile') +import System.CGroup.V2.CGroup +import System.Info (os) +import Test.Hspec.Core.Spec (Spec, describe, it) +import Test.Hspec.Expectations (shouldBe) + +-- This test won't work on Windows, because paths starting with `/` are invalid +tests :: Spec +tests = exceptOnWindows $ do + describe "resolveCGroup" $ do + it "should resolve a root cgroup" $ do + cgroup <- resolveFile' "test/System/CGroup/V2/testdata-cgroup/root/cgroup" + mountinfo <- resolveFile' "test/System/CGroup/V2/testdata-cgroup/root/mountinfo" + expectedRoot <- parseAbsDir "/sys/fs/cgroup" + expectedLeaf <- parseRelDir "." + + result <- liftIO $ resolveCGroup' cgroup mountinfo + result `shouldBe` CGroup{cgroupRoot = expectedRoot, cgroupLeaf = expectedLeaf} + + it "should resolve a nested cgroup" $ do + cgroup <- resolveFile' "test/System/CGroup/V2/testdata-cgroup/nested/cgroup" + mountinfo <- resolveFile' "test/System/CGroup/V2/testdata-cgroup/nested/mountinfo" + expectedRoot <- parseAbsDir "/sys/fs/cgroup" + expectedLeaf <- parseRelDir "some/nested/cgroup" + + result <- liftIO $ resolveCGroup' cgroup mountinfo + result `shouldBe` CGroup{cgroupRoot = expectedRoot, cgroupLeaf = expectedLeaf} + +exceptOnWindows :: Applicative f => f () -> f () +exceptOnWindows act + | os == "mingw32" = pure () + | otherwise = act diff --git a/test/System/CGroup/V2/CPUSpec.hs b/test/System/CGroup/V2/CPUSpec.hs new file mode 100644 index 0000000..d2d42d2 --- /dev/null +++ b/test/System/CGroup/V2/CPUSpec.hs @@ -0,0 +1,85 @@ +module System.CGroup.V2.CPUSpec ( + tests, +) where + +import Control.Monad.IO.Class (liftIO) +import Data.Ratio ((%)) +import Path +import Path.IO (resolveDir') +import System.CGroup.V2.CGroup +import System.CGroup.V2.CPU +import Test.Hspec.Core.Spec (Spec, describe, it) +import Test.Hspec.Expectations (shouldBe) + +tests :: Spec +tests = do + describe "getEffectiveCPUQuota" $ do + it "should return NoQuota for the root cgroup" $ do + root <- resolveDir' "test/System/CGroup/V2/testdata-cpu" + leaf <- parseRelDir "." + let cgroup = + CGroup + { cgroupRoot = root + , cgroupLeaf = leaf + } + quota <- liftIO $ getEffectiveCPUQuota cgroup + quota `shouldBe` NoQuota + + it "should return NoQuota when there is no quota" $ do + root <- resolveDir' "test/System/CGroup/V2/testdata-cpu" + leaf <- parseRelDir "max" + let cgroup = + CGroup + { cgroupRoot = root + , cgroupLeaf = leaf + } + + single <- liftIO $ getCPUQuota cgroup + single `shouldBe` NoQuota + + effective <- liftIO $ getEffectiveCPUQuota cgroup + effective `shouldBe` NoQuota + + it "should return a simple quota" $ do + root <- resolveDir' "test/System/CGroup/V2/testdata-cpu" + leaf <- parseRelDir "limited" + let cgroup = + CGroup + { cgroupRoot = root + , cgroupLeaf = leaf + } + + single <- liftIO $ getCPUQuota cgroup + single `shouldBe` CPUQuota (1 % 5) + + effective <- liftIO $ getEffectiveCPUQuota cgroup + effective `shouldBe` CPUQuota (1 % 5) + + it "should defer to parent quotas when there is no quota" $ do + root <- resolveDir' "test/System/CGroup/V2/testdata-cpu" + leaf <- parseRelDir "limited/unlimited" + let cgroup = + CGroup + { cgroupRoot = root + , cgroupLeaf = leaf + } + + single <- liftIO $ getCPUQuota cgroup + single `shouldBe` NoQuota + + effective <- liftIO $ getEffectiveCPUQuota cgroup + effective `shouldBe` CPUQuota (1 % 5) + + it "should respect parent cgroup quotas" $ do + root <- resolveDir' "test/System/CGroup/V2/testdata-cpu" + leaf <- parseRelDir "limited/bigger" + let cgroup = + CGroup + { cgroupRoot = root + , cgroupLeaf = leaf + } + single <- liftIO $ getCPUQuota cgroup + single `shouldBe` CPUQuota (4 % 5) + + effective <- liftIO $ getEffectiveCPUQuota cgroup + effective `shouldBe` CPUQuota (1 % 5) diff --git a/test/System/CGroup/V2/testdata-cgroup/nested/cgroup b/test/System/CGroup/V2/testdata-cgroup/nested/cgroup new file mode 100644 index 0000000..4301d41 --- /dev/null +++ b/test/System/CGroup/V2/testdata-cgroup/nested/cgroup @@ -0,0 +1 @@ +0::/some/nested/cgroup diff --git a/test/System/CGroup/V2/testdata-cgroup/nested/mountinfo b/test/System/CGroup/V2/testdata-cgroup/nested/mountinfo new file mode 100644 index 0000000..2987451 --- /dev/null +++ b/test/System/CGroup/V2/testdata-cgroup/nested/mountinfo @@ -0,0 +1 @@ +32 23 0:27 / /sys/fs/cgroup rw,nosuid,nodev,noexec,relatime shared:9 - cgroup2 cgroup2 rw,nsdelegate,memory_recursiveprot diff --git a/test/System/CGroup/V2/testdata-cgroup/root/cgroup b/test/System/CGroup/V2/testdata-cgroup/root/cgroup new file mode 100644 index 0000000..1e027b2 --- /dev/null +++ b/test/System/CGroup/V2/testdata-cgroup/root/cgroup @@ -0,0 +1 @@ +0::/ diff --git a/test/System/CGroup/V2/testdata-cgroup/root/mountinfo b/test/System/CGroup/V2/testdata-cgroup/root/mountinfo new file mode 100644 index 0000000..2987451 --- /dev/null +++ b/test/System/CGroup/V2/testdata-cgroup/root/mountinfo @@ -0,0 +1 @@ +32 23 0:27 / /sys/fs/cgroup rw,nosuid,nodev,noexec,relatime shared:9 - cgroup2 cgroup2 rw,nsdelegate,memory_recursiveprot diff --git a/test/System/CGroup/V2/testdata-cpu/limited/bigger/cpu.max b/test/System/CGroup/V2/testdata-cpu/limited/bigger/cpu.max new file mode 100644 index 0000000..8782968 --- /dev/null +++ b/test/System/CGroup/V2/testdata-cpu/limited/bigger/cpu.max @@ -0,0 +1 @@ +80000 100000 diff --git a/test/System/CGroup/V2/testdata-cpu/limited/cpu.max b/test/System/CGroup/V2/testdata-cpu/limited/cpu.max new file mode 100644 index 0000000..1bfb45a --- /dev/null +++ b/test/System/CGroup/V2/testdata-cpu/limited/cpu.max @@ -0,0 +1 @@ +2000 10000 diff --git a/test/System/CGroup/V2/testdata-cpu/limited/unlimited/cpu.max b/test/System/CGroup/V2/testdata-cpu/limited/unlimited/cpu.max new file mode 100644 index 0000000..5721cc4 --- /dev/null +++ b/test/System/CGroup/V2/testdata-cpu/limited/unlimited/cpu.max @@ -0,0 +1 @@ +max 2000 diff --git a/test/System/CGroup/V2/testdata-cpu/max/cpu.max b/test/System/CGroup/V2/testdata-cpu/max/cpu.max new file mode 100644 index 0000000..1c1d3e7 --- /dev/null +++ b/test/System/CGroup/V2/testdata-cpu/max/cpu.max @@ -0,0 +1 @@ +max 100000 diff --git a/test/System/CGroup/testdata-controller/cgroupsv2/cgroup b/test/System/CGroup/testdata-controller/cgroupsv2/cgroup deleted file mode 100644 index 437ec46..0000000 --- a/test/System/CGroup/testdata-controller/cgroupsv2/cgroup +++ /dev/null @@ -1 +0,0 @@ -0::/docker/9a727716c6193036fa661c0bbe254354036e130905cbbd6c69568b26df684b1d diff --git a/test/System/CGroup/testdata-controller/indirect/mountinfo b/test/System/CGroup/testdata-controller/indirect/mountinfo deleted file mode 100644 index f94cebe..0000000 --- a/test/System/CGroup/testdata-controller/indirect/mountinfo +++ /dev/null @@ -1 +0,0 @@ -630 628 0:31 /docker/9a727716c6193036fa661c0bbe254354036e130905cbbd6c69568b26df684b1d /sys/fs/cgroup/cpu ro,nosuid,nodev,noexec,relatime master:19 - cgroup cpu rw,cpu