Fix issue 60: confusing error messages in rename/createLink/createSymbolicLink

System/Posix/ByteString/FilePath.hsc

@@ -25,7 +25,8 @@ module System.Posix.ByteString.FilePath (
      throwErrnoPathIf_,
      throwErrnoPathIfNull,
      throwErrnoPathIfMinus1,
-     throwErrnoPathIfMinus1_
+     throwErrnoPathIfMinus1_,
+     throwErrnoTwoPathsIfMinus1_
   ) where
 
 import Foreign hiding ( void )
@@ -41,6 +42,9 @@ import Control.Monad
 import Data.ByteString
 import Data.ByteString.Char8 as BC
 import Prelude hiding (FilePath)
+#if !MIN_VERSION_base(4, 11, 0)
+import Data.Monoid ((<>))
+#endif
 
 -- | A literal POSIX file path
 type RawFilePath = ByteString
@@ -121,3 +125,9 @@ throwErrnoPathIfMinus1 = throwErrnoPathIf (== -1)
 --
 throwErrnoPathIfMinus1_ :: (Eq a, Num a) => String -> RawFilePath -> IO a -> IO ()
 throwErrnoPathIfMinus1_  = throwErrnoPathIf_ (== -1)
+
+-- | as 'throwErrnoTwoPathsIfMinus1_', but exceptions include two paths when appropriate.
+--
+throwErrnoTwoPathsIfMinus1_ :: (Eq a, Num a) => String -> RawFilePath -> RawFilePath -> IO a -> IO ()
+throwErrnoTwoPathsIfMinus1_  loc path1 path2 =
+    throwErrnoIfMinus1_ (loc <> " '" <> BC.unpack path1 <> "' to '" <> BC.unpack path2 <> "'")

System/Posix/Files.hsc

@@ -102,8 +102,19 @@ import System.Posix.Files.Common
 import System.Posix.Error
 import System.Posix.Internals
 
+#if !MIN_VERSION_base(4, 11, 0)
+import Data.Monoid ((<>))
+#endif
+
 import Data.Time.Clock.POSIX (POSIXTime)
 
+-- throwErrnoTwoPathsIfMinus1_
+--
+-- | For operations that require two paths (e.g., renaming a file)
+throwErrnoTwoPathsIfMinus1_ :: (Eq a, Num a) => String -> FilePath -> FilePath -> IO a -> IO ()
+throwErrnoTwoPathsIfMinus1_ loc path1 path2 =
+  throwErrnoIfMinus1_ (loc <> " '" <> path1 <> "' to '" <> path2 <> "'")
+
 -- -----------------------------------------------------------------------------
 -- chmod()
 
@@ -228,7 +239,7 @@ createLink :: FilePath -> FilePath -> IO ()
 createLink name1 name2 =
   withFilePath name1 $ \s1 ->
   withFilePath name2 $ \s2 ->
-  throwErrnoPathIfMinus1_ "createLink" name1 (c_link s1 s2)
+  throwErrnoTwoPathsIfMinus1_ "createLink" name1 name2 (c_link s1 s2)
 
 -- | @removeLink path@ removes the link named @path@.
 --
@@ -241,18 +252,18 @@ removeLink name =
 -- -----------------------------------------------------------------------------
 -- Symbolic Links
 
--- | @createSymbolicLink file1 file2@ creates a symbolic link named @file2@
--- which points to the file @file1@.
+-- | @createSymbolicLink name1 name2@ creates a symbolic link named @name2@
+-- which points to the file @name1@.
 --
 -- Symbolic links are interpreted at run-time as if the contents of the link
 -- had been substituted into the path being followed to find a file or directory.
 --
 -- Note: calls @symlink@.
 createSymbolicLink :: FilePath -> FilePath -> IO ()
