diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,16 @@ +zip-archive 0.3 + + * Support preservation of file modes on Posix (Dan Aloni, #26). + * Add `eVersionMadeBy` field to `Entry` (API change). + * Export `ZipException` (API change). + * `fromEntry` no longer checks for CRC32 match. Previously, it issued + `error` if the match failed. CRC32 match is now checked in `writeEntry` + instead, and a `CRC32Exception` is raised if the checksum doesn't match. + * Test suite: return nonzero status if there are test failures. + Previously we mistakenly did this only on 'errors', not failures. + * Test suite: don't use -9 with zip as it isn't always available. + * Use .travis.yml that builds on both stack and cabal. + zip-archive 0.2.3.7 * Declared test suite's dependency on 'zip' using custom Setup.lhs (#21,#22). 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 @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} ------------------------------------------------------------------------ -- | -- Module : Codec.Archive.Zip @@ -34,6 +35,7 @@ , Entry (..) , CompressionMethod (..) , ZipOption (..) + , ZipException (..) , emptyArchive -- * Pure functions for working with zip archives @@ -64,10 +66,13 @@ import Data.Binary.Get import Data.Binary.Put import Data.List ( nub, find, intercalate ) +import Data.Data (Data) +import Data.Typeable (Typeable) import Text.Printf import System.FilePath import System.Directory ( doesDirectoryExist, getDirectoryContents, createDirectoryIfMissing ) import Control.Monad ( when, unless, zipWithM ) +import qualified Control.Exception as E import System.Directory ( getModificationTime ) import System.IO ( stderr, hPutStrLn ) import qualified Data.Digest.CRC32 as CRC32 @@ -76,7 +81,7 @@ import Control.Applicative #endif #ifndef _WINDOWS -import System.Posix.Files ( setFileTimes ) +import System.Posix.Files ( setFileTimes, setFileMode, fileMode, getFileStatus ) #endif -- from bytestring @@ -89,6 +94,13 @@ -- from zlib import qualified Codec.Compression.Zlib.Raw as Zlib +versionMadeBy :: Word16 +#ifdef _WINDOWS +versionMadeBy = 0x0000 -- FAT/VFAT/VFAT32 file attributes +#else +versionMadeBy = 0x0300 -- UNIX file attributes +#endif + #if !MIN_VERSION_binary(0, 6, 0) manySig :: Word32 -> Get a -> Get [a] manySig sig p = do @@ -126,6 +138,7 @@ , eUncompressedSize :: Word32 -- ^ Uncompressed size in bytes , eExtraField :: B.ByteString -- ^ Extra field - unused by this library , eFileComment :: B.ByteString -- ^ File comment - unused by this library + , eVersionMadeBy :: Word16 -- ^ Version made by field , eInternalFileAttributes :: Word16 -- ^ Internal file attributes - unused by this library , eExternalFileAttributes :: Word32 -- ^ External file attributes (system-dependent) , eCompressedData :: B.ByteString -- ^ Compressed contents of file @@ -143,6 +156,12 @@ | OptLocation FilePath Bool -- ^ Where to place file when adding files and whether to append current path deriving (Read, Show, Eq) +data ZipException = + CRC32Mismatch FilePath + deriving (Show, Typeable, Data) + +instance E.Exception ZipException + -- | A zip archive with no contents. emptyArchive :: Archive emptyArchive = Archive @@ -197,10 +216,7 @@ -- | Returns uncompressed contents of zip entry. fromEntry :: Entry -> B.ByteString fromEntry entry = - let uncompressedData = decompressData (eCompressionMethod entry) (eCompressedData entry) - in if eCRC32 entry == CRC32.crc32 uncompressedData - then uncompressedData - else error "CRC32 mismatch" + decompressData (eCompressionMethod entry) (eCompressedData entry) -- | Create an 'Entry' with specified file path, modification time, and contents. toEntry :: FilePath -- ^ File path for entry @@ -225,6 +241,7 @@ , eUncompressedSize = fromIntegral uncompressedSize , eExtraField = B.empty , eFileComment = B.empty + , eVersionMadeBy = versionMadeBy , eInternalFileAttributes = 0 -- potentially non-text , eExternalFileAttributes = 0 -- appropriate if from stdin , eCompressedData = finalData @@ -252,16 +269,28 @@ (TOD modEpochTime _) <- getModificationTime path #endif let entry = toEntry path' modEpochTime contents + + entryE <- +#ifdef _WINDOWS + return $ entry +#else + do fm <- fmap fileMode $ getFileStatus path' + let modes = fromIntegral $ shiftL (toInteger fm) 16 + return $ entry { eExternalFileAttributes = modes } +#endif + when (OptVerbose `elem` opts) $ do - let compmethod = case eCompressionMethod entry of + let compmethod = case eCompressionMethod entryE of Deflate -> "deflated" NoCompression -> "stored" hPutStrLn stderr $ - printf " adding: %s (%s %.f%%)" (eRelativePath entry) - compmethod (100 - (100 * compressionRatio entry)) - return entry + printf " adding: %s (%s %.f%%)" (eRelativePath entryE) + compmethod (100 - (100 * compressionRatio entryE)) + return entryE --- | Writes contents of an 'Entry' to a file. +-- | Writes contents of an 'Entry' to a file. Throws a +-- 'CRC32Mismatch' exception if the CRC32 checksum for the entry +-- does not match the uncompressed data. writeEntry :: [ZipOption] -> Entry -> IO () writeEntry opts entry = do let path = case [d | OptDestination d <- opts] of @@ -281,7 +310,16 @@ hPutStrLn stderr $ case eCompressionMethod entry of Deflate -> " inflating: " ++ path NoCompression -> "extracting: " ++ path - B.writeFile path (fromEntry entry) + let uncompressedData = fromEntry entry + if eCRC32 entry == CRC32.crc32 uncompressedData + then B.writeFile path uncompressedData + else E.throwIO $ CRC32Mismatch path +#ifndef _WINDOWS + let modes = fromIntegral $ shiftR (eExternalFileAttributes entry) 16 + when (eVersionMadeBy entry == 0x0300 && + modes /= 0) $ setFileMode path modes +#endif + -- Note that last modified times are supported only for POSIX, not for -- Windows. setFileTimeStamp path (eLastModified entry) @@ -637,7 +675,7 @@ -> Get Entry getFileHeader locals = do getWord32le >>= ensure (== 0x02014b50) - skip 2 -- version made by + vmb <- getWord16le -- version made by versionNeededToExtract <- getWord8 skip 1 -- upper byte indicates OS part of "version needed to extract" unless (versionNeededToExtract <= 20) $ @@ -678,6 +716,7 @@ , eUncompressedSize = uncompressedSize , eExtraField = extraField , eFileComment = fileComment + , eVersionMadeBy = vmb , eInternalFileAttributes = internalFileAttributes , eExternalFileAttributes = externalFileAttributes , eCompressedData = compressedData @@ -688,7 +727,7 @@ -> Put putFileHeader offset local = do putWord32le 0x02014b50 - putWord16le 0 -- version made by + putWord16le $ eVersionMadeBy local putWord16le 20 -- version needed to extract (>= 2.0) putWord16le 0x802 -- general purpose bit flag (bit 1 = max compression, bit 11 = UTF-8) putWord16le $ case eCompressionMethod local of 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 @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} -- Test suite for Codec.Archive.Zip -- runghc Test.hs @@ -11,6 +12,10 @@ import Control.Applicative import System.Exit +#ifndef _WINDOWS +import System.Posix.Files +#endif + -- define equality for Archives so timestamps aren't distinguished if they -- correspond to the same MSDOS datetime. instance Eq Archive where @@ -29,9 +34,12 @@ , testAddFilesOptions , testDeleteEntries , testExtractFiles +#ifndef _WINDOWS + , testExtractFilesWithPosixAttrs +#endif ] removeDirectoryRecursive "test-temp" - exitWith $ case errors res of + exitWith $ case (failures res + errors res) of 0 -> ExitSuccess n -> ExitFailure n @@ -45,7 +53,7 @@ testReadExternalZip :: Test testReadExternalZip = TestCase $ do - _ <- runCommand "zip -q -9 test-temp/test4.zip zip-archive.cabal src/Codec/Archive/Zip.hs" >>= waitForProcess + _ <- runCommand "zip -q test-temp/test4.zip zip-archive.cabal src/Codec/Archive/Zip.hs" >>= waitForProcess archive <- toArchive <$> B.readFile "test-temp/test4.zip" let files = filesInArchive archive assertEqual "for results of filesInArchive" ["zip-archive.cabal", "src/Codec/Archive/Zip.hs"] files @@ -99,3 +107,17 @@ assertEqual "contents of test-temp/dir1/hi" hiMsg hi assertEqual "contents of test-temp/dir1/dir2/hello" helloMsg hello +testExtractFilesWithPosixAttrs :: Test +testExtractFilesWithPosixAttrs = TestCase $ do + createDirectory "test-temp/dir3" + let hiMsg = "hello there" + writeFile "test-temp/dir3/hi" hiMsg + let perms = unionFileModes ownerReadMode $ unionFileModes ownerWriteMode ownerExecuteMode + setFileMode "test-temp/dir3/hi" perms + archive <- addFilesToArchive [OptRecursive] emptyArchive ["test-temp/dir3"] + removeDirectoryRecursive "test-temp/dir3" + extractFilesFromArchive [OptVerbose] archive + hi <- readFile "test-temp/dir3/hi" + fm <- fmap fileMode $ getFileStatus "test-temp/dir3/hi" + assertEqual "file modes" perms (intersectFileModes perms fm) + assertEqual "contents of test-temp/dir3/hi" hiMsg hi diff --git a/zip-archive.cabal b/zip-archive.cabal --- a/zip-archive.cabal +++ b/zip-archive.cabal @@ -1,5 +1,5 @@ Name: zip-archive -Version: 0.2.3.7 +Version: 0.3 Cabal-Version: >= 1.10 Build-type: Custom Synopsis: Library for creating and modifying zip archives. @@ -64,3 +64,7 @@ Default-Language: Haskell98 Ghc-Options: -Wall Build-Tools: zip + if os(windows) + cpp-options: -D_WINDOWS + else + Build-depends: unix