{-# 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 -> String -> IO [(String, (ExitCode, String, String))]
umountBelow Bool
lazy String
belowPath =
do String
procMount <- String -> IO String
readFile String
"/proc/mounts"
let mountPoints :: [String]
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]
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 -> [String]
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]
[String]
needsUmount <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
isMountPoint [String]
maybeMounts
[(String, (ExitCode, String, String))]
results <- (String -> IO (String, (ExitCode, String, String)))
-> [String] -> IO [(String, (ExitCode, String, String))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
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)) [String]
needsUmount
let results' :: [(String, (ExitCode, String, String))]
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
(((String, (ExitCode, String, String)),
(String, (ExitCode, String, String)))
-> IO ())
-> [((String, (ExitCode, String, String)),
(String, (ExitCode, String, String)))]
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
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
""))) ([(String, (ExitCode, String, String))]
-> [(String, (ExitCode, String, String))]
-> [((String, (ExitCode, String, String)),
(String, (ExitCode, String, String)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(String, (ExitCode, String, String))]
results [(String, (ExitCode, String, String))]
results')
String
procMount' <- String -> IO String
readFile String
"/proc/mounts"
[(String, (ExitCode, String, String))]
results'' <- if String
procMount String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
procMount' then Bool -> String -> IO [(String, (ExitCode, String, String))]
umountBelow Bool
lazy String
belowPath else [(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))]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, (ExitCode, String, String))]
-> IO [(String, (ExitCode, String, String))])
-> [(String, (ExitCode, String, String))]
-> IO [(String, (ExitCode, String, String))]
forall a b. (a -> b) -> a -> b
$ [(String, (ExitCode, String, String))]
results' [(String, (ExitCode, String, String))]
-> [(String, (ExitCode, String, String))]
-> [(String, (ExitCode, String, String))]
forall a. [a] -> [a] -> [a]
++ [(String, (ExitCode, String, String))]
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 :: (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 :: 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 :: 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 :: [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
isMountPoint :: String -> IO Bool
isMountPoint String
path =
do
Bool
exists <- String -> IO Bool
doesDirectoryExist (String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/.")
Bool
parentExists <- String -> IO Bool
doesDirectoryExist (String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/..")
case (Bool
exists, Bool
parentExists) of
(Bool
True, Bool
True) ->
do
DeviceID
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
DeviceID
parentID <- 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
Bool -> IO Bool
forall a. a -> IO a
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 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
(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 -> 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
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
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
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)
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)
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
Bool
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 Bool
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)
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