diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,9 @@ +zip-archive 0.3.2.1 + + * Fixes for handling of symbolic links (#39, Tommaso Piazza). + + * Fixes for symbolic link tests, and additional tests. + zip-archive 0.3.2 * Add ZipOption to preserve symbolic links (#37, Tommaso Piazza). diff --git a/src/Codec/Archive/Zip.hs b/src/Codec/Archive/Zip.hs --- a/src/Codec/Archive/Zip.hs +++ b/src/Codec/Archive/Zip.hs @@ -48,10 +48,18 @@ , findEntryByPath , fromEntry , toEntry +#ifndef _WINDOWS + , isEntrySymbolicLink + , symbolicLinkEntryTarget + , entryCMode +#endif -- * IO functions for working with zip archives , readEntry , writeEntry +#ifndef _WINDOWS + , writeSymbolicLinkEntry +#endif , addFilesToArchive , extractFilesFromArchive @@ -65,12 +73,13 @@ import Data.Binary import Data.Binary.Get import Data.Binary.Put -import Data.List ( nub, find, intercalate ) +import Data.List ( nub, find, intercalate, partition) import Data.Data (Data) +import Data.Maybe (fromJust) import Data.Typeable (Typeable) import Text.Printf import System.FilePath -import System.Directory ( doesDirectoryExist, getDirectoryContents, createDirectoryIfMissing, ) +import System.Directory ( doesDirectoryExist, getDirectoryContents, createDirectoryIfMissing ) import Control.Monad ( when, unless, zipWithM ) import qualified Control.Exception as E import System.Directory ( getModificationTime ) @@ -81,13 +90,14 @@ import Control.Applicative #endif #ifndef _WINDOWS -import System.Posix.Files ( setFileTimes, setFileMode, fileMode, getSymbolicLinkStatus, symbolicLinkMode, readSymbolicLink, isSymbolicLink) +import System.Posix.Files ( setFileTimes, setFileMode, fileMode, getSymbolicLinkStatus, symbolicLinkMode, readSymbolicLink, isSymbolicLink, unionFileModes, createSymbolicLink ) +import System.Posix.Types ( CMode(..) ) #endif -- from bytestring import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as B -import qualified Data.ByteString.Lazy.Char8 as C (pack) +import qualified Data.ByteString.Lazy.Char8 as C (pack, unpack) -- text import qualified Data.Text.Lazy as TL @@ -260,7 +270,7 @@ fs <- getSymbolicLinkStatus path let isSymLink = isSymbolicLink fs #endif - -- make sure directories end in / and deal with the OptLocation option + -- make sure directories end in / and deal with the OptLocation option let path' = let p = path ++ (case reverse path of ('/':_) -> "" _ | isDir && not isSymLink -> "/" @@ -296,7 +306,7 @@ #else do let fm = if isSymLink - then symbolicLinkMode + then unionFileModes symbolicLinkMode (fileMode fs) else fileMode fs let modes = fromIntegral $ shiftL (toInteger fm) 16 @@ -342,13 +352,50 @@ #ifndef _WINDOWS let modes = fromIntegral $ shiftR (eExternalFileAttributes entry) 16 when (eVersionMadeBy entry .&. 0xFF00 == 0x0300 && - modes /= 0) $ setFileMode path modes + modes /= 0) $ setFileMode path modes #endif - -- Note that last modified times are supported only for POSIX, not for -- Windows. setFileTimeStamp path (eLastModified entry) +#ifndef _WINDOWS +-- | Write an 'Entry' representing a symbolic link to a file. +-- If the 'Entry' does not represent a symbolic link or +-- the options do not contain 'OptPreserveSymbolicLinks`, this +-- function behaves like `writeEntry`. +writeSymbolicLinkEntry :: [ZipOption] -> Entry -> IO () +writeSymbolicLinkEntry opts entry = do + if OptPreserveSymbolicLinks `notElem` opts + then writeEntry opts entry + else do + if (isEntrySymbolicLink entry) + then do + let prefixPath = case [d | OptDestination d <- opts] of + (x:_) -> x + _ -> "" + let targetPath = fromJust . symbolicLinkEntryTarget $ entry + let symlinkPath = prefixPath eRelativePath entry + when (OptVerbose `elem` opts) $ do + hPutStrLn stderr $ "linking " ++ symlinkPath ++ " to " ++ targetPath + createSymbolicLink targetPath symlinkPath + else writeEntry opts entry + + +-- | Get the target of a 'Entry' representing a symbolic link. This might fail +-- if the 'Entry' does not represent a symbolic link +symbolicLinkEntryTarget :: Entry -> Maybe FilePath +symbolicLinkEntryTarget entry | isEntrySymbolicLink entry = Just . C.unpack $ fromEntry entry + | otherwise = Nothing + +-- | Check if an 'Entry' represents a symbolic link +isEntrySymbolicLink :: Entry -> Bool +isEntrySymbolicLink entry = entryCMode entry .&. symbolicLinkMode == symbolicLinkMode + +-- | Get the 'eExternalFileAttributes' of an 'Entry' as a 'CMode' a.k.a. 'FileMode' +entryCMode :: Entry -> CMode +entryCMode entry = CMode (fromIntegral $ shiftR (eExternalFileAttributes entry) 16) +#endif + -- | Add the specified files to an 'Archive'. If 'OptRecursive' is specified, -- recursively add files contained in directories. if 'OptPreserveSymbolicLinks' -- is specified, don't recurse into it. If 'OptVerbose' is specified, @@ -370,8 +417,17 @@ -- Note that the last-modified time is set correctly only in POSIX, -- not in Windows. extractFilesFromArchive :: [ZipOption] -> Archive -> IO () -extractFilesFromArchive opts archive = - mapM_ (writeEntry opts) $ zEntries archive +extractFilesFromArchive opts archive = do + if OptPreserveSymbolicLinks `elem` opts + then do +#ifdef _WINDOWS + mapM_ (writeEntry opts) $ zEntries archive +#else + let (symbolicLinkEntries, nonSymbolicLinkEntries) = partition isEntrySymbolicLink $ zEntries archive + mapM_ (writeEntry opts) $ nonSymbolicLinkEntries + mapM_ (writeSymbolicLinkEntry opts) $ symbolicLinkEntries +#endif + else mapM_ (writeEntry opts) $ zEntries archive -------------------------------------------------------------------------------- -- Internal functions for reading and writing zip binary format. diff --git a/tests/test-zip-archive.hs b/tests/test-zip-archive.hs --- a/tests/test-zip-archive.hs +++ b/tests/test-zip-archive.hs @@ -4,17 +4,21 @@ -- runghc Test.hs import Codec.Archive.Zip -import System.Directory +import Control.Applicative +import System.Directory hiding (isSymbolicLink) import Test.HUnit.Base import Test.HUnit.Text import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as BL -import Control.Applicative import System.Exit import System.IO.Temp (withTempDirectory) #ifndef _WINDOWS +import System.FilePath.Posix import System.Posix.Files +import System.Process (callCommand) +#else +import System.FilePath.Windows #endif -- define equality for Archives so timestamps aren't distinguished if they @@ -25,6 +29,23 @@ && (all id $ zipWith (\x y -> x { eLastModified = eLastModified x `div` 2 } == y { eLastModified = eLastModified y `div` 2 }) (zEntries a1) (zEntries a2)) +#ifndef _WINDOWS + +createTestDirectoryWithSymlinks :: FilePath -> FilePath -> IO FilePath +createTestDirectoryWithSymlinks prefixDir baseDir = do + let testDir = prefixDir baseDir + createDirectoryIfMissing True testDir + createDirectoryIfMissing True (testDir "1") + writeFile (testDir "1/file.txt") "hello" + cwd <- getCurrentDirectory + createFileLink (cwd testDir "1/file.txt") (testDir "link_to_file") + createSymbolicLink (cwd testDir "1") (testDir "link_to_directory") + return testDir + +#endif + + + main :: IO Counts main = withTempDirectory "." "test-zip-archive." $ \tmpDir -> do res <- runTestTT $ TestList $ map (\f -> f tmpDir) @@ -37,6 +58,9 @@ , testExtractFiles #ifndef _WINDOWS , testExtractFilesWithPosixAttrs + , testArchiveExtractSymlinks + , testExtractExternalZipWithSymlinks + , testArchiveAndUnzip #endif ] exitWith $ case (failures res + errors res) of @@ -46,8 +70,8 @@ testReadWriteArchive :: FilePath -> Test testReadWriteArchive tmpDir = TestCase $ do archive <- addFilesToArchive [OptRecursive] emptyArchive ["LICENSE", "src"] - BL.writeFile (tmpDir ++ "/test1.zip") $ fromArchive archive - archive' <- toArchive <$> BL.readFile (tmpDir ++ "/test1.zip") + BL.writeFile (tmpDir "test1.zip") $ fromArchive archive + archive' <- toArchive <$> BL.readFile (tmpDir "test1.zip") assertEqual "for writing and reading test1.zip" archive archive' assertEqual "for writing and reading test1.zip" archive archive' @@ -69,11 +93,14 @@ BL.empty (fromEntry f) testFromToArchive :: FilePath -> Test -testFromToArchive _tmpDir = TestCase $ do +testFromToArchive tmpDir = TestCase $ do archive1 <- addFilesToArchive [OptRecursive] emptyArchive ["LICENSE", "src"] assertEqual "for (toArchive $ fromArchive archive)" archive1 (toArchive $ fromArchive archive1) - archive2 <- addFilesToArchive [OptRecursive, OptPreserveSymbolicLinks] emptyArchive ["tests/test_dir_with_symlinks"] +#ifndef _WINDOWS + testDir <- createTestDirectoryWithSymlinks tmpDir "test_dir_with_symlinks" + archive2 <- addFilesToArchive [OptRecursive, OptPreserveSymbolicLinks] emptyArchive [testDir] assertEqual "for (toArchive $ fromArchive archive)" archive2 (toArchive $ fromArchive archive2) +#endif testReadWriteEntry :: FilePath -> Test testReadWriteEntry tmpDir = TestCase $ do @@ -81,19 +108,22 @@ setCurrentDirectory tmpDir writeEntry [] entry setCurrentDirectory ".." - entry' <- readEntry [] (tmpDir ++ "/zip-archive.cabal") + entry' <- readEntry [] (tmpDir "zip-archive.cabal") let entry'' = entry' { eRelativePath = eRelativePath entry, eLastModified = eLastModified entry } assertEqual "for readEntry -> writeEntry -> readEntry" entry entry'' testAddFilesOptions :: FilePath -> Test -testAddFilesOptions _tmpDir = TestCase $ do +testAddFilesOptions tmpDir = TestCase $ do archive1 <- addFilesToArchive [OptVerbose] emptyArchive ["LICENSE", "src"] archive2 <- addFilesToArchive [OptRecursive, OptVerbose] archive1 ["LICENSE", "src"] assertBool "for recursive and nonrecursive addFilesToArchive" (length (filesInArchive archive1) < length (filesInArchive archive2)) #ifndef _WINDOWS - archive3 <- addFilesToArchive [OptVerbose, OptRecursive] emptyArchive ["tests/test_dir_with_symlinks"] - archive4 <- addFilesToArchive [OptVerbose, OptRecursive, OptPreserveSymbolicLinks] emptyArchive ["tests/test_dir_with_symlinks"] + testDir <- createTestDirectoryWithSymlinks tmpDir "test_dir_with_symlinks2" + archive3 <- addFilesToArchive [OptVerbose, OptRecursive] emptyArchive [testDir] + archive4 <- addFilesToArchive [OptVerbose, OptRecursive, OptPreserveSymbolicLinks] emptyArchive [testDir] + mapM_ putStrLn $ filesInArchive archive3 + mapM_ putStrLn $ filesInArchive archive4 assertBool "for recursive and recursive by preserving symlinks addFilesToArchive" (length (filesInArchive archive4) < length (filesInArchive archive3)) #endif @@ -108,33 +138,87 @@ testExtractFiles :: FilePath -> Test testExtractFiles tmpDir = TestCase $ do - createDirectory (tmpDir ++ "/dir1") - createDirectory (tmpDir ++ "/dir1/dir2") + createDirectory (tmpDir "dir1") + createDirectory (tmpDir "dir1/dir2") let hiMsg = BS.pack "hello there" let helloMsg = BS.pack "Hello there. This file is very long. Longer than 31 characters." - BS.writeFile (tmpDir ++ "/dir1/hi") hiMsg - BS.writeFile (tmpDir ++ "/dir1/dir2/hello") helloMsg - archive <- addFilesToArchive [OptRecursive] emptyArchive [(tmpDir ++ "/dir1")] - removeDirectoryRecursive (tmpDir ++ "/dir1") + BS.writeFile (tmpDir "dir1/hi") hiMsg + BS.writeFile (tmpDir "dir1/dir2/hello") helloMsg + archive <- addFilesToArchive [OptRecursive] emptyArchive [(tmpDir "dir1")] + removeDirectoryRecursive (tmpDir "dir1") extractFilesFromArchive [OptVerbose] archive - hi <- BS.readFile (tmpDir ++ "/dir1/hi") - hello <- BS.readFile (tmpDir ++ "/dir1/dir2/hello") - assertEqual ("contents of " ++ tmpDir ++ "/dir1/hi") hiMsg hi - assertEqual ("contents of " ++ tmpDir ++ "/dir1/dir2/hello") helloMsg hello + hi <- BS.readFile (tmpDir "dir1/hi") + hello <- BS.readFile (tmpDir "dir1/dir2/hello") + assertEqual ("contents of " tmpDir "dir1/hi") hiMsg hi + assertEqual ("contents of " tmpDir "dir1/dir2/hello") helloMsg hello #ifndef _WINDOWS + testExtractFilesWithPosixAttrs :: FilePath -> Test testExtractFilesWithPosixAttrs tmpDir = TestCase $ do - createDirectory (tmpDir ++ "/dir3") + createDirectory (tmpDir "dir3") let hiMsg = "hello there" - writeFile (tmpDir ++ "/dir3/hi") hiMsg + writeFile (tmpDir "dir3/hi") hiMsg let perms = unionFileModes ownerReadMode $ unionFileModes ownerWriteMode ownerExecuteMode - setFileMode (tmpDir ++ "/dir3/hi") perms - archive <- addFilesToArchive [OptRecursive] emptyArchive [(tmpDir ++ "/dir3")] - removeDirectoryRecursive (tmpDir ++ "/dir3") + setFileMode (tmpDir "dir3/hi") perms + archive <- addFilesToArchive [OptRecursive] emptyArchive [(tmpDir "dir3")] + removeDirectoryRecursive (tmpDir "dir3") extractFilesFromArchive [OptVerbose] archive - hi <- readFile (tmpDir ++ "/dir3/hi") - fm <- fmap fileMode $ getFileStatus (tmpDir ++ "/dir3/hi") + hi <- readFile (tmpDir "dir3/hi") + fm <- fmap fileMode $ getFileStatus (tmpDir "dir3/hi") assertEqual "file modes" perms (intersectFileModes perms fm) - assertEqual ("contents of " ++ tmpDir ++ "/dir3/hi") hiMsg hi + assertEqual ("contents of " tmpDir "dir3/hi") hiMsg hi + +testArchiveExtractSymlinks :: FilePath -> Test +testArchiveExtractSymlinks tmpDir = TestCase $ do + testDir <- createTestDirectoryWithSymlinks tmpDir "test_dir_with_symlinks3" + let locationDir = "location_dir" + archive <- addFilesToArchive [OptRecursive, OptPreserveSymbolicLinks, OptLocation locationDir True] emptyArchive [testDir] + removeDirectoryRecursive testDir + let destination = "test_dest" + extractFilesFromArchive [OptPreserveSymbolicLinks, OptDestination destination] archive + isDirSymlink <- pathIsSymbolicLink (destination locationDir testDir "link_to_directory") + isFileSymlink <- pathIsSymbolicLink (destination locationDir testDir "link_to_file") + assertBool "Symbolic link to directory is preserved" isDirSymlink + assertBool "Symbolic link to file is preserved" isFileSymlink + removeDirectoryRecursive destination + +testExtractExternalZipWithSymlinks :: FilePath -> Test +testExtractExternalZipWithSymlinks tmpDir = TestCase $ do + archive <- toArchive <$> BL.readFile "tests/zip_with_symlinks.zip" + extractFilesFromArchive [OptPreserveSymbolicLinks, OptDestination tmpDir] archive + let zipRootDir = "zip_test_dir_with_symlinks" + symlinkDir = tmpDir zipRootDir "symlink_to_dir_1" + symlinkFile = tmpDir zipRootDir "symlink_to_file_1" + isDirSymlink <- pathIsSymbolicLink symlinkDir + targetDirExists <- doesDirectoryExist symlinkDir + isFileSymlink <- pathIsSymbolicLink symlinkFile + targetFileExists <- doesFileExist symlinkFile + assertBool "Symbolic link to directory is preserved" isDirSymlink + assertBool "Target directory exists" targetDirExists + assertBool "Symbolic link to file is preserved" isFileSymlink + assertBool "Target file exists" targetFileExists + removeDirectoryRecursive tmpDir + +testArchiveAndUnzip :: FilePath -> Test +testArchiveAndUnzip tmpDir = TestCase $ do + let dir = "test_dir_with_symlinks4" + testDir <- createTestDirectoryWithSymlinks tmpDir dir + archive <- addFilesToArchive [OptRecursive, OptPreserveSymbolicLinks] emptyArchive [testDir] + removeDirectoryRecursive testDir + let zipFile = tmpDir "testUnzip.zip" + BL.writeFile zipFile $ fromArchive archive + callCommand $ "unzip " ++ zipFile + let symlinkDir = testDir "link_to_directory" + symlinkFile = testDir "link_to_file" + isDirSymlink <- pathIsSymbolicLink symlinkDir + targetDirExists <- doesDirectoryExist symlinkDir + isFileSymlink <- pathIsSymbolicLink symlinkFile + targetFileExists <- doesFileExist symlinkFile + assertBool "Symbolic link to directory is preserved" isDirSymlink + assertBool "Target directory exists" targetDirExists + assertBool "Symbolic link to file is preserved" isFileSymlink + assertBool "Target file exists" targetFileExists + removeDirectoryRecursive tmpDir + #endif diff --git a/tests/zip_with_symlinks.zip b/tests/zip_with_symlinks.zip new file mode 100644 Binary files /dev/null and b/tests/zip_with_symlinks.zip differ diff --git a/zip-archive.cabal b/zip-archive.cabal --- a/zip-archive.cabal +++ b/zip-archive.cabal @@ -1,23 +1,24 @@ Name: zip-archive -Version: 0.3.2 +Version: 0.3.2.1 Cabal-Version: >= 1.10 Build-type: Simple Synopsis: Library for creating and modifying zip archives. Description: The zip-archive library provides functions for creating, modifying, and extracting files from zip archives. Category: Codec -Tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.2 +Tested-with: GHC == 7.8.2, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2 License: BSD3 License-file: LICENSE Homepage: http://github.com/jgm/zip-archive Author: John MacFarlane Maintainer: jgm@berkeley.edu -Extra-Source-Files: changelog, - README.markdown, - tests/test4.zip, - tests/test4/a.txt, - tests/test4/b.bin, +Extra-Source-Files: changelog + README.markdown + tests/test4.zip + tests/test4/a.txt + tests/test4/b.bin "tests/test4/c/with spaces.txt" + tests/zip_with_symlinks.zip Source-repository head type: git @@ -65,8 +66,8 @@ Main-Is: test-zip-archive.hs Hs-Source-Dirs: tests Build-Depends: base >= 4.2 && < 5, - directory, bytestring >= 0.9.0, process, time, old-time, - HUnit, zip-archive, temporary + directory >= 1.3.1, bytestring >= 0.9.0, process, time, old-time, + HUnit, zip-archive, temporary, filepath Default-Language: Haskell98 Ghc-Options: -Wall if os(windows)