diff --git a/src/Data/DirTree.hs b/src/Data/DirTree.hs index 927c7e4..7c30bbe 100644 --- a/src/Data/DirTree.hs +++ b/src/Data/DirTree.hs @@ -35,6 +35,7 @@ import Data.Default import Data.List ( delete + , foldl' , isPrefixOf , sort , sortBy @@ -64,6 +65,7 @@ import Data.Word import Safe ( atDef + , initDef ) import System.Directory ( @@ -79,6 +81,7 @@ import System.Directory import System.FilePath ( combine + , normalise , equalFilePath , joinPath , splitDirectories @@ -248,7 +251,7 @@ readFileWith :: (FilePath -> IO a) -> FilePath -> IO (AnchoredFile a b) readFileWith fd ff fp = do - cfp <- canonicalizePath fp + cfp <- canonicalizePath' fp let fn = topDir cfp bd = baseDir cfp file <- handleDT fn $ do @@ -260,14 +263,14 @@ readFileWith fd ff fp = do readFile :: FilePath -> IO (AnchoredFile FileInfo FileInfo) -readFile fp = readFileWith getFileInfo getFileInfo =<< canonicalizePath fp +readFile fp = readFileWith getFileInfo getFileInfo =<< canonicalizePath' fp -- |Build a list of AnchoredFile, given the path to a directory, filling -- the free variables via `getFileInfo`. readDirectory :: FilePath -> IO [AnchoredFile FileInfo FileInfo] readDirectory fp = readDirectoryWith getFileInfo getFileInfo - =<< canonicalizePath fp + =<< canonicalizePath' fp -- | same as readDirectory but allows us to, for example, use @@ -277,7 +280,7 @@ readDirectoryWith :: (FilePath -> IO a) -> FilePath -> IO [AnchoredFile a b] readDirectoryWith fd ff p = buildWith' buildAtOnce' fd ff - =<< canonicalizePath p + =<< canonicalizePath' p @@ -304,7 +307,7 @@ buildWith' :: Builder a b -> IO [AnchoredFile a b] buildWith' bf' fd ff p = do - cfp <- canonicalizePath p + cfp <- canonicalizePath' p tree <- bf' fd ff cfp return $ fmap (cfp :/) (removeNonexistent tree) @@ -313,7 +316,7 @@ buildWith' bf' fd ff p = -- IO function passed to our builder and finally executed here: buildAtOnce' :: Builder a b buildAtOnce' fd ff p = do - cfp <- canonicalizePath p + cfp <- canonicalizePath' p contents <- getAllDirsFiles cfp for contents $ \n -> handleDT n $ do let subf = cfp n @@ -425,6 +428,30 @@ hiddenFile str | otherwise = False +-- |Like `normalise` from System.FilePath but removes occurences of '..'. +-- Note that this sort of misbehaves if the path contains symlink +-- components. +normalize :: FilePath -> FilePath +normalize fp = + joinPath $ foldl' ff [] (splitDirectories . normalise $ fp) + where + ff ["/"] ".." = ["/"] + ff x ".." = initDef [] x + ff x y = x ++ [y] + + +-- |Like `canonicalizePath` from System.Directory, but preserves the last +-- component if it's a symlink. +canonicalizePath' :: FilePath -> IO FilePath +canonicalizePath' fp = do + isSymlink <- PF.isSymbolicLink <$> PF.getSymbolicLinkStatus fp + if isSymlink + then do + cbase <- canonicalizePath (baseDir fp) + return $ cbase topDir fp + else canonicalizePath fp + + ---- IO HELPERS: ---- @@ -436,7 +463,7 @@ goUp (bp :/ _) = Data.DirTree.readFile bp goUp' :: FilePath -> IO (AnchoredFile FileInfo FileInfo) goUp' fp = do - cfp <- canonicalizePath fp + cfp <- canonicalizePath' fp Data.DirTree.readFile $ baseDir cfp diff --git a/src/IO/File.hs b/src/IO/File.hs index bb4d0e1..9969c3b 100644 --- a/src/IO/File.hs +++ b/src/IO/File.hs @@ -143,8 +143,8 @@ copyDir :: DirCopyMode -> FilePath -- ^ destination dir -> IO () copyDir cm from' to' = do - from <- canonicalizePath from' - to <- canonicalizePath to' + from <- canonicalizePath' from' + to <- canonicalizePath' to' go from to where go from to = do @@ -204,13 +204,13 @@ copyFile :: FilePath -- ^ source file -> FilePath -- ^ destination file -> IO () copyFile from' to' = do - from <- canonicalizePath from' - tod <- canonicalizePath (baseDir to') + from <- canonicalizePath' from' + tod <- canonicalizePath' (baseDir to') let to = tod takeFileName to' fileSanityThrow from throwNotAbsolute to throwDirDoesExist to - toC <- canonicalizePath (takeDirectory to) + toC <- canonicalizePath' (takeDirectory to) let to' = toC takeFileName to throwSameFile from to' SD.copyFile from to' @@ -226,8 +226,8 @@ copyFile from' to' = do -- * anything that `copyFile` throws copyFileToDir :: FilePath -> FilePath -> IO () copyFileToDir from' to' = do - from <- canonicalizePath from' - to <- canonicalizePath to' + from <- canonicalizePath' from' + to <- canonicalizePath' to' let name = takeFileName from dirSanityThrow to copyFile from (to name) @@ -254,7 +254,7 @@ easyCopy cm from to = doFileOrDir from (copyDir cm from to) -- * anything that `removeFile` throws deleteFile :: FilePath -> IO () deleteFile fp' = do - fp <- canonicalizePath fp' + fp <- canonicalizePath' fp' fileSanityThrow fp removeFile fp @@ -269,7 +269,7 @@ deleteFile fp' = do -- * anything that `removeDirectory` throws deleteDir :: FilePath -> IO () deleteDir fp' = do - fp <- canonicalizePath fp' + fp <- canonicalizePath' fp' dirSanityThrow fp removeDirectory fp @@ -283,7 +283,7 @@ deleteDir fp' = do -- * anything that `removeDirectoryRecursive` throws deleteDirRecursive :: FilePath -> IO () deleteDirRecursive fp' = do - fp <- canonicalizePath fp' + fp <- canonicalizePath' fp' dirSanityThrow fp removeDirectoryRecursive fp @@ -297,7 +297,7 @@ deleteDirRecursive fp' = do -- * anything that `deleteDir`/`deleteFile` throws easyDelete :: FilePath -> IO () easyDelete fp' = do - fp <- canonicalizePath fp' + fp <- canonicalizePath' fp' doFileOrDir fp (deleteDir fp) (deleteFile fp) @@ -316,7 +316,7 @@ easyDelete fp' = do openFile :: FilePath -> IO ProcessHandle openFile fp' = do - fp <- canonicalizePath fp' + fp <- canonicalizePath' fp' fileSanityThrow fp spawnProcess "xdg-open" [fp] @@ -332,7 +332,7 @@ executeFile :: FilePath -- ^ program -> [String] -- ^ arguments -> IO ProcessHandle executeFile prog' args = do - prog <- canonicalizePath prog' + prog <- canonicalizePath' prog' fileSanityThrow prog unlessM (fileAccess prog False False True) (throw $ FileNotExecutable prog) spawnProcess prog args @@ -353,7 +353,7 @@ executeFile prog' args = do -- * `throwFileDoesNotExist` if the filepath is neither a file or directory doFileOrDir :: FilePath -> IO () -> IO () -> IO () doFileOrDir fp' iod iof = do - fp <- canonicalizePath fp' + fp <- canonicalizePath' fp' isD <- doesDirectoryExist fp isF <- doesFileExist fp case (isD, isF) of