Unixutils (empty) → 1.17
raw patch · 11 files changed
+1497/−0 lines, 11 filesdep +basedep +bytestringdep +directorysetup-changed
Dependencies added: base, bytestring, directory, old-time, parallel, process, regex-compat, unix
Files
- Setup.hs +5/−0
- System/Unix/Directory.hs +159/−0
- System/Unix/FilePath.hsc +113/−0
- System/Unix/Files.hs +14/−0
- System/Unix/List.hs +15/−0
- System/Unix/Misc.hs +37/−0
- System/Unix/Mount.hs +108/−0
- System/Unix/Process.hs +418/−0
- System/Unix/Progress.hs +378/−0
- System/Unix/SpecialDevice.hs +228/−0
- Unixutils.cabal +22/−0
+ Setup.hs view
@@ -0,0 +1,5 @@+#!/usr/bin/runhaskell++import Distribution.Simple++main = defaultMainWithHooks defaultUserHooks
+ System/Unix/Directory.hs view
@@ -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
+ System/Unix/FilePath.hsc view
@@ -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 <limits.h>+#include <stdlib.h>++(+/+) :: 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
+ System/Unix/Files.hs view
@@ -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)
+ System/Unix/List.hs view
@@ -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
+ System/Unix/Misc.hs view
@@ -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)
+ System/Unix/Mount.hs view
@@ -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
+ System/Unix/Process.hs view
@@ -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,+-- <http://hackage.haskell.org/trac/ghc/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)
+ System/Unix/Progress.hs view
@@ -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
+ System/Unix/SpecialDevice.hs view
@@ -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
+ Unixutils.cabal view
@@ -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/