Unixutils 1.52.4 → 1.53

raw patch · 2 files changed

+96/−9 lines, 2 filesdep +exceptionsdep +mtldep +process-extrasdep ~basedep ~processPVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions, mtl, process-extras

Dependency ranges changed: base, process

API changes (from Hackage documentation)

Files

• System/Unix/Mount.hs +81/−6
• Unixutils.cabal +15/−3

@@ -1,10 +1,16 @@+{-# 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-    where+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@@ -16,6 +22,21 @@ 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.@@ -78,7 +99,7 @@ unescape ('\\':'1':'3':'4':rest) = '\\' : (unescape rest) unescape (c:rest) = c : (unescape rest) --- |'escape' - \/proc\/mount stytle string escaper+-- |'escape' - \/proc\/mount style string escaper escape :: String -> String escape [] = [] escape (' ':rest)  = ('\\':'0':'4':'0':escape rest)@@ -115,3 +136,57 @@             -- It is hard to know what is going on if . or .. don't exist.             -- Assume we are seeing some sort of mount point.             return True++readProcess :: CreateProcess -> L.ByteString -> IO L.ByteString+readProcess p input = do+  (code, out, _err) <- readCreateProcess p input :: IO (ExitCode, L.ByteString, L.ByteString)+  case code of+    ExitFailure n -> ioError (mkIOError OtherError (showCreateProcessForUser p ++ " -> " ++ show n) Nothing Nothing)+    ExitSuccess -> return 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 directory mountpoint task =+    bracket pre (\ _ -> post) (\ _ -> task)+    where+      mount = proc "mount" ["--bind", directory, mountpoint]+      umount = proc "umount" [mountpoint]+      umountLazy = proc "umount" ["-l", mountpoint]++      pre = liftIO $ do -- hPutStrLn stderr $ "mounting /proc at " ++ show mountpoint+                        createDirectoryIfMissing True mountpoint+                        readProcess mount L.empty++      post = liftIO $ do -- hPutStrLn stderr $ "unmounting /proc at " ++ show mountpoint+                         readProcess umount L.empty+                           `catch` (\ (e :: IOError) ->+                                        do hPutStrLn stderr ("Exception unmounting " ++ mountpoint ++ ", trying -l: " ++ show e)+                                           readProcess umountLazy L.empty)++-- | Monad transformer to ensure that /proc and /sys are mounted+-- during a computation.+newtype WithProcAndSys m a = WithProcAndSys { runWithProcAndSys :: m a } deriving (Functor, Monad, Applicative)++instance MonadTrans WithProcAndSys where+    lift = WithProcAndSys++instance MonadIO m => MonadIO (WithProcAndSys m) where+    liftIO task = WithProcAndSys (liftIO 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 "/" task = runWithProcAndSys task+withProcAndSys root task = do+  exists <- liftIO $ doesDirectoryExist root+  case exists of+    True -> withMount "/proc" (root </> "proc") $ withMount "/sys" (root </> "sys") $ runWithProcAndSys task+    False -> liftIO $ ioError $ mkIOError doesNotExistErrorType "chroot directory does not exist" Nothing (Just 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 root task = withMount "/tmp" (root </> "tmp") task

@@ -1,5 +1,5 @@ Name:           Unixutils-Version:        1.52.4+Version:        1.53 License:        BSD3 License-File:	COPYING Author:         Jeremy Shaw, David Fox@@ -13,8 +13,20 @@ Build-type:	Simple Cabal-Version: >= 1.2 -Library -    Build-Depends:  base >= 4 && <5, bytestring, directory, filepath, process, pureMD5, regex-tdfa, unix, zlib+Library+    Build-Depends:+      base >= 4 && <5,+      bytestring,+      directory,+      exceptions,+      filepath,+      mtl,+      process,+      process-extras,+      pureMD5,+      regex-tdfa,+      unix,+      zlib     ghc-options:	-O2     Exposed-modules:         System.Unix.Chroot,