{-# 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 -> FilePath -> IO [(FilePath, (ExitCode, FilePath, FilePath))]
umountBelow Bool
lazy FilePath
belowPath =
    do FilePath
procMount <- FilePath -> IO FilePath
readFile FilePath
"/proc/mounts"
       let mountPoints :: [FilePath]
mountPoints = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath
unescape (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([FilePath] -> Int -> FilePath
forall a. [a] -> Int -> a
!! Int
1) ([FilePath] -> FilePath)
-> (FilePath -> [FilePath]) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
words) (FilePath -> [FilePath]
lines FilePath
procMount)
           maybeMounts :: [FilePath]
maybeMounts = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf FilePath
belowPath) ([[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((FilePath -> [FilePath]) -> [FilePath] -> [[FilePath]]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> [FilePath]
forall a. [a] -> [[a]]
tails [FilePath]
mountPoints))
           args :: FilePath -> [FilePath]
args FilePath
path = [FilePath
"-f"] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ if Bool
lazy then [FilePath
"-l"] else [] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
path]
       [FilePath]
needsUmount <- (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
isMountPoint [FilePath]
maybeMounts
       [(FilePath, (ExitCode, FilePath, FilePath))]
results <- (FilePath -> IO (FilePath, (ExitCode, FilePath, FilePath)))
-> [FilePath] -> IO [(FilePath, (ExitCode, FilePath, FilePath))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ FilePath
path -> Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath
"umountBelow: umount " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
" " (FilePath -> [FilePath]
args FilePath
path)) IO ()
-> IO (ExitCode, FilePath, FilePath)
-> IO (ExitCode, FilePath, FilePath)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [FilePath] -> IO (ExitCode, FilePath, FilePath)
umount (FilePath -> [FilePath]
args FilePath
path) IO (ExitCode, FilePath, FilePath)
-> ((ExitCode, FilePath, FilePath)
    -> IO (FilePath, (ExitCode, FilePath, FilePath)))
-> IO (FilePath, (ExitCode, FilePath, FilePath))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FilePath, (ExitCode, FilePath, FilePath))
-> IO (FilePath, (ExitCode, FilePath, FilePath))
forall (m :: * -> *) a. Monad m => a -> m a
return ((FilePath, (ExitCode, FilePath, FilePath))
 -> IO (FilePath, (ExitCode, FilePath, FilePath)))
-> ((ExitCode, FilePath, FilePath)
    -> (FilePath, (ExitCode, FilePath, FilePath)))
-> (ExitCode, FilePath, FilePath)
-> IO (FilePath, (ExitCode, FilePath, FilePath))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((,) FilePath
path)) [FilePath]
needsUmount
       let results' :: [(FilePath, (ExitCode, FilePath, FilePath))]
results' = ((FilePath, (ExitCode, FilePath, FilePath))
 -> (FilePath, (ExitCode, FilePath, FilePath)))
-> [(FilePath, (ExitCode, FilePath, FilePath))]
-> [(FilePath, (ExitCode, FilePath, FilePath))]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, (ExitCode, FilePath, FilePath))
-> (FilePath, (ExitCode, FilePath, FilePath))
fixNotMounted [(FilePath, (ExitCode, FilePath, FilePath))]
results
       (((FilePath, (ExitCode, FilePath, FilePath)),
  (FilePath, (ExitCode, FilePath, FilePath)))
 -> IO ())
-> [((FilePath, (ExitCode, FilePath, FilePath)),
     (FilePath, (ExitCode, FilePath, FilePath)))]
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ ((FilePath, (ExitCode, FilePath, FilePath))
result, (FilePath, (ExitCode, FilePath, FilePath))
result') -> Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr ((FilePath, (ExitCode, FilePath, FilePath)) -> FilePath
forall a. Show a => a -> FilePath
show (FilePath, (ExitCode, FilePath, FilePath))
result FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (if (FilePath, (ExitCode, FilePath, FilePath))
result (FilePath, (ExitCode, FilePath, FilePath))
-> (FilePath, (ExitCode, FilePath, FilePath)) -> Bool
forall a. Eq a => a -> a -> Bool
/= (FilePath, (ExitCode, FilePath, FilePath))
result' then FilePath
" -> " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (FilePath, (ExitCode, FilePath, FilePath)) -> FilePath
forall a. Show a => a -> FilePath
show (FilePath, (ExitCode, FilePath, FilePath))
result' else FilePath
""))) ([(FilePath, (ExitCode, FilePath, FilePath))]
-> [(FilePath, (ExitCode, FilePath, FilePath))]
-> [((FilePath, (ExitCode, FilePath, FilePath)),
     (FilePath, (ExitCode, FilePath, FilePath)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(FilePath, (ExitCode, FilePath, FilePath))]
results [(FilePath, (ExitCode, FilePath, FilePath))]
results')
       -- Did /proc/mounts change?  If so we should try again because
       -- nested mounts might have been revealed.
       FilePath
procMount' <- FilePath -> IO FilePath
readFile FilePath
"/proc/mounts"
       [(FilePath, (ExitCode, FilePath, FilePath))]
results'' <- if FilePath
procMount FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
procMount' then Bool -> FilePath -> IO [(FilePath, (ExitCode, FilePath, FilePath))]
umountBelow Bool
lazy FilePath
belowPath else [(FilePath, (ExitCode, FilePath, FilePath))]
-> IO [(FilePath, (ExitCode, FilePath, FilePath))]
forall (m :: * -> *) a. Monad m => a -> m a
return []
       [(FilePath, (ExitCode, FilePath, FilePath))]
-> IO [(FilePath, (ExitCode, FilePath, FilePath))]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(FilePath, (ExitCode, FilePath, FilePath))]
 -> IO [(FilePath, (ExitCode, FilePath, FilePath))])
-> [(FilePath, (ExitCode, FilePath, FilePath))]
-> IO [(FilePath, (ExitCode, FilePath, FilePath))]
forall a b. (a -> b) -> a -> b
$ [(FilePath, (ExitCode, FilePath, FilePath))]
results' [(FilePath, (ExitCode, FilePath, FilePath))]
-> [(FilePath, (ExitCode, FilePath, FilePath))]
-> [(FilePath, (ExitCode, FilePath, FilePath))]
forall a. [a] -> [a] -> [a]
++ [(FilePath, (ExitCode, FilePath, FilePath))]
results''
    where
      fixNotMounted :: (FilePath, (ExitCode, FilePath, FilePath))
-> (FilePath, (ExitCode, FilePath, FilePath))
fixNotMounted (FilePath
path, (ExitFailure Int
1, FilePath
"", FilePath
err)) | FilePath
err FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== (FilePath
"umount: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": not mounted\n") = (FilePath
path, (ExitCode
ExitSuccess, FilePath
"", FilePath
""))
      fixNotMounted (FilePath, (ExitCode, FilePath, FilePath))
x = (FilePath, (ExitCode, FilePath, FilePath))
x

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

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

-- |'escape' - \/proc\/mount style string escaper
escape :: String -> String
escape :: FilePath -> FilePath
escape [] = []
escape (Char
' ':FilePath
rest)  = (Char
'\\'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Char
'0'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Char
'4'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Char
'0'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
escape FilePath
rest)
escape (Char
'\t':FilePath
rest) = (Char
'\\'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Char
'0'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Char
'1'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Char
'1'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
escape FilePath
rest)
escape (Char
'\n':FilePath
rest) = (Char
'\\'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Char
'0'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Char
'1'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Char
'2'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
escape FilePath
rest)
escape (Char
'\\':FilePath
rest) = (Char
'\\'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Char
'1'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Char
'3'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Char
'4'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
escape FilePath
rest)
escape (Char
c:FilePath
rest)    = Char
c Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: (FilePath -> FilePath
escape FilePath
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 :: [FilePath] -> IO (ExitCode, FilePath, FilePath)
umount [FilePath]
args = FilePath
-> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
readProcessWithExitCode FilePath
"umount" [FilePath]
args FilePath
""

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 :: FilePath -> IO Bool
isMountPoint FilePath
path =
    do
      Bool
exists <- FilePath -> IO Bool
doesDirectoryExist (FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/.")
      Bool
parentExists <- FilePath -> IO Bool
doesDirectoryExist (FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/..")
      case (Bool
exists, Bool
parentExists) of
        (Bool
True, Bool
True) ->
            do
              DeviceID
id <- FilePath -> IO FileStatus
getFileStatus (FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/.") IO FileStatus -> (FileStatus -> IO DeviceID) -> IO DeviceID
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DeviceID -> IO DeviceID
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
              DeviceID
parentID <- FilePath -> IO FileStatus
getFileStatus (FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/..") IO FileStatus -> (FileStatus -> IO DeviceID) -> IO DeviceID
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DeviceID -> IO DeviceID
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
              Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ DeviceID
id DeviceID -> DeviceID -> Bool
forall a. Eq a => a -> a -> Bool
/= DeviceID
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 (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
  (ExitCode
code, ByteString
out, ByteString
_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 ExitCode
code of
    ExitFailure Int
n -> IOError -> IO ByteString
forall a. IOError -> IO a
ioError (IOErrorType
-> FilePath -> Maybe Handle -> Maybe FilePath -> IOError
mkIOError IOErrorType
OtherError (CreateProcess -> FilePath
showCreateProcessForUser CreateProcess
p FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" -> " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n) Maybe Handle
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing)
    ExitCode
ExitSuccess -> ByteString -> IO ByteString
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 :: FilePath -> FilePath -> m a -> m a
withMount FilePath
directory FilePath
mountpoint m a
task =
    m ByteString
-> (ByteString -> m ByteString) -> (ByteString -> m a) -> m a
forall (m :: * -> *) a c b.
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 = FilePath -> [FilePath] -> CreateProcess
proc FilePath
"mount" [FilePath
"--bind", FilePath
directory, FilePath
mountpoint]
      umount :: CreateProcess
umount = FilePath -> [FilePath] -> CreateProcess
proc FilePath
"umount" [FilePath
mountpoint]
      umountLazy :: CreateProcess
umountLazy = FilePath -> [FilePath] -> CreateProcess
proc FilePath
"umount" [FilePath
"-l", FilePath
mountpoint]

      pre :: m ByteString
pre = IO ByteString -> m ByteString
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 -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
mountpoint
                        CreateProcess -> ByteString -> IO ByteString
readProcess CreateProcess
mount ByteString
L.empty

      post :: m ByteString
post = IO ByteString -> m ByteString
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 -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath
"Exception unmounting " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
mountpoint FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
", trying -l: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ IOError -> FilePath
forall a. Show a => a -> FilePath
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 { WithProcAndSys m a -> m a
runWithProcAndSys :: m a } deriving (a -> WithProcAndSys m b -> WithProcAndSys m a
(a -> b) -> WithProcAndSys m a -> WithProcAndSys m b
(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
<$ :: a -> WithProcAndSys m b -> WithProcAndSys m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> WithProcAndSys m b -> WithProcAndSys m a
fmap :: (a -> b) -> WithProcAndSys m a -> WithProcAndSys m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> WithProcAndSys m a -> WithProcAndSys m b
Functor, Applicative (WithProcAndSys m)
a -> WithProcAndSys m a
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)
WithProcAndSys m a
-> (a -> WithProcAndSys m b) -> WithProcAndSys m b
WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m b
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
return :: a -> WithProcAndSys m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> WithProcAndSys m a
>> :: WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m b
>>= :: WithProcAndSys m a
-> (a -> WithProcAndSys m b) -> WithProcAndSys m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
WithProcAndSys m a
-> (a -> WithProcAndSys m b) -> WithProcAndSys m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (WithProcAndSys m)
Monad, Functor (WithProcAndSys m)
a -> WithProcAndSys m a
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)
WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m b
WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m a
WithProcAndSys m (a -> b)
-> WithProcAndSys m a -> WithProcAndSys m b
(a -> b -> c)
-> WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m c
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
<* :: WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m a
*> :: WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m b
liftA2 :: (a -> b -> c)
-> WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> WithProcAndSys m a -> WithProcAndSys m b -> WithProcAndSys m c
<*> :: WithProcAndSys m (a -> b)
-> WithProcAndSys m a -> WithProcAndSys m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
WithProcAndSys m (a -> b)
-> WithProcAndSys m a -> WithProcAndSys m b
pure :: a -> WithProcAndSys m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> WithProcAndSys m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (WithProcAndSys m)
Applicative)

instance MonadTrans WithProcAndSys where
    lift :: 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 :: 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 (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 :: FilePath -> WithProcAndSys m a -> m a
withProcAndSys FilePath
"/" WithProcAndSys m a
task = WithProcAndSys m a -> m a
forall (m :: * -> *) a. WithProcAndSys m a -> m a
runWithProcAndSys WithProcAndSys m a
task
withProcAndSys FilePath
root WithProcAndSys m a
task = do
  Bool
exists <- IO Bool -> m Bool
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
$ FilePath -> IO Bool
doesDirectoryExist FilePath
root
  case Bool
exists of
    Bool
True -> FilePath -> FilePath -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> FilePath -> m a -> m a
withMount FilePath
"/proc" (FilePath
root FilePath -> FilePath -> FilePath
</> FilePath
"proc") (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> FilePath -> m a -> m a
withMount FilePath
"/sys" (FilePath
root FilePath -> FilePath -> FilePath
</> FilePath
"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 (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
-> FilePath -> Maybe Handle -> Maybe FilePath -> IOError
mkIOError IOErrorType
doesNotExistErrorType FilePath
"chroot directory does not exist" Maybe Handle
forall a. Maybe a
Nothing (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
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 :: FilePath -> m a -> m a
withTmp FilePath
root m a
task = FilePath -> FilePath -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> FilePath -> m a -> m a
withMount FilePath
"/tmp" (FilePath
root FilePath -> FilePath -> FilePath
</> FilePath
"tmp") m a
task