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

-- | 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 :: Text -> IO (Controller a)
resolveCGroupController Text
controller = do
  Path Abs File
cgroupPath <- String -> IO (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile String
"/proc/self/cgroup"
  Path Abs File
mountinfoPath <- String -> IO (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile String
"/proc/self/mountinfo"
  Path Abs File -> Path Abs File -> Text -> IO (Controller a)
forall a.
Path Abs File -> Path Abs File -> Text -> IO (Controller a)
resolveCGroupController' Path Abs File
cgroupPath Path Abs File
mountinfoPath Text
controller

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

  Controller a -> IO (Controller a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir -> Controller a
forall a. Path Abs Dir -> Controller a
Controller Path Abs Dir
resolved)

-- | Parse a file
parseFile :: Parser a -> Path b File -> IO a
parseFile :: Parser a -> Path b File -> IO a
parseFile Parser a
parser Path b File
file = (ParseErrorBundle Text Void -> IO a)
-> (a -> IO a) -> Either (ParseErrorBundle Text Void) a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseErrorBundle Text Void -> IO a
forall e a. Exception e => e -> IO a
throwIO a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ParseErrorBundle Text Void) a -> IO a)
-> (Text -> Either (ParseErrorBundle Text Void) a) -> Text -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a -> String -> Text -> Either (ParseErrorBundle Text Void) a
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parser a
parser (Path b File -> String
forall b t. Path b t -> String
toFilePath Path b File
file) (Text -> IO a) -> IO Text -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO Text
TIO.readFile (Path b File -> String
forall b t. Path b t -> String
toFilePath Path b File
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 :: Text -> [CGroup] -> Maybe CGroup
findMatchingCGroup Text
controllerName = (CGroup -> Bool) -> [CGroup] -> Maybe CGroup
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\CGroup
group -> CGroup -> Bool
containsController CGroup
group Bool -> Bool -> Bool
|| CGroup -> Bool
emptyControllers CGroup
group)
  where
    containsController :: CGroup -> Bool
    containsController :: CGroup -> Bool
containsController = (Text
controllerName Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) ([Text] -> Bool) -> (CGroup -> [Text]) -> CGroup -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CGroup -> [Text]
controlGroupControllers

    emptyControllers :: CGroup -> Bool
    emptyControllers :: CGroup -> Bool
emptyControllers = [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Text] -> Bool) -> (CGroup -> [Text]) -> CGroup -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CGroup -> [Text]
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 :: Text -> CGroup -> [Mount] -> Maybe (Path Abs Dir)
resolveControllerMountPath Text
controllerName CGroup
cgroup = (Mount -> Maybe (Path Abs Dir)) -> [Mount] -> Maybe (Path Abs Dir)
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstMaybe (Text -> CGroup -> Mount -> Maybe (Path Abs Dir)
tryResolveMount Text
controllerName CGroup
cgroup)

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

-- | 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 :: Text -> CGroup -> Mount -> Maybe (Path Abs Dir)
tryResolveMount Text
controllerName CGroup
cgroup Mount
mount = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
"cgroup" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Mount -> Text
mountFilesystemType Mount
mount)
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
controllerName Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Mount -> [Text]
mountSuperOptions Mount
mount)
  if CGroup -> Path Abs Dir
controlGroupPath CGroup
cgroup Path Abs Dir -> Path Abs Dir -> Bool
forall a. Eq a => a -> a -> Bool
== Mount -> Path Abs Dir
mountRoot Mount
mount
    then Path Abs Dir -> Maybe (Path Abs Dir)
forall a. a -> Maybe a
Just (Mount -> Path Abs Dir
mountPoint Mount
mount)
    else do
      Path Rel Dir
rel <- Path Abs Dir -> Path Abs Dir -> Maybe (Path Rel Dir)
forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix (Mount -> Path Abs Dir
mountRoot Mount
mount) (CGroup -> Path Abs Dir
controlGroupPath CGroup
cgroup)
      Path Abs Dir -> Maybe (Path Abs Dir)
