diff --git a/System/Posix/ByteString/FilePath.hsc b/System/Posix/ByteString/FilePath.hsc index 9c487a52..1e49546e 100644 --- a/System/Posix/ByteString/FilePath.hsc +++ b/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 <> "'") diff --git a/System/Posix/Files.hsc b/System/Posix/Files.hsc index 949abf7c..3cf963df 100644 --- a/System/Posix/Files.hsc +++ b/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 diff --git a/System/Posix/Files/ByteString.hsc b/System/Posix/Files/ByteString.hsc index d808e86e..deb83da8 100644 --- a/System/Posix/Files/ByteString.hsc +++ b/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 diff --git a/tests/FileStatus.hs b/tests/FileStatus.hs index bdd5f043..88a4f25c 100644 --- a/tests/FileStatus.hs +++ b/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 ()) diff --git a/tests/FileStatusByteString.hs b/tests/FileStatusByteString.hs index ed8bbd8e..65908e51 100644 --- a/tests/FileStatusByteString.hs +++ b/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 ())