    {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
    -- |functions for mounting, umounting, parsing \/proc\/mounts, etc
    module System.Unix.Mount
        ( umountBelow       -- FilePath -> IO [(FilePath, (String, String, ExitCode))]
        , umount            -- [String] -> IO (String, String, ExitCode)
        , isMountPoint      -- FilePath -> IO Bool

        , withMount
        , WithProcAndSys(runWithProcAndSys)
        , withProcAndSys
        , withTmp
        ) where

    -- Standard GHC modules

    import Control.Monad
    import Data.ByteString.Lazy.Char8 (empty)
    import Data.List
    import System.Directory
    import System.Exit
    import System.IO (readFile, hPutStrLn, stderr)
    import System.Posix.Files
    import System.Process (readProcessWithExitCode)

    import Control.Applicative (Applicative)
    import Control.Exception (catch)
    import Control.Monad.Catch (bracket, MonadCatch, MonadMask)
    import Control.Monad.Trans (MonadTrans, lift, liftIO, MonadIO)
    -- import Control.Monad.Trans.Except ({- ExceptT instances -})
    import Data.ByteString.Lazy as L (ByteString, empty)
    import GHC.IO.Exception (IOErrorType(OtherError))
    import System.Directory (createDirectoryIfMissing)
    import System.Exit (ExitCode(ExitFailure, ExitSuccess))
    import System.FilePath ((</>))
    import System.IO (hPutStrLn, stderr)
    import System.IO.Error
    import System.Process (CreateProcess, proc)
    import System.Process.ListLike (readCreateProcess, showCreateProcessForUser)

    -- Local Modules

    -- In ghc610 readFile "/proc/mounts" hangs.  Use this instead.
    -- rf path = lazyCommand ("cat '" ++ path ++ "'") empty >>= return . (\ (o, _, _) -> o) . collectOutputUnpacked

    -- |'umountBelow' - unmounts all mount points below /belowPath/
    -- \/proc\/mounts must be present and readable.  Because of the way
    -- linux handles changeroots, we can't trust everything we see in
    -- \/proc\/mounts.  However, we make the following assumptions:
    --
    --  (1) there is a one-to-one correspondence between the entries in
    --      \/proc\/mounts and the actual mounts, and
    --  (2) every mount point we might encounter is a suffix of one of
    --      the mount points listed in \/proc\/mounts (because being in a
    --      a chroot doesn't affect \/proc\/mounts.)
    --
    -- So we can search \/proc\/mounts for an entry has the mount point
    -- we are looking for as a substring, then add the extra text on
    -- the right to our path and try to unmount that.  Then we start
    -- again since nested mounts might have been revealed.
    --
    -- For example, suppose we are chrooted into
    -- \/home\/david\/environments\/sid and we call "umountBelow \/proc".  We
    -- might see the mount point \/home\/david\/environments\/sid\/proc\/bus\/usb
    -- in \/proc\/mounts, which means we need to run "umount \/proc\/bus\/usb".
    --
    -- See also: 'umountSucceeded'
    umountBelow :: Bool     -- ^ Lazy (umount -l flag) if true
                -> FilePath -- ^ canonicalised, absolute path
                -> IO [(FilePath, (ExitCode, String, String))] -- ^ paths that we attempted to umount, and the responding output from the umount command
    umountBelow :: Bool -> String -> IO [(String, (ExitCode, String, String))]
    umountBelow Bool
    lazy String
    belowPath =
        do procMount <- String -> IO String
    readFile String
    "/proc/mounts"
           let mountPoints = (String -> String) -> [String] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (String -> String
    unescape (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ([String] -> Int -> String
    forall a. HasCallStack => [a] -> Int -> a
    !! Int
    1) ([String] -> String) -> (String -> [String]) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String]
    words) (String -> [String]
    lines String
    procMount)
               maybeMounts = (String -> Bool) -> [String] -> [String]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    isPrefixOf String
    belowPath) ([[String]] -> [String]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ((String -> [String]) -> [String] -> [[String]]
    forall a b. (a -> b) -> [a] -> [b]
    map String -> [String]
    forall a. [a] -> [[a]]
    tails [String]
    mountPoints))
               args String
    path = [String
    "-f"] [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++ if Bool
    lazy then [String
    "-l"] else [] [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++ [String
    path]
           needsUmount <- filterM isMountPoint maybeMounts
           results <- mapM (\ String
    path -> Handle -> String -> IO ()
    hPutStrLn Handle
    stderr (String
    "umountBelow: umount " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> [String] -> String
    forall a. [a] -> [[a]] -> [a]
    intercalate String
    " " (String -> [String]
    args String
    path)) IO ()
    -> IO (ExitCode, String, String) -> IO (ExitCode, String, String)
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> [String] -> IO (ExitCode, String, String)
    umount (String -> [String]
    args String
    path) IO (ExitCode, String, String)
    -> ((ExitCode, String, String)
        -> IO (String, (ExitCode, String, String)))
    -> IO (String, (ExitCode, String, String))
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= (String, (ExitCode, String, String))
    -> IO (String, (ExitCode, String, String))
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((String, (ExitCode, String, String))
     -> IO (String, (ExitCode, String, String)))
    -> ((ExitCode, String, String)
        -> (String, (ExitCode, String, String)))
    -> (ExitCode, String, String)
    -> IO (String, (ExitCode, String, String))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((,) String
    path)) needsUmount
           let results' = ((String, (ExitCode, String, String))
     -> (String, (ExitCode, String, String)))
    -> [(String, (ExitCode, String, String))]
    -> [(String, (ExitCode, String, String))]
    forall a b. (a -> b) -> [a] -> [b]
    map (String, (ExitCode, String, String))
    -> (String, (ExitCode, String, String))
    fixNotMounted [(String, (ExitCode, String, String))]
    results
           mapM_ (\ ((String, (ExitCode, String, String))
    result, (String, (ExitCode, String, String))
    result') -> Handle -> String -> IO ()
    hPutStrLn Handle
    stderr ((String, (ExitCode, String, String)) -> String
    forall a. Show a => a -> String
    show (String, (ExitCode, String, String))
    result String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (if (String, (ExitCode, String, String))
    result (String, (ExitCode, String, String))
    -> (String, (ExitCode, String, String)) -> Bool
    forall a. Eq a => a -> a -> Bool
    /= (String, (ExitCode, String, String))
    result' then String
    " -> " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (String, (ExitCode, String, String)) -> String
    forall a. Show a => a -> String
    show (String, (ExitCode, String, String))
    result' else String
    ""))) (zip results results')
           -- Did /proc/mounts change?  If so we should try again because
           -- nested mounts might have been revealed.
           procMount' <- readFile "/proc/mounts"
           results'' <- if procMount /= procMount' then umountBelow lazy belowPath else return []
           return $ results' ++ results''
        where
          fixNotMounted :: (String, (ExitCode, String, String))
    -> (String, (ExitCode, String, String))
    fixNotMounted (String
    path, (ExitFailure Int
    1, String
    "", String
    err)) | String
    err String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == (String
    "umount: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    path String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ": not mounted\n") = (String
    path, (ExitCode
    ExitSuccess, String
    "", String
    ""))
          fixNotMounted (String, (ExitCode, String, String))
    x = (String, (ExitCode, String, String))
    x

    -- |umountSucceeded - predicated suitable for filtering results of 'umountBelow'
    umountSucceeded :: (FilePath, (String, String, ExitCode)) -> Bool
    umountSucceeded :: (String, (String, String, ExitCode)) -> Bool
    umountSucceeded (String
    _, (String
    _,String
    _,ExitCode
    ExitSuccess)) = Bool
    True
    umountSucceeded (String, (String, String, ExitCode))
    _ = Bool
    False

    -- |'unescape' - unescape function for strings in \/proc\/mounts
    unescape :: String -> String
    unescape :: String -> String
    unescape [] = []
    unescape (Char
    '\\':Char
    '0':Char
    '4':Char
    '0':String
    rest) = Char
    ' ' Char -> String -> String
    forall a. a -> [a] -> [a]
    : (String -> String
    unescape String
    rest)
    unescape (Char
    '\\':Char
    '0':Char
    '1':Char
    '1':String
    rest) = Char
    '\t' Char -> String -> String
    forall a. a -> [a] -> [a]
    : (String -> String
    unescape String
    rest)
    unescape (Char
    '\\':Char
    '0':Char
    '1':Char
    '2':String
    rest) = Char
    '\n' Char -> String -> String
    forall a. a -> [a] -> [a]
    : (String -> String
    unescape String
    rest)
    unescape (Char
    '\\':Char
    '1':Char
    '3':Char
    '4':String
    rest) = Char
    '\\' Char -> String -> String
    forall a. a -> [a] -> [a]
    : (String -> String
    unescape String
    rest)
    unescape (Char
    c:String
    rest) = Char
    c Char -> String -> String
    forall a. a -> [a] -> [a]
    : (String -> String
    unescape String
    rest)

    -- |'escape' - \/proc\/mount style string escaper
    escape :: String -> String
    escape :: String -> String
    escape [] = []
    escape (Char
    ' ':String
    rest)  = (Char
    '\\'Char -> String -> String
    forall a. a -> [a] -> [a]
    :Char
    '0'Char -> String -> String
    forall a. a -> [a] -> [a]
    :Char
    '4'Char -> String -> String
    forall a. a -> [a] -> [a]
    :Char
    '0'Char -> String -> String
    forall a. a -> [a] -> [a]
    :String -> String
    escape String
    rest)
    escape (Char
    '\t':String
    rest) = (Char
    '\\'Char -> String -> String
    forall a. a -> [a] -> [a]
    :Char
    '0'Char -> String -> String
    forall a. a -> [a] -> [a]
    :Char
    '1'Char -> String -> String
    forall a. a -> [a] -> [a]
    :Char
    '1'Char -> String -> String
    forall a. a -> [a] -> [a]
    :String -> String
    escape String
    rest)
    escape (Char
    '\n':String
    rest) = (Char
    '\\'Char -> String -> String
    forall a. a -> [a] -> [a]
    :Char
    '0'Char -> String -> String
    forall a. a -> [a] -> [a]
    :Char
    '1'Char -> String -> String
    forall a. a -> [a] -> [a]
    :Char
    '2'Char -> String -> String
    forall a. a -> [a] -> [a]
    :String -> String
    escape String
    rest)
    escape (Char
    '\\':String
    rest) = (Char
    '\\'Char -> String -> String
    forall a. a -> [a] -> [a]
    :Char
    '1'Char -> String -> String
    forall a. a -> [a] -> [a]
    :Char
    '3'Char -> String -> String
    forall a. a -> [a] -> [a]
    :Char
    '4'Char -> String -> String
    forall a. a -> [a] -> [a]
    :String -> String
    escape String
    rest)
    escape (Char
    c:String
    rest)    = Char
    c Char -> String -> String
    forall a. a -> [a] -> [a]
    : (String -> String
    escape String
    rest)

    -- |'umount' - run umount with the specified args
    -- NOTE: this function uses exec, so you do /not/ need to shell-escape
    -- NOTE: we don't use the umount system call because the system call
    -- is not smart enough to update \/etc\/mtab
    umount :: [String] -> IO (ExitCode, String, String)
    umount :: [String] -> IO (ExitCode, String, String)
    umount [String]
    args = String -> [String] -> String -> IO (ExitCode, String, String)
    readProcessWithExitCode String
    "umount" [String]
    args String
    ""

    isMountPoint :: FilePath -> IO Bool
    -- This implements the functionality of mountpoint(1), deciding
    -- whether a path is a mountpoint by seeing whether it is on a
    -- different device from its parent.  It would fail if a file system
    -- is mounted directly inside itself, but I think maybe that isn't
    -- allowed.
    isMountPoint :: String -> IO Bool
    isMountPoint String
    path =
        do
          exists <- String -> IO Bool
    doesDirectoryExist (String
    path String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "/.")
          parentExists <- doesDirectoryExist (path ++ "/..")
          case (exists, parentExists) of
            (Bool
    True, Bool
    True) ->
                do
                  id <- String -> IO FileStatus
    getFileStatus (String
    path String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "/.") IO FileStatus -> (FileStatus -> IO DeviceID) -> IO DeviceID
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= DeviceID -> IO DeviceID
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DeviceID -> IO DeviceID)
    -> (FileStatus -> DeviceID) -> FileStatus -> IO DeviceID
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . FileStatus -> DeviceID
    deviceID
                  parentID <- getFileStatus (path ++ "/..") >>= return . deviceID
                  return $ id /= parentID
            (Bool, Bool)
    _ ->
                -- It is hard to know what is going on if . or .. don't exist.
                -- Assume we are seeing some sort of mount point.
                Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True

    readProcess :: CreateProcess -> L.ByteString -> IO L.ByteString
    readProcess :: CreateProcess -> ByteString -> IO ByteString
    readProcess CreateProcess
    p ByteString
    input = do
      (code, out, _err) <- CreateProcess
    -> ByteString -> IO (ExitCode, ByteString, ByteString)
    forall maker text result char.
    (ProcessMaker maker, ProcessResult text result,
     ListLikeProcessIO text char) =>
    maker -> text -> IO result
    readCreateProcess CreateProcess
    p ByteString
    input :: IO (ExitCode, L.ByteString, L.ByteString)
      case code of
        ExitFailure Int
    n -> IOError -> IO ByteString
    forall a. IOError -> IO a
    ioError (IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
    mkIOError IOErrorType
    OtherError (CreateProcess -> String
    showCreateProcessForUser CreateProcess
    p String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " -> " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    n) Maybe Handle
    forall a. Maybe a
    Nothing Maybe String
    forall a. Maybe a
    Nothing)
        ExitCode
    ExitSuccess -> ByteString -> IO ByteString
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ByteString
    out

    -- | Do an IO task with a file system remounted using mount --bind.
    -- This was written to set up a build environment.
    withMount :: (MonadIO m, MonadMask m) => FilePath -> FilePath -> m a -> m a
    withMount :: forall (m :: * -> *) a.
    (MonadIO m, MonadMask m) =>
    String -> String -> m a -> m a
    withMount String
    directory String
    mountpoint m a
    task =
        m ByteString
    -> (ByteString -> m ByteString) -> (ByteString -> m a) -> m a
    forall (m :: * -> *) a c b.
    (HasCallStack, MonadMask m) =>
    m a -> (a -> m c) -> (a -> m b) -> m b
    bracket m ByteString
    pre (\ ByteString
    _ -> m ByteString
    post) (\ ByteString
    _ -> m a
    task)
        where
          mount :: CreateProcess
    mount = String -> [String] -> CreateProcess
    proc String
    "mount" [String
    "--bind", String
    directory, String
    mountpoint]
          umount :: CreateProcess
    umount = String -> [String] -> CreateProcess
    proc String
    "umount" [String
    mountpoint]
          umountLazy :: CreateProcess
    umountLazy = String -> [String] -> CreateProcess
    proc String
    "umount" [String
    "-l", String
    mountpoint]

          pre :: m ByteString
    pre = IO ByteString -> m ByteString
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
    forall a b. (a -> b) -> a -> b
    $ do -- hPutStrLn stderr $ "mounting /proc at " ++ show mountpoint
                            Bool -> String -> IO ()
    createDirectoryIfMissing Bool
    True String
    mountpoint
                            CreateProcess -> ByteString -> IO ByteString
    readProcess CreateProcess
    mount ByteString
    L.empty

          post :: m ByteString
    post = IO ByteString -> m ByteString
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
    forall a b. (a -> b) -> a -> b
    $ do -- hPutStrLn stderr $ "unmounting /proc at " ++ show mountpoint
                             CreateProcess -> ByteString -> IO ByteString
    readProcess CreateProcess
    umount ByteString
    L.empty
                               IO ByteString -> (IOError -> IO ByteString) -> IO ByteString
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    `catch` (\ (IOError
    e :: IOError) ->
                                            do Handle -> String -> IO ()
    hPutStrLn Handle
    stderr (String
    "Exception unmounting " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    mountpoint String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ", trying -l: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ IOError -> String
    forall a. Show a => a -> String
    show IOError
    e)
                                               CreateProcess -> ByteString -> IO ByteString
    readProcess CreateProcess
    umountLazy ByteString
    L.empty)

    -- | Monad transformer to ensure that /proc and /sys are mounted
    -- during a computation.
    newtype WithProcAndSys m a = WithProcAndSys { forall (m :: * -> *) a. WithProcAndSys m a -> m a
    runWithProcAndSys :: m a } deriving ((forall a b. (a -> b) -> WithProcAndSys m a -> WithProcAndSys m b)
    -> (forall a b. a -> WithProcAndSys m b -> WithProcAndSys m a)
    -> Functor (WithProcAndSys m)
    forall a b. a -> WithProcAndSys m b -> WithProcAndSys m a
    forall a b. (a -> b) -> WithProcAndSys m a -> WithProcAndSys m b
    forall (m :: * -> *) a b.
    Functor m =>
    a -> WithProcAndSys m b -> WithProcAndSys m a
    forall (m :: * -> *) a b.
    Functor m =>
    (a -> b) -> WithProcAndSys m a -> WithProcAndSys m b
    forall (f :: * -> *).
    (forall a b. (a -> b) -> f a -> f b)
    -> (forall a b. a -> f b -> f a) -> Functor f
    $cfmap :: forall (m :: * -> *) a b.
    Functor m =>
    (a -> b) -> WithProcAndSys m a -> WithProcAndSys m b
    fmap :: forall a b. (a -> b) -> WithProcAndSys m a -> WithProcAndSys m b
    $c<$ :: forall (m :: * -> *) a b.
    Functor m =>
    a -> WithProcAndSys m b -> WithProcAndSys m a
    <$ :: forall a b. a -> WithProcAndSys m b -> WithProcAndSys m a
    Functor, Applicative (WithProcAndSys m)
    Applicative (WithProcAndSys m) =>
    (forall a b.
     WithProcAndSys m a
     -> (a -> WithProcAndSys m b) -> WithProcAndSys m b)
    -> (forall a b.
        WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m b)
    -> (forall a. a -> WithProcAndSys m a)
    -> Monad (WithProcAndSys m)
    forall a. a -> WithProcAndSys m a
    forall a b.
    WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m b
    forall a b.
    WithProcAndSys m a
    -> (a -> WithProcAndSys m b) -> WithProcAndSys m b
    forall (m :: * -> *). Monad m => Applicative (WithProcAndSys m)
    forall (m :: * -> *) a. Monad m => a -> WithProcAndSys m a
    forall (m :: * -> *) a b.
    Monad m =>
    WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m b
    forall (m :: * -> *) a b.
    Monad m =>
    WithProcAndSys m a
    -> (a -> WithProcAndSys m b) -> WithProcAndSys m b
    forall (m :: * -> *).
    Applicative m =>
    (forall a b. m a -> (a -> m b) -> m b)
    -> (forall a b. m a -> m b -> m b)
    -> (forall a. a -> m a)
    -> Monad m
    $c>>= :: forall (m :: * -> *) a b.
    Monad m =>
    WithProcAndSys m a
    -> (a -> WithProcAndSys m b) -> WithProcAndSys m b
    >>= :: forall a b.
    WithProcAndSys m a
    -> (a -> WithProcAndSys m b) -> WithProcAndSys m b
    $c>> :: forall (m :: * -> *) a b.
    Monad m =>
    WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m b
    >> :: forall a b.
    WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m b
    $creturn :: forall (m :: * -> *) a. Monad m => a -> WithProcAndSys m a
    return :: forall a. a -> WithProcAndSys m a
    Monad, Functor (WithProcAndSys m)
    Functor (WithProcAndSys m) =>
    (forall a. a -> WithProcAndSys m a)
    -> (forall a b.
        WithProcAndSys m (a -> b)
        -> WithProcAndSys m a -> WithProcAndSys m b)
    -> (forall a b c.
        (a -> b -> c)
        -> WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m c)
    -> (forall a b.
        WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m b)
    -> (forall a b.
        WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m a)
    -> Applicative (WithProcAndSys m)
    forall a. a -> WithProcAndSys m a
    forall a b.
    WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m a
    forall a b.
    WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m b
    forall a b.
    WithProcAndSys m (a -> b)
    -> WithProcAndSys m a -> WithProcAndSys m b
    forall a b c.
    (a -> b -> c)
    -> WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m c
    forall (f :: * -> *).
    Functor f =>
    (forall a. a -> f a)
    -> (forall a b. f (a -> b) -> f a -> f b)
    -> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
    -> (forall a b. f a -> f b -> f b)
    -> (forall a b. f a -> f b -> f a)
    -> Applicative f
    forall (m :: * -> *). Applicative m => Functor (WithProcAndSys m)
    forall (m :: * -> *) a. Applicative m => a -> WithProcAndSys m a
    forall (m :: * -> *) a b.
    Applicative m =>
    WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m a
    forall (m :: * -> *) a b.
    Applicative m =>
    WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m b
    forall (m :: * -> *) a b.
    Applicative m =>
    WithProcAndSys m (a -> b)
    -> WithProcAndSys m a -> WithProcAndSys m b
    forall (m :: * -> *) a b c.
    Applicative m =>
    (a -> b -> c)
    -> WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m c
    $cpure :: forall (m :: * -> *) a. Applicative m => a -> WithProcAndSys m a
    pure :: forall a. a -> WithProcAndSys m a
    $c<*> :: forall (m :: * -> *) a b.
    Applicative m =>
    WithProcAndSys m (a -> b)
    -> WithProcAndSys m a -> WithProcAndSys m b
    <*> :: forall a b.
    WithProcAndSys m (a -> b)
    -> WithProcAndSys m a -> WithProcAndSys m b
    $cliftA2 :: forall (m :: * -> *) a b c.
    Applicative m =>
    (a -> b -> c)
    -> WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m c
    liftA2 :: forall a b c.
    (a -> b -> c)
    -> WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m c
    $c*> :: forall (m :: * -> *) a b.
    Applicative m =>
    WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m b
    *> :: forall a b.
    WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m b
    $c<* :: forall (m :: * -> *) a b.
    Applicative m =>
    WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m a
    <* :: forall a b.
    WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m a
    Applicative)

    instance MonadTrans WithProcAndSys where
        lift :: forall (m :: * -> *) a. Monad m => m a -> WithProcAndSys m a
    lift = m a -> WithProcAndSys m a
    forall (m :: * -> *) a. m a -> WithProcAndSys m a
    WithProcAndSys

    instance MonadIO m => MonadIO (WithProcAndSys m) where
        liftIO :: forall a. IO a -> WithProcAndSys m a
    liftIO IO a
    task = m a -> WithProcAndSys m a
    forall (m :: * -> *) a. m a -> WithProcAndSys m a
    WithProcAndSys (IO a -> m a
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO IO a
    task)

    -- | Mount /proc and /sys in the specified build root and execute a
    -- task.  Typically, the task would start with a chroot into the build
    -- root.  If the build root given is "/" it is assumed that the file
    -- systems are already mounted, no mounting or unmounting is done.
    withProcAndSys :: (MonadIO m, MonadMask m) => FilePath -> WithProcAndSys m a -> m a
    withProcAndSys :: forall (m :: * -> *) a.
    (MonadIO m, MonadMask m) =>
    String -> WithProcAndSys m a -> m a
    withProcAndSys String
    "/" WithProcAndSys m a
    task = WithProcAndSys m a -> m a
    forall (m :: * -> *) a. WithProcAndSys m a -> m a
    runWithProcAndSys WithProcAndSys m a
    task
    withProcAndSys String
    root WithProcAndSys m a
    task = do
      exists <- IO Bool -> m Bool
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
    forall a b. (a -> b) -> a -> b
    $ String -> IO Bool
    doesDirectoryExist String
    root
      case exists of
        Bool
    True -> String -> String -> m a -> m a
    forall (m :: * -> *) a.
    (MonadIO m, MonadMask m) =>
    String -> String -> m a -> m a
    withMount String
    "/proc" (String
    root String -> String -> String
    </> String
    "proc") (m a -> m a) -> m a -> m a
    forall a b. (a -> b) -> a -> b
    $ String -> String -> m a -> m a
    forall (m :: * -> *) a.
    (MonadIO m, MonadMask m) =>
    String -> String -> m a -> m a
    withMount String
    "/sys" (String
    root String -> String -> String
    </> String
    "sys") (m a -> m a) -> m a -> m a
    forall a b. (a -> b) -> a -> b
    $ WithProcAndSys m a -> m a
    forall (m :: * -> *) a. WithProcAndSys m a -> m a
    runWithProcAndSys WithProcAndSys m a
    task
        Bool
    False -> IO a -> m a
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO a -> m a) -> IO a -> m a
    forall a b. (a -> b) -> a -> b
    $ IOError -> IO a
    forall a. IOError -> IO a
    ioError (IOError -> IO a) -> IOError -> IO a
    forall a b. (a -> b) -> a -> b
    $ IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
    mkIOError IOErrorType
    doesNotExistErrorType String
    "chroot directory does not exist" Maybe Handle
    forall a. Maybe a
    Nothing (String -> Maybe String
    forall a. a -> Maybe a
    Just String
    root)

    -- | Do an IO task with /tmp remounted.  This could be used
    -- to share /tmp with a build root.
    withTmp :: (MonadIO m, MonadMask m) => FilePath -> m a -> m a
    withTmp :: forall (m :: * -> *) a.
    (MonadIO m, MonadMask m) =>
    String -> m a -> m a
    withTmp String
    root m a
    task = String -> String -> m a -> m a
    forall (m :: * -> *) a.
    (MonadIO m, MonadMask m) =>
    String -> String -> m a -> m a
    withMount String
    "/tmp" (String
    root String -> String -> String
    </> String
    "tmp") m a
    task