diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,1 @@ +BSD diff --git a/System/Unix/Directory.hs b/System/Unix/Directory.hs --- a/System/Unix/Directory.hs +++ b/System/Unix/Directory.hs @@ -15,6 +15,7 @@ import System.Cmd import System.Directory import System.Exit +import System.FilePath import System.IO import System.Posix.Files import System.Posix.Types @@ -30,7 +31,7 @@ True -> do subs <- getDirectoryContents path >>= - return . map ((path ++ "/") ++) . filter (not . flip elem [".", ".."]) >>= + return . map (path ) . filter (not . flip elem [".", ".."]) >>= mapM find >>= return . concat return $ (path, status) : subs @@ -64,7 +65,7 @@ error ("Couldn't unmount file system on " ++ path) doDirectoryFile tries status path name = do - let child = path ++ "/" ++ name + let child = path name childStatus <- getSymbolicLinkStatus child if deviceID status == deviceID childStatus then doPath child childStatus else @@ -144,7 +145,7 @@ withTemporaryDirectory :: FilePath -> (FilePath -> IO a) -> IO a withTemporaryDirectory fp f = do sysTmpDir <- getTemporaryDirectory - bracket (mkdtemp (sysTmpDir ++ "/" ++ fp)) + bracket (mkdtemp (sysTmpDir fp)) removeRecursiveSafely f diff --git a/System/Unix/FilePath.hsc b/System/Unix/FilePath.hsc --- a/System/Unix/FilePath.hsc +++ b/System/Unix/FilePath.hsc @@ -1,17 +1,17 @@ {-# 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 System.FilePath (makeRelative, (), takeFileName, dropFileName) import Text.Regex import Foreign.C import Foreign.Marshal.Array @@ -19,89 +19,16 @@ #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 +-- |Concatenate two paths, making sure there is exactly one path separator. +a <++> b = a (makeRelative "" b) +-- |Use dropFileName dirName :: FilePath -> FilePath -dirName path = fst (splitFileName path) +dirName = dropFileName +-- |Use takeFileName 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 = '/' +baseName = takeFileName -- |resolve all references to /./, /../, extra slashes, and symlinks realpath :: FilePath -> IO FilePath diff --git a/System/Unix/Mount.hs b/System/Unix/Mount.hs --- a/System/Unix/Mount.hs +++ b/System/Unix/Mount.hs @@ -8,15 +8,20 @@ -- Standard GHC modules import Control.Monad +import Data.ByteString.Lazy.Char8 (empty) import Data.List import System.Directory import System.Exit import System.Posix.Files +import System.Unix.Process -- Local Modules import System.Unix.Process +-- In ghc610 readFile "/proc/mounts" hangs. Use this instead. +rf path = lazyCommand ("cat '" ++ path ++ "'") empty >>= return . (\ (o, _, _) -> o) . collectOutputUnpacked + -- |'umountBelow' - unmounts all mount points below /belowPath/ -- \/proc\/mounts must be present and readable. Because of the way -- linux handles changeroots, we can't trust everything we see in @@ -42,14 +47,14 @@ 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" + do procMount <- rf "/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" + procMount' <- rf "/proc/mounts" result' <- if procMount /= procMount' then umountBelow belowPath else return [] diff --git a/System/Unix/Process.hs b/System/Unix/Process.hs --- a/System/Unix/Process.hs +++ b/System/Unix/Process.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} -- |functions for killing processes, running processes, etc module System.Unix.Process ( @@ -233,6 +234,13 @@ etc <- unsafeInterleaveIO (elements (input, inh, outh, errh, [])) return $ elems ++ etc +-- A quick fix for the issue where hWaitForInput has actually started +-- raising the isEOFError exception in ghc 6.10. +data Readyness = Ready | Unready | EndOfFile + +hReady' :: Handle -> IO Readyness +hReady' h = (hReady h >>= (\ flag -> return (if flag then Ready else Unready))) `catch` (\ e -> return EndOfFile) + -- | 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 @@ -243,21 +251,21 @@ -> 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 + outReady <- maybe (return Unready) hReady' outh + errReady <- maybe (return Unready) hReady' errh case (input, inh, outReady, errReady) of -- Input exhausted, close the input handle. - ([], Just handle, False, False) -> + ([], Just handle, Unready, Unready) -> 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) -> + ([], Nothing, Unready, Unready) -> 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) + (input : etc, Just handle, Unready, Unready) -- Discard a zero byte input | input == B.empty -> ready waitUSecs (etc, inh, outh, errh, elems) -- Send some input to the process @@ -278,10 +286,11 @@ -- | 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 :: (Maybe Handle) -> Readyness -> (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 +nextOut _ EndOfFile _ = return ([], Nothing) -- Handle is closed +nextOut handle Unready _ = return ([], handle) -- Handle is not ready +nextOut (Just handle) Ready constructor = -- Perform a read do a <- B.hGetNonBlocking handle bufSize case B.length a of diff --git a/System/Unix/SpecialDevice.hs b/System/Unix/SpecialDevice.hs --- a/System/Unix/SpecialDevice.hs +++ b/System/Unix/SpecialDevice.hs @@ -42,6 +42,7 @@ import Data.Char import Data.List import Data.Maybe +import System.FilePath import System.Posix.Types import System.Posix.Files import System.Posix.User @@ -217,7 +218,7 @@ -- Catch the exception thrown if we lack read permission subs <- (try $ getDirectoryContents path) >>= return . either (const []) id >>= - return . map ((path ++ "/") ++) . filter (not . flip elem [".", ".."]) >>= + return . map (path ) . filter (not . flip elem [".", ".."]) >>= mapM (directory_find follow) >>= return . concat return $ (path, status) : subs diff --git a/Unixutils.cabal b/Unixutils.cabal --- a/Unixutils.cabal +++ b/Unixutils.cabal @@ -1,11 +1,11 @@ Name: Unixutils -Version: 1.17 +Version: 1.22 License: BSD3 --- License-File: debian/copyright +License-File: COPYING Author: Jeremy Shaw Homepage: http://src.seereason.com/haskell-unixutils Category: System -Build-Depends: base, unix, regex-compat, process, bytestring, directory, old-time, parallel +Build-Depends: base >= 3 && < 4, unix, regex-compat, process, bytestring, directory, old-time, parallel, filepath Synopsis: A crude interface between Haskell and Unix-like operating systems Maintainer: jeremy@n-heptane.com Description: