{-# 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 = forall a b. (a -> b) -> [a] -> [b]
map (String -> String
unescape forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> Int -> a
!! Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words) (String -> [String]
lines String
procMount)
maybeMounts :: [String]
maybeMounts = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
belowPath) (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b. (a -> b) -> [a] -> [b]
map forall a. [a] -> [[a]]
tails [String]
mountPoints))
args :: String -> [String]
args String
path = [String
"-f"] forall a. [a] -> [a] -> [a]
++ if Bool
lazy then [String
"-l"] else [] forall a. [a] -> [a] -> [a]
++ [String
path]
[String]
needsUmount <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
isMountPoint [String]
maybeMounts
[(String, (ExitCode, String, String))]
results <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ String
path -> Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"umountBelow: umount " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
" " (String -> [String]
args String
path)) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> IO (ExitCode, String, String)
umount (String -> [String]
args String
path) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((,) String
path)) [String]
needsUmount
let results' :: [(String, (ExitCode, String, String))]
results' = forall a b. (a -> b) -> [a] -> [b]
map (String, (ExitCode, String, String))
-> (String, (ExitCode, String, String))
fixNotMounted [(String, (ExitCode, String, String))]
results
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 (forall a. Show a => a -> String
show (String, (ExitCode, String, String))
result forall a. [a] -> [a] -> [a]
++ (if (String, (ExitCode, String, String))
result forall a. Eq a => a -> a -> Bool
/= (String, (ExitCode, String, String))
result' then String
" -> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (String, (ExitCode, String, String))
result' else 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 forall a. Eq a => a -> a -> Bool
/= String
procMount' then Bool -> String -> IO [(String, (ExitCode, String, String))]
umountBelow Bool
lazy String
belowPath else forall (m :: * -> *) a. Monad m => a -> m a
return []
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(String, (ExitCode, String, String))]
results' 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 forall a. Eq a => a -> a -> Bool
== (String
"umount: " forall a. [a] -> [a] -> [a]
++ String
path 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
' ' forall a. a -> [a] -> [a]
: (String -> String
unescape String
rest)
unescape (Char
'\\':Char
'0':Char
'1':Char
'1':String
rest) = Char
'\t' forall a. a -> [a] -> [a]
: (String -> String
unescape String
rest)
unescape (Char
'\\':Char
'0':Char
'1':Char
'2':String
rest) = Char
'\n' forall a. a -> [a] -> [a]
: (String -> String
unescape String
rest)
unescape (Char
'\\':Char
'1':Char
'3':Char
'4':String
rest) = Char
'\\' forall a. a -> [a] -> [a]
: (String -> String
unescape String
rest)
unescape (Char
c:String
rest) = Char
c forall a. a -> [a] -> [a]
: (String -> String
unescape String
rest)
escape :: String -> String
escape :: String -> String
escape [] = []
escape (Char
' ':String
rest) = (Char
'\\'forall a. a -> [a] -> [a]
:Char
'0'forall a. a -> [a] -> [a]
:Char
'4'forall a. a -> [a] -> [a]
:Char
'0'forall a. a -> [a] -> [a]
:String -> String
escape String
rest)
escape (Char
'\t':String
rest) = (Char
'\\'forall a. a -> [a] -> [a]
:Char
'0'forall a. a -> [a] -> [a]
:Char
'1'forall a. a -> [a] -> [a]
:Char
'1'forall a. a -> [a] -> [a]
:String -> String
escape String
rest)
escape (Char
'\n':String
rest) = (Char
'\\'forall a. a -> [a] -> [a]
:Char
'0'forall a. a -> [a] -> [a]
:Char
'1'forall a. a -> [a] -> [a]
:Char
'2'forall a. a -> [a] -> [a]
:String -> String
escape String
rest)
escape (Char
'\\':String
rest) = (Char
'\\'forall a. a -> [a] -> [a]
:Char
'1'forall a. a -> [a] -> [a]
:Char
'3'forall a. a -> [a] -> [a]
:Char
'4'forall a. a -> [a] -> [a]
:String -> String
escape String
rest)
escape (Char
c:String
rest) = Char
c 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 forall a. [a] -> [a] -> [a]
++ String
"/.")
Bool
parentExists <- String -> IO Bool
doesDirectoryExist (String
path 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 forall a. [a] -> [a] -> [a]
++ String
"/.") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> DeviceID
deviceID
DeviceID
parentID <- String -> IO FileStatus
getFileStatus (String
path forall a. [a] -> [a] -> [a]
++ String
"/..") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> DeviceID
deviceID
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DeviceID
id forall a. Eq a => a -> a -> Bool
/= DeviceID
parentID
(Bool, 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) <- 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 -> forall a. IOError -> IO a
ioError (IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
OtherError (CreateProcess -> String
showCreateProcessForUser CreateProcess
p forall a. [a] -> [a] -> [a]
++ String
" -> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n) forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
ExitCode
ExitSuccess -> 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 =
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 = 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
CreateProcess -> ByteString -> IO ByteString
readProcess CreateProcess
umount ByteString
L.empty
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 " forall a. [a] -> [a] -> [a]
++ String
mountpoint forall a. [a] -> [a] -> [a]
++ String
", trying -l: " forall a. [a] -> [a] -> [a]
++ 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 -> 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
<$ :: forall a b. a -> WithProcAndSys m b -> WithProcAndSys m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> WithProcAndSys m b -> WithProcAndSys m a
fmap :: forall a b. (a -> b) -> WithProcAndSys m a -> WithProcAndSys m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> WithProcAndSys m a -> WithProcAndSys m b
Functor, 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 :: forall a. a -> WithProcAndSys m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> WithProcAndSys m a
>> :: forall a b.
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
>>= :: forall a 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
Monad, 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
<* :: forall a b.
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
*> :: 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 b
liftA2 :: forall a b c.
(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
<*> :: forall a b.
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 :: forall a. a -> WithProcAndSys m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> WithProcAndSys m a
Applicative)
instance MonadTrans WithProcAndSys where
lift :: forall (m :: * -> *) a. Monad m => m a -> WithProcAndSys m a
lift = 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 = forall (m :: * -> *) a. m a -> WithProcAndSys m a
WithProcAndSys (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 = forall (m :: * -> *) a. WithProcAndSys m a -> m a
runWithProcAndSys WithProcAndSys m a
task
withProcAndSys String
root WithProcAndSys m a
task = do
Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
root
case Bool
exists of
Bool
True -> forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> String -> m a -> m a
withMount String
"/proc" (String
root String -> String -> String
</> String
"proc") forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> String -> m a -> m a
withMount String
"/sys" (String
root String -> String -> String
</> String
"sys") forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. WithProcAndSys m a -> m a
runWithProcAndSys WithProcAndSys m a
task
Bool
False -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IOError -> IO a
ioError forall a b. (a -> b) -> a -> b
$ IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
doesNotExistErrorType String
"chroot directory does not exist" forall a. Maybe a
Nothing (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 = 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