LIB: fix throwDestinationInSource

We now examine device+file IDs, so this check works reliably
with mountpoints too.

3rdparty/hpath

@@ -1 +1 @@
-Subproject commit 3c3a2d276646f6530970f675ef32c6089c1e56d4
+Subproject commit 3a52a9ea4b3b693785364e3f899775cbdc78befc

src/HSFM/FileSystem/Errors.hs

@@ -27,6 +27,7 @@ import Control.Exception
 import Control.Monad
   (
     when
+  , forM
   )
 import Data.Typeable
 import Foreign.C.Error
@@ -110,15 +111,24 @@ throwSameFile fp1 fp2 = do
   when (equalFilePath fp1' fp2') (throw $ SameFile fp1' fp2')
 
 
-throwDestinationInSource :: Path Abs -- ^ will be canonicalized
+-- |Checks whether the destination directory is contained
-                         -> Path Abs -- ^ `dirname dest` will be canonicalized
+-- within the source directory by comparing the device+file ID of the
+-- source directory with all device+file IDs of the parent directories
+-- of the destination.
+throwDestinationInSource :: Path Abs -- ^ source dir
+                         -> Path Abs -- ^ full destination, `basename dest`
+                                     --   must exist
                          -> IO ()
 throwDestinationInSource source dest = do
-  source'   <- P.canonicalizePath source
+  source' <- P.canonicalizePath source
-  cDestbase <- P.canonicalizePath $ P.dirname dest
+  dest'   <- (P.</> P.basename dest) <$> (P.canonicalizePath $ P.dirname dest)
-  let dest' = cDestbase P.</> P.basename dest
+  dids <- forM (P.getAllParents dest') $ \p -> do
-  when (source' `P.isParentOf` dest')
+          fs <- PF.getSymbolicLinkStatus (P.fromAbs p)
-       (throw $ DestinationInSource (P.fromAbs dest') (P.fromAbs source'))
+          return (PF.deviceID fs, PF.fileID fs)
+  sid <- fmap (\x -> (PF.deviceID x, PF.fileID x))
+              $ PF.getSymbolicLinkStatus (P.fromAbs source')
+  when (elem sid dids)
+       (throw $ DestinationInSource (P.fromAbs dest) (P.fromAbs source))
 
 
 -- |Checks if the given file exists and is not a directory. This follows