diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +#!/usr/bin/runhaskell + +import Distribution.Simple + +main = defaultMainWithHooks defaultUserHooks diff --git a/System/Unix/Directory.hs b/System/Unix/Directory.hs new file mode 100644 --- /dev/null +++ b/System/Unix/Directory.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module System.Unix.Directory + ( find + , removeRecursiveSafely + , unmountRecursiveSafely + , renameFileWithBackup + , withWorkingDirectory + , withTemporaryDirectory + , mkdtemp + ) + where + +import Control.Exception +import Data.List (isSuffixOf) +import System.Cmd +import System.Directory +import System.Exit +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 (\ _ -> 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 = + 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 = + 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 diff --git a/System/Unix/FilePath.hsc b/System/Unix/FilePath.hsc new file mode 100644 --- /dev/null +++ b/System/Unix/FilePath.hsc @@ -0,0 +1,113 @@ +{-# 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, + -- * From MissingH + splitFileName) + where + +import Data.List +import Text.Regex +import Foreign.C +import Foreign.Marshal.Array + +#include +#include + +(+/+) :: FilePath -> FilePath -> FilePath +(+/+) path1 "" = path1 +(+/+) "" path2 = path2 +(+/+) path1 path2 = + case (head (reverse path1), head path2) of + ('/', '/') -> path1 ++ drop 1 path2 + (_, '/') -> path1 ++ path2 + ('/', _) -> path1 ++ path2 + (_, _) -> path1 ++ "/" ++ path2 + +dirName :: FilePath -> FilePath +dirName path = fst (splitFileName path) + +baseName :: FilePath -> String +baseName path = snd (splitFileName path) + +canon :: FilePath -> FilePath +-- ^ Weak attempt at canonicalizing a file path. +canon path = + let re = mkRegex "/" in + let names = splitRegex re path in + concat (intersperse "/" (merge names)) + where + merge (".." : xs) = ".." : (merge xs) + merge ("." : xs) = "." : (merge xs) + merge (_ : ".." : xs) = (merge xs) + merge (x : "." : xs) = (merge (x : xs)) + merge (x : xs) = x : merge xs + merge [] = [] + +-------------- From MissingH -------------- + + +-- | Split the path into directory and file name +-- +-- Examples: +-- +-- \[Posix\] +-- +-- > splitFileName "/" == ("/", ".") +-- > splitFileName "/foo/bar.ext" == ("/foo", "bar.ext") +-- > splitFileName "bar.ext" == (".", "bar.ext") +-- > splitFileName "/foo/." == ("/foo", ".") +-- > splitFileName "/foo/.." == ("/foo", "..") +-- +-- \[Windows\] +-- +-- > splitFileName "\\" == ("\\", "") +-- > splitFileName "c:\\foo\\bar.ext" == ("c:\\foo", "bar.ext") +-- > splitFileName "bar.ext" == (".", "bar.ext") +-- > splitFileName "c:\\foo\\." == ("c:\\foo", ".") +-- > splitFileName "c:\\foo\\.." == ("c:\\foo", "..") +-- +-- The first case in the Windows examples returns an empty file name. +-- This is a special case because the \"\\\\\" path doesn\'t refer to +-- an object (file or directory) which resides within a directory. +splitFileName :: FilePath -> (String, String) +splitFileName p = (reverse path1, reverse fname1) + where + (fname,path) = break isPathSeparator (reverse p) + path1 = case path of + "" -> "." + _ -> case dropWhile isPathSeparator path of + "" -> [pathSeparator] + p -> p + fname1 = case fname of + "" -> "." + _ -> fname + +-- | Checks whether the character is a valid path separator for the host +-- platform. The valid character is a 'pathSeparator' but since the Windows +-- operating system also accepts a slash (\"\/\") since DOS 2, the function +-- checks for it on this platform, too. +isPathSeparator :: Char -> Bool +isPathSeparator ch = + ch == '/' + +-- | Provides a platform-specific character used to separate directory levels in +-- a path string that reflects a hierarchical file system organization. The +-- separator is a slash (@\"\/\"@) on Unix and Macintosh, and a backslash +-- (@\"\\\"@) on the Windows operating system. +pathSeparator :: Char +pathSeparator = '/' + +-- |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 diff --git a/System/Unix/Files.hs b/System/Unix/Files.hs new file mode 100644 --- /dev/null +++ b/System/Unix/Files.hs @@ -0,0 +1,14 @@ +module System.Unix.Files where + +import System.Posix.Files +import System.IO.Error + +-- |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) diff --git a/System/Unix/List.hs b/System/Unix/List.hs new file mode 100644 --- /dev/null +++ b/System/Unix/List.hs @@ -0,0 +1,15 @@ +-- | A function taken From missingh, which will not build under +-- sid at the moment. + +module System.Unix.List + (join, + consperse) + where + +import Data.List + +join :: [a] -> [[a]] -> [a] +join x l = concat . intersperse x $ l + +consperse :: [a] -> [[a]] -> [a] +consperse = join diff --git a/System/Unix/Misc.hs b/System/Unix/Misc.hs new file mode 100644 --- /dev/null +++ b/System/Unix/Misc.hs @@ -0,0 +1,37 @@ +-- |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 Data.Maybe +import System.Cmd +import System.Directory +import System.Exit +import System.IO +import System.Posix.Files +import System.Process +import System.Unix.Process + +md5sum :: FilePath -> IO String +md5sum path = + do + (text, _, exitCode) <- simpleProcess "md5sum" [path] + let output = listToMaybe (words text) + case exitCode of + ExitSuccess -> + case output of + Nothing -> error ("Error in output of 'md5sum " ++ path ++ "'") + Just checksum -> return checksum + ExitFailure _ -> error ("Error running 'md5sum " ++ path ++ "'") + +gzip :: FilePath -> IO () +gzip path = + do + result <- system ("gzip < " ++ path ++ " > " ++ path ++ ".gz") + case result of + ExitSuccess -> return () + e -> error (show e) diff --git a/System/Unix/Mount.hs b/System/Unix/Mount.hs new file mode 100644 --- /dev/null +++ b/System/Unix/Mount.hs @@ -0,0 +1,108 @@ +-- |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 + +-- Standard GHC modules + +import Control.Monad +import Data.List +import System.Directory +import System.Exit +import System.Posix.Files + +-- Local Modules + +import System.Unix.Process + +-- |'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 :: FilePath -- ^ canonicalised, absolute path + -> IO [(FilePath, (String, String, ExitCode))] -- ^ paths that we attempted to umount, and the responding output from the umount command +umountBelow belowPath = + do procMount <- readFile "/proc/mounts" + let mountPoints = map (unescape . (!! 1) . words) (lines procMount) + maybeMounts = filter (isPrefixOf belowPath) (concat (map tails mountPoints)) + needsUmount <- filterM isMountPoint maybeMounts + result <- mapM (\path -> umount [path,"-f","-l"] >>= return . ((,) path)) needsUmount + -- Did /proc/mounts change? If so we should try again because + -- nested mounts might have been revealed. + procMount' <- readFile "/proc/mounts" + result' <- if procMount /= procMount' then + umountBelow belowPath else + return [] + return $ result ++ result' + +-- |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 stytle 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 (String, String, ExitCode) +umount args = simpleProcess "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 diff --git a/System/Unix/Process.hs b/System/Unix/Process.hs new file mode 100644 --- /dev/null +++ b/System/Unix/Process.hs @@ -0,0 +1,418 @@ +-- |functions for killing processes, running processes, etc +module System.Unix.Process + ( + -- * Strict process running + simpleProcess -- FilePath -> [String] -> IO (String, String, ExitCode) + , processResult -- FilePath -> [String] -> IO (Either Int (String, String)) + , processOutput -- FilePath -> [String] -> IO (Either Int String) + , simpleCommand -- String -> IO (String, String, ExitCode) + , commandResult -- String -> IO (Either Int (String, String)) + , commandOutput -- String -> IO (Either Int String) + -- * Lazy process running + , Process + , Output(Stdout, Stderr, Result) + , lazyRun -- L.ByteString -> Process -> IO [Output] + , lazyCommand -- String -> IO [Output] + , lazyProcess -- FilePath -> [String] -> Maybe FilePath + -- -> Maybe [(String, String)] -> IO [Output] + , stdoutOnly -- [Output] -> L.ByteString + , stderrOnly -- [Output] -> L.ByteString + , outputOnly -- [Output] -> L.ByteString + , checkResult + , discardStdout + , discardStderr + , discardOutput + , mergeToStderr + , mergeToStdout + , collectStdout + , collectStderr + , collectOutput + , collectOutputUnpacked + , ExitCode(ExitSuccess, ExitFailure) + , exitCodeOnly -- [Output] -> [ExitCode] + , hPutNonBlocking -- Handle -> B.ByteString -> IO Int + -- * Process killing + , killByCwd -- FilePath -> IO [(String, Maybe String)] + ) where + +import Control.Monad +import Control.Exception hiding (catch) +import Control.Parallel.Strategies +import Data.Char +import qualified Data.ByteString as B +--import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy.Char8 as L +--import qualified Data.ByteString.Internal as I +import Data.ByteString.Internal(toForeignPtr) -- for hPutNonBlocking only +import Data.List +import Data.Word +import Data.Int +import System.Process +import System.IO +import System.IO.Unsafe +import System.Directory +import System.Exit +import System.Posix.Files +import System.Posix.Signals +import System.Posix.Unistd (usleep) +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Marshal.Array (peekArray, pokeArray) +import Foreign.Ptr (plusPtr) -- for hPutNonBlocking only +import Foreign.ForeignPtr (withForeignPtr) -- for hPutNonBlocking only + +{- +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 + similar 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 = + catch (liftM (isPrefixOf cwd) (readSymbolicLink ("/proc/" ++ pid ++"/cwd"))) (const (return False)) + exePath :: String -> IO (Maybe String) + exePath pid = catch (readSymbolicLink ("/proc/" ++ pid ++"/exe") >>= return . Just) (const (return Nothing)) + kill :: String -> IO () + kill pidStr = signalProcess sigTERM (read pidStr) + +-- |'simpleProcess' - run a process returning (stdout, stderr, exitcode) +-- +-- /Warning/ - stdout and stderr will be read strictly so that we do +-- not deadlock when trying to check the exitcode. Do not try doing +-- something like, @simpleProcess [\"yes\"]@ +-- +-- NOTE: this may still dead-lock because we first strictly read +-- outStr and then errStr. Perhaps we should use forkIO or something? +simpleProcess :: FilePath -> [String] -> IO (String, String, ExitCode) +simpleProcess exec args = + do (inp,out,err,pid) <- runInteractiveProcess exec args Nothing Nothing + hClose inp + outStr <- hGetContents out + errStr <- hGetContents err + evaluate (rnf outStr) -- read output strictly + evaluate (rnf errStr) -- read stderr strictly + ec <- waitForProcess pid + return (outStr, errStr, ec) + +processResult :: FilePath -> [String] -> IO (Either Int (String, String)) +processResult exec args = + simpleProcess exec args >>= return . resultOrCode + where + resultOrCode (_, _, ExitFailure n) = Left n + resultOrCode (out, err, ExitSuccess) = Right (out, err) + +processOutput :: FilePath -> [String] -> IO (Either Int String) +processOutput exec args = + simpleProcess exec args >>= return . outputOrCode + where + outputOrCode (_, _, ExitFailure n) = Left n + outputOrCode (out, _, ExitSuccess) = Right out + +simpleCommand :: String -> IO (String, String, ExitCode) +simpleCommand cmd = + do (inp,out,err,pid) <- runInteractiveCommand cmd + hClose inp + outStr <- hGetContents out + errStr <- hGetContents err + evaluate (rnf outStr) -- read output strictly + evaluate (rnf errStr) -- read stderr strictly + ec <- waitForProcess pid + return (outStr, errStr, ec) + +commandResult :: String -> IO (Either Int (String, String)) +commandResult cmd = + simpleCommand cmd >>= return . resultOrCode + where + resultOrCode (_, _, ExitFailure n) = Left n + resultOrCode (out, err, ExitSuccess) = Right (out, err) + +commandOutput :: String -> IO (Either Int String) +commandOutput cmd = + simpleCommand cmd >>= return . outputOrCode + where + outputOrCode (_, _, ExitFailure n) = Left n + outputOrCode (out, _, ExitSuccess) = Right out + +{- Functions to run a process and return a lazy list of chunks from + standard output, standard error, and at the end of the list an + object indicating the process result code. If neither output + handle is ready for reading the process sleeps and tries again, + with the sleep intervals increasing from 8 microseconds to a + maximum of 0.1 seconds. -} + +-- | This is the type returned by 'System.Process.runInteractiveProcess' et. al. +type Process = (Handle, Handle, Handle, ProcessHandle) + +-- | The process returns a list of objects of type 'Output'. There will be +-- one Result object at the end of the list (if the list has an end.) +data Output + = Stdout B.ByteString + | Stderr B.ByteString + | Result ExitCode + deriving Show + +-- | Display up to thirty characters of a ByteString followed by an +-- ellipsis if some of it was omitted. +showBrief :: B.ByteString -> String +showBrief s = + let l = B.length s in + show (B.take (min 30 l) s) ++ + if l > 30 then " ... (" ++ show (l - 30) ++ " additional bytes)" else "" + +{- +instance Show Output where + show (Stdout s) = + let l = B.length s in + "Stdout: " ++ showBrief s + show (Stderr s) = + let l = B.length s in + "Stderr: " ++ showBrief s + -- show (Sleep n) = "Slept " ++ show n ++ " usec" + show (Result e) = show e +-} + +bufSize = 65536 -- maximum chunk size +uSecs = 8 -- minimum wait time, doubles each time nothing is ready +maxUSecs = 100000 -- maximum wait time (microseconds) + +--stringToByteString = B.pack . map (fromInteger . toInteger . ord) + +-- | Debugging output +ePut :: Int -> String -> IO () +ePut minv s = if curv >= minv then hPutStr stderr s else return () +ePut0 = ePut 0 +ePut1 = ePut 1 +ePut2 = ePut 2 + +-- | Current verbosity level. +curv = 0 + +-- | Create a process with 'runInteractiveCommand' and run it with 'lazyRun'. +lazyCommand :: String -> L.ByteString -> IO [Output] +lazyCommand cmd input = runInteractiveCommand cmd >>= lazyRun input + +-- | Create a process with 'runInteractiveProcess' and run it with 'lazyRun'. +lazyProcess :: FilePath -> [String] -> Maybe FilePath + -> Maybe [(String, String)] -> L.ByteString -> IO [Output] +lazyProcess exec args cwd env input = + runInteractiveProcess exec args cwd env >>= lazyRun input + +-- | Take the tuple like that returned by 'runInteractiveProcess', +-- create a process, send the list of inputs to its stdin and return +-- the lazy list of 'Output' objects. +lazyRun :: L.ByteString -> Process -> IO [Output] +lazyRun input (inh, outh, errh, pid) = + elements (L.toChunks input, Just inh, Just outh, Just errh, []) + where + elements :: ([B.ByteString], Maybe Handle, Maybe Handle, Maybe Handle, [Output]) -> IO [Output] + -- EOF on both output descriptors, get exit code + elements (_, _, Nothing, Nothing, elems) = + do result <- waitForProcess pid + return $ elems ++ [Result result] + -- The available output has been processed, send input and read + -- from the ready handles + elements tl@(_, _, _, _, []) = ready uSecs tl >>= elements + -- Add some output to the result value + elements (input, inh, outh, errh, elems) = + do + etc <- unsafeInterleaveIO (elements (input, inh, outh, errh, [])) + return $ elems ++ etc + +-- | Wait until at least one handle is ready and then write input or +-- read output. Note that there is no way to check whether the input +-- handle is ready except to try to write to it and see if any bytes +-- are accepted. If no input is accepted, or the input handle is +-- already closed, and none of the output descriptors are ready for +-- reading the function sleeps and tries again. +ready :: Int -> ([B.ByteString], Maybe Handle, Maybe Handle, Maybe Handle, [Output]) + -> IO ([B.ByteString], Maybe Handle, Maybe Handle, Maybe Handle, [Output]) +ready waitUSecs (input, inh, outh, errh, elems) = + do + outReady <- maybe (return False) hReady outh + errReady <- maybe (return False) hReady errh + case (input, inh, outReady, errReady) of + -- Input exhausted, close the input handle. + ([], Just handle, False, False) -> + do hClose handle + ready waitUSecs ([], Nothing, outh, errh, elems) + -- Input handle closed and there are no ready output handles, + -- wait a bit + ([], Nothing, False, False) -> + do usleep uSecs + --ePut0 ("Slept " ++ show uSecs ++ " microseconds\n") + ready (min maxUSecs (2 * waitUSecs)) (input, inh, outh, errh, elems) + -- Input is available and there are no ready output handles + (input : etc, Just handle, False, False) + -- Discard a zero byte input + | input == B.empty -> ready waitUSecs (etc, inh, outh, errh, elems) + -- Send some input to the process + | True -> + do count' <- hPutNonBlocking handle input >>= return . fromInteger . toInteger + case count' of + -- Input buffer is full too, sleep. + 0 -> do usleep uSecs + ready (min maxUSecs (2 * waitUSecs)) (input : etc, inh, outh, errh, elems) + -- We wrote some input, discard it and continue + n -> do let input' = B.drop count' input : etc + return (input', Just handle, outh, errh, elems) + -- One or both output handles are ready, try to read from them + _ -> + do (out1, errh') <- nextOut errh errReady Stderr + (out2, outh') <- nextOut outh outReady Stdout + return (input, inh, outh', errh', elems ++ out1 ++ out2) + +-- | Return the next output element and the updated handle +-- from a handle which is assumed ready. +nextOut :: (Maybe Handle) -> Bool -> (B.ByteString -> Output) -> IO ([Output], Maybe Handle) +nextOut Nothing _ _ = return ([], Nothing) -- Handle is closed +nextOut handle False _ = return ([], handle) -- Handle is not ready +nextOut (Just handle) True constructor = -- Perform a read + do + a <- B.hGetNonBlocking handle bufSize + case B.length a of + -- A zero length read, unlike a zero length write, always + -- means EOF. + 0 -> do hClose handle + return ([], Nothing) + -- Got some input + n -> return ([constructor a], Just handle) + +-- | Filter everything except stdout from the output list. +stdoutOnly :: [Output] -> L.ByteString +stdoutOnly out = + L.fromChunks $ f out + where + f (Stdout s : etc) = s : f etc + f (_ : etc) = f etc + f [] = [] + +-- | Filter everything except stderr from the output list. +stderrOnly :: [Output] -> L.ByteString +stderrOnly out = + L.fromChunks $ f out + where + f (Stderr s : etc) = s : f etc + f (_ : etc) = f etc + f [] = [] + +-- | Filter the exit codes output list and merge the two output +-- streams in the order they appear. +outputOnly :: [Output] -> L.ByteString +outputOnly out = + L.fromChunks $ f out + where + f (Stderr s : etc) = s : f etc + f (Stdout s : etc) = s : f etc + f (_ : etc) = f etc + f [] = [] + +-- | Filter everything except the exit code from the output list. +exitCodeOnly :: [Output] -> [ExitCode] +exitCodeOnly (Result code : etc) = code : exitCodeOnly etc +exitCodeOnly (_ : etc) = exitCodeOnly etc +exitCodeOnly [] = [] + +-- | This belongs in Data.ByteString. See ticket 1070, +-- . +hPutNonBlocking :: Handle -> B.ByteString -> IO Int64 +hPutNonBlocking h b = + case toForeignPtr b of + (_, _, 0) -> return 0 + (ps, s, l) -> withForeignPtr ps $ \ p-> hPutBufNonBlocking h (p `plusPtr` s) l >>= return . fromInteger . toInteger + +-- Examples: +-- +-- > runInteractiveCommand "ls -l /usr/bin" >>= lazyRun [] >>= mapM_ (putStrLn . show) +-- Stdout: \"total 137411\n-rwxr-xr-x 1 root\" ... (4066 additional bytes) +-- Stdout: \"oot 7642 2006-12-07 17:0\" ... (65506 additional bytes) +-- Stdout: \"oot 57220 2006-10-24 01:1\" ... (31961 additional bytes) +-- ExitSuccess +-- +-- > lazyCommand "cat -n" (map stringToByteString ["abc\n", "def\n"]) >>= mapM_ (putStrLn . show) +-- +-- > lazyCommand "yes" [] >>= return . stdoutOnly >>= lazyCommand "cat -n" >>= mapM_ (putStrLn . show) + + +checkResult :: (Int -> a) -> a -> [Output] -> a +checkResult _ _ [] = error $ "*** FAILURE: Missing exit code" +checkResult _ onSuccess (Result ExitSuccess : _) = onSuccess +checkResult onFailure _ (Result (ExitFailure n) : _) = onFailure n +checkResult onFailure onSuccess (_ : more) = checkResult onFailure onSuccess more + +discardStdout :: [Output] -> [Output] +discardStdout (Stdout _ : more) = discardStdout more +discardStdout (x : more) = x : discardStdout more +discardStdout [] = [] + +discardStderr :: [Output] -> [Output] +discardStderr (Stderr _ : more) = discardStderr more +discardStderr (x : more) = x : discardStderr more +discardStderr [] = [] + +discardOutput :: [Output] -> [Output] +discardOutput = discardStdout . discardStderr + +-- |Turn all the Stdout text into Stderr, preserving the order. +mergeToStderr :: [Output] -> [Output] +mergeToStderr output = + map merge output + where + merge (Stdout s) = Stderr s + merge x = x + +-- |Turn all the Stderr text into Stdout, preserving the order. +mergeToStdout :: [Output] -> [Output] +mergeToStdout output = + map merge output + where + merge (Stderr s) = Stdout s + merge x = x + +-- |Split out and concatenate Stdout +collectStdout :: [Output] -> (L.ByteString, [Output]) +collectStdout output = + (L.fromChunks out, other) + where + (out, other) = foldr collect ([], []) output + collect (Stdout s) (text, result) = (s : text, result) + collect x (text, result) = (text, x : result) + +-- |Split out and concatenate Stderr +collectStderr :: [Output] -> (L.ByteString, [Output]) +collectStderr output = + (L.fromChunks err, other) + where + (err, other) = foldr collect ([], []) output + collect (Stderr s) (text, result) = (s : text, result) + collect x (text, result) = (text, x : result) + +-- |Split out and concatenate both Stdout and Stderr, leaving only the exit code. +collectOutput :: [Output] -> (L.ByteString, L.ByteString, [ExitCode]) +collectOutput output = + (L.fromChunks out, L.fromChunks err, code) + where + (out, err, code) = foldr collect ([], [], []) output + collect (Stdout s) (out, err, result) = (s : out, err, result) + collect (Stderr s) (out, err, result) = (out, s : err, result) + collect (Result r) (out, err, result) = (out, err, r : result) + +-- |Collect all output, unpack and concatenate. +collectOutputUnpacked :: [Output] -> (String, String, [ExitCode]) +collectOutputUnpacked = + unpack . collectOutput + where unpack (out, err, result) = (L.unpack out, L.unpack err, result) diff --git a/System/Unix/Progress.hs b/System/Unix/Progress.hs new file mode 100644 --- /dev/null +++ b/System/Unix/Progress.hs @@ -0,0 +1,378 @@ +-- |Run shell commands with various types of progress reporting. +-- +-- Author: David Fox +module System.Unix.Progress + ( + systemTask, -- [Style] -> String -> IO TimeDiff + otherTask, -- [Style] -> IO a -> IO a + Style (Start, Finish, Error, Output, Echo, Elapsed, Verbosity, Indent), + readStyle, -- String -> Maybe Style + Output (Indented, Dots, Done, Quiet), + msg, -- [Style] -> String -> IO () + msgLn, -- [Style] -> String -> IO () + -- * Accessors + output, -- [Style] -> Maybe Output + verbosity, -- [Style] -> Int + -- * Style Set modification + setStyles, -- [Style] -> [Style] -> [Style] + setStyle, -- Style -> [Style] -> [Style] + addStyles, -- [Style] -> [Style] -> [Style] + addStyle, -- Style -> [Style] -> [Style] + removeStyle, -- Style -> [Style] -> [Style] + -- * Utilities + stripDist, -- FilePath -> FilePath + showElapsed, -- String -> IO a -> IO a + System.Time.TimeDiff, + System.Time.noTimeDiff, + fixedTimeDiffToString + ) where + +import Control.Exception +import Data.List +import System.Exit +import System.IO +import System.Process +import System.Time + +data Output + = Indented | + -- ^ Print all the command's output with each line + -- indented using (by default) the string ' > '. + Dots | + -- ^ Print a dot for every 1024 characters the command + -- outputs + Done | + -- ^ Print an ellipsis (...) when the command starts + -- and then "done." when it finishes. + Quiet + -- ^ Print nothing. + +instance Show Output where + show Indented = "Indented" + show Dots = "Dots" + show Done = "Done" + show Quiet = "Quiet " + +data Style + = Start String | + -- ^ Message printed before the execution begins + Finish String | + -- ^ Message printed on successful termination + Error String | + -- ^ Message printed on failure + Output Output | + -- ^ Type of output to generate during execution + Echo Bool | + -- ^ If true, echo the shell command before beginning + Elapsed Bool | + -- ^ If true print the elapsed time on termination + Verbosity Int | + -- ^ Set the verbosity level. This value can be queried + -- using the verbosity function, but is not otherwise used + -- by the -- functions in this module. + Indent String + -- ^ Set the indentation string for the generated output. + +instance Show Style where + show (Start s) = "Start " ++ show s + show (Finish s) = "Finish " ++ show s + show (Error s) = "Error " ++ show s + show (Output output) = "Output " ++ show output + show (Echo flag) = "Echo " ++ show flag + show (Elapsed flag) = "Elapsed " ++ show flag + show (Verbosity n) = "Verbosity " ++ show n + show (Indent s) = "Verbosity " ++ show s + +styleClass (Start _) = "Start" +styleClass (Finish _) = "Finish" +styleClass (Error _) = "Error" +styleClass (Output _) = "Progress" +styleClass (Echo _) = "Echo" +styleClass (Elapsed _) = "Elapsed" +styleClass (Verbosity _) = "Verbosity" +styleClass (Indent _) = "Indent" + +-- This definition of equivalence is used to add or replace a style +-- parameter - for example, supply a Start message if none is present. +instance Eq Style where + a == b = styleClass a == styleClass b + +-- |Create a task that sends its output to a handle and then can be +-- terminated using an IO operation that returns an exit status. +-- Throws an error if the command fails. +systemTask :: [Style] -> String -> IO TimeDiff +systemTask style command = + do + start <- getClockTime + putIndent style + startMessage style + taskStart style + (_, _, outputHandle, processHandle) <- runInteractiveCommand ("{ " ++ command ++ "; } 1>&2") + text <- progressOutput (maybe Indented id (output style)) outputHandle; + result <- waitForProcess processHandle + finish <- getClockTime + let elapsed = diffClockTimes finish start + case result of + ExitSuccess -> finishMessage style elapsed + ExitFailure _ -> errorMessage style text + return elapsed + where + taskStart (Echo True : etc) = do hPutStrLn stderr ("\n -> " ++ command); taskStart etc + taskStart (_ : etc) = taskStart etc + taskStart [] = return () + +otherTask :: [Style] -> IO a -> IO a +otherTask style task = + do + start <- getClockTime + putIndent style + startMessage style + taskStart style + result <- try task + hPutStr stderr "..." + finish <- getClockTime + let elapsed = diffClockTimes finish start + case result of + Left e -> do errorMessage style (show e) + error (show e) + Right a -> + do finishMessage style elapsed + return a + where + taskStart (_ : etc) = taskStart etc + taskStart [] = return () + +-- FIXME: these two should break up the text into lines and prepend +-- the indentation to each. +msg :: [Style] -> String -> IO () +msg style text = + do + putIndent style + hPutStr stderr text + +msgLn :: [Style] -> String -> IO () +msgLn style text = + do + putIndent style + hPutStrLn stderr text + +putIndent :: [Style] -> IO () +putIndent style = hPutStr stderr (indent style) + +startMessage :: [Style] -> IO () +startMessage (Start message : etc) = do hPutStr stderr message; startMessage etc +startMessage (_ : etc) = startMessage etc +startMessage [] = return () + +progressOutput :: Output -> Handle -> IO String + +progressOutput Dots handle = + do + hPutStr stderr "..." + doText 0 "" + where + doText count text = + do + eof <- hIsEOF handle + case eof of + False -> + do + line <- hGetLine handle + let count' = count + length line + 1 + let text' = text ++ line ++ "\n" + let (n, m) = quotRem count' 1024 + hPutStr stderr (replicate n '.') + doText m text' + True -> + do + -- hPutStr stderr "done." + return text + +progressOutput Done handle = + do + hPutStr stderr "..." + doText "" + where + doText text = + do + eof <- hIsEOF handle + case eof of + False -> + do + line <- hGetLine handle + let text' = text ++ line ++ "\n" + doText text' + True -> + do + -- hPutStr stderr "done." + return text + +progressOutput Indented handle = + do + hPutStrLn stderr "" + doText + where + doText = + do + eof <- hIsEOF handle + case eof of + True -> return "" + False -> + do + line <- hGetLine handle + -- Not collecting text here since it gets output. + -- This is a judgement call. + -- let text' = text ++ line ++ "\n" + hPutStrLn stdout (prefix ++ line) + hFlush stdout + doText + prefix = " > " + +progressOutput Quiet handle = + do + doText "" + where + doText text = + do + eof <- hIsEOF handle + case eof of + False -> + do + line <- hGetLine handle + let text' = text ++ line ++ "\n" + doText text' + True -> return text + +finishMessage :: [Style] -> TimeDiff -> IO () +finishMessage (Elapsed True : etc) elapsed = + do + hPutStr stderr (" (Elapsed: " ++ fixedTimeDiffToString elapsed ++ ")") + finishMessage etc elapsed +finishMessage (Finish message : etc) elapsed = do hPutStr stderr message; finishMessage etc elapsed +finishMessage (_ : etc) elapsed = finishMessage etc elapsed +finishMessage [] _ = do hPutStrLn stderr ""; return () + +errorMessage :: [Style] -> String -> IO () +errorMessage (Error message : _) text = + do + hPutStrLn stderr text + error message +errorMessage (_ : etc) text = errorMessage etc text +errorMessage [] text = errorMessage [Error "failed"] text + +-- |Remove styles by class +removeStyle :: Style -> [Style] -> [Style] +removeStyle (Start _) style = filter (not . isStart) style +removeStyle (Finish _) style = filter (not . isFinish) style +removeStyle (Error _) style = filter (not. isError) style +removeStyle (Output _) style = filter (not . isOutput) style +removeStyle (Echo _) style = filter (not . isEcho) style +removeStyle old style = filter (/= old) style + +-- |Add styles, replacing old ones if present +setStyles :: [Style] -> [Style] -> [Style] +setStyles [] style = style +setStyles (x:xs) style = setStyles xs (x : (removeStyle x style)) + +-- |Singleton case of setStyles +setStyle :: Style -> [Style] -> [Style] +setStyle new style = setStyles [new] style + +-- |Singleton case of addStyles +addStyle :: Style -> [Style] -> [Style] +addStyle x@(Start _) style = case filter isStart style of [] -> x : style; _ -> style +addStyle x@(Finish _) style = case filter isFinish style of [] -> x : style; _ -> style +addStyle x@(Error _) style = case filter isError style of [] -> x : style; _ -> style +addStyle x@(Output _) style = case filter isOutput style of [] -> x : style; _ -> style +addStyle x@(Echo _) style = case filter isEcho style of [] -> x : style; _ -> style +addStyle x style = if elem x style then style else x : style + +isStart (Start _) = True +isStart _ = False +isFinish (Finish _) = True +isFinish _ = False +isError (Error _) = True +isError _ = False +isOutput (Output _) = True +isOutput _ = False +isEcho (Echo _) = True +isEcho _ = False + +output :: [Style] -> Maybe Output +output (Output x : _) = Just x +output (_ : xs) = output xs +output [] = Nothing + +-- |Add styles only if not present +addStyles :: [Style] -> [Style] -> [Style] +addStyles styles style = foldr addStyle style styles + +stripDist :: FilePath -> FilePath +stripDist path = maybe path (\ n -> "..." ++ drop (n + 7) path) (isSublistOf "/dists/" path) + +verbosity :: [Style] -> Int +verbosity [] = 0 +verbosity (Verbosity n : _) = n +verbosity (_ : etc) = verbosity etc + +indent :: [Style] -> String +indent [] = "" +indent (Indent s : _) = s +indent (_ : etc) = indent etc + +readStyle :: String -> Maybe Style +-- FIXME: implement this +readStyle text = + case (mapSnd tail . break (== '=')) text of + ("Start", message) -> Just $ Start message + ("Finish", message) -> Just $ Finish message + ("Error", message) -> Just $ Error message + ("Output", "Indented") -> Just $ Output Indented + ("Output", "Dots") -> Just $ Output Dots + ("Output", "Done") -> Just $ Output Done + ("Output", "Quiet") -> Just $ Output Quiet + ("Echo", flag) -> Just $ Echo (readFlag flag) + ("Elapsed", flag) -> Just $ Elapsed (readFlag flag) + ("Verbosity", value) -> Just $ Verbosity (read value) + ("Indent", prefix) -> Just $ Indent prefix + _ -> Nothing + where + readFlag "yes" = True + readFlag "no" = False + readFlag "true" = True + readFlag "false" = True + readFlag text = error ("Unrecognized bool: " ++ text) + +-- |The timeDiffToString function returns the empty string for +-- the zero time diff, this is not the behavior I need. +fixedTimeDiffToString :: TimeDiff -> [Char] +fixedTimeDiffToString diff = + case timeDiffToString diff of + "" -> "0 sec" + s -> s + +showElapsed :: String -> IO a -> IO a +showElapsed label f = + do + (result, time) <- elapsed f + ePut (label ++ fixedTimeDiffToString time) + return result + +elapsed :: IO a -> IO (a, TimeDiff) +elapsed f = + do + start <- getClockTime + result <- f + finish <- getClockTime + return (result, diffClockTimes finish start) + +isSublistOf :: Eq a => [a] -> [a] -> Maybe Int +isSublistOf sub lst = + maybe Nothing (\ s -> Just (length s - length sub)) + (find (isSuffixOf sub) (inits lst)) + +mapSnd :: (b -> c) -> (a, b) -> (a, c) +mapSnd f (a, b) = (a, f b) + +ePut :: String -> IO () +ePut s = hPutStrLn stderr s diff --git a/System/Unix/SpecialDevice.hs b/System/Unix/SpecialDevice.hs new file mode 100644 --- /dev/null +++ b/System/Unix/SpecialDevice.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE PatternSignatures #-} +-- | 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.Posix.Types +import System.Posix.Files +import System.Posix.User +import Text.Regex + +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 (const 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 (const 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 + isPart (path, _) = maybe False (const True) (matchRegex (mkRegex "-part[0-9]+$") path) + +getAllPartitions :: IO [SpecialDevice] +getAllPartitions = + directory_find True "/dev/disk/by-path" >>= return . filter isPart >>= return . catMaybes . map (ofNodeStatus . snd) + where + isPart (path, _) = maybe False (const True) (matchRegex (mkRegex "-part[0-9]+$") path) + +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 = + do + maybeStatus <- + if follow then + -- Catch the exception exception thrown on an invalid symlink + try . getFileStatus $ path else + getSymbolicLinkStatus path >>= return . Right + case maybeStatus of + Left _ -> return [] + Right status -> + case isDirectory status of + True -> + do + -- Catch the exception thrown if we lack read permission + subs <- (try $ getDirectoryContents path) >>= + return . either (const []) id >>= + return . map ((path ++ "/") ++) . filter (not . flip elem [".", ".."]) >>= + mapM (directory_find follow) >>= + return . concat + return $ (path, status) : subs + False -> + return [(path, status)] + +dirname path = reverse . tail . snd . break (== '/') . reverse $ path +basename path = reverse . fst . break (== '/') . reverse $ path diff --git a/Unixutils.cabal b/Unixutils.cabal new file mode 100644 --- /dev/null +++ b/Unixutils.cabal @@ -0,0 +1,22 @@ +Name: Unixutils +Version: 1.17 +License: BSD3 +-- License-File: debian/copyright +Author: Jeremy Shaw +Homepage: http://src.seereason.com/haskell-unixutils +Category: System +Build-Depends: base, unix, regex-compat, process, bytestring, directory, old-time, parallel +Synopsis: A crude interface between Haskell and Unix-like operating systems +Maintainer: jeremy@n-heptane.com +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 +ghc-options: -O2 +Exposed-modules: + System.Unix.Directory, System.Unix.FilePath, System.Unix.List, + System.Unix.Misc, System.Unix.Mount, System.Unix.Process, + System.Unix.Progress, System.Unix.SpecialDevice, System.Unix.Files + +-- For more complex build options see: +-- http://www.haskell.org/ghc/docs/latest/html/Cabal/