{-# 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 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')
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 :: (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 :: 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 :: 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 :: [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
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)
_ ->
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
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
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 (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)
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)
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)
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