diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -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. diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -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 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 @@ -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 -- @@ -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 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 @@ -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 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.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