MissingH 1.2.1.0 → 1.3.0.1
raw patch · 10 files changed
+141/−119 lines, 10 filesdep ~basedep ~containersdep ~directory
Dependency ranges changed: base, containers, directory, old-locale, time
Files
- MissingH.cabal +1/−1
- src/System/IO/HVFS/Combinators.hs +7/−7
- src/System/IO/HVFS/InstanceHelpers.hs +31/−29
- src/System/IO/HVFS/Utils.hs +4/−3
- src/System/Path.hs +3/−2
- src/System/Path/Glob.hs +20/−23
- src/System/Path/NameManip.hs +29/−32
- testsrc/Globtest.hs +6/−3
- testsrc/HVFStest.hs +22/−15
- testsrc/Pathtest.hs +18/−4
MissingH.cabal view
@@ -1,5 +1,5 @@ Name: MissingH-Version: 1.2.1.0+Version: 1.3.0.1 License: BSD3 Maintainer: John Goerzen <jgoerzen@complete.org> Author: John Goerzen
src/System/IO/HVFS/Combinators.hs view
@@ -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 =
src/System/IO/HVFS/InstanceHelpers.hs view
@@ -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
src/System/IO/HVFS/Utils.hs view
@@ -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
src/System/Path.hs view
@@ -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
src/System/Path/Glob.hs view
@@ -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]
src/System/Path/NameManip.hs view
@@ -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
testsrc/Globtest.hs view
@@ -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
testsrc/HVFStest.hs view
@@ -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"
testsrc/Pathtest.hs view
@@ -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")