{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
module System.Unix.Mount
( umountBelow
, umount
, isMountPoint
, withMount
, WithProcAndSys(runWithProcAndSys)
, withProcAndSys
, withTmp
) where
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 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)
umountBelow :: Bool
-> FilePath
-> IO [(FilePath, (ExitCode, String, String))]
umountBelow :: Bool -> FilePath -> IO [(FilePath, (ExitCode, FilePath, FilePath))]
umountBelow lazy :: Bool
lazy belowPath :: FilePath
belowPath =
do FilePath
procMount <- FilePath -> IO FilePath
readFile "/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
!! 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 path :: FilePath
path = ["-f"] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ if Bool
lazy then ["-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 (\ path :: FilePath
path -> Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr ("umountBelow: umount " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate " " (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_ (\ (result :: (FilePath, (ExitCode, FilePath, FilePath))
result, 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
forall a. [a] -> [a] -> [a]
++ (FilePath, (ExitCode, FilePath, FilePath)) -> FilePath
forall a. Show a => a -> FilePath
show (FilePath, (ExitCode, FilePath, FilePath))
result' else ""))) ([(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')
FilePath
procMount' <- FilePath -> IO FilePath
readFile "/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 (path :: FilePath
path, (ExitFailure 1, "", err :: FilePath
err)) | FilePath
err FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== ("umount: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ": not mounted\n") = (FilePath
path, (ExitCode
ExitSuccess, "", ""))
fixNotMounted x :: (FilePath, (ExitCode, FilePath, FilePath))
x = (FilePath, (ExitCode, FilePath, FilePath))
x
umountSucceeded :: (FilePath, (String, String, ExitCode)) -> Bool
umountSucceeded :: (FilePath, (FilePath, FilePath, ExitCode)) -> Bool
umountSucceeded (_, (_,_,ExitSuccess)) = Bool
True
umountSucceeded _ = Bool
False
unescape :: String -> String
unescape :: FilePath -> FilePath
unescape [] = []
unescape ('\\':'0':'4':'0':rest :: FilePath
rest) = ' ' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: (FilePath -> FilePath
unescape FilePath
rest)
unescape ('\\':'0':'1':'1':rest :: FilePath
rest) = '\t' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: (FilePath -> FilePath
unescape FilePath
rest)
unescape ('\\':'0':'1':'2':rest :: FilePath
rest) = '\n' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: (FilePath -> FilePath
unescape FilePath
rest)
unescape ('\\':'1':'3':'4':rest :: FilePath
rest) = '\\' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: (FilePath -> FilePath
unescape FilePath
rest)
unescape (c :: Char
c:rest :: FilePath
rest) = Char
c Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: (FilePath -> FilePath
unescape FilePath
rest)
escape :: String -> String
escape :: FilePath -> FilePath
escape [] = []
escape (' ':rest :: FilePath
rest) = ('\\'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:'0'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:'4'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:'0'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
escape FilePath
rest)
escape ('\t':rest :: FilePath
rest) = ('\\'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:'0'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:'1'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:'1'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
escape FilePath
rest)
escape ('\n':rest :: FilePath
rest) = ('\\'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:'0'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:'1'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:'2'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
escape FilePath
rest)
escape ('\\':rest :: FilePath
rest) = ('\\'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:'1'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:'3'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:'4'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
escape FilePath
rest)
escape (c :: Char
c:rest :: FilePath
rest) = Char
c Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: (FilePath -> FilePath
escape FilePath
rest)
umount :: [String] -> IO (ExitCode, String, String)
umount :: [FilePath] -> IO (ExitCode, FilePath, FilePath)
umount args :: [FilePath]
args = FilePath
-> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
readProcessWithExitCode "umount" [FilePath]
args ""
isMountPoint :: FilePath -> IO Bool
isMountPoint :: FilePath -> IO Bool
isMountPoint path :: FilePath
path =
do
Bool
exists <- FilePath -> IO Bool
doesDirectoryExist (FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "/.")
Bool
parentExists <- FilePath -> IO Bool
doesDirectoryExist (FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "/..")
case (Bool
exists, Bool
parentExists) of
(True, True) ->
do
DeviceID
id <- FilePath -> IO FileStatus
getFileStatus (FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "/.") 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]
++ "/..") 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 -> 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 p :: CreateProcess
p input :: ByteString
input = do
(code :: ExitCode
code, out :: ByteString
out, _err :: 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 n :: 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
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)
ExitSuccess -> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
out
withMount :: (MonadIO m, MonadMask m) => FilePath -> FilePath -> m a -> m a
withMount :: FilePath -> FilePath -> m a -> m a
withMount directory :: FilePath
directory mountpoint :: FilePath
mountpoint task :: 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 (\ _ -> m ByteString
post) (\ _ -> m a
task)
where
mount :: CreateProcess
mount = FilePath -> [FilePath] -> CreateProcess
proc "mount" ["--bind", FilePath
directory, FilePath
mountpoint]
umount :: CreateProcess
umount = FilePath -> [FilePath] -> CreateProcess
proc "umount" [FilePath
mountpoint]
umountLazy :: CreateProcess
umountLazy = FilePath -> [FilePath] -> CreateProcess
proc "umount" ["-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
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
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 ("Exception unmounting " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
mountpoint FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ", 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)
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 task :: 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)
withProcAndSys :: (MonadIO m, MonadMask m) => FilePath -> WithProcAndSys m a -> m a
withProcAndSys :: FilePath -> WithProcAndSys m a -> m a
withProcAndSys "/" task :: WithProcAndSys m a
task = WithProcAndSys m a -> m a
forall (m :: * -> *) a. WithProcAndSys m a -> m a
runWithProcAndSys WithProcAndSys m a
task
withProcAndSys root :: FilePath
root task :: 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
True -> FilePath -> FilePath -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> FilePath -> m a -> m a
withMount "/proc" (FilePath
root 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 "/sys" (FilePath
root 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
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 "chroot directory does not exist" Maybe Handle
forall a. Maybe a
Nothing (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
root)
withTmp :: (MonadIO m, MonadMask m) => FilePath -> m a -> m a
withTmp :: FilePath -> m a -> m a
withTmp root :: FilePath
root task :: m a
task = FilePath -> FilePath -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> FilePath -> m a -> m a
withMount "/tmp" (FilePath
root FilePath -> FilePath -> FilePath
</> "tmp") m a
task