diff --git a/MissingH.cabal b/MissingH.cabal --- a/MissingH.cabal +++ b/MissingH.cabal @@ -1,5 +1,5 @@ Name: MissingH -Version: 1.2.1.0 +Version: 1.3.0.1 License: BSD3 Maintainer: John Goerzen Author: John Goerzen diff --git a/src/System/IO/HVFS/Combinators.hs b/src/System/IO/HVFS/Combinators.hs --- a/src/System/IO/HVFS/Combinators.hs +++ b/src/System/IO/HVFS/Combinators.hs @@ -36,6 +36,7 @@ #endif import System.Path (secureAbsNormPath) import System.Path.NameManip (normalise_path) +import System.FilePath ((), pathSeparator, isPathSeparator) ---------------------------------------------------------------------- -- Providing read-only access @@ -97,7 +98,7 @@ isdir <- vDoesDirectoryExist fh full if isdir then do let newobj = (HVFSChroot full fh) - vSetCurrentDirectory newobj "/" + vSetCurrentDirectory newobj [pathSeparator] return newobj else vRaiseError fh doesNotExistErrorType ("Attempt to instantiate HVFSChroot over non-directory " ++ full) @@ -110,10 +111,9 @@ {- | Convert a local (chroot) path to a full path. -} dch2fp, fp2dch :: (HVFS t) => HVFSChroot t -> String -> IO String dch2fp mainh@(HVFSChroot fp h) locfp = - do full <- case (head locfp) of - '/' -> return (fp ++ locfp) - _ -> do y <- getFullPath mainh locfp - return $ fp ++ y + do full <- (fp ++) `fmap` if isPathSeparator (head locfp) + then return locfp + else getFullPath mainh locfp case secureAbsNormPath fp full of Nothing -> vRaiseError h doesNotExistErrorType ("Trouble normalizing path in chroot") @@ -125,14 +125,14 @@ do newpath <- case secureAbsNormPath fp locfp of Nothing -> vRaiseError h doesNotExistErrorType ("Unable to securely normalize path") - (Just (fp ++ "/" ++ locfp)) + (Just (fp locfp)) Just x -> return x if (take (length fp) newpath /= fp) then vRaiseError h doesNotExistErrorType ("Local path is not subdirectory of parent path") (Just newpath) else let newpath2 = drop (length fp) newpath - in return $ normalise_path ("/" ++ newpath2) + in return $ normalise_path ([pathSeparator] ++ newpath2) dch2fph :: (HVFS t) => (t -> String -> IO t1) -> HVFSChroot t -> [Char] -> IO t1 dch2fph func fh@(HVFSChroot _ h) locfp = diff --git a/src/System/IO/HVFS/InstanceHelpers.hs b/src/System/IO/HVFS/InstanceHelpers.hs --- a/src/System/IO/HVFS/InstanceHelpers.hs +++ b/src/System/IO/HVFS/InstanceHelpers.hs @@ -41,6 +41,7 @@ import System.IO.HVIO (newStreamReader) import System.Path (absNormPath) import System.Path.NameManip (slice_path) +import System.FilePath ((), pathSeparator, isPathSeparator) {- | A simple "System.IO.HVFS.HVFSStat" class that assumes that everything is either a file @@ -86,7 +87,7 @@ -- existing tree. newMemoryVFSRef :: IORef [MemoryNode] -> IO MemoryVFS newMemoryVFSRef r = do - c <- newIORef "/" + c <- newIORef [pathSeparator] return (MemoryVFS {content = r, cwd = c}) {- | Similar to 'System.Path.NameManip' but the first element @@ -96,14 +97,15 @@ >nice_slice "/foo/bar" -> ["foo", "bar"] -} nice_slice :: String -> [String] -nice_slice "/" = [] -nice_slice path = - let sliced1 = slice_path path - h = head sliced1 - t = tail sliced1 - newh = if head h == '/' then tail h else h - sliced2 = newh : t - in sliced2 +nice_slice path + | path == [pathSeparator] = [] + | otherwise = + let sliced1 = slice_path path + h = head sliced1 + t = tail sliced1 + newh = if isPathSeparator (head h) then tail h else h + sliced2 = newh : t + in sliced2 {- | Gets a full path, after investigating the cwd. -} @@ -112,7 +114,7 @@ do cwd <- vGetCurrentDirectory fs case (absNormPath cwd path) of Nothing -> vRaiseError fs doesNotExistErrorType - ("Trouble normalizing path " ++ path) (Just (cwd ++ "/" ++ path)) + ("Trouble normalizing path " ++ path) (Just (cwd path)) Just newpath -> return newpath {- | Gets the full path via 'getFullPath', then splits it via 'nice_slice'. @@ -124,34 +126,34 @@ -- | Find an element on the tree, assuming a normalized path findMelem :: MemoryVFS -> String -> IO MemoryEntry -findMelem x "/" = readIORef (content x) >>= return . MemoryDirectory -findMelem x path = +findMelem x path + | path == [pathSeparator] = readIORef (content x) >>= return . MemoryDirectory + | otherwise = let sliced1 = slice_path path h = head sliced1 t = tail sliced1 - newh = if (h /= "/") && head h == '/' then tail h else h + newh = if (h /= [pathSeparator]) && isPathSeparator (head h) then tail h else h sliced2 = newh : t -- Walk the tree walk :: MemoryEntry -> [String] -> Either String MemoryEntry -- Empty list -- return the item we have - walk y [] = Right y - -- Root directory -- return the item we have - walk y ["/"] = Right y - -- File but stuff: error - walk (MemoryFile _) (z : _) = - Left $ "Attempt to look up name " ++ z ++ " in file" - walk (MemoryDirectory y) (z : zs) = - let newentry = case lookup z y of - Nothing -> Left $ "Couldn't find entry " ++ z - Just a -> Right a + walk y zs + | null zs = Right y + | zs == [[pathSeparator]] = Right y + | otherwise = case y of + MemoryFile _ -> Left $ "Attempt to look up name " ++ head zs ++ " in file" + MemoryDirectory y -> + let newentry = case lookup (head zs) y of + Nothing -> Left $ "Couldn't find entry " ++ head zs + Just a -> Right a in do newobj <- newentry - walk newobj zs - in do - c <- readIORef $ content x - case walk (MemoryDirectory c) (sliced2) of - Left err -> vRaiseError x doesNotExistErrorType err Nothing - Right result -> return result + walk newobj (tail zs) + in do + c <- readIORef $ content x + case walk (MemoryDirectory c) (sliced2) of + Left err -> vRaiseError x doesNotExistErrorType err Nothing + Right result -> return result -- | Find an element on the tree, normalizing the path first getMelem :: MemoryVFS -> String -> IO MemoryEntry diff --git a/src/System/IO/HVFS/Utils.hs b/src/System/IO/HVFS/Utils.hs --- a/src/System/IO/HVFS/Utils.hs +++ b/src/System/IO/HVFS/Utils.hs @@ -40,6 +40,7 @@ import System.Time import System.Locale import System.IO.Unsafe +import System.FilePath ((), pathSeparator) {- | Obtain a recursive listing of all files\/directories beneath the specified directory. The traversal is depth-first @@ -72,7 +73,7 @@ if withStat fs vIsDirectory then do dirc <- vGetDirectoryContents h fn - let contents = map ((++) (fn ++ "/")) $ + let contents = map ((++) (fn ++ [pathSeparator])) $ filter (\x -> x /= "." && x /= "..") dirc subdirs <- unsafeInterleaveIO $ mapM (recurseDirStat h) contents return $ (concat subdirs) ++ [(fn, fs)] @@ -127,7 +128,7 @@ linkstr <- case vIsSymbolicLink se of False -> return "" True -> do sl <- vReadSymbolicLink fh - (origdir ++ "/" ++ fp) + (origdir fp) return $ " -> " ++ sl return $ printf "%c%s 1 %-8d %-8d %-9d %s %s%s" typechar @@ -139,7 +140,7 @@ fp linkstr in do c <- vGetDirectoryContents fs fp - pairs <- mapM (\x -> do ss <- vGetSymbolicLinkStatus fs (fp ++ "/" ++ x) + pairs <- mapM (\x -> do ss <- vGetSymbolicLinkStatus fs (fp x) return (ss, x) ) c linedata <- mapM (showentry fp fs) pairs diff --git a/src/System/Path.hs b/src/System/Path.hs --- a/src/System/Path.hs +++ b/src/System/Path.hs @@ -41,6 +41,7 @@ #else import System.Directory #endif +import System.FilePath ((), pathSeparator, isPathSeparator) import Control.Exception import System.IO import System.Path.NameManip @@ -53,7 +54,7 @@ splitExt :: String -> (String, String) splitExt path = let dotindex = alwaysElemRIndex '.' path - slashindex = alwaysElemRIndex '/' path + slashindex = alwaysElemRIndex pathSeparator path in if dotindex <= slashindex then (path, "") @@ -77,7 +78,7 @@ absNormPath base thepath = let abs = absolute_path_by base thepath in case guess_dotdot (normalise_path abs) of - Just "." -> Just "/" + Just "." -> Just [pathSeparator] x -> x {- | Like absNormPath, but returns Nothing if the generated result is not diff --git a/src/System/Path/Glob.hs b/src/System/Path/Glob.hs --- a/src/System/Path/Glob.hs +++ b/src/System/Path/Glob.hs @@ -26,7 +26,7 @@ where import Data.List.Utils (hasAny) import System.IO.HVFS -import System.FilePath (splitFileName) +import System.FilePath (splitFileName, (), pathSeparator, isPathSeparator) import Control.Exception (tryJust) import System.Path.WildMatch (wildCheckCase) import Data.List (isSuffixOf) @@ -60,27 +60,24 @@ else expandGlob fs fn -- It's there expandGlob :: HVFS a => a -> FilePath -> IO [FilePath] -expandGlob fs fn = - case dirnameslash of - "./" -> runGlob fs "." basename - "/" -> do - rgs <- runGlob fs "/" basename - return $ map ('/' :) rgs - _ -> do dirlist <- if hasWild dirname - then expandGlob fs dirname - else return [dirname] - if hasWild basename - then do r <- mapM expandWildBase dirlist - return $ concat r - else do r <- mapM expandNormalBase dirlist - return $ concat r +expandGlob fs fn + | dirnameslash == '.':pathSeparator:[] = runGlob fs "." basename + | dirnameslash == [pathSeparator] = do + rgs <- runGlob fs [pathSeparator] basename + return $ map (pathSeparator :) rgs + | otherwise = do dirlist <- if hasWild dirname + then expandGlob fs dirname + else return [dirname] + if hasWild basename + then concat `fmap` mapM expandWildBase dirlist + else concat `fmap` mapM expandNormalBase dirlist where (dirnameslash, basename) = splitFileName fn - dirname = case dirnameslash of - "/" -> "/" - x -> if isSuffixOf "/" x - then take (length x - 1) x - else x + dirname = if dirnameslash == [pathSeparator] + then [pathSeparator] + else if isSuffixOf [pathSeparator] dirnameslash + then init dirnameslash + else dirnameslash expandWildBase :: FilePath -> IO [FilePath] expandWildBase dname = @@ -88,15 +85,15 @@ return $ map withD dirglobs where withD = case dname of "" -> id - _ -> \globfn -> dname ++ "/" ++ globfn + _ -> \globfn -> dname ++ [pathSeparator] ++ globfn expandNormalBase :: FilePath -> IO [FilePath] expandNormalBase dname = do isdir <- vDoesDirectoryExist fs dname - let newname = dname ++ "/" ++ basename + let newname = dname basename isexists <- vDoesExist fs newname if isexists && ((basename /= "." && basename /= "") || isdir) - then return [dname ++ "/" ++ basename] + then return [dname basename] else return [] runGlob :: HVFS a => a -> FilePath -> FilePath -> IO [FilePath] diff --git a/src/System/Path/NameManip.hs b/src/System/Path/NameManip.hs --- a/src/System/Path/NameManip.hs +++ b/src/System/Path/NameManip.hs @@ -14,8 +14,9 @@ module System.Path.NameManip where -import Data.List (intersperse) +import Data.List (intercalate, unfoldr) import System.Directory (getCurrentDirectory) +import System.FilePath ((), pathSeparator, isPathSeparator) {- | Split a path in components. Repeated \"@\/@\" characters don\'t lead to empty components. \"@.@\" path components are removed. If the path is absolute, the first component @@ -37,21 +38,23 @@ -} slice_path :: String -- ^ The path to be broken to components. -> [String] -- ^ List of path components. -slice_path p = - case p of - ('/':p') -> case slice_path' p' of - [] -> ["/"] - (c:cs) -> (('/':c):cs) - _ -> slice_path' p - where +slice_path "" = [] +slice_path (c:cs) = if isPathSeparator c + then case slice_path' cs of + [] -> [[c]] + (p:ps) -> (c:p):ps + else slice_path' (c:cs) + where slice_path' o = filter (\c -> c /= "" && c /= ".") (split o) - split "" = [] - split ('/':o) = "" : split o - split (x:xs) = case split xs of - [] -> [[x]] - (y:ys) -> ((x:y):ys) + split xs = unfoldr f xs + where + f "" = Nothing + f xs = Just $ fmap tail' $ break isPathSeparator xs + tail' [] = [] + tail' xs = tail xs + {- | Form a path from path components. This isn't the inverse of 'slice_path', since @'unslice_path' . 'slice_path'@ normalises the path. @@ -61,7 +64,7 @@ unslice_path :: [String] -- ^ List of path components -> String -- ^ The path which consists of the supplied path components unslice_path [] = "." -unslice_path cs = concat (intersperse "/" cs) +unslice_path cs = intercalate [pathSeparator] cs {- | Normalise a path. This is done by reducing repeated @\/@ characters to one, and removing @@ -152,7 +155,7 @@ -} unslice_filename :: [String] -- ^ List of file name components -> String -- ^ Name of the file which consists of the supplied components -unslice_filename = concat . intersperse "." +unslice_filename = intercalate "." {- | Split a path in directory and file name. Only in the case that the @@ -188,13 +191,12 @@ split_path "" = ("","") split_path path = case slice_path path of - [] -> (".",".") - ["/"] -> ("/", ".") - ['/':p] -> ("/", p) - [fn] -> (".", fn) - parts -> ( unslice_path (init parts) - , last parts - ) + [] -> (".", ".") + [""] -> (".", "") + [f:fs] -> if isPathSeparator f then ([pathSeparator], fs) else (".", f:fs) + parts -> ( unslice_path (init parts) + , last parts + ) {- | Get the directory part of a path. @@ -251,7 +253,7 @@ unsplit_path ("", q) = q unsplit_path (p, "") = p unsplit_path (p, ".") = p -unsplit_path (p, q) = p ++ "/" ++ q +unsplit_path (p, q) = p q {- | Split a file name in prefix and suffix. If there isn't any suffix in @@ -287,7 +289,7 @@ case slice_path path of [] -> (".","") comps -> let (pref_fn, suff_fn) = split_filename' (last comps) - in ( concat (intersperse "/" (init comps ++ [pref_fn])) + in ( intercalate [pathSeparator] (init comps ++ [pref_fn]) , suff_fn ) @@ -367,10 +369,7 @@ -} absolute_path :: String -- ^ The path to be made absolute -> IO String -- ^ Absulte path -absolute_path path@('/':_) = return path -absolute_path path = do - cwd <- getCurrentDirectory - return (cwd ++ "/" ++ path) +absolute_path path = fmap (absolute_path' path) getCurrentDirectory {- | Make a path absolute. @@ -381,8 +380,7 @@ absolute_path_by :: String -- ^ The directory relative to which the path is made absolute -> String -- ^ The path to be made absolute -> String -- ^ Absolute path -absolute_path_by _ path@('/':_) = path -absolute_path_by dir path = dir ++ "/" ++ path +absolute_path_by = () {- | Make a path absolute. @@ -395,8 +393,7 @@ absolute_path' :: String -- ^ The path to be made absolute -> String -- ^ The directory relative to which the path is made absolute -> String -- ^ Absolute path -absolute_path' path@('/':_) _ = path -absolute_path' path dir = dir ++ "/" ++ path +absolute_path' = flip absolute_path_by {- | Guess the @\"..\"@-component free form of a path, specified as a list of path components, by syntactically removing them, along with the preceding diff --git a/testsrc/Globtest.hs b/testsrc/Globtest.hs --- a/testsrc/Globtest.hs +++ b/testsrc/Globtest.hs @@ -21,16 +21,19 @@ #endif import Control.Exception import Data.List +import System.FilePath (pathSeparator) +sep = map (\c -> if c == '/' then pathSeparator else c) + bp = "testtmp" -touch x = writeFile x "" +touch x = writeFile (sep x) "" globtest thetest = bracket_ (setupfs) (recursiveRemove SystemFS bp) thetest where setupfs = - do mapM_ (\x -> createDirectory x) + do mapM_ (\x -> createDirectory (sep x)) [bp, bp ++ "/a", bp ++ "/aab", bp ++ "/aaa", bp ++ "/ZZZ", bp ++ "/a/bcd", bp ++ "/a/bcd/efg"] @@ -47,7 +50,7 @@ assertEqual msg (sort exp) (sort res) mf msg func = TestLabel msg $ TestCase $ globtest func f func = TestCase $ globtest func -preppath x = bp ++ "/" ++ x +preppath x = sep (bp ++ "/" ++ x) test_literal = map f diff --git a/testsrc/HVFStest.hs b/testsrc/HVFStest.hs --- a/testsrc/HVFStest.hs +++ b/testsrc/HVFStest.hs @@ -16,7 +16,10 @@ import System.IO import System.IO.Error import Control.Exception +import System.FilePath (pathSeparator) +sep = map (\c -> if c == '/' then pathSeparator else c) + ioeq :: (Show a, Eq a) => a -> IO a -> Assertion ioeq exp inp = do x <- inp exp @=? x @@ -33,7 +36,9 @@ ] test_nice_slice = - let f exp fp = TestLabel fp $ TestCase $ exp @=? nice_slice fp + let f exp fp' = TestLabel fp $ TestCase $ exp @=? nice_slice fp + where + fp = sep fp' in [ f [] "/" ,f ["foo", "bar"] "/foo/bar" @@ -41,11 +46,13 @@ ] test_content = - let f exp fp = TestLabel fp $ TestCase $ + let f exp fp' = TestLabel fp $ TestCase $ do x <- newMemoryVFS testTree h <- vOpen x fp ReadMode case h of HVFSOpenEncap h2 -> exp `ioeq` vGetContents h2 + where + fp = sep fp' in [ f "line1\nline2\n" "test.txt", @@ -57,27 +64,27 @@ test_chroot = let f msg testfunc = TestLabel msg $ TestCase $ do x <- newMemoryVFS testTree - vSetCurrentDirectory x "/emptydir" - y <- newHVFSChroot x "/dir1" + vSetCurrentDirectory x (sep "/emptydir") + y <- newHVFSChroot x (sep "/dir1") testfunc y in [ f "root" (\x -> ["file3.txt", "test.txt", "dir2"] - `ioeq` vGetDirectoryContents x "/") - ,f "cwd" (\x -> "/" `ioeq` vGetCurrentDirectory x) - ,f "dir2" (\x -> [] `ioeq` vGetDirectoryContents x "/dir2") + `ioeq` vGetDirectoryContents x (sep "/")) + ,f "cwd" (\x -> sep "/" `ioeq` vGetCurrentDirectory x) + ,f "dir2" (\x -> [] `ioeq` vGetDirectoryContents x (sep "/dir2")) ,f "dot" (\x -> ["file3.txt", "test.txt", "dir2"] `ioeq` vGetDirectoryContents x ".") ,f "cwd tests" $ - (\x -> do a <- vGetDirectoryContents x "/" + (\x -> do a <- vGetDirectoryContents x (sep "/") ["file3.txt", "test.txt", "dir2"] @=? a - vSetCurrentDirectory x "/dir2" + vSetCurrentDirectory x (sep "/dir2") cwd <- vGetCurrentDirectory x - "/dir2" @=? cwd + sep "/dir2" @=? cwd y <- vGetDirectoryContents x "." [] @=? y vSetCurrentDirectory x ".." - "/" `ioeq` vGetCurrentDirectory x + sep "/" `ioeq` vGetCurrentDirectory x --vSetCurrentDirectory x ".." --"/" `ioeq` vGetCurrentDirectory x ) @@ -92,16 +99,16 @@ in [ f "root" (\x -> ["test.txt", "file2.txt", "emptydir", "dir1"] - `ioeq` vGetDirectoryContents x "/") + `ioeq` vGetDirectoryContents x (sep ("/"))) ,f "dot" (\x -> ["test.txt", "file2.txt", "emptydir", "dir1"] `ioeq` vGetDirectoryContents x ".") ,f "dot2" (\x -> ["file3.txt", "test.txt", "dir2"] - `ioeq` do vSetCurrentDirectory x "./dir1" + `ioeq` do vSetCurrentDirectory x (sep "./dir1") vGetDirectoryContents x ".") - ,f "emptydir" (\x -> [] `ioeq` vGetDirectoryContents x "/emptydir") + ,f "emptydir" (\x -> [] `ioeq` vGetDirectoryContents x (sep "/emptydir")) ,f "dir1" (\x -> ["file3.txt", "test.txt", "dir2"] `ioeq` vGetDirectoryContents x "/dir1") - ,f "dir1/dir2" (\x -> [] `ioeq` vGetDirectoryContents x "/dir1/dir2") + ,f (sep "dir1/dir2") (\x -> [] `ioeq` vGetDirectoryContents x (sep "/dir1/dir2")) ,f "relative tests" (\x -> do vSetCurrentDirectory x "dir1" [] `ioeq` vGetDirectoryContents x "dir2" diff --git a/testsrc/Pathtest.hs b/testsrc/Pathtest.hs --- a/testsrc/Pathtest.hs +++ b/testsrc/Pathtest.hs @@ -10,9 +10,16 @@ module Pathtest(tests) where import Test.HUnit import System.Path +import System.FilePath (pathSeparator) +sep = map (\c -> if c == '/' then pathSeparator else c) + test_absNormPath = - let f base p exp = TestLabel (show (base, p)) $ TestCase $ exp @=? absNormPath base p + let f base' p' exp' = TestLabel (show (base, p)) $ TestCase $ exp @=? absNormPath base p + where + base = sep base' + p = sep p' + exp = fmap sep exp' f2 = f "/usr/1/2" in [ f "/" "" (Just "/") @@ -31,7 +38,11 @@ ] test_secureAbsNormPath = - let f base p exp = TestLabel (show (base, p)) $ TestCase $ exp @=? secureAbsNormPath base p + let f base' p' exp' = TestLabel (show (base, p)) $ TestCase $ exp @=? secureAbsNormPath base p + where + base = sep base' + p = sep p' + exp = fmap sep exp' f2 = f "/usr/1/2" in [ f "/" "" (Just "/") @@ -52,8 +63,11 @@ ] test_splitExt = - let f inp exp = TestCase $ exp @=? splitExt inp in - [ + let f inp' exp' = TestCase $ exp @=? splitExt inp + where + inp = sep inp' + exp = (\(x,y) -> (sep x, y)) exp' + in [ f "" ("", "") ,f "/usr/local" ("/usr/local", "") ,f "../foo.txt" ("../foo", ".txt")