forall a. a -> Maybe a
Just (Mount -> Path Abs Dir
mountPoint Mount
mount Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
rel)

-----

-- | A cgroup, as viewed within \/proc\/[pid]\/cgroup
--
-- see cgroups(7): \/proc\/[pid]\/cgroup section
data CGroup = CGroup
  { CGroup -> [Text]
controlGroupControllers :: [Text]
  , CGroup -> Path Abs Dir
controlGroupPath :: Path Abs Dir
  }
  deriving (Int -> CGroup -> ShowS
[CGroup] -> ShowS
CGroup -> String
(Int -> CGroup -> ShowS)
-> (CGroup -> String) -> ([CGroup] -> ShowS) -> Show CGroup
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CGroup] -> ShowS
$cshowList :: [CGroup] -> ShowS
show :: CGroup -> String
$cshow :: CGroup -> String
showsPrec :: Int -> CGroup -> ShowS
$cshowsPrec :: Int -> CGroup -> ShowS
Show)

-- | Parse an entire \/proc\/[pid]\/cgroup file into a list of cgroups
parseCGroups :: Parser [CGroup]
parseCGroups :: Parser [CGroup]
parseCGroups = ParsecT Void Text Identity CGroup -> Parser [CGroup]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void Text Identity CGroup
parseSingleCGroup Parser [CGroup] -> ParsecT Void Text Identity () -> Parser [CGroup]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
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 :: ParsecT Void Text Identity CGroup
parseSingleCGroup =
  [Text] -> Path Abs Dir -> CGroup
CGroup
    ([Text] -> Path Abs Dir -> CGroup)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity ([Text] -> Path Abs Dir -> CGroup)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT Void Text Identity Text
takeUntil1P Char
':' -- ignore hierarchy ID number
    ParsecT Void Text Identity ([Text] -> Path Abs Dir -> CGroup)
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity (Path Abs Dir -> CGroup)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Text -> [Text]
splitOnIgnoreEmpty Text
"," (Text -> [Text])
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> ParsecT Void Text Identity Text
takeUntilP Char
':') -- comma-separated list of controllers
    ParsecT Void Text Identity (Path Abs Dir -> CGroup)
-> ParsecT Void Text Identity (Path Abs Dir)
-> ParsecT Void Text Identity CGroup
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> ParsecT Void Text Identity (Path Abs Dir)
parseIntoAbsDir (Text -> ParsecT Void Text Identity (Path Abs Dir))
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Path Abs Dir)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Char -> ParsecT Void Text Identity Text
takeUntil1P Char
'\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 :: Char -> ParsecT Void Text Identity Text
takeUntilP Char
c = Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe String
forall a. Maybe a
Nothing (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
c) ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Maybe Char)
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
c)

-- like 'takeUntilP', but expects a non-empty prefix before the character
takeUntil1P :: Char -> Parser Text
takeUntil1P :: Char -> ParsecT Void Text Identity Text
takeUntil1P Char
c = Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe String
forall a. Maybe a
Nothing (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
c) ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Maybe Char)
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
c)

-- Data.Text.splitOn, but returns empty list on empty haystack, rather than [""]
--
-- >>> Data.Text.splitOn "foo" ""
-- [""]
--
-- >>> splitOnIgnoreEmpty "foo" ""
-- []
splitOnIgnoreEmpty :: Text -> Text -> [Text]
splitOnIgnoreEmpty :: Text -> Text -> [Text]
splitOnIgnoreEmpty Text
_ Text
"" = []
splitOnIgnoreEmpty Text
s Text
str = Text -> Text -> [Text]
Text.splitOn Text
s Text
str

--------------

-- | A mount, as viewed within \/proc\/[pid]\/mountinfo
--
-- see proc(5): \/proc\/[pid]\/mountinfo section
data Mount = Mount
  { Mount -> Text
mountId :: Text
  , Mount -> Text
mountParentId :: Text
  , Mount -> Text
mountStDev :: Text
  , Mount -> Path Abs Dir
mountRoot :: Path Abs Dir
  , Mount -> Path Abs Dir
mountPoint :: Path Abs Dir
  , Mount -> Text
mountOptions :: Text
  , Mount -> [Text]
mountTags :: [Text]
  , Mount -> Text
mountFilesystemType :: Text
  , Mount -> Text
mountSource :: Text
  , Mount -> [Text]
mountSuperOptions :: [Text]
  }
  deriving (Int -> Mount -> ShowS
[Mount] -> ShowS
Mount -> String
(Int -> Mount -> ShowS)
-> (Mount -> String) -> ([Mount] -> ShowS) -> Show Mount
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mount] -> ShowS
$cshowList :: [Mount] -> ShowS
show :: Mount -> String
$cshow :: Mount -> String
showsPrec :: Int -> Mount -> ShowS
$cshowsPrec :: Int -> Mount -> ShowS
Show)

-- | Parse an entire \/proc\/[pid]\/mountinfo file into a list of mounts
parseMountInfo :: Parser [Mount]
parseMountInfo :: Parser [Mount]
parseMountInfo = ParsecT Void Text Identity Mount -> Parser [Mount]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void Text Identity Mount
parseSingleMount Parser [Mount] -> ParsecT Void Text Identity () -> Parser [Mount]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
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 :: ParsecT Void Text Identity Mount
parseSingleMount =
  Text
-> Text
-> Text
-> Path Abs Dir
-> Path Abs Dir
-> Text
-> [Text]
-> Text
-> Text
-> [Text]
-> Mount
Mount
    (Text
 -> Text
 -> Text
 -> Path Abs Dir
 -> Path Abs Dir
 -> Text
 -> [Text]
 -> Text
 -> Text
 -> [Text]
 -> Mount)
-> ParsecT Void Text Identity Text
-> ParsecT
     Void
     Text
     Identity
     (Text
      -> Text
      -> Path Abs Dir
      -> Path Abs Dir
      -> Text
      -> [Text]
      -> Text
      -> Text
      -> [Text]
      -> Mount)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
field -- id
    ParsecT
  Void
  Text
  Identity
  (Text
   -> Text
   -> Path Abs Dir
   -> Path Abs Dir
   -> Text
   -> [Text]
   -> Text
   -> Text
   -> [Text]
   -> Mount)
-> ParsecT Void Text Identity Text
-> ParsecT
     Void
     Text
     Identity
     (Text
      -> Path Abs Dir
      -> Path Abs Dir
      -> Text
      -> [Text]
      -> Text
      -> Text
      -> [Text]
      -> Mount)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity Text
field -- parent id
    ParsecT
  Void
  Text
  Identity
  (Text
   -> Path Abs Dir
   -> Path Abs Dir
   -> Text
   -> [Text]
   -> Text
   -> Text
   -> [Text]
   -> Mount)
-> ParsecT Void Text Identity Text
-> ParsecT
     Void
     Text
     Identity
     (Path Abs Dir
      -> Path Abs Dir
      -> Text
      -> [Text]
      -> Text
      -> Text
      -> [Text]
      -> Mount)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity Text
field -- st_dev
    ParsecT
  Void
  Text
  Identity
  (Path Abs Dir
   -> Path Abs Dir
   -> Text
   -> [Text]
   -> Text
   -> Text
   -> [Text]
   -> Mount)
-> ParsecT Void Text Identity (Path Abs Dir)
-> ParsecT
     Void
     Text
     Identity
     (Path Abs Dir -> Text -> [Text] -> Text -> Text -> [Text] -> Mount)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> ParsecT Void Text Identity (Path Abs Dir)
parseIntoAbsDir (Text -> ParsecT Void Text Identity (Path Abs Dir))
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Path Abs Dir)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ParsecT Void Text Identity Text
field) -- mount root
    ParsecT
  Void
  Text
  Identity
  (Path Abs Dir -> Text -> [Text] -> Text -> Text -> [Text] -> Mount)
-> ParsecT Void Text Identity (Path Abs Dir)
-> ParsecT
     Void
     Text
     Identity
     (Text -> [Text] -> Text -> Text -> [Text] -> Mount)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> ParsecT Void Text Identity (Path Abs Dir)
parseIntoAbsDir (Text -> ParsecT Void Text Identity (Path Abs Dir))
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Path Abs Dir)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ParsecT Void Text Identity Text
field) -- mount point
    ParsecT
  Void
  Text
  Identity
  (Text -> [Text] -> Text -> Text -> [Text] -> Mount)
-> ParsecT Void Text Identity Text
-> ParsecT
     Void Text Identity ([Text] -> Text -> Text -> [Text] -> Mount)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity Text
field -- mount options
    ParsecT
  Void Text Identity ([Text] -> Text -> Text -> [Text] -> Mount)
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity (Text -> Text -> [Text] -> Mount)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity Text
field ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity [Text]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
`manyTill` ParsecT Void Text Identity Char
separator -- optional mount tags, terminated by "-"
    ParsecT Void Text Identity (Text -> Text -> [Text] -> Mount)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Text -> [Text] -> Mount)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity Text
field -- filesystem type
    ParsecT Void Text Identity (Text -> [Text] -> Mount)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity ([Text] -> Mount)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity Text
field -- mount source
    ParsecT Void Text Identity ([Text] -> Mount)
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity Mount
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Text -> [Text]
splitOnIgnoreEmpty Text
"," (Text -> [Text])
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
field) -- super options
    ParsecT Void Text Identity Mount
-> ParsecT Void Text Identity (Maybe Char)
-> ParsecT Void Text Identity Mount
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'\n')

-- | Megaparsec Parser
type Parser = Parsec Void Text

-- a field in the mountinfo file, terminated by whitespace
field :: Parser Text
field :: ParsecT Void Text Identity Text
field = ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a. Parser a -> Parser a
lexeme (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe String
forall a. Maybe a
Nothing (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace)

-- separator after optional mount tags ("-")
separator :: Parser Char
separator :: ParsecT Void Text Identity Char
separator = ParsecT Void Text Identity Char -> ParsecT Void Text Identity Char
forall a. Parser a -> Parser a
lexeme (ParsecT Void Text Identity Char
 -> ParsecT Void Text Identity Char)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-'

lexeme :: Parser a -> Parser a
lexeme :: Parser a -> Parser a
lexeme = ParsecT Void Text Identity () -> Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme (ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall (m :: * -> *) a. MonadPlus m => m a -> m ()
skipMany (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
' '))

parseIntoAbsDir :: Text -> Parser (Path Abs Dir)
parseIntoAbsDir :: Text -> ParsecT Void Text Identity (Path Abs Dir)
parseIntoAbsDir = (SomeException -> ParsecT Void Text Identity (Path Abs Dir))
-> (Path Abs Dir -> ParsecT Void Text Identity (Path Abs Dir))
-> Either SomeException (Path Abs Dir)
-> ParsecT Void Text Identity (Path Abs Dir)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> ParsecT Void Text Identity (Path Abs Dir)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT Void Text Identity (Path Abs Dir))
-> (SomeException -> String)
-> SomeException
-> ParsecT Void Text Identity (Path Abs Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show) Path Abs Dir -> ParsecT Void Text Identity (Path Abs Dir)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException (Path Abs Dir)
 -> ParsecT Void Text Identity (Path Abs Dir))
-> (Text -> Either SomeException (Path Abs Dir))
-> Text
-> ParsecT Void Text Identity (Path Abs Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either SomeException (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir (String -> Either SomeException (Path Abs Dir))
-> (Text -> String) -> Text -> Either SomeException (Path Abs Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack