Unixutils-1.54.3/0000755000000000000000000000000007346545000012001 5ustar0000000000000000Unixutils-1.54.3/COPYING0000644000000000000000000000277307346545000013045 0ustar0000000000000000Copyright Jeremy Shaw, David Fox 2007-2010 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holder nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Unixutils-1.54.3/Setup.hs0000644000000000000000000000021007346545000013426 0ustar0000000000000000#!/usr/bin/runhaskell import Distribution.Simple import System.Process import System.Exit main = defaultMainWithHooks simpleUserHooks Unixutils-1.54.3/System/Unix/0000755000000000000000000000000007346545000014210 5ustar0000000000000000Unixutils-1.54.3/System/Unix/Chroot.hs0000644000000000000000000001205107346545000016001 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE CPP #-} -- | This module, except for useEnv, is copied from the build-env package. module System.Unix.Chroot ( fchroot , useEnv -- , forceList -- moved to progress -- , forceList' ) where import Control.Exception (evaluate) import Control.Monad.Catch (MonadMask, finally) import Control.Monad.Trans (MonadIO, liftIO) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as L import Foreign.C.Error import Foreign.C.String import System.Directory (createDirectoryIfMissing) import System.Exit (ExitCode(ExitSuccess)) import System.FilePath (dropTrailingPathSeparator, dropFileName) import System.IO (hPutStr, stderr) import System.Posix.Env (getEnv) import System.Posix.IO import System.Posix.Directory import System.Process (readProcessWithExitCode, showCommandForUser) foreign import ccall unsafe "chroot" c_chroot :: CString -> IO Int {-# DEPRECATED forceList "If you need forceList enable it in progress-System.Unix.Process." #-} forceList = undefined {-# DEPRECATED forceList' "If you need forceList' enable it in progress-System.Unix.Process." #-} forceList' = undefined -- |chroot changes the root directory to filepath -- NOTE: it does not change the working directory, just the root directory -- NOTE: will throw IOError if chroot fails chroot :: FilePath -> IO () chroot fp = withCString fp $ \cfp -> throwErrnoIfMinus1_ "chroot" (c_chroot cfp) -- |fchroot runs an IO action inside a chroot -- fchroot performs a chroot, runs the action, and then restores the -- original root and working directory. This probably affects the -- chroot and working directory of all the threads in the process, -- so... -- NOTE: will throw IOError if internal chroot fails fchroot :: (MonadIO m, MonadMask m) => FilePath -> m a -> m a fchroot path action = do origWd <- liftIO $ getWorkingDirectory #if MIN_VERSION_unix(2,8,0) rootFd <- liftIO $ openFd "/" ReadOnly defaultFileFlags #else rootFd <- liftIO $ openFd "/" ReadOnly Nothing defaultFileFlags #endif liftIO $ chroot path liftIO $ changeWorkingDirectory "/" action `finally` (liftIO $ breakFree origWd rootFd) where breakFree origWd rootFd = do changeWorkingDirectoryFd rootFd closeFd rootFd chroot "." changeWorkingDirectory origWd -- |The ssh inside of the chroot needs to be able to talk to the -- running ssh-agent. Therefore we mount --bind the ssh agent socket -- dir inside the chroot (and umount it when we exit the chroot. useEnv :: (MonadIO m, MonadMask m) => FilePath -> (a -> m a) -> m a -> m a useEnv rootPath force action = do -- In order to minimize confusion, this QIO message is output -- at default quietness. If you want to suppress it while seeing -- the output from your action, you need to say something like -- quieter (+ 1) (useEnv (quieter (\x->x-1) action)) sockPath <- liftIO $ getEnv "SSH_AUTH_SOCK" home <- liftIO $ getEnv "HOME" liftIO $ copySSH home -- We need to force the output before we exit the changeroot. -- Otherwise we lose our ability to communicate with the ssh -- agent and we get errors. withSock sockPath . fchroot rootPath $ (action >>= force) where copySSH Nothing = return () copySSH (Just home) = -- Do NOT preserve ownership, files must be owned by root. createDirectoryIfMissing True (rootPath ++ "/root") >> run "/usr/bin/rsync" ["-rlptgDHxS", "--delete", home ++ "/.ssh/", rootPath ++ "/root/.ssh"] withSock :: (MonadIO m, MonadMask m) => Maybe FilePath -> m a -> m a withSock Nothing action = action withSock (Just sockPath) action = withMountBind dir (rootPath ++ dir) action where dir = dropTrailingPathSeparator (dropFileName sockPath) withMountBind :: (MonadIO m, MonadMask m) => FilePath -> FilePath -> m a -> m a withMountBind toMount mountPoint action = (do liftIO $ createDirectoryIfMissing True mountPoint liftIO $ run "/bin/mount" ["--bind", escapePathForMount toMount, escapePathForMount mountPoint] action) `finally` (liftIO $ run "/bin/umount" [escapePathForMount mountPoint]) escapePathForMount = id -- FIXME - Path arguments should be escaped run cmd args = do (code, out, err) <- readProcessWithExitCode cmd args "" case code of ExitSuccess -> return () _ -> error ("Exception in System.Unix.Chroot.useEnv: " ++ showCommandForUser cmd args ++ " -> " ++ show code ++ "\n\nstdout:\n " ++ prefix "> " out ++ "\n\nstderr:\n" ++ prefix "> " err) prefix pre s = unlines (map (pre ++) (lines s)) {- printDots :: Int -> [Output] -> IO [Output] printDots cpd output = foldM f 0 output >> return output where print rem (Stdout s) = let (dots, rem') = quotRem (rem + length s) in hPutStr stderr (replicate dots '.') return rem' print rem (Stderr s) = print rem (Stdout s) -} Unixutils-1.54.3/System/Unix/Crypt.hs0000644000000000000000000000164207346545000015650 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} ----------------------------------------------------------------------------- -- | -- Module : System.Unix.Crypt -- Copyright : (c) 2010 -- License : BSD3 -- -- Maintainer : jeremy@seereason.com -- Stability : provisional -- Portability : non-portable (requires POSIX) -- -- support for crypt() and /etc/shadow -- ----------------------------------------------------------------------------- module System.Unix.Crypt ( crypt ) where import Foreign.C foreign import ccall unsafe "unistd.h crypt" c_crypt :: CString -> CString -> IO CString -- | calls crypt(3) crypt :: String -- ^ key -> String -- ^ salt -> IO String -- ^ encrypted password crypt key salt = withCString key $ \ckey -> withCString salt $ \csalt -> do cpassword <- throwErrnoIfNull "crypt" (c_crypt ckey csalt) peekCString cpassword Unixutils-1.54.3/System/Unix/Directory.hs0000644000000000000000000001433007346545000016511 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-} module System.Unix.Directory ( find , removeRecursiveSafely , unmountRecursiveSafely , renameFileWithBackup , withWorkingDirectory , withTemporaryDirectory , mkdtemp ) where import Control.Exception import Data.List (isSuffixOf) import System.Process import System.Directory import System.Exit import System.FilePath import System.IO import System.Posix.Files import System.Posix.Types import Foreign.C -- | Traverse a directory and return a list of all the (path, -- fileStatus) pairs. find :: FilePath -> IO [(FilePath, FileStatus)] find path = do status <- getSymbolicLinkStatus path case isDirectory status of True -> do subs <- getDirectoryContents path >>= return . map (path ) . filter (not . flip elem [".", ".."]) >>= mapM find >>= return . concat return $ (path, status) : subs False -> return [(path, status)] traverse :: FilePath -> (FilePath -> IO ()) -> (FilePath -> IO ()) -> (FilePath -> IO ()) -> IO () -- ^ Traverse a file system directory applying D to every directory, F -- to every non-directory file, and M to every mount point. -- NOTE: It is tempting to use the "find" function to returns a list -- of the elements of the directory and then map that list over an -- "unmount and remove" function. However, because we are unmounting -- as we traverse, the contents of the file list may change in ways -- that could confuse the find function. traverse path f d m = do result <- try $ getSymbolicLinkStatus path either (\ (_ :: SomeException) -> return ()) (doPath path) result where doPath path status = if isDirectory status then do getDirectoryContents path >>= mapM (doDirectoryFile 1 status path) d path else f path doDirectoryFile :: Int -> FileStatus -> FilePath -> String -> IO () doDirectoryFile _ _ _ "." = return () doDirectoryFile _ _ _ ".." = return () doDirectoryFile tries _ _ _ | tries >= 5 = error ("Couldn't unmount file system on " ++ path) doDirectoryFile tries status path name = do let child = path name childStatus <- getSymbolicLinkStatus child if deviceID status == deviceID childStatus then doPath child childStatus else do if tries > 1 then hPutStrLn stderr ("try " ++ show tries ++ ":") else return () m child doDirectoryFile (tries + 1) status path name -- |Recursively remove a directory contents on a single file system. -- The adjective \"Safely\" refers to these features: -- 1. It will not follow symlinks -- 2. If it finds a directory that seems to be a mount point, -- it will attempt to unmount it up to five times. If it -- still seems to be a mount point it gives up -- 3. It doesn't use /proc/mounts, which is ambiguous or wrong -- when you are inside a chroot. removeRecursiveSafely :: FilePath -> IO () removeRecursiveSafely path = System.Unix.Directory.traverse path removeFile removeDirectory umount where umount path = do hPutStrLn stderr ("-- removeRecursiveSafely: unmounting " ++ path) -- This is less likely to hang and more likely to succeed -- than regular umount. let cmd = "umount -l " ++ path result <- system cmd case result of ExitSuccess -> return () ExitFailure n -> error ("Failure: " ++ cmd ++ " -> " ++ show n) unmountRecursiveSafely :: FilePath -> IO () -- ^ Like removeRecursiveSafely but doesn't remove any files, just -- unmounts anything it finds mounted. Note that this can be much -- slower than Mount.umountBelow, use that instead. unmountRecursiveSafely path = System.Unix.Directory.traverse path noOp noOp umount where noOp _ = return () umount path = do hPutStrLn stderr ("-- unmountRecursiveSafely: unmounting " ++ path) -- This is less likely to hang and more likely to succeed -- than regular umount. let cmd = "umount -l " ++ path code <- system cmd case code of ExitSuccess -> return () ExitFailure n -> error ("Failure: " ++ cmd ++ " -> " ++ show n) -- |Rename src to dst, and if dst already exists move it to dst~. -- If dst~ exists it is removed. renameFileWithBackup :: FilePath -> FilePath -> IO () renameFileWithBackup src dst = do removeIfExists (dst ++ "~") renameIfExists dst (dst ++ "~") System.Directory.renameFile src dst where removeIfExists path = do exists <- doesFileExist path if exists then removeFile path else return () renameIfExists src dst = do exists <- doesFileExist src if exists then System.Directory.renameFile src dst else return () -- |temporarily change the working directory to |dir| while running |action| withWorkingDirectory :: FilePath -> IO a -> IO a withWorkingDirectory dir action = bracket getCurrentDirectory setCurrentDirectory (\ _ -> setCurrentDirectory dir >> action) -- |create a temporary directory, run the action, remove the temporary directory -- the first argument is a template for the temporary directory name -- the directory will be created as a subdirectory of the directory returned by getTemporaryDirectory -- the temporary directory will be automatically removed afterwards. -- your working directory is not altered withTemporaryDirectory :: FilePath -> (FilePath -> IO a) -> IO a withTemporaryDirectory fp f = do sysTmpDir <- getTemporaryDirectory bracket (mkdtemp (sysTmpDir fp)) removeRecursiveSafely f foreign import ccall unsafe "stdlib.h mkdtemp" c_mkdtemp :: CString -> IO CString mkdtemp :: FilePath -> IO FilePath mkdtemp template = withCString (if "XXXXXX" `isSuffixOf` template then template else (template ++ "XXXXXX")) $ \ ptr -> do cname <- throwErrnoIfNull "mkdtemp" (c_mkdtemp ptr) name <- peekCString cname return name Unixutils-1.54.3/System/Unix/FilePath.hsc0000644000000000000000000000206207346545000016403 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} -- | The function splitFileName is taken from missingh, at the moment -- missingh will not build under sid. module System.Unix.FilePath (dirName, baseName, realpath, (<++>)) where import Data.List import System.FilePath (makeRelative, (), takeFileName, dropFileName) --import Text.Regex import Foreign.C import Foreign.Marshal.Array #include #include -- |Concatenate two paths, making sure there is exactly one path separator. a <++> b = a (makeRelative "" b) -- |Use dropFileName dirName :: FilePath -> FilePath dirName = dropFileName -- |Use takeFileName baseName :: FilePath -> String baseName = takeFileName -- |resolve all references to /./, /../, extra slashes, and symlinks realpath :: FilePath -> IO FilePath realpath fp = withCString fp $ \cfp -> allocaArray (#const PATH_MAX) $ \res -> throwErrnoIfNull "realpath" (c_realpath cfp res) >>= peekCString foreign import ccall unsafe "realpath" c_realpath :: CString -> CString -> IO CString Unixutils-1.54.3/System/Unix/Files.hs0000644000000000000000000000114207346545000015604 0ustar0000000000000000module System.Unix.Files where import Control.Exception (catch) import Prelude hiding (catch) import System.Posix.Files (createSymbolicLink, removeLink) import System.IO.Error (isAlreadyExistsError) -- |calls 'createSymbolicLink' but will remove the target and retry if -- 'createSymbolicLink' raises EEXIST. forceSymbolicLink :: FilePath -> FilePath -> IO () forceSymbolicLink target linkName = createSymbolicLink target linkName `catch` (\e -> if isAlreadyExistsError e then do removeLink linkName createSymbolicLink target linkName else ioError e) Unixutils-1.54.3/System/Unix/KillByCwd.hs0000644000000000000000000000313607346545000016373 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} -- |A place to collect and hopefully retire all the random ways of -- running shell commands that have accumulated over the years. module System.Unix.KillByCwd ( killByCwd ) where import Control.Exception (catch) import Control.Monad (liftM, filterM) import Data.Char (isDigit) import Data.List (isPrefixOf) import Prelude hiding (catch) import System.Directory (getDirectoryContents) import System.Posix.Files (readSymbolicLink) import System.Posix.Signals (signalProcess, sigTERM) {- NOTE: + We should make sure this works if we are inside a chroot. + path needs to be absolute or we might kill processes living in similarly named, but different directories. + path is an canoncialised, absolute path, such as what realpath returns -} -- | Kill the processes whose working directory is in or under the -- given directory. killByCwd :: FilePath -> IO [(String, Maybe String)] killByCwd path = do pids <- liftM (filter (all isDigit)) (getDirectoryContents "/proc") cwdPids <- filterM (isCwd path) pids exePaths <- mapM exePath cwdPids mapM_ kill cwdPids return (zip cwdPids exePaths) where isCwd :: FilePath -> String -> IO Bool isCwd cwd pid = (liftM (isPrefixOf cwd) (readSymbolicLink ("/proc/" ++ pid ++"/cwd"))) `catch` (\ (_ :: IOError) -> return False) exePath :: String -> IO (Maybe String) exePath pid = (readSymbolicLink ("/proc/" ++ pid ++"/exe") >>= return . Just) `catch` (\ (_ :: IOError) -> return Nothing) kill :: String -> IO () kill pidStr = signalProcess sigTERM (read pidStr) Unixutils-1.54.3/System/Unix/Misc.hs0000644000000000000000000000345607346545000015447 0ustar0000000000000000-- |Wrappers around some handy unix shell commands. Please let -- me know if you think of better module names to hold these -- functions. -dsf module System.Unix.Misc ( md5sum , gzip) where import Control.Exception import qualified Codec.Compression.GZip import Data.ByteString.Lazy.Char8 (empty, readFile, writeFile) import Data.Digest.Pure.MD5 (md5) import Data.Maybe import System.Process import System.Directory import System.Exit import System.IO import System.Posix.Files import System.Process -- | Deprecated: Use @Data.ByteString.Lazy.Char8.readFile path >>= return . show . Data.Digest.Pure.MD5.md5@ {-# DEPRECATED md5sum "Use Data.ByteString.Lazy.Char8.readFile path >>= return . show . Data.Digest.Pure.MD5.md5" #-} md5sum :: FilePath -> IO String md5sum path = Data.ByteString.Lazy.Char8.readFile path >>= return . show . md5 {- do (text, _, exitCode) <- lazyProcess "md5sum" [path] Nothing Nothing empty >>= return . collectOutputUnpacked let output = listToMaybe (words text) case exitCode of ExitSuccess -> case output of Nothing -> error ("Error in output of 'md5sum " ++ path ++ "'") Just checksum -> return checksum _ -> error ("Error running 'md5sum " ++ path ++ "'") -} -- | Deprecated: Use @Data.ByteString.Lazy.Char8.readFile path >>= Data.ByteString.Lazy.Char8.writeFile (path ++ \".gz\")@ {-# DEPRECATED gzip "Use Data.ByteString.Lazy.Char8.readFile path >>= Data.ByteString.Lazy.Char8.writeFile (path ++ \".gz\")" #-} gzip :: FilePath -> IO () gzip path = Data.ByteString.Lazy.Char8.readFile path >>= Data.ByteString.Lazy.Char8.writeFile (path ++ ".gz") {- do result <- system ("gzip < " ++ path ++ " > " ++ path ++ ".gz") case result of ExitSuccess -> return () e -> error (show e) -} Unixutils-1.54.3/System/Unix/Mount.hs0000644000000000000000000002160307346545000015650 0ustar0000000000000000{-# 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 , withMount , WithProcAndSys(runWithProcAndSys) , withProcAndSys , withTmp ) where -- Standard GHC modules 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 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. -- rf path = lazyCommand ("cat '" ++ path ++ "'") empty >>= return . (\ (o, _, _) -> o) . collectOutputUnpacked -- |'umountBelow' - unmounts all mount points below /belowPath/ -- \/proc\/mounts must be present and readable. Because of the way -- linux handles changeroots, we can't trust everything we see in -- \/proc\/mounts. However, we make the following assumptions: -- -- (1) there is a one-to-one correspondence between the entries in -- \/proc\/mounts and the actual mounts, and -- (2) every mount point we might encounter is a suffix of one of -- the mount points listed in \/proc\/mounts (because being in a -- a chroot doesn't affect \/proc\/mounts.) -- -- So we can search \/proc\/mounts for an entry has the mount point -- we are looking for as a substring, then add the extra text on -- the right to our path and try to unmount that. Then we start -- again since nested mounts might have been revealed. -- -- For example, suppose we are chrooted into -- \/home\/david\/environments\/sid and we call "umountBelow \/proc". We -- might see the mount point \/home\/david\/environments\/sid\/proc\/bus\/usb -- in \/proc\/mounts, which means we need to run "umount \/proc\/bus\/usb". -- -- See also: 'umountSucceeded' umountBelow :: Bool -- ^ Lazy (umount -l flag) if true -> FilePath -- ^ canonicalised, absolute path -> IO [(FilePath, (ExitCode, String, String))] -- ^ paths that we attempted to umount, and the responding output from the umount command umountBelow lazy belowPath = do procMount <- readFile "/proc/mounts" let mountPoints = map (unescape . (!! 1) . words) (lines procMount) maybeMounts = filter (isPrefixOf belowPath) (concat (map tails mountPoints)) args path = ["-f"] ++ if lazy then ["-l"] else [] ++ [path] needsUmount <- filterM isMountPoint maybeMounts results <- mapM (\ path -> hPutStrLn stderr ("umountBelow: umount " ++ intercalate " " (args path)) >> umount (args path) >>= return . ((,) path)) needsUmount let results' = map fixNotMounted results mapM_ (\ (result, result') -> hPutStrLn stderr (show result ++ (if result /= result' then " -> " ++ show result' else ""))) (zip results results') -- Did /proc/mounts change? If so we should try again because -- nested mounts might have been revealed. procMount' <- readFile "/proc/mounts" results'' <- if procMount /= procMount' then umountBelow lazy belowPath else return [] return $ results' ++ results'' where fixNotMounted (path, (ExitFailure 1, "", err)) | err == ("umount: " ++ path ++ ": not mounted\n") = (path, (ExitSuccess, "", "")) fixNotMounted x = x -- |umountSucceeded - predicated suitable for filtering results of 'umountBelow' umountSucceeded :: (FilePath, (String, String, ExitCode)) -> Bool umountSucceeded (_, (_,_,ExitSuccess)) = True umountSucceeded _ = False -- |'unescape' - unescape function for strings in \/proc\/mounts unescape :: String -> String unescape [] = [] unescape ('\\':'0':'4':'0':rest) = ' ' : (unescape rest) unescape ('\\':'0':'1':'1':rest) = '\t' : (unescape rest) unescape ('\\':'0':'1':'2':rest) = '\n' : (unescape rest) unescape ('\\':'1':'3':'4':rest) = '\\' : (unescape rest) unescape (c:rest) = c : (unescape rest) -- |'escape' - \/proc\/mount style string escaper escape :: String -> String escape [] = [] escape (' ':rest) = ('\\':'0':'4':'0':escape rest) escape ('\t':rest) = ('\\':'0':'1':'1':escape rest) escape ('\n':rest) = ('\\':'0':'1':'2':escape rest) escape ('\\':rest) = ('\\':'1':'3':'4':escape rest) escape (c:rest) = c : (escape rest) -- |'umount' - run umount with the specified args -- NOTE: this function uses exec, so you do /not/ need to shell-escape -- NOTE: we don't use the umount system call because the system call -- is not smart enough to update \/etc\/mtab umount :: [String] -> IO (ExitCode, String, String) umount args = readProcessWithExitCode "umount" args "" isMountPoint :: FilePath -> IO Bool -- This implements the functionality of mountpoint(1), deciding -- whether a path is a mountpoint by seeing whether it is on a -- different device from its parent. It would fail if a file system -- is mounted directly inside itself, but I think maybe that isn't -- allowed. isMountPoint path = do exists <- doesDirectoryExist (path ++ "/.") parentExists <- doesDirectoryExist (path ++ "/..") case (exists, parentExists) of (True, True) -> do id <- getFileStatus (path ++ "/.") >>= return . deviceID parentID <- getFileStatus (path ++ "/..") >>= return . deviceID return $ id /= parentID _ -> -- 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 Unixutils-1.54.3/System/Unix/SpecialDevice.hs0000644000000000000000000002075107346545000017251 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeSynonymInstances #-} -- | Construct an ADT representing block and character devices -- (but mostly block devices) by interpreting the contents of -- the Linux sysfs filesystem. module System.Unix.SpecialDevice (SpecialDevice, sysMountPoint, -- IO String ofNode, -- FilePath -> IO (Maybe SpecialDevice) ofNodeStatus, -- FileStatus -> Maybe SpecialDevice ofPath, -- FilePath -> IO (Maybe SpecialDevice) rootPart, -- IO (Maybe SpecialDevice) ofDevNo, -- (DeviceID -> SpecialDevice) -> Int -> SpecialDevice ofSysName, -- String -> IO (Maybe SpecialDevice) ofSysPath, -- (DeviceID -> SpecialDevice) -> FilePath -> IO (Maybe SpecialDevice) toDevno, -- SpecialDevice -> Int --major, -- SpecialDevice -> Int --minor, -- SpecialDevice -> Int ofMajorMinor, -- (DeviceID -> SpecialDevice) -> Int -> Int -> SpecialDevice node, -- SpecialDevice -> IO (Maybe FilePath) nodes, -- SpecialDevice -> IO [FilePath] sysName, -- SpecialDevice -> IO (Maybe String) splitPart, -- String -> (String, Int) sysDir, -- SpecialDevice -> IO (Maybe FilePath) diskOfPart, -- SpecialDevice -> IO (Maybe SpecialDevice) getAllDisks, -- IO [SpecialDevice] getAllPartitions, -- IO [SpecialDevice] getAllCdroms, -- IO [SpecialDevice] getAllRemovable, -- IO [SpecialDevice] -- toDevName, -- getBlkidAlist, -- getBlkidInfo, -- deviceOfUuid, -- devicesOfLabel, -- updateBlkidFns, -- update ) where import Control.Exception import System.IO import System.Directory import Data.Char import Data.List import Data.Maybe import System.FilePath import System.Posix.Types import System.Posix.Files import System.Posix.User import Text.Regex.TDFA data SpecialDevice = BlockDevice DeviceID | CharacterDevice DeviceID deriving (Show, Ord, Eq) -- | FIXME: We should really get this value from the mount table. sysMountPoint :: FilePath sysMountPoint = "/sys" ofPath :: FilePath -> IO (Maybe SpecialDevice) ofPath path = -- Catch the exception thrown on an invalid symlink (try $ getFileStatus path) >>= return . either (\ (_ :: SomeException) -> Nothing) (Just . BlockDevice . deviceID) rootPart :: IO (Maybe SpecialDevice) rootPart = ofPath "/" -- | Return the device represented by a device node, such as \/dev\/sda2. -- Returns Nothing if there is an exception trying to stat the node, or -- if the node turns out not to be a special device. ofNode :: FilePath -> IO (Maybe SpecialDevice) ofNode "/dev/root" = ofPath "/" ofNode node = (try $ getFileStatus node) >>= return . either (\ (_ :: SomeException) -> Nothing) ofNodeStatus ofNodeStatus :: FileStatus -> Maybe SpecialDevice ofNodeStatus status = if isBlockDevice status then (Just . BlockDevice . specialDeviceID $ status) else if isCharacterDevice status then (Just . CharacterDevice . specialDeviceID $ status) else Nothing ofSysName :: String -> IO (Maybe SpecialDevice) ofSysName name = do paths <- directory_find False (sysMountPoint ++ "/block") >>= return . map fst . filter isDev case filter (\ x -> basename (dirname x) == name) paths of [path] -> ofSysPath BlockDevice (dirname path) where isDev (path, status) = basename path == "dev" ofSysPath :: (DeviceID -> SpecialDevice) -> FilePath -> IO (Maybe SpecialDevice) ofSysPath typ path = readFile (path ++ "/dev") >>= return . parseSysDevFile typ parseSysDevFile :: (DeviceID -> SpecialDevice) -> String -> Maybe SpecialDevice parseSysDevFile typ text = case filter (all isDigit) . groupBy (\ a b -> isDigit a && isDigit b) $ text of [major, minor] -> Just (ofMajorMinor typ (read major) (read minor)) _ -> Nothing ofMajorMinor :: (DeviceID -> SpecialDevice) -> Int -> Int -> SpecialDevice ofMajorMinor typ major minor = ofDevNo typ $ major * 256 + minor ofDevNo :: (DeviceID -> SpecialDevice) -> Int -> SpecialDevice ofDevNo typ n = typ . fromInteger . toInteger $ n {- major :: SpecialDevice -> Integer major dev = toInteger (toDevno dev) minor :: SpecialDevice -> Int minor dev = mod (fromInteger (toInteger (toDevno dev))) 256 -} toDevno :: SpecialDevice -> DeviceID toDevno (BlockDevice n) = n toDevno (CharacterDevice n) = n node :: SpecialDevice -> IO (Maybe FilePath) node dev@(BlockDevice _) = nodes dev >>= return . listToMaybe nodes :: SpecialDevice -> IO [FilePath] nodes dev@(BlockDevice _) = do pairs <- directory_find True "/dev" >>= return . filter (not . isPrefixOf "/dev/.static/" . fst) . filter (not . isPrefixOf "/dev/.udevdb/" . fst) let pairs' = filter (\ (node, status) -> (ofNodeStatus status) == Just dev) pairs return . map fst $ pairs' where mapSnd f (a, b) = (a, f b) splitPart :: String -> (String, Int) splitPart name = mapSnd read (break isDigit name) where mapSnd f (a, b) = (a, f b) diskOfPart :: SpecialDevice -> IO (Maybe SpecialDevice) diskOfPart part = sysName part >>= return . maybe Nothing (Just . fst . splitPart) >>= maybe (return Nothing) ofSysName sysName :: SpecialDevice -> IO (Maybe String) sysName dev = sysDir dev >>= return . maybe Nothing (Just . basename) sysDir :: SpecialDevice -> IO (Maybe FilePath) sysDir dev@(BlockDevice _) = do (pairs' :: [(FilePath, FileStatus)]) <- directory_find False (sysMountPoint ++ "/block") let (paths :: [FilePath]) = map fst . filter isDev $ pairs' devs <- mapM readFile paths >>= return . map (parseSysDevFile BlockDevice) let pairs = zip devs (map dirname paths) return . lookup (Just dev) $ pairs where isDev (path, status) = basename path == "dev" diskGroup :: IO GroupID diskGroup = getGroupEntryForName "disk" >>= return . groupID cdromGroup :: IO GroupID cdromGroup = getGroupEntryForName "cdrom" >>= return . groupID -- | Removable devices, such as USB keys, are in this group. floppyGroup :: IO GroupID floppyGroup = getGroupEntryForName "floppy" >>= return . groupID getDisksInGroup :: GroupID -> IO [SpecialDevice] getDisksInGroup group = directory_find True "/dev/disk/by-path" >>= return . filter (inGroup group) >>= return . catMaybes . map (ofNodeStatus . snd) where inGroup group (_, status) = fileGroup status == group getAllDisks :: IO [SpecialDevice] getAllDisks = do group <- diskGroup devs <- directory_find True "/dev/disk/by-path" >>= return . filter (not . isPart) . filter (inGroup group) >>= return . map (ofNodeStatus . snd) return (catMaybes devs) where inGroup group (_, status) = fileGroup status == group getAllPartitions :: IO [SpecialDevice] getAllPartitions = directory_find True "/dev/disk/by-path" >>= return . filter isPart >>= return . catMaybes . map (ofNodeStatus . snd) isPart :: (FilePath, FileStatus) -> Bool isPart (path, _) = case path =~ "-part[0-9]+$" of x | mrMatch x == "" -> False x -> True getAllCdroms :: IO [SpecialDevice] getAllCdroms = cdromGroup >>= getDisksInGroup getAllRemovable :: IO [SpecialDevice] getAllRemovable = floppyGroup >>= getDisksInGroup -- ofNode "/dev/sda1" >>= maybe (return Nothing) sysDir >>= putStrLn . show -- -> Just "/sys/block/sda/sda1/dev" -- | Traverse a directory and return a list of all the (path, -- fileStatus) pairs. directory_find :: Bool -> FilePath -> IO [(FilePath, FileStatus)] directory_find follow path = if follow then fileStatus else linkStatus where fileStatus = try (getFileStatus path) >>= either (\ (_ :: SomeException) -> return []) useStatus linkStatus = getSymbolicLinkStatus path >>= useStatus useStatus status | isDirectory status = do -- Catch the exception thrown if we lack read permission subs <- (try $ getDirectoryContents path) >>= return . either (\ (_ :: SomeException) -> []) id >>= return . map (path ) . filter (not . flip elem [".", ".."]) >>= mapM (directory_find follow) >>= return . concat return $ (path, status) : subs | True = return [(path, status)] dirname path = reverse . tail . snd . break (== '/') . reverse $ path basename path = reverse . fst . break (== '/') . reverse $ path Unixutils-1.54.3/Unixutils.cabal0000644000000000000000000000217307346545000014774 0ustar0000000000000000Name: Unixutils Version: 1.54.3 License: BSD3 License-File: COPYING Author: Jeremy Shaw, David Fox Homepage: https://github.com/seereason/haskell-unixutils.git Category: System Synopsis: A crude interface between Haskell and Unix-like operating systems Maintainer: David Fox Description: A collection of useful and mildly useful functions that you might expect to find in System.* which a heavy bias towards Unix-type operating systems. Build-type: Simple Cabal-Version: >= 1.10 Library Default-Language: Haskell2010 Build-Depends: base >= 4.6 && <5, bytestring, directory, exceptions, filepath, mtl, process, process-extras >= 0.3, pureMD5, regex-tdfa, unix, zlib Exposed-modules: System.Unix.Chroot, System.Unix.Crypt, System.Unix.Directory, System.Unix.FilePath, System.Unix.KillByCwd, System.Unix.Misc, System.Unix.Mount, System.Unix.SpecialDevice, System.Unix.Files if !os(darwin) Extra-libraries: crypt