LIB: wrap canonicalizePath so it doesn't follow the last symlink component

canonicalizePath tries to remove as many symlink components as possible,
but this is not what we want for a lot of operations like copying
files. So instead we preserve the last path component if it's a symlink
and canonicalize it's parent filepath.

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
 
 

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