cgroup-rts-threads 0.1.0.0 → 0.2.0.0

raw patch · 20 files changed

+747/−444 lines, 20 filesdep +directoryPVP ok

version bump matches the API change (PVP)

Dependencies added: directory

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• README.md +8/−7
• cgroup-rts-threads.cabal +14/−10
• src/Control/Concurrent/CGroup.hs +21/−18
• src/System/CGroup.hs +0/−7
• src/System/CGroup/CPU.hs +0/−75
• src/System/CGroup/Controller.hs +0/−9
• src/System/CGroup/Controller/Internal.hs +0/−239
• src/System/CGroup/Types.hs +175/−0
• src/System/CGroup/V1/CPU.hs +67/−0
• src/System/CGroup/V1/Controller.hs +94/−0
• src/System/CGroup/V2/CGroup.hs +77/−0
• src/System/CGroup/V2/CPU.hs +88/−0
• test/Main.hs +8/−4
• test/System/CGroup/CPUSpec.hs +0/−23
• test/System/CGroup/ControllerSpec.hs +0/−52
• test/System/CGroup/V1/CPUSpec.hs +24/−0
• test/System/CGroup/V1/ControllerSpec.hs +44/−0
• test/System/CGroup/V2/CGroupSpec.hs +38/−0
• test/System/CGroup/V2/CPUSpec.hs +85/−0

@@ -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

@@ -7,7 +7,7 @@  Similar to the RTS `-N` flag, this library considers the number of cpu cores (as reported by `GHC.Conc.getNumProcessors`) to set this number. -Unlike the RTS `-N` flag, this library observes the process' [cgroup cpu quota][cgroup-quota] to constrain the number of runtime threads, as applicable.+Unlike the RTS `-N` flag, this library observes the process' cgroup cpu quota to constrain the number of runtime threads, as applicable.  When running outside of a cgroup, or on a platform other than linux, this library matches the behavior of `-N`. @@ -44,15 +44,16 @@  It's common in containerized environments to limit cpu consumption of individual containers. There are two primary ways of doing this: -1. The `cpuset` option within a cgroup, which can be used to pin a process to specific cpu cores.-2. The `cfs.cpu_quota_us` option within a cgroup, which can be used to set a limit on the cpu time a process is allowed to consume.+1. Configure a cgroup's `cpuset` to pin a process to specific cpu cores.+2. Configure a cgroup's cpu quota ([`cfs` under cgroups v1][cgroup-quota-v1] or [`cpu.max` under cgroups v2][cgroup-quota-v2]) to set a limit on the cpu time a process is allowed to consume. -The GHC threaded RTS offers [a flag, `-N`,][rts-n] that can be used to automatically determine the number of threads to use, based on the number of physical processors.+The GHC threaded RTS offers [a flag, `-N`,][rts-n] that automatically determines the number of threads to use, based on the number of physical processors. -The RTS `-N` flag, [as of GHC `9.0.1`][cpuset-commit], respects the `cpuset` option when automatically determining the number of threads to use.+The RTS `-N` flag, [as of GHC `9.0.1`][cpuset-commit], respects the `cpuset` options when determining the number of threads to use. -Unfortunately, the RTS `-N` flag **does not respect cgroup `cfs` quotas**. This leads to substantially degraded performance when there's a large disparity between a `cfs` quota and the number of physical cpu cores -- a very common scenario in, e.g., production kubernetes clusters.+Unfortunately, the RTS `-N` flag **does not respect cgroup cpu quotas**. This leads to substantially degraded performance when there's a large disparity between a cgroup's cpu quota and the number of physical cpu cores -- a very common scenario in, e.g., production kubernetes clusters.  [cpuset-commit]: https://gitlab.haskell.org/ghc/ghc/-/commit/4413828b7c507872c56719fb8920e1c2322830f8 [rts-n]: https://downloads.haskell.org/~ghc/9.0.1/docs/html/users_guide/using-concurrent.html#rts-options-for-smp-parallelism-[cgroup-quota]: https://www.kernel.org/doc/html/latest/scheduler/sched-bwc.html#management+[cgroup-quota-v1]: https://www.kernel.org/doc/html/latest/scheduler/sched-bwc.html#management+[cgroup-quota-v2]: https://www.kernel.org/doc/html/latest/admin-guide/cgroup-v2.html#cpu-interface-files

@@ -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 @@   -- 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 @@   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

@@ -5,8 +5,11 @@ ) 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 @@ -- -- 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 @@   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)

@@ -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

@@ -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")

@@ -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')

@@ -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

@@ -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)

@@ -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")

@@ -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)

@@ -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)

@@ -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")

@@ -2,8 +2,10 @@   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 @@  tests :: Spec tests = do-  CPUSpec.tests-  ControllerSpec.tests+  V1.CPUSpec.tests+  V1.ControllerSpec.tests+  V2.CGroupSpec.tests+  V2.CPUSpec.tests

@@ -1,23 +0,0 @@-module System.CGroup.CPUSpec (-  tests,-) where--import Control.Monad.IO.Class (liftIO)-import Path.IO (resolveDir')-import System.CGroup.CPU-import System.CGroup.Controller (Controller (..))-import Test.Hspec.Core.Spec (Spec, describe, it)-import Test.Hspec.Expectations (shouldBe)--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"-      quota <- liftIO $ getCPUQuota (Controller controller)-      quota `shouldBe` CPUQuota 1 2--    it "should return NoQuota when there is no quota" $ do-      controller <- resolveDir' "test/System/CGroup/testdata-cpu/noquota"-      quota <- liftIO $ getCPUQuota (Controller controller)-      quota `shouldBe` NoQuota

@@ -1,52 +0,0 @@-module System.CGroup.ControllerSpec (-  tests,-) where--import Control.Monad.IO.Class (liftIO)-import Path-import Path.IO (resolveFile')-import System.CGroup.Controller-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 "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"-      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"-      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"-      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 ()-  | otherwise = act

@@ -0,0 +1,24 @@+module System.CGroup.V1.CPUSpec (+  tests,+) where++import Control.Monad.IO.Class (liftIO)+import Data.Ratio ((%))+import Path.IO (resolveDir')+import System.CGroup.V1.CPU+import System.CGroup.V1.Controller (Controller (..))+import Test.Hspec.Core.Spec (Spec, describe, it)+import Test.Hspec.Expectations (shouldBe)++tests :: Spec+tests = do+  describe "getCPUQuota" $ do+    it "should return CPUQuota when there is a quota" $ do+      controller <- resolveDir' "test/System/CGroup/V1/testdata-cpu/quota"+      quota <- liftIO $ getCPUQuota (Controller controller)+      quota `shouldBe` CPUQuota (1 % 2)++    it "should return NoQuota when there is no quota" $ do+      controller <- resolveDir' "test/System/CGroup/V1/testdata-cpu/noquota"+      quota <- liftIO $ getCPUQuota (Controller controller)+      quota `shouldBe` NoQuota

@@ -0,0 +1,44 @@+module System.CGroup.V1.ControllerSpec (+  tests,+) where++import Control.Monad.IO.Class (liftIO)+import Path+import Path.IO (resolveFile')+import System.CGroup.V1.Controller+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 "resolveGroupController" $ do+    it "should work on a real world example" $ do+      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/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/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++exceptOnWindows :: Applicative f => f () -> f ()+exceptOnWindows act+  | os == "mingw32" = pure ()+  | otherwise = act

@@ -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

@@ -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)