zip-archive 0.4.3.2 → 0.5
raw patch · 5 files changed
+671/−109 lines, 5 filesdep −mtldep −prettydep ~basePVP ok
version bump matches the API change (PVP)
Dependencies removed: mtl, pretty
Dependency ranges changed: base
API changes (from Hackage documentation)
+ Codec.Archive.Zip: Zip64NotSupported :: String -> ZipException
Files
- README.markdown +1/−1
- changelog +85/−1
- src/Codec/Archive/Zip.hs +269/−88
- tests/test-zip-archive.hs +296/−1
- zip-archive.cabal +20/−18
README.markdown view
@@ -24,4 +24,4 @@ archives in "pure" contexts. As an example of the use of the library, a standalone zip archiver-and extracter is provided in the source distribution.+and extractor is provided in the source distribution.
changelog view
@@ -1,3 +1,87 @@+zip-archive 0.5++ * Reject absolute and drive-qualified entry paths on extraction, even+ when OptDestination is given. `checkPath` now throws UnsafePath for+ absolute (and, on Windows, drive-qualified) paths regardless of options.++ * Validate symbolic link entry paths on extraction.++ * Decode file names per the UTF-8 flag, with CP437 fallback.+ Previously file names were unconditionally decoded as UTF-8, so archives+ with non-UTF-8 names raised an impure UnicodeException.+ Now the general purpose bit flag is consulted: when bit 11 (language+ encoding flag) is set, names are decoded as UTF-8 leniently (invalid+ bytes become U+FFFD); otherwise they are decoded as code page 437 as+ specified in APPNOTE.TXT appendix D.++ * Return Nothing from `decryptData` on truncated encrypted data, instead+ of raising an exception.++ * Raise Zip64NotSupported instead of silently truncating on overflow.+ The library does not support ZIP64, but nothing prevented writing+ archives that would need it: toEntry truncated sizes of entries of 4GB+ or more to Word32, and putArchive truncated entry counts (Word16) and+ central directory offsets (Word32), silently producing corrupt output.+ Add a Zip64NotSupported constructor to ZipException [API change]+ and throw it (as a pure exception) from toEntry for oversized+ entries and from putArchive for too many entries or too-large+ archives. Local file offsets are now computed in Int64 so overflow+ can actually be detected.++ * Undo the local time zone shift when setting extracted file times.+ `readEntry` stores `eLastModified` shifted by the local time+ zone offset; ensure that this shift is reversed on extraction.++ * Clamp DOS datetimes at the upper end of the representable range+ (year 2108).++ * Stop claiming maximum compression in the general purpose bit flag.+ `compressData` uses zlib's default compression level, but the written+ flag (0x802) had bit 1 set, which means the entry was deflated with+ maximum compression. Write 0x800 (UTF-8 file names only) instead.++ * Make `addFilesToArchive` near-linear in the number of files.+ Large directory trees now dedupe via Data.Set on normalized paths,+ preserving the previous semantics (first entry for a path wins,+ new entries precede old ones).++ * Avoid retaining the whole remaining archive in `getCompressedData`.+ The raw deflate stream is fed to zlib's incremental `decompressST`+ chunk by chunk, counting only the bytes actually consumed, so+ memory use is proportional to the entry rather than to everything+ after it.++ * Use a CRC32 lookup table in the PKWARE key schedule.++ * Stream extraction in `writeEntry` with an incremental CRC check.+ writeEntry previously computed the CRC32 of the whole uncompressed+ entry and then wrote it with B.writeFile; the reference to the+ data across the CRC pass forced the entire entry to be retained in+ memory. Now the entry is written chunk by chunk to a temporary+ file in the target directory while the CRC is updated+ incrementally, and the file is renamed into place only if the CRC+ matches. As before, a pre-existing file at the target path is+ left intact when the CRC check fails; the temporary file is+ removed on mismatch or on any exception during writing.++ * Encode each entry path once in `putLocalFile` and `putFileHeader`.+ Previously both serializers normalized and UTF-8-encoded the entry+ path twice: once for its length field and once for the path bytes.++ * cabal: use extra-doc-files stanza.++ * Add regression test for issue #55 (dotfile paths).++ * Fix spelling errors (@kianmeng, #69).++ * Remove stack.yaml.++ * Change default-language to Haskell2010.++ * Remove spurious dependencies (pretty, mtl).++ * Depend on base >= 4.11.+ zip-archive 0.4.3.2 * readEntry: Fix computation of modification time (#67).@@ -19,7 +103,7 @@ zlib's Internal module to identify where the compressed data ends. Fixes both #65 and #25. - zip-archive 0.4.3+zip-archive 0.4.3 * Improve code for retrieving compressed data of unknown length (#63). Do not assume we'll have the signature 0x08074b50 that is
src/Codec/Archive/Zip.hs view
@@ -22,8 +22,17 @@ -- read the most common zip archives, and the archives it produces should -- be readable by all standard unzip programs. --+-- One known limitation: when parsing an archive whose local file+-- headers defer sizes to a data descriptor (general purpose bit 3)+-- and whose entries are stored without compression, the end of the+-- entry data can only be found by scanning for the optional data+-- descriptor signature @0x08074b50@. Parsing such an archive can+-- therefore fail (or truncate an entry) if that byte sequence occurs+-- within the stored data itself. Archives of this kind are rare;+-- deflated entries with data descriptors are not affected.+-- -- As an example of the use of the library, a standalone zip archiver--- and extracter, Zip.hs, is provided in the source distribution.+-- and extractor, Zip.hs, is provided in the source distribution. -- -- For more information on the format of zip archives, consult -- <http://www.pkware.com/documents/casestudies/APPNOTE.TXT>@@ -75,28 +84,33 @@ import Data.Time.LocalTime ( TimeZone(..), TimeOfDay(..), timeToTimeOfDay, getTimeZone ) import Data.Time.Clock.POSIX ( posixSecondsToUTCTime, utcTimeToPOSIXSeconds )-import Data.Bits ( shiftL, shiftR, (.&.), (.|.), xor, testBit )+import Data.Bits ( shiftL, shiftR, (.&.), (.|.), xor, testBit, complement ) import Data.Binary import Data.Binary.Get import Data.Binary.Put-import Data.List (nub, find, intercalate)+import Data.List (find, intercalate)+import Data.Int (Int64) import Data.Data (Data) import Data.Typeable (Typeable) import Text.Printf import System.FilePath import System.Directory (doesDirectoryExist, getDirectoryContents,- createDirectoryIfMissing, getModificationTime,)-import Control.Monad ( when, unless, zipWithM_ )+ createDirectoryIfMissing, getModificationTime,+ renameFile, removeFile)+import Control.Monad ( when, unless, zipWithM_, foldM )+import Control.Monad.ST.Lazy ( runST ) import qualified Control.Exception as E-import System.IO ( stderr, hPutStrLn )+import System.IO ( stderr, hPutStrLn, hClose, openBinaryTempFile ) import qualified Data.Digest.CRC32 as CRC32+import Data.Array.Unboxed ( UArray, listArray, (!) ) import qualified Data.Map as M+import qualified Data.Set as Set import Control.Applicative #ifdef _WINDOWS import Data.Char (isLetter) #else-import System.Posix.Files ( setFileTimes, setFileMode, fileMode, getSymbolicLinkStatus, symbolicLinkMode, readSymbolicLink, isSymbolicLink, unionFileModes, createSymbolicLink, removeLink )+import System.Posix.Files ( setFileTimes, setFileMode, setFileCreationMask, fileMode, getSymbolicLinkStatus, symbolicLinkMode, readSymbolicLink, isSymbolicLink, unionFileModes, createSymbolicLink, removeLink, FileStatus ) import System.Posix.Types ( CMode(..) ) import Data.List (partition) import Data.Maybe (fromJust)@@ -110,6 +124,7 @@ -- text import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL+import qualified Data.Text.Encoding.Error as TE -- from zlib import qualified Codec.Compression.Zlib.Raw as Zlib@@ -148,7 +163,7 @@ { eRelativePath :: FilePath -- ^ Relative path, using '/' as separator , eCompressionMethod :: !CompressionMethod -- ^ Compression method , eEncryptionMethod :: !EncryptionMethod -- ^ Encryption method- , eLastModified :: !Integer -- ^ Modification time (seconds since unix epoch)+ , eLastModified :: !Integer -- ^ Modification time (seconds since unix epoch, shifted by the local time zone offset: MSDOS timestamps in zip archives are conventionally local time) , eCRC32 :: !Word32 -- ^ CRC32 checksum , eCompressedSize :: !Word32 -- ^ Compressed size in bytes , eUncompressedSize :: !Word32 -- ^ Uncompressed size in bytes@@ -179,13 +194,14 @@ | OptVerbose -- ^ Print information to stderr | OptDestination FilePath -- ^ Directory in which to extract | OptLocation FilePath !Bool -- ^ Where to place file when adding files and whether to append current path- | OptPreserveSymbolicLinks -- ^ Preserve symbolic links as such. This option is ignored on Windows.+ | OptPreserveSymbolicLinks -- ^ Preserve symbolic links as such. This option is ignored on Windows. WARNING: symbolic link targets are not validated on extraction, so they may be absolute or point outside of the destination directory; do not use this option when extracting untrusted archives. deriving (Read, Show, Eq) data ZipException = CRC32Mismatch FilePath | UnsafePath FilePath | CannotWriteEncryptedEntry FilePath+ | Zip64NotSupported String -- ^ Data too large for the original zip format (which this library is limited to); the ZIP64 extension would be required deriving (Show, Typeable, Data, Eq) instance E.Exception ZipException@@ -212,6 +228,9 @@ Right (_,_,x) -> Right x -- | Writes an 'Archive' structure to a raw zip archive (in a lazy bytestring).+-- Throws a pure 'Zip64NotSupported' exception if the archive has 65535+-- or more entries or is 4GB or larger, since this would require the+-- (unsupported) ZIP64 extension. fromArchive :: Archive -> B.ByteString fromArchive = encode @@ -229,13 +248,16 @@ -- | Deletes an entry from a zip archive. deleteEntryFromArchive :: FilePath -> Archive -> Archive deleteEntryFromArchive path archive =- archive { zEntries = [e | e <- zEntries archive- , not (eRelativePath e `matches` path)] }+ let path' = normalizePath path+ in archive { zEntries = [e | e <- zEntries archive+ , normalizePath (eRelativePath e) /= path'] } -- | Returns Just the zip entry with the specified path, or Nothing. findEntryByPath :: FilePath -> Archive -> Maybe Entry findEntryByPath path archive =- find (\e -> path `matches` eRelativePath e) (zEntries archive)+ let path' = normalizePath path+ in find (\e -> path' == normalizePath (eRelativePath e))+ (zEntries archive) -- | Returns uncompressed contents of zip entry. fromEntry :: Entry -> B.ByteString@@ -255,6 +277,8 @@ _ -> False -- | Create an 'Entry' with specified file path, modification time, and contents.+-- Throws a pure 'Zip64NotSupported' exception if the contents are too+-- large to be represented without the (unsupported) ZIP64 extension. toEntry :: FilePath -- ^ File path for entry -> Integer -- ^ Modification time for entry (seconds since unix epoch) -> B.ByteString -- ^ Contents of entry@@ -269,7 +293,11 @@ then (NoCompression, contents, uncompressedSize) else (Deflate, compressedData, compressedSize) crc32 = CRC32.crc32 contents- in Entry { eRelativePath = normalizePath path+ in if uncompressedSize >= 0xFFFFFFFF+ then E.throw $ Zip64NotSupported $+ path ++ ": entry of 4GB or more requires ZIP64"+ else+ Entry { eRelativePath = normalizePath path , eCompressionMethod = compressionMethod , eEncryptionMethod = NoEncryption , eLastModified = modtime@@ -346,12 +374,15 @@ compmethod (100 - (100 * compressionRatio entryE)) return entryE --- check path, resolving .. and . components, raising--- UnsafePath exception if this takes you outside of the root.+-- check path: reject absolute paths and drive-qualified paths, and+-- resolve .. and . components, raising UnsafePath exception if this+-- takes you outside of the root. checkPath :: FilePath -> IO ()-checkPath fp =- maybe (E.throwIO (UnsafePath fp)) (\_ -> return ())- (resolve . splitDirectories $ fp)+checkPath fp+ | isAbsolute' fp || hasDrive fp = E.throwIO (UnsafePath fp)+ | otherwise =+ maybe (E.throwIO (UnsafePath fp)) (\_ -> return ())+ (resolve . splitDirectories $ fp) where resolve = fmap reverse . foldl go (return [])@@ -364,6 +395,9 @@ [] -> fail "outside of root path" (_:ys) -> return ys _ -> return (x:xs)+ -- ensure that /foo is absolute even on Windows:+ isAbsolute' ('/':_) = True+ isAbsolute' f = isAbsolute f -- | Writes contents of an 'Entry' to a file. Throws a -- 'CRC32Mismatch' exception if the CRC32 checksum for the entry@@ -375,9 +409,8 @@ let relpath = eRelativePath entry checkPath relpath path <- case [d | OptDestination d <- opts] of- (x:_) -> return (x </> relpath)- [] | isAbsolute relpath -> E.throwIO $ UnsafePath relpath- | otherwise -> return relpath+ (x:_) -> return (x </> relpath)+ [] -> return relpath -- create directories if needed let dir = takeDirectory path exists <- doesDirectoryExist dir@@ -392,14 +425,35 @@ hPutStrLn stderr $ case eCompressionMethod entry of Deflate -> " inflating: " ++ path NoCompression -> "extracting: " ++ path- let uncompressedData = fromEntry entry- if eCRC32 entry == CRC32.crc32 uncompressedData- then B.writeFile path uncompressedData- else E.throwIO $ CRC32Mismatch path+ -- Write the entry chunk by chunk while updating the CRC+ -- incrementally, so the uncompressed data need not be held in+ -- memory in full. Write to a temporary file first and rename+ -- it into place only if the CRC matches, so a pre-existing+ -- file at the target path is left intact on a CRC mismatch.+ (tmpPath, tmpHandle) <- openBinaryTempFile dir+ (takeFileName path ++ ".tmp")+ crc <- foldM (\k chunk -> do+ S.hPut tmpHandle chunk+ return (CRC32.crc32Update k chunk))+ 0 (B.toChunks (fromEntry entry))+ `E.onException` (hClose tmpHandle >> removeFile tmpPath)+ hClose tmpHandle+ if crc == eCRC32 entry+ then renameFile tmpPath path+ else do+ removeFile tmpPath+ E.throwIO $ CRC32Mismatch path #ifndef _WINDOWS+ -- openBinaryTempFile creates the file with mode 0600; restore+ -- the default permissions the file would have had if written+ -- directly, unless the entry carries its own mode bits. let modes = fromIntegral $ shiftR (eExternalFileAttributes entry) 16- when (eVersionMadeBy entry .&. 0xFF00 == 0x0300 &&- modes /= 0) $ setFileMode path modes+ if eVersionMadeBy entry .&. 0xFF00 == 0x0300 && modes /= 0+ then setFileMode path modes+ else do+ umask <- setFileCreationMask 0o022+ _ <- setFileCreationMask umask+ setFileMode path (0o666 .&. complement umask) #endif -- Note that last modified times are supported only for POSIX, not for -- Windows.@@ -410,6 +464,10 @@ -- If the 'Entry' does not represent a symbolic link or -- the options do not contain 'OptPreserveSymbolicLinks`, this -- function behaves like `writeEntry`.+--+-- Note that the symbolic link target is written as is; it may be+-- absolute or point outside of the extraction directory. Do not+-- extract untrusted archives with 'OptPreserveSymbolicLinks'. writeSymbolicLinkEntry :: [ZipOption] -> Entry -> IO () writeSymbolicLinkEntry opts entry = if OptPreserveSymbolicLinks `notElem` opts@@ -417,17 +475,39 @@ else do if isEntrySymbolicLink entry then do+ let relpath = eRelativePath entry+ checkPath relpath let prefixPath = case [d | OptDestination d <- opts] of (x:_) -> x _ -> ""+ checkSymbolicLinkAncestry prefixPath relpath let targetPath = fromJust . symbolicLinkEntryTarget $ entry- let symlinkPath = prefixPath </> eRelativePath entry+ let symlinkPath = prefixPath </> relpath when (OptVerbose `elem` opts) $ do hPutStrLn stderr $ "linking " ++ symlinkPath ++ " to " ++ targetPath forceSymLink targetPath symlinkPath else writeEntry opts entry +-- Guard against symlink chaining on extraction: raise 'UnsafePath' if+-- any directory component of relpath (relative to prefix) is itself a+-- symbolic link. Otherwise a crafted archive containing a symbolic+-- link entry @a -> /somewhere@ followed by an entry @a/b@ could create+-- a symbolic link outside of the destination directory.+checkSymbolicLinkAncestry :: FilePath -> FilePath -> IO ()+checkSymbolicLinkAncestry prefix relpath =+ mapM_ check $ scanl1 (</>) ancestors+ where+ ancestors = case splitDirectories relpath of+ [] -> []+ cs -> init cs+ check dir = do+ res <- E.try (getSymbolicLinkStatus (prefix </> dir))+ :: IO (Either E.IOException FileStatus)+ case res of+ Right st | isSymbolicLink st -> E.throwIO (UnsafePath relpath)+ _ -> return () + -- | Writes a symbolic link, but removes any conflicting files and retries if necessary. forceSymLink :: FilePath -> FilePath -> IO () forceSymLink target linkName =@@ -459,19 +539,41 @@ addFilesToArchive opts archive files = do filesAndChildren <- if OptRecursive `elem` opts #ifdef _WINDOWS- then mapM getDirectoryContentsRecursive files >>= return . nub . concat+ then ordNub . concat <$> mapM getDirectoryContentsRecursive files #else- then nub . concat <$> mapM (getDirectoryContentsRecursive' opts) files+ then ordNub . concat <$> mapM (getDirectoryContentsRecursive' opts) files #endif else return files entries <- mapM (readEntry opts) filesAndChildren- return $ foldr addEntryToArchive archive entries+ -- Equivalent to foldr addEntryToArchive archive entries (the first+ -- entry for a given path wins, new entries precede old ones), but+ -- without quadratic cost in the number of entries.+ let newPaths = Set.fromList $ map (normalizePath . eRelativePath) entries+ return archive+ { zEntries = ordNubOn (normalizePath . eRelativePath) entries +++ [e | e <- zEntries archive+ , normalizePath (eRelativePath e) `Set.notMember` newPaths] } +-- Remove duplicates from a list, keeping the first occurrence of each+-- element and preserving order.+ordNub :: Ord a => [a] -> [a]+ordNub = ordNubOn id++ordNubOn :: Ord b => (a -> b) -> [a] -> [a]+ordNubOn f = go Set.empty+ where go _ [] = []+ go seen (x:xs)+ | fx `Set.member` seen = go seen xs+ | otherwise = x : go (Set.insert fx seen) xs+ where fx = f x+ -- | Extract all files from an 'Archive', creating directories -- as needed. If 'OptVerbose' is specified, print messages to stderr. -- Note that the last-modified time is set correctly only in POSIX, -- not in Windows.--- This function fails if encrypted entries are present+-- This function fails if encrypted entries are present.+-- See the warning on 'OptPreserveSymbolicLinks' before using it+-- with untrusted archives. extractFilesFromArchive :: [ZipOption] -> Archive -> IO () extractFilesFromArchive opts archive = do let entries = zEntries archive@@ -505,10 +607,6 @@ dirParts = filter (/=".") $ splitDirectories dir' in intercalate "/" (dirParts ++ [fn]) --- Equality modulo normalization. So, "./foo" `matches` "foo".-matches :: FilePath -> FilePath -> Bool-matches fp1 fp2 = normalizePath fp1 == normalizePath fp2- -- | Uncompress a lazy bytestring. compressData :: CompressionMethod -> B.ByteString -> B.ByteString compressData Deflate = Zlib.compress@@ -520,22 +618,25 @@ decompressData NoCompression = id -- | Decrypt a lazy bytestring--- Returns Nothing if password is incorrect+-- Returns Nothing if password is incorrect or the data is too short+-- to contain the 12-byte encryption header decryptData :: String -> EncryptionMethod -> B.ByteString -> Maybe B.ByteString decryptData _ NoEncryption s = Just s-decryptData password (PKWAREEncryption controlByte) s =- let headerlen = 12- initKeys = (305419896, 591751049, 878082192)- startKeys = B.foldl pkwareUpdateKeys initKeys (C.pack password)- (header, content) = B.splitAt headerlen $ snd $ B.mapAccumL pkwareDecryptByte startKeys s- in if B.last header == controlByte- then Just content- else Nothing+decryptData password (PKWAREEncryption controlByte) s+ | B.length s < headerlen = Nothing+ | otherwise =+ let initKeys = (305419896, 591751049, 878082192)+ startKeys = B.foldl pkwareUpdateKeys initKeys (C.pack password)+ (header, content) = B.splitAt headerlen $ snd $ B.mapAccumL pkwareDecryptByte startKeys s+ in if B.last header == controlByte+ then Just content+ else Nothing+ where headerlen = 12 -- | PKWARE decryption context type DecryptionCtx = (Word32, Word32, Word32) --- | An interation of the PKWARE decryption algorithm+-- | An implementation of the PKWARE decryption algorithm pkwareDecryptByte :: DecryptionCtx -> Word8 -> (DecryptionCtx, Word8) pkwareDecryptByte keys@(_, _, key2) inB = let tmp = key2 .|. 2@@ -546,12 +647,28 @@ -- | Update decryption keys after a decrypted byte pkwareUpdateKeys :: DecryptionCtx -> Word8 -> DecryptionCtx pkwareUpdateKeys (key0, key1, key2) inB =- let key0' = CRC32.crc32Update (key0 `xor` 0xffffffff) [inB] `xor` 0xffffffff+ let key0' = pkwareCrc32Byte key0 inB key1' = (key1 + (key0' .&. 0xff)) * 134775813 + 1 key1Byte = fromIntegral (key1' `shiftR` 24) :: Word8- key2' = CRC32.crc32Update (key2 `xor` 0xffffffff) [key1Byte] `xor` 0xffffffff+ key2' = pkwareCrc32Byte key2 key1Byte in (key0', key1', key2') +-- | One step of the raw (unconditioned) CRC32 used by the PKWARE+-- key schedule, computed with a lookup table.+pkwareCrc32Byte :: Word32 -> Word8 -> Word32+pkwareCrc32Byte key b =+ (key `shiftR` 8) `xor`+ (pkwareCrcTable ! ((key `xor` fromIntegral b) .&. 0xff))++-- | Standard CRC32 table (reflected, polynomial 0xedb88320).+pkwareCrcTable :: UArray Word32 Word32+pkwareCrcTable = listArray (0, 255) $ map crcEntry [0..255]+ where+ crcEntry n = iterate step n !! (8 :: Int)+ step x = if odd x+ then (x `shiftR` 1) `xor` 0xedb88320+ else x `shiftR` 1+ -- | Calculate compression ratio for an entry (for verbose output). compressionRatio :: Entry -> Float compressionRatio entry =@@ -575,11 +692,24 @@ minMSDOSDateTime :: Integer minMSDOSDateTime = 315532800 --- | Convert a clock time to a MSDOS datetime. The MSDOS time will be relative to UTC.+-- | Epoch time corresponding to the maximum DOS DateTime (Dec 31 2107 23:59:58).+maxMSDOSDateTime :: Integer+maxMSDOSDateTime = floor $ utcTimeToPOSIXSeconds $+ UTCTime (fromGregorian 2107 12 31) (23 * 3600 + 59 * 60 + 58)++-- | Convert an epoch time to a MSDOS datetime. Note that no time zone+-- adjustment happens here: the epoch time is rendered as is, so callers+-- are expected to pass times already shifted to the local time zone+-- (see 'readEntry' and 'setFileTimeStamp'). epochTimeToMSDOSDateTime :: Integer -> MSDOSDateTime epochTimeToMSDOSDateTime epochtime | epochtime < minMSDOSDateTime = epochTimeToMSDOSDateTime minMSDOSDateTime -- if time is earlier than minimum DOS datetime, return minimum+epochTimeToMSDOSDateTime epochtime | epochtime > maxMSDOSDateTime =+ epochTimeToMSDOSDateTime maxMSDOSDateTime+ -- if time is later than maximum DOS datetime, return maximum;+ -- the year field of a DOS datetime cannot represent years past 2107,+ -- and larger values would make toEnum fail below epochTimeToMSDOSDateTime epochtime = let UTCTime@@ -641,7 +771,13 @@ setFileTimeStamp _ _ = return () -- TODO: figure out how to set the timestamp on Windows #else setFileTimeStamp file epochtime = do- let epochtime' = fromInteger epochtime+ -- eLastModified is relative to the LOCAL time zone (see readEntry+ -- and #67), because MSDOS timestamps are conventionally local time.+ -- Reverse that shift here, so that reading and extracting an entry+ -- preserves the file's modification time.+ tzone <- getTimeZone (posixSecondsToUTCTime (fromIntegral epochtime))+ let epochtime' = fromInteger $+ epochtime - fromIntegral (timeZoneMinutes tzone * 60) setFileTimes file epochtime' epochtime' #endif @@ -716,11 +852,16 @@ putArchive :: Archive -> Put putArchive archive = do+ let numEntries = length $ zEntries archive+ when (numEntries >= 0xFFFF) $+ E.throw $ Zip64NotSupported "65535 or more entries require ZIP64" mapM_ putLocalFile $ zEntries archive let localFileSizes = map localFileSize $ zEntries archive let offsets = scanl (+) 0 localFileSizes let cdOffset = last offsets- _ <- zipWithM_ putFileHeader offsets (zEntries archive)+ when (cdOffset >= 0xFFFFFFFF) $+ E.throw $ Zip64NotSupported "archive of 4GB or more requires ZIP64"+ _ <- zipWithM_ putFileHeader (map fromIntegral offsets) (zEntries archive) putDigitalSignature $ zSignature archive putWord32le 0x06054b50 putWord16le 0 -- disk number@@ -739,10 +880,12 @@ fromIntegral (B.length $ fromString $ normalizePath $ eRelativePath f) + B.length (eExtraField f) + B.length (eFileComment f) -localFileSize :: Entry -> Word32+-- Note: computed as Int64 (not Word32) so that putArchive can detect+-- offsets that would overflow the 32-bit fields of the zip format.+localFileSize :: Entry -> Int64 localFileSize f =- fromIntegral $ 4 + 2 + 2 + 2 + 2 + 2 + 4 + 4 + 4 + 2 + 2 +- fromIntegral (B.length $ fromString $ normalizePath $ eRelativePath f) ++ 4 + 2 + 2 + 2 + 2 + 2 + 4 + 4 + 4 + 2 + 2 ++ B.length (fromString $ normalizePath $ eRelativePath f) + B.length (eExtraField f) + B.length (eCompressedData f) -- Local file header:@@ -806,7 +949,7 @@ then return raw else fail $ printf ("Content size mismatch in data descriptor record: "- <> "expected %d, got %d bytes")+ ++ "expected %d, got %d bytes") cs (B.length raw) return (fromIntegral offset, compressedData) @@ -814,7 +957,7 @@ putLocalFile f = do putWord32le 0x04034b50 putWord16le 20 -- version needed to extract (>=2.0)- putWord16le 0x802 -- general purpose bit flag (bit 1 = max compression, bit 11 = UTF-8)+ putWord16le 0x800 -- general purpose bit flag (bit 11 = UTF-8) putWord16le $ case eCompressionMethod f of NoCompression -> 0 Deflate -> 8@@ -824,10 +967,10 @@ putWord32le $ eCRC32 f putWord32le $ eCompressedSize f putWord32le $ eUncompressedSize f- putWord16le $ fromIntegral $ B.length $ fromString- $ normalizePath $ eRelativePath f+ let encodedPath = fromString $ normalizePath $ eRelativePath f+ putWord16le $ fromIntegral $ B.length encodedPath putWord16le $ fromIntegral $ B.length $ eExtraField f- putLazyByteString $ fromString $ normalizePath $ eRelativePath f+ putLazyByteString encodedPath putLazyByteString $ eExtraField f putLazyByteString $ eCompressedData f @@ -896,7 +1039,7 @@ Nothing -> fail $ "Unable to find data at offset " ++ show relativeOffset return Entry- { eRelativePath = toString fileName+ { eRelativePath = decodeFileName bitflag fileName , eCompressionMethod = compressionMethod , eEncryptionMethod = encryptionMethod , eLastModified = msDOSDateTimeToEpochTime $@@ -920,7 +1063,7 @@ putWord32le 0x02014b50 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 0x800 -- general purpose bit flag (bit 11 = UTF-8) putWord16le $ case eCompressionMethod local of NoCompression -> 0 Deflate -> 8@@ -930,15 +1073,15 @@ putWord32le $ eCRC32 local putWord32le $ eCompressedSize local putWord32le $ eUncompressedSize local- putWord16le $ fromIntegral $ B.length $ fromString- $ normalizePath $ eRelativePath local+ let encodedPath = fromString $ normalizePath $ eRelativePath local+ putWord16le $ fromIntegral $ B.length encodedPath putWord16le $ fromIntegral $ B.length $ eExtraField local putWord16le $ fromIntegral $ B.length $ eFileComment local putWord16le 0 -- disk number start putWord16le $ eInternalFileAttributes local putWord32le $ eExternalFileAttributes local putWord32le offset- putLazyByteString $ fromString $ normalizePath $ eRelativePath local+ putLazyByteString encodedPath putLazyByteString $ eExtraField local putLazyByteString $ eFileComment local @@ -967,18 +1110,37 @@ then return () else fail "ensure not satisfied" -toString :: B.ByteString -> String-toString = TL.unpack . TL.decodeUtf8+-- | Decode a file name from a zip archive according to the general+-- purpose bit flag: if bit 11 is set, the name is UTF-8 encoded;+-- otherwise the zip spec says it is encoded in IBM code page 437.+-- Invalid UTF-8 is decoded leniently (invalid bytes are replaced by+-- U+FFFD) rather than raising an exception, so that 'toArchiveOrFail'+-- remains total.+decodeFileName :: Word16 -> B.ByteString -> String+decodeFileName bitflag fn+ | testBit bitflag 11 = TL.unpack $ TL.decodeUtf8With TE.lenientDecode fn+ | otherwise = map cp437ToChar $ B.unpack fn +cp437ToChar :: Word8 -> Char+cp437ToChar w+ | w < 128 = toEnum (fromIntegral w)+ | otherwise = cp437table !! fromIntegral (w - 128)++-- IBM code page 437, upper half (0x80 - 0xFF).+cp437table :: String+cp437table =+ "\199\252\233\226\228\224\229\231\234\235\232\239\238\236\196\197\+ \\201\230\198\244\246\242\251\249\255\214\220\162\163\165\8359\402\+ \\225\237\243\250\241\209\170\186\191\8976\172\189\188\161\171\187\+ \\9617\9618\9619\9474\9508\9569\9570\9558\9557\9571\9553\9559\9565\9564\9563\9488\+ \\9492\9524\9516\9500\9472\9532\9566\9567\9562\9556\9577\9574\9568\9552\9580\9575\+ \\9576\9572\9573\9561\9560\9554\9555\9579\9578\9496\9484\9608\9604\9612\9616\9600\+ \\945\223\915\960\931\963\181\964\934\920\937\948\8734\966\949\8745\+ \\8801\177\8805\8804\8992\8993\247\8776\176\8729\183\8730\8319\178\9632\160"+ fromString :: String -> B.ByteString fromString = TL.encodeUtf8 . TL.pack -data DecompressResult =- DecompressSuccess B.ByteString -- bytes remaining- -- (we just discard decompressed chunks, because we only- -- want to know where the compressed data ends)- | DecompressFailure ZlibInt.DecompressError- getCompressedData :: CompressionMethod -> Get B.ByteString getCompressedData NoCompression = do -- we assume there will be a signature on the data descriptor,@@ -1008,20 +1170,39 @@ getLazyByteString compressedBytes getCompressedData Deflate = do remainingBytes <- lookAhead getRemainingLazyByteString- let result = ZlibInt.foldDecompressStreamWithInput- (\_bs res -> res)- DecompressSuccess- DecompressFailure- (ZlibInt.decompressST ZlibInt.rawFormat- ZlibInt.defaultDecompressParams{- ZlibInt.decompressAllMembers = False })- remainingBytes- case result of- DecompressFailure err -> fail (show err)- DecompressSuccess afterCompressedBytes ->- -- Consume the compressed bytes; we don't do anything with- -- the decompressed chunks. We are just decompressing as a- -- way of finding where the compressed data ends.- getLazyByteString- (fromIntegral (B.length remainingBytes - B.length afterCompressedBytes))+ -- We decompress (discarding the output) only as a way of finding+ -- where the compressed data ends.+ case countCompressedBytes remainingBytes of+ Left err -> fail (show err)+ Right consumed -> getLazyByteString consumed++-- Decompress the input chunk by chunk, discarding the decompressed+-- output, and return the number of compressed bytes consumed (i.e.,+-- where the deflate stream ends). Feeding the decompressor chunk by+-- chunk means we only ever force the compressed data itself, rather+-- than computing the length of everything that follows it (which+-- would force the entire rest of the archive).+countCompressedBytes :: B.ByteString -> Either ZlibInt.DecompressError Int64+countCompressedBytes input =+ runST (go (B.toChunks input) 0+ (ZlibInt.decompressST ZlibInt.rawFormat+ ZlibInt.defaultDecompressParams{+ ZlibInt.decompressAllMembers = False }))+ where+ go chunks supplied stream =+ case stream of+ ZlibInt.DecompressInputRequired next ->+ case chunks of+ (c:cs) -> let supplied' = supplied + fromIntegral (S.length c)+ in supplied' `seq` (next c >>= go cs supplied')+ [] -> next S.empty >>= go [] supplied+ -- S.empty signals end of input; the+ -- decompressor then either ends cleanly or+ -- reports a truncated stream+ ZlibInt.DecompressOutputAvailable _out next ->+ next >>= go chunks supplied+ ZlibInt.DecompressStreamEnd leftover ->+ return $ Right $ supplied - fromIntegral (S.length leftover)+ ZlibInt.DecompressStreamError err ->+ return $ Left err
tests/test-zip-archive.hs view
@@ -6,7 +6,11 @@ import Codec.Archive.Zip import Control.Monad (unless)-import Control.Exception (try, catch, SomeException)+import Data.Bits+import Data.Word (Word8)+import Control.Exception (try, catch, evaluate, SomeException)+import Data.Int (Int64)+import Data.Time.Clock (diffUTCTime) import System.Directory hiding (isSymbolicLink) import Test.HUnit.Base import Test.HUnit.Text@@ -26,6 +30,65 @@ -- define equality for Archives so timestamps aren't distinguished if they -- correspond to the same MSDOS datetime.+-- build a minimal raw zip archive containing a single stored entry+-- with empty contents (CRC32 = 0), a given general purpose bit flag,+-- and the given raw file name bytes+mkRawZip :: Int -> [Word8] -> BL.ByteString+mkRawZip flag name = BL.pack (local ++ central ++ eocd)+ where+ n = length name+ le16, le32 :: Int -> [Word8]+ le16 x = [fromIntegral (x .&. 0xff), fromIntegral ((x `shiftR` 8) .&. 0xff)]+ le32 x = le16 (x .&. 0xffff) ++ le16 ((x `shiftR` 16) .&. 0xffff)+ local = [0x50,0x4b,0x03,0x04] ++ le16 20 ++ le16 flag ++ le16 0 -- stored+ ++ le16 0 ++ le16 0x21 -- mod time/date (1980-01-01)+ ++ le32 0 ++ le32 0 ++ le32 0 -- crc, csize, usize+ ++ le16 n ++ le16 0 ++ name+ central = [0x50,0x4b,0x01,0x02] ++ le16 20 ++ le16 20 ++ le16 flag+ ++ le16 0 ++ le16 0 ++ le16 0x21+ ++ le32 0 ++ le32 0 ++ le32 0+ ++ le16 n ++ le16 0 ++ le16 0 -- name/extra/comment len+ ++ le16 0 ++ le16 0 ++ le32 0 -- disk, int attrs, ext attrs+ ++ le32 0 -- local header offset+ ++ name+ eocd = [0x50,0x4b,0x05,0x06] ++ le16 0 ++ le16 0 ++ le16 1 ++ le16 1+ ++ le32 (46 + n) ++ le32 (30 + n) ++ le16 0++-- build a raw zip archive whose local file header uses a data+-- descriptor (general purpose bit 3): sizes and CRC in the local+-- header are zero and instead follow the file data+mkDataDescriptorZip :: Entry -> BL.ByteString+mkDataDescriptorZip e = BL.concat+ [ BL.pack local, eCompressedData e, BL.pack descriptor+ , BL.pack central, BL.pack eocd ]+ where+ name = map (fromIntegral . fromEnum) (eRelativePath e) :: [Word8]+ n = length name+ flag = 8 -- bit 3: data descriptor+ method = case eCompressionMethod e of+ NoCompression -> 0+ Deflate -> 8+ crc = fromIntegral $ eCRC32 e+ csize = fromIntegral $ eCompressedSize e+ usize = fromIntegral $ eUncompressedSize e+ le16, le32 :: Int -> [Word8]+ le16 x = [fromIntegral (x .&. 0xff), fromIntegral ((x `shiftR` 8) .&. 0xff)]+ le32 x = le16 (x .&. 0xffff) ++ le16 ((x `shiftR` 16) .&. 0xffff)+ local = [0x50,0x4b,0x03,0x04] ++ le16 20 ++ le16 flag ++ le16 method+ ++ le16 0 ++ le16 0x21+ ++ le32 0 ++ le32 0 ++ le32 0 -- deferred to data descriptor+ ++ le16 n ++ le16 0 ++ name+ descriptor = [0x50,0x4b,0x07,0x08] ++ le32 crc ++ le32 csize ++ le32 usize+ central = [0x50,0x4b,0x01,0x02] ++ le16 20 ++ le16 20 ++ le16 flag+ ++ le16 method ++ le16 0 ++ le16 0x21+ ++ le32 crc ++ le32 csize ++ le32 usize+ ++ le16 n ++ le16 0 ++ le16 0+ ++ le16 0 ++ le16 0 ++ le32 0+ ++ le32 0+ ++ name+ eocd = [0x50,0x4b,0x05,0x06] ++ le16 0 ++ le16 0 ++ le16 1 ++ le16 1+ ++ le32 (46 + n) ++ le32 (30 + n + csize + 16) ++ le16 0+ instance Eq Archive where (==) a1 a2 = zSignature a1 == zSignature a2 && zComment a1 == zComment a2@@ -34,6 +97,17 @@ #ifndef _WINDOWS +-- construct an Entry that represents a symbolic link, as found in+-- archives produced by Info-ZIP and this library+mkSymlinkEntry :: FilePath -> String -> Entry+mkSymlinkEntry linkPath target =+ (toEntry linkPath 0 (BLC.pack target))+ { eRelativePath = linkPath+ , eVersionMadeBy = 0x0300 -- UNIX+ , eExternalFileAttributes =+ fromIntegral (shiftL (fromIntegral symbolicLinkMode .|. (0o777 :: Integer)) 16)+ }+ createTestDirectoryWithSymlinks :: FilePath -> FilePath -> IO FilePath createTestDirectoryWithSymlinks prefixDir baseDir = do let testDir = prefixDir </> baseDir@@ -64,17 +138,30 @@ , testFromToArchive , testReadWriteEntry , testAddFilesOptions+ , testAddFilesDedupe , testDeleteEntries , testExtractFiles , testExtractFilesFailOnEncrypted , testPasswordProtectedRead , testIncorrectPasswordRead+ , testTruncatedEncryptedRead , testEvilPath+ , testAbsolutePath+ , testDotFilePaths+ , testCRCMismatchLeavesFileIntact+ , testFileNameEncodings+ , testZip64Limits+ , testExtremeTimestamps+ , testGeneralPurposeBitFlag+ , testDataDescriptor #ifndef _WINDOWS+ , testTimestampRoundTrip , testExtractFilesWithPosixAttrs , testArchiveExtractSymlinks , testExtractExternalZipWithSymlinks , testExtractOverwriteExternalZipWithSymlinks+ , testEvilSymlinkPath+ , testEvilSymlinkChain #endif ] #ifndef _WINDOWS@@ -149,6 +236,17 @@ #endif +testAddFilesDedupe :: FilePath -> Test+testAddFilesDedupe _tmpDir = TestCase $ do+ -- adding the same file twice results in a single entry+ archive <- addFilesToArchive [] emptyArchive ["LICENSE", "LICENSE"]+ assertEqual "duplicate files are added once"+ ["LICENSE"] (filesInArchive archive)+ -- re-adding a file replaces the existing entry rather than duplicating it+ archive2 <- addFilesToArchive [] archive ["LICENSE", "Setup.hs"]+ assertEqual "re-adding a file replaces the entry"+ ["LICENSE", "Setup.hs"] (filesInArchive archive2)+ testDeleteEntries :: FilePath -> Test testDeleteEntries _tmpDir = TestCase $ do archive1 <- addFilesToArchive [] emptyArchive ["LICENSE", "src"]@@ -156,6 +254,142 @@ let archive3 = deleteEntryFromArchive "src" archive2 assertEqual "for deleteFilesFromArchive" emptyArchive archive3 +testZip64Limits :: FilePath -> Test+testZip64Limits _tmpDir = TestCase $ do+ -- an entry of 4GB or more cannot be represented without ZIP64+ bigResult <- try $ evaluate $ toEntry "big" 0 (BL.replicate (2^(32 :: Int)) 0)+ :: IO (Either ZipException Entry)+ case bigResult of+ Left (Zip64NotSupported _) -> return ()+ Left err -> assertFailure $ "wrong exception for 4GB entry: " ++ show err+ Right _ -> assertFailure "toEntry should have failed on a 4GB entry"+ -- an archive with 65535 or more entries cannot be represented without ZIP64+ let e = toEntry "a" 0 BL.empty+ manyEntries = Archive (replicate 65535 e) Nothing BL.empty+ manyResult <- try $ evaluate $ BL.length $ fromArchive manyEntries+ :: IO (Either ZipException Int64)+ case manyResult of+ Left (Zip64NotSupported _) -> return ()+ Left err -> assertFailure $ "wrong exception for 65535 entries: " ++ show err+ Right _ -> assertFailure "fromArchive should have failed on 65535 entries"++testDataDescriptor :: FilePath -> Test+testDataDescriptor _tmpDir = TestCase $ do+ -- deflated entry whose sizes are only in a trailing data descriptor+ let content = BLC.pack $ concat $ replicate 50 "all work and no play"+ entry = toEntry "dd.txt" 0 content+ assertEqual "test entry is deflated" Deflate (eCompressionMethod entry)+ case toArchiveOrFail (mkDataDescriptorZip entry) of+ Left err -> assertFailure $ "could not parse: " ++ err+ Right a -> case findEntryByPath "dd.txt" a of+ Nothing -> assertFailure "dd.txt not found in archive"+ Just e -> assertEqual "for contents of dd.txt"+ content (fromEntry e)+ -- the same, for a stored entry (identified by descriptor signature)+ let content' = BLC.pack "stored data"+ entry' = (toEntry "dd2.txt" 0 content')+ assertEqual "test entry is stored" NoCompression (eCompressionMethod entry')+ case toArchiveOrFail (mkDataDescriptorZip entry') of+ Left err -> assertFailure $ "could not parse: " ++ err+ Right a -> case findEntryByPath "dd2.txt" a of+ Nothing -> assertFailure "dd2.txt not found in archive"+ Just e -> assertEqual "for contents of dd2.txt"+ content' (fromEntry e)++testGeneralPurposeBitFlag :: FilePath -> Test+testGeneralPurposeBitFlag _tmpDir = TestCase $ do+ -- we compress with zlib's default level, so the flag must not claim+ -- maximum compression (bit 1); only bit 11 (UTF-8 names) is set+ let bytes = fromArchive $ Archive [toEntry "a.txt" 0 (BLC.pack "hi")]+ Nothing BL.empty+ -- general purpose bit flag of the local file header is at offset 6+ assertEqual "for general purpose bit flag"+ [0x00, 0x08] (BL.unpack (BL.take 2 (BL.drop 6 bytes)))++testExtremeTimestamps :: FilePath -> Test+testExtremeTimestamps _tmpDir = TestCase $ do+ -- timestamps outside the representable MSDOS datetime range+ -- (1980..2107) are clamped rather than crashing+ let farFuture = toEntry "future.txt" 99999999999 (BLC.pack "later")+ past = toEntry "past.txt" (-99999) (BLC.pack "earlier")+ archive = Archive [farFuture, past] Nothing BL.empty+ result <- try $ evaluate $ BL.length $ fromArchive archive+ :: IO (Either SomeException Int64)+ case result of+ Left err -> assertFailure $ "fromArchive crashed: " ++ show err+ Right _ -> return ()++testFileNameEncodings :: FilePath -> Test+testFileNameEncodings _tmpDir = TestCase $ do+ -- bit 11 clear: name is in IBM code page 437 (0x82 = 'é')+ case toArchiveOrFail (mkRawZip 0 [0x82]) of+ Left err -> assertFailure $ "could not parse CP437 archive: " ++ err+ Right a -> assertEqual "for CP437 file name" ["\233"] (filesInArchive a)+ -- bit 11 set: name is UTF-8 ('é' = 0xC3 0xA9)+ case toArchiveOrFail (mkRawZip 0x800 [0xc3, 0xa9]) of+ Left err -> assertFailure $ "could not parse UTF-8 archive: " ++ err+ Right a -> assertEqual "for UTF-8 file name" ["\233"] (filesInArchive a)+ -- bit 11 set but name is invalid UTF-8: decode leniently, don't crash+ result <- try $ case toArchiveOrFail (mkRawZip 0x800 [0x82]) of+ Left err -> return [err]+ Right a -> mapM (\f -> length f `seq` return f)+ (filesInArchive a)+ :: IO (Either SomeException [FilePath])+ case result of+ Left err -> assertFailure $ "invalid UTF-8 name raised: " ++ show err+ Right fs -> assertEqual "for invalid UTF-8 file name" ["\65533"] fs++testAbsolutePath :: FilePath -> Test+testAbsolutePath tmpDir = TestCase $ do+ -- an entry with an absolute path must not escape OptDestination+ -- (note that dest </> "/absolute/evil" == "/absolute/evil")+ let entry = (toEntry "placeholder" 0 (BLC.pack "boom"))+ { eRelativePath = "/absolute/evil" }+ result <- try $ writeEntry [OptDestination (tmpDir </> "absdest")] entry+ :: IO (Either ZipException ())+ case result of+ Left err -> assertEqual "exception for absolute path"+ (UnsafePath "/absolute/evil") err+ Right _ -> assertFailure "writeEntry should have failed on absolute path"++testDotFilePaths :: FilePath -> Test+testDotFilePaths tmpDir = TestCase $ do+ -- issue #55: dotfiles and names containing ".." as a substring are+ -- legitimate and must not raise UnsafePath; only actual "." and+ -- ".." path components are unsafe+ let dest = tmpDir </> "dotdest"+ let archive = foldr addEntryToArchive emptyArchive+ [ toEntry ".bowerrc" 0 (BLC.pack "dot")+ , toEntry "sub/Hello..ciao" 0 (BLC.pack "dots")+ , toEntry "sub/.hidden/file.txt" 0 (BLC.pack "hidden")+ ]+ extractFilesFromArchive [OptDestination dest] archive+ c1 <- readFile (dest </> ".bowerrc")+ assertEqual "for contents of extracted dotfile" "dot" c1+ c2 <- readFile (dest </> "sub/Hello..ciao")+ assertEqual "for contents of file with dots in name" "dots" c2+ c3 <- readFile (dest </> "sub/.hidden/file.txt")+ assertEqual "for contents of file in hidden directory" "hidden" c3++testCRCMismatchLeavesFileIntact :: FilePath -> Test+testCRCMismatchLeavesFileIntact tmpDir = TestCase $ do+ let dest = tmpDir </> "crcdest"+ createDirectoryIfMissing True dest+ writeFile (dest </> "file.txt") "original"+ let entry = (toEntry "file.txt" 0 (BLC.pack "corrupted contents"))+ { eCRC32 = 0xdeadbeef }+ result <- try (writeEntry [OptDestination dest] entry)+ :: IO (Either ZipException ())+ case result of+ Left err -> assertEqual "exception for corrupt entry"+ (CRC32Mismatch (dest </> "file.txt")) err+ Right _ -> assertFailure "writeEntry should have failed on a bad CRC"+ original <- readFile (dest </> "file.txt")+ assertEqual "pre-existing file left intact" "original" original+ files <- getDirectoryContents dest+ assertEqual "no leftover temporary files" ["file.txt"]+ (filter (`notElem` [".", ".."]) files)+ testEvilPath :: FilePath -> Test testEvilPath _tmpDir = TestCase $ do archive <- toArchive <$> BL.readFile "tests/zip_with_evil_path.zip"@@ -206,6 +440,15 @@ assertEqual "for contents of test.txt in archive" (Just $ BLC.pack "SUCCESS\n") (fromEncryptedEntry "s3cr3t" f) +testTruncatedEncryptedRead :: FilePath -> Test+testTruncatedEncryptedRead _tmpDir = TestCase $ do+ -- encrypted data shorter than the 12-byte header must not crash+ let entry = (toEntry "trunc.txt" 0 BL.empty)+ { eEncryptionMethod = PKWAREEncryption 0+ , eCompressedData = BLC.pack "short" }+ assertEqual "for truncated encrypted entry"+ Nothing (fromEncryptedEntry "password" entry)+ testIncorrectPasswordRead :: FilePath -> Test testIncorrectPasswordRead _tmpDir = TestCase $ do archive <- toArchive <$> BL.readFile "tests/zip_with_password.zip"@@ -217,6 +460,19 @@ #ifndef _WINDOWS +testTimestampRoundTrip :: FilePath -> Test+testTimestampRoundTrip tmpDir = TestCase $ do+ let src = tmpDir </> "ts-src.txt"+ writeFile src "timestamp"+ srcTime <- getModificationTime src+ entry <- readEntry [] src+ let dest = tmpDir </> "ts-dest"+ writeEntry [OptDestination dest] entry+ destTime <- getModificationTime (dest </> src)+ let diff = abs (realToFrac (diffUTCTime destTime srcTime)) :: Double+ assertBool ("extracted mtime differs from original by " ++ show diff ++ "s")+ (diff < 3) -- MSDOS timestamps have 2-second resolution+ testExtractFilesWithPosixAttrs :: FilePath -> Test testExtractFilesWithPosixAttrs tmpDir = TestCase $ do createDirectory (tmpDir </> "dir3")@@ -283,6 +539,45 @@ assertBool "Target directory exists" targetDirExists assertBool "Symbolic link to file is preserved" isFileSymlink assertBool "Target file exists" targetFileExists++testEvilSymlinkPath :: FilePath -> Test+testEvilSymlinkPath tmpDir = TestCase $ do+ let dest = tmpDir </> "symlink-dest1"+ createDirectoryIfMissing True dest+ let entry = mkSymlinkEntry "../evil-link" "/tmp"+ result <- try $ writeSymbolicLinkEntry+ [OptPreserveSymbolicLinks, OptDestination dest] entry+ :: IO (Either ZipException ())+ case result of+ Left err -> assertEqual "exception for evil symlink path"+ (UnsafePath "../evil-link") err+ Right _ -> assertFailure "writeSymbolicLinkEntry should have failed"+ evilExists <- pathIsSymbolicLink (tmpDir </> "evil-link")+ `catch` (\(_ :: SomeException) -> return False)+ assertBool "no symlink was created outside the destination" (not evilExists)++testEvilSymlinkChain :: FilePath -> Test+testEvilSymlinkChain tmpDir = TestCase $ do+ let dest = tmpDir </> "symlink-dest2"+ let outside = tmpDir </> "outside"+ createDirectoryIfMissing True dest+ createDirectoryIfMissing True outside+ cwd <- getCurrentDirectory+ -- first entry creates a symlink pointing outside the destination;+ -- second entry tries to create a symlink through it+ let archive = Archive [ mkSymlinkEntry "sub" (cwd </> outside)+ , mkSymlinkEntry "sub/inner" "anywhere"+ ] Nothing BL.empty+ result <- try $ extractFilesFromArchive+ [OptPreserveSymbolicLinks, OptDestination dest] archive+ :: IO (Either ZipException ())+ case result of+ Left err -> assertEqual "exception for chained symlink"+ (UnsafePath "sub/inner") err+ Right _ -> assertFailure "extractFilesFromArchive should have failed"+ innerExists <- pathIsSymbolicLink (outside </> "inner")+ `catch` (\(_ :: SomeException) -> return False)+ assertBool "no symlink was created through another symlink" (not innerExists) testArchiveAndUnzip :: FilePath -> Test testArchiveAndUnzip tmpDir = TestCase $ do
zip-archive.cabal view
@@ -1,5 +1,5 @@ Name: zip-archive-Version: 0.4.3.2+Version: 0.5 Cabal-Version: 2.0 Build-type: Simple Synopsis: Library for creating and modifying zip archives.@@ -24,49 +24,45 @@ choice if you want to manipulate zip archives in "pure" contexts. . As an example of the use of the library, a standalone zip archiver and- extracter is provided in the source distribution.+ extractor is provided in the source distribution. Category: Codec-Tested-with: GHC == 8.6.5, GHC == 8.8.1, GHC == 8.10.4, GHC == 9.0.1,- GHC == 8.8.3, GHC == 9.2.1 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+Extra-Source-Files: tests/test4.zip tests/test4/a.txt tests/test4/b.bin "tests/test4/c/with spaces.txt" tests/zip_with_symlinks.zip tests/zip_with_password.zip tests/zip_with_evil_path.zip+Extra-Doc-Files: changelog+ README.markdown Source-repository head type: git- location: git://github.com/jgm/zip-archive.git+ location: https://github.com/jgm/zip-archive.git flag executable Description: Build the Zip executable. Default: False Library- Build-depends: base >= 4.5 && < 5,- pretty,+ Build-depends: base >= 4.11 && < 5, containers, binary >= 0.7.2, zlib, filepath,- bytestring >= 0.10.0, array,- mtl,+ bytestring >= 0.10.0, text >= 0.11, digest >= 0.0.0.1, directory >= 1.2.0, time Exposed-modules: Codec.Archive.Zip- Default-Language: Haskell98+ Default-Language: Haskell2010 Hs-Source-Dirs: src Ghc-Options: -Wall if os(windows)@@ -81,23 +77,29 @@ Buildable: False Main-is: Main.hs Hs-Source-Dirs: .- Build-Depends: base >= 4.5 && < 5,+ Build-Depends: base >= 4.11 && < 5, directory >= 1.1, bytestring >= 0.9.0, zip-archive Other-Modules: Paths_zip_archive Autogen-Modules: Paths_zip_archive Ghc-Options: -Wall- Default-Language: Haskell98+ Default-Language: Haskell2010 Test-Suite test-zip-archive Type: exitcode-stdio-1.0 Main-Is: test-zip-archive.hs Hs-Source-Dirs: tests Build-Depends: base >= 4.5 && < 5,- directory >= 1.3, bytestring >= 0.9.0, process, time,- HUnit, zip-archive, temporary, filepath- Default-Language: Haskell98+ zip-archive,+ directory >= 1.3,+ bytestring >= 0.9.0,+ process,+ time,+ HUnit,+ temporary,+ filepath+ Default-Language: Haskell2010 Ghc-Options: -Wall if os(windows) cpp-options: -D_WINDOWS