-createSymbolicLink file1 file2 =
-  withFilePath file1 $ \s1 ->
-  withFilePath file2 $ \s2 ->
-  throwErrnoPathIfMinus1_ "createSymbolicLink" file2 (c_symlink s1 s2)
+createSymbolicLink name1 name2 =
+  withFilePath name1 $ \s1 ->
+  withFilePath name2 $ \s2 ->
+  throwErrnoTwoPathsIfMinus1_ "createSymbolicLink" name1 name2 (c_symlink s1 s2)
 
 foreign import ccall unsafe "symlink"
   c_symlink :: CString -> CString -> IO CInt
@@ -290,7 +301,7 @@ rename :: FilePath -> FilePath -> IO ()
 rename name1 name2 =
   withFilePath name1 $ \s1 ->
   withFilePath name2 $ \s2 ->
-  throwErrnoPathIfMinus1_ "rename" name1 (c_rename s1 s2)
+  throwErrnoTwoPathsIfMinus1_  "rename" name1 name2 (c_rename s1 s2)
 
 foreign import ccall unsafe "rename"
    c_rename :: CString -> CString -> IO CInt

System/Posix/Files/ByteString.hsc

@@ -234,7 +234,7 @@ createLink :: RawFilePath -> RawFilePath -> IO ()
 createLink name1 name2 =
   withFilePath name1 $ \s1 ->
   withFilePath name2 $ \s2 ->
-  throwErrnoPathIfMinus1_ "createLink" name1 (c_link s1 s2)
+  throwErrnoTwoPathsIfMinus1_ "createLink" name1 name2 (c_link s1 s2)
 
 -- | @removeLink path@ removes the link named @path@.
 --
@@ -255,10 +255,10 @@ removeLink name =
 --
 -- Note: calls @symlink@.
 createSymbolicLink :: RawFilePath -> RawFilePath -> IO ()
-createSymbolicLink file1 file2 =
-  withFilePath file1 $ \s1 ->
-  withFilePath file2 $ \s2 ->
-  throwErrnoPathIfMinus1_ "createSymbolicLink" file2 (c_symlink s1 s2)
+createSymbolicLink name1 name2 =
+  withFilePath name1 $ \s1 ->
+  withFilePath name2 $ \s2 ->
+  throwErrnoTwoPathsIfMinus1_ "createSymbolicLink" name1 name2 (c_symlink s1 s2)
 
 foreign import ccall unsafe "symlink"
   c_symlink :: CString -> CString -> IO CInt
@@ -296,7 +296,7 @@ rename :: RawFilePath -> RawFilePath -> IO ()
 rename name1 name2 =
   withFilePath name1 $ \s1 ->
   withFilePath name2 $ \s2 ->
-  throwErrnoPathIfMinus1_ "rename" name1 (c_rename s1 s2)
+  throwErrnoTwoPathsIfMinus1_ "rename" name1 name2 (c_rename s1 s2)
 
 foreign import ccall unsafe "rename"
    c_rename :: CString -> CString -> IO CInt

tests/FileStatus.hs

@@ -10,18 +10,21 @@ import System.Posix.Directory
 import System.Posix.IO
 import Control.Exception as E
 import Control.Monad
+import Test.Tasty.HUnit
 
 main = do
   cleanup
   fs <- testRegular
   ds <- testDir
   testSymlink fs ds
+  testLink
   cleanup
 
-regular      = "regular"
-dir          = "dir"
-link_regular = "link-regular"
-link_dir     = "link-dir"
+regular       = "regular"
+dir           = "dir"
+slink_regular = "link-regular-symlink"
+hlink_regular = "link-regular-hardlink"
+link_dir      = "link-dir"
 
 testRegular = do
   _ <- createFile regular ownerReadMode
@@ -42,9 +45,9 @@ testDir = do
   return ds
 
 testSymlink fs ds = do
-  createSymbolicLink regular link_regular
+  createSymbolicLink regular slink_regular
   createSymbolicLink dir     link_dir
-  (fs', ls)  <- getStatus link_regular
+  (fs', ls)  <- getStatus slink_regular
   (ds', lds) <- getStatus link_dir
 
   let expected = (False,False,False,False,False,True,False)
@@ -63,10 +66,27 @@ testSymlink fs ds = do
   when (statusElements ds /= statusElements ds') $
     fail "status for a directory does not match when it's accessed via a symlink"
 
+
+testLink = do
+  createLink regular hlink_regular
+  (fs, _)  <- getStatus regular -- we need to retrieve it again as creating the link causes it to change!
+  (fs', ls)  <- getStatus hlink_regular
+  snd (statusElements ls) @?= (
+                False, -- isBlockDevice
+                False, -- isCharacterDevice
+                False, -- isNamedPipe
+                True,  -- isRegularFile
+                False, -- isDirectory
+                False, -- isSymbolicLink
+                False) -- isSocket
+  linkCount fs' == 2 @? "Newly created hard link was expected to have a link count of 2"
+  statusElements fs @?= statusElements fs' -- status for a file should match when accessed via a link
+
+
 cleanup = do
   ignoreIOExceptions $ removeDirectory dir
   mapM_ (ignoreIOExceptions . removeLink)
-        [regular, link_regular, link_dir]
+        [regular, hlink_regular, slink_regular, link_dir]
 
 ignoreIOExceptions io = io `E.catch`
                         ((\_ -> return ()) :: IOException -> IO ())

tests/FileStatusByteString.hs

@@ -9,18 +9,21 @@ module FileStatusByteString (main) where
 import System.Posix.ByteString
 import Control.Exception as E
 import Control.Monad
+import Test.Tasty.HUnit
 
 main = do
   cleanup
   fs <- testRegular
   ds <- testDir
   testSymlink fs ds
+  testLink
   cleanup
 
-regular      = "regular2"
-dir          = "dir2"
-link_regular = "link-regular2"
-link_dir     = "link-dir2"
+regular       = "regular2"
+dir           = "dir2"
+hlink_regular = "hlink-regular2"
+slink_regular = "slink-regular2"
+link_dir      = "link-dir2"
 
 testRegular = do
   _ <- createFile regular ownerReadMode
@@ -41,9 +44,9 @@ testDir = do
   return ds
 
 testSymlink fs ds = do
-  createSymbolicLink regular link_regular
+  createSymbolicLink regular slink_regular
   createSymbolicLink dir     link_dir
-  (fs', ls)  <- getStatus link_regular
+  (fs', ls)  <- getStatus slink_regular
   (ds', lds) <- getStatus link_dir
 
   let expected = (False,False,False,False,False,True,False)
@@ -62,10 +65,26 @@ testSymlink fs ds = do
   when (statusElements ds /= statusElements ds') $
     fail "status for a directory does not match when it's accessed via a symlink"
 
+testLink = do
+  createLink regular hlink_regular
+  (fs, _)  <- getStatus regular -- we need to retrieve it again as creating the link causes it to change!
+  (fs', ls)  <- getStatus hlink_regular
+  snd (statusElements ls) @?= (
+                False, -- isBlockDevice
+                False, -- isCharacterDevice
+                False, -- isNamedPipe
+                True,  -- isRegularFile
+                False, -- isDirectory
+                False, -- isSymbolicLink
+                False) -- isSocket
+  linkCount fs' == 2 @? "Newly created hard link was expected to have a link count of 2"
+  statusElements fs @?= statusElements fs' -- status for a file should match when accessed via a link
+
+
 cleanup = do
   ignoreIOExceptions $ removeDirectory dir
   mapM_ (ignoreIOExceptions . removeLink)
-        [regular, link_regular, link_dir]
+        [regular, hlink_regular, slink_regular, link_dir]
 
 ignoreIOExceptions io = io `E.catch`
                         ((\_ -> return ()) :: IOException -> IO ())