zip-archive 0.1.4 → 0.5
raw patch · 16 files changed
Files
- Main.hs +100/−0
- README.markdown +27/−0
- Setup.hs +2/−0
- Setup.lhs +0/−3
- Zip.hs +0/−80
- changelog +370/−0
- src/Codec/Archive/Zip.hs +654/−167
- tests/test-zip-archive.hs +551/−47
- tests/test4.zip binary
- tests/test4/a.txt +1/−0
- tests/test4/b.bin +1/−0
- tests/test4/c/with spaces.txt +1/−0
- tests/zip_with_evil_path.zip binary
- tests/zip_with_password.zip binary
- tests/zip_with_symlinks.zip binary
- zip-archive.cabal +68/−24
+ Main.hs view
@@ -0,0 +1,100 @@+------------------------------------------------------------------------+-- Zip.hs+-- Copyright (c) 2008 John MacFarlane+-- License : BSD3 (see LICENSE)+--+-- This is a demonstration of the use of the 'Codec.Archive.Zip' library.+-- It duplicates some of the functionality of the 'zip' command-line+-- program.+------------------------------------------------------------------------++import Codec.Archive.Zip+import System.IO+import qualified Data.ByteString.Lazy as B+import System.Exit+import System.Environment+import System.Directory+import System.Console.GetOpt+import Control.Monad ( when )+import Data.Version ( showVersion )+import Paths_zip_archive ( version )+import Debug.Trace ( traceShowId )++data Flag+ = Quiet+ | Version+ | Decompress+ | Recursive+ | Remove+ | List+ | Debug+ | Help+ deriving (Eq, Show, Read)++options :: [OptDescr Flag]+options =+ [ Option ['d'] ["decompress"] (NoArg Decompress) "decompress (unzip)"+ , Option ['r'] ["recursive"] (NoArg Recursive) "recursive"+ , Option ['R'] ["remove"] (NoArg Remove) "remove"+ , Option ['l'] ["list"] (NoArg List) "list"+ , Option ['v'] ["version"] (NoArg Version) "version"+ , Option ['q'] ["quiet"] (NoArg Quiet) "quiet"+ , Option [] ["debug"] (NoArg Debug) "debug output"+ , Option ['h'] ["help"] (NoArg Help) "help"+ ]++quit :: Bool -> String -> IO a+quit failure msg = do+ hPutStr stderr msg+ _ <- exitWith $ if failure+ then ExitFailure 1+ else ExitSuccess+ return undefined++main :: IO ()+main = do+ argv <- getArgs+ progname <- getProgName+ let header = "Usage: " ++ progname ++ " [OPTION...] archive files..."+ (opts, args) <- case getOpt Permute options argv of+ (o, _, _) | Version `elem` o -> do+ putStrLn ("version " ++ showVersion version)+ exitWith ExitSuccess+ (o, _, _) | Help `elem` o -> quit False $ usageInfo header options+ (o, (a:as), []) -> return (o, a:as)+ (_, [], []) -> quit True $ usageInfo header options+ (_, _, errs) -> quit True $ concat errs ++ "\n" ++ usageInfo header options+ let verbosity = if Quiet `elem` opts then [] else [OptVerbose]+ let debug = Debug `elem` opts+ let cmd = case filter (`notElem` [Quiet, Help, Version, Debug]) opts of+ [] -> Recursive+ (x:_) -> x+ (archivePath : files) <- case args of+ [] -> quit True "No archive path given"+ _ -> return args+ exists <- doesFileExist archivePath+ archive <- if exists+ then toArchive <$> B.readFile archivePath+ else return emptyArchive+ let showArchiveIfDebug x = if debug+ then traceShowId x+ else x+ case cmd of+ Decompress -> extractFilesFromArchive verbosity $ showArchiveIfDebug archive+ Remove -> do tempDir <- getTemporaryDirectory+ (tempArchivePath, tempArchive) <- openTempFile tempDir "zip"+ B.hPut tempArchive $ fromArchive $ showArchiveIfDebug $+ foldr deleteEntryFromArchive archive files+ hClose tempArchive+ copyFile tempArchivePath archivePath+ removeFile tempArchivePath+ List -> mapM_ putStrLn $ filesInArchive $ showArchiveIfDebug archive+ Recursive -> do when (null files) $ error "No files specified."+ tempDir <- getTemporaryDirectory+ (tempArchivePath, tempArchive) <- openTempFile tempDir "zip"+ addFilesToArchive (verbosity ++ [OptRecursive]) archive files >>=+ B.hPut tempArchive . fromArchive . showArchiveIfDebug+ hClose tempArchive+ copyFile tempArchivePath archivePath+ removeFile tempArchivePath+ _ -> error $ "Unknown command " ++ show cmd
+ README.markdown view
@@ -0,0 +1,27 @@+zip-archive+===========++The zip-archive library provides functions for creating, modifying,+and extracting files from zip archives. The zip archive format+is documented in+<http://www.pkware.com/documents/casestudies/APPNOTE.TXT>.++Certain simplifying assumptions are made about the zip archives:+in particular, there is no support for strong encryption, zip+files that span multiple disks, ZIP64, OS-specific file+attributes, or compression methods other than Deflate. However,+the library should be able to read the most common zip archives,+and the archives it produces should be readable by all standard+unzip programs.++Archives are built and extracted in memory, so manipulating+large zip files will consume a lot of memory. If you work with+large zip files or need features not supported by this library,+a better choice may be [zip](http://hackage.haskell.org/package/zip),+which uses a memory-efficient streaming approach. However, zip+can only read and write archives inside instances of MonadIO, so+zip-archive is a better 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 extractor is provided in the source distribution.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
− Setup.lhs
@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple-> main = defaultMain
− Zip.hs
@@ -1,80 +0,0 @@---------------------------------------------------------------------------- Zip.hs--- Copyright (c) 2008 John MacFarlane--- License : BSD3 (see LICENSE)------ This is a demonstration of the use of the 'Codec.Archive.Zip' library.--- It duplicates some of the functionality of the 'zip' command-line--- program.---------------------------------------------------------------------------import Codec.Archive.Zip-import System.IO-import qualified Data.ByteString.Lazy as B-import System.Exit-import System.Environment-import System.Directory-import System.Console.GetOpt-import Control.Monad ( when )-import Control.Applicative ( (<$>) )--data Flag - = Quiet - | Version- | Decompress- | Recursive- | Remove- | List- | Help- deriving (Eq, Show, Read)--options :: [OptDescr Flag]-options =- [ Option ['d'] ["decompress"] (NoArg Decompress) "decompress (unzip)"- , Option ['r'] ["recursive"] (NoArg Recursive) "recursive"- , Option ['R'] ["remove"] (NoArg Remove) "remove"- , Option ['l'] ["list"] (NoArg List) "list"- , Option ['v'] ["version"] (NoArg Version) "version"- , Option ['q'] ["quiet"] (NoArg Quiet) "quiet"- , Option ['h'] ["help"] (NoArg Help) "help"- ]--main :: IO ()-main = do- argv <- getArgs- progname <- getProgName- let header = "Usage: " ++ progname ++ " [OPTION...] archive files..."- (opts, args) <- case getOpt Permute options argv of- (o, _, _) | Version `elem` o -> putStrLn "version 0.1.1.4" >> exitWith ExitSuccess- (o, _, _) | Help `elem` o -> error $ usageInfo header options- (o, (a:as), []) -> return (o, a:as)- (_, _, errs) -> error $ concat errs ++ "\n" ++ usageInfo header options- let verbosity = if Quiet `elem` opts then [] else [OptVerbose]- let cmd = take 1 $ filter (`notElem` [Quiet, Help, Version]) opts- let cmd' = if null cmd- then Recursive- else head cmd- let (archivePath : files) = args- exists <- doesFileExist archivePath- archive <- if exists- then toArchive <$> B.readFile archivePath- else return emptyArchive- case cmd' of- Decompress -> extractFilesFromArchive verbosity archive - Remove -> do tempDir <- getTemporaryDirectory- (tempArchivePath, tempArchive) <- openTempFile tempDir "zip" - B.hPut tempArchive $ fromArchive $ - foldr deleteEntryFromArchive archive files- hClose tempArchive- copyFile tempArchivePath archivePath- removeFile tempArchivePath- List -> mapM_ putStrLn $ filesInArchive archive- Recursive -> do when (null files) $ error "No files specified."- tempDir <- getTemporaryDirectory- (tempArchivePath, tempArchive) <- openTempFile tempDir "zip" - addFilesToArchive (verbosity ++ [OptRecursive]) archive files >>= - B.hPut tempArchive . fromArchive- hClose tempArchive- copyFile tempArchivePath archivePath- removeFile tempArchivePath- _ -> error "Unknown command"
+ changelog view
@@ -0,0 +1,370 @@+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).+ It should be a UNIX time (seconds since UNIX epoch), but+ computed relative to the local time zone, not UTC.++zip-archive 0.4.3.1++ * Use streaming decompress to identify extent of compressed data (#66).+ This fixes a problem that arises for local files with bit 3+ of the general purpose bit flag set. In this case, we don't+ get information up front about the size of the compressed+ data. So how do we know where the compressed data ends?+ Previously, we tried to determine this by looking for the+ signature of the data descriptor. But the data descriptor doesn't+ always HAVE a signature, and it is also possible for signatures to+ occur accidentally in the compressed data itself (#65).+ Instead, we now use the streaming decompression interface from+ zlib's Internal module to identify where the compressed data+ ends. Fixes both #65 and #25.++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+ sometimes used for the data description, because it is not+ in the spec and is not always used.+ * Make some record fields strict.+ * Require binary >= 0.7.2, remove some CPP++zip-archive 0.4.2.2++ * Use `command -v` before trying `which` in the test suite (#62).+ `command` is a bash builtin, but for busybox we'll need `which`.++zip-archive 0.4.2.1++ * Fix Windows build regression (#61).++zip-archive 0.4.2++ * Fix problem with files with colon (#89).+ * Remove build-tools. This was used to indicate that the 'unzip'+ executable was needed for testing, but it was never intended to be used+ this way and now the field is deprecated. The current test suite+ simply skips the test using the unzip executable (with a warning) if+ 'unzip' is not in the path.+ * Remove existing symlinks when extracting zip files with symlinks (#60,+ Vikrem). Previously, writeEntry would raise an error if it tried to+ create a symlink and a symlink already existed at that path. This+ behavior was inconsistent with its behavior for regular files, which+ it overwrote without comment. This commit causes symlinks to be replaced+ by writeEntry instead of an error being raised.+ * Remove binary < 0.6 CPP. It's no longer needed because we don't support+ binary < 0.6. Also use manySig instead of many, to get better error+ messages.+ * Add type annotation for printf.+ * Better checking for unsafe paths (#55). This method allows things like+ `foo/bar/../../baz`.+ * Require base >= 4.5 (#56)+ * Add GitHub CI.++zip-archive 0.4.1++ * writEntry behavior change: Improve raising of UnsafePath error (#55).+ Previously we raised this error spuriously when archives were unpacked+ outside the working directory. Now we raise it if eRelativePath contains+ ".." as a path component, or eRelativePath path is an absolute path and+ there is no separate destination directory. (Note that `/foo/bar` is fine+ as a path as long as a destination directory, e.g. `/usr/local`, is+ specified.)++zip-archive 0.4++ * Implement read-only support for PKWARE encryption (Sergii Rudchenko).+ The "traditional" PKWARE encryption is a symmetric encryption+ algorithm described in zip format specification in section 6.1.+ This change allows to extract basic "password-protected" entries from+ ZIP files. Note that the standard file extraction function+ extractFilesFromArchive does not decrypt entries (it will raise+ an exception if it encounters an encrypted entry). To handle+ archives with encrypted entries, use the new function+ fromEncryptedEntry.++ API changes:++ + Add eEncryptionMethod field to Entry.+ + Add EncryptionMethod type.+ + Add function isEncryptedEntry.+ + Add function fromEncryptedEntry.+ * Add CannotWriteEncryptedEntry constructor to ZipException.++ * Add UnsafePath to ZipException (#50).+ * writeEntry: raise UnsafePath exception for unsafe paths (#50).+ This prevents malicious zip files from overwriting paths+ above the working directory.+ * Add Paths_zip_archive to autogen-modules.+ * Clarify README and cabal description.+ * Specify cabal-version: 2.0. Otherwise we get an unknown build+ tool error using `build-depends` without a custom Setup.hs.+ * Change build-type to simple. Retain 'build-tools: unzip' in+ test stanza, though now it doesn't do anything except give a+ hint to external tools. If unzip is not found in the path,+ the test suite prints a message and counts the test that+ requires unzip as succeeding (see #51).++zip-archive 0.3.3++ * Remove dependency on old-time (typedrat).+ * Drop splitBase flag and support for base versions < 3.++zip-archive 0.3.2.5++ * Move 'build-tools: unzip' from library stanza to test stanza.+ unzip should only be required for testing, not for regular+ builds of the library.++zip-archive 0.3.2.4++ * Make build-tools stanza conditional on non-windows. Closes #44.++zip-archive 0.3.2.3++ * Use custom-setup stanza and specify build-tools. Closes #41.++zip-archive 0.3.2.2++ * Use createSymbolicLink instead of createFileLink in tests. This allows+ us to lower the directory lower bound (#40).++zip-archive 0.3.2.1++ * Fixes for handling of symbolic links (#39, Tommaso Piazza).++ * Fixes for symbolic link tests, and additional tests.++zip-archive 0.3.2++ * Add ZipOption to preserve symbolic links (#37, Tommaso Piazza).+ Add OptPreserveSymbolicLinks constructor to ZipOption. If this option+ is set, symbolic links will be preserved. Symbolic links are not+ supported on Windows.++ * Require binary >= 0.6 (#36).++ * Improve exit handling in zip-archive program.++zip-archive 0.3.1.1++ * readEntry: Read file as a strict ByteString. This avoids+ problems on Windows, where the file handle wasn't being closed.+ * Added appveyor.yml to do continuous testing on Windows.+ * Test suite: remove need for external zip program (#35).+ Instead of creating an archive with zip, we now store+ a small externally created zip archive to use for testing.++zip-archive 0.3.1++ * Don't use a custom build (#28).+ * Renamed executable Zip -> zip-archive, added --debug option.+ The --debug option prints the intermediate Haskell data structure.++zip-archive 0.3.0.7++ * Fix check for unix file attributes (#34).+ Previously attributes would not always be preserved+ for files in zip archives.++zip-archive 0.3.0.6++ * Bump bytestring lower bound so toStrict is guaranteed (Benjamin Landers).++zip-archive 0.3.0.5++ * Fix bug in `OptLocation` handling (EugeneN). When using+ `OptLocation folder False` (for adding files to an archive into a+ folder without preserving full path hierarchy), original files'+ names were ignored, resulting in all the files getting the same name.++zip-archive 0.3.0.4++ * Fix `toArchive` so it doesn't use too much memory when a data+ data descriptor holds the size (Michael Stahl, #29).+ The size fields in the local file headers may not contain valid values,+ in which case the sizes are stored in a "data descriptor" that follows+ the file data. Previously handling this case required reading the+ entire archive is a `[Word8]` list. With this change, `getWordsTilSig`+ iteratively reads chunks as strict ByteStrings and converts them to+ a lazy ByteString at the end.++zip-archive 0.3.0.3++ * Test suite: use withTempDir to create temporary directory.+ This should help fix problems some have encountered with the+ test suite leaving a temporary directory behind.++zip-archive 0.3.0.2++ * Fix test suite so it runs on Windows.+ * Zip executable: get version from cabal `Paths_zip_archive` (#27).++zip-archive 0.3.0.1++ * Set `eVersionMadeBy` to 0 (default) in `toEntry`, since we are+ setting external attributes to 0. See jgm/pandoc#2822.+ Only to `eVersionMadeBy` to UNIX if we actually read file+ attributes on a UNIX system.++zip-archive 0.3++ * Support preservation of file modes on Posix (Dan Aloni, #26).+ * Add `eVersionMadeBy` field to `Entry` (API change).+ * Export `ZipException` (API change).+ * `fromEntry` no longer checks for CRC32 match. Previously, it issued+ `error` if the match failed. CRC32 match is now checked in `writeEntry`+ instead, and a `CRC32Exception` is raised if the checksum doesn't match.+ * Test suite: return nonzero status if there are test failures.+ Previously we mistakenly did this only on 'errors', not failures.+ * Test suite: don't use -9 with zip as it isn't always available.+ * Use .travis.yml that builds on both stack and cabal.++zip-archive 0.2.3.7++ * Declared test suite's dependency on 'zip' using custom Setup.lhs (#21,#22).++zip-archive 0.2.3.6++ * Removed hard-coded path to zip in test suite (#21).+ * Removed misplaced build-depends in cabal file.++zip-archive 0.2.3.5++ * Allow compilation with binary >= 0.5. Note that toArchiveOrFail+ is not safe when compiled against binary < 0.7; it will never+ return a Left value, and will raise an error if parsing fails,+ just like toArchive. This is documented in the haddocks.+ This is ugly, but justified by the need to have a version+ of zip-archive that compiles against older versions of binary.++zip-archive 0.2.3.4++ * Make sure all path comparisons compare normalized paths.+ So, findEntryByPath "foo" will find something stored as "./foo"+ in the zip container.++zip-archive 0.2.3.3++ * Better normalization of file paths: "./foo/bar" and "foo/./bar"+ are now treated the same, for example. Note that we do not+ yet treat "foo/../bar" and "bar" as the same.++zip-archive 0.2.3.2++ * Removed lower bound on directory (>= 1.2), which caused build+ failures with GHC 7.4 and 7.6.+ * Added travis script for automatic testing on 3 GHC versions.++zip-archive 0.2.3.1++ * Require binary >= 0.7 and directory >= 1.2. The newer binary+ is needed to provide toArchiveOrFail. The other change is+ mainly for convenience, to avoid lots of ugly conditional+ compilation.++zip-archive 0.2.3++ * Export new function `toArchiveOrFail`. Closes #17.+ * Set general purpose bit flag to use UTF8 in local file header.+ Otherwise we get a mismatch between the flag in the central+ directory and the flag in the local file header, which causes some+ programs not to be able to extract the files. Closes #19.++zip-archive 0.2.2.1++ * Fix a stack overflow in getWordsTillSig (Tristan Ravitch).++zip-archive 0.2.2++ * Set bit 11 in the file header to ensure other programs+ recognize UTF-8 encoded file names (Tobias Brandt).++zip-archive 0.2.1++ * Added OptLocation, to specify the path to which a file+ is to be added when readEntry is used (Stephen McIntosh).+
src/Codec/Archive/Zip.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------ -- | -- Module : Codec.Archive.Zip@@ -13,14 +16,23 @@ -- and extracting files from zip archives. -- -- Certain simplifying assumptions are made about the zip archives: in--- particular, there is no support for encryption, zip files that span+-- particular, there is no support for strong encryption, zip files that span -- multiple disks, ZIP64, OS-specific file attributes, or compression -- methods other than Deflate. However, the library should be able to -- 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>@@ -33,65 +45,94 @@ Archive (..) , Entry (..) , CompressionMethod (..)+ , EncryptionMethod (..) , ZipOption (..)+ , ZipException (..) , emptyArchive -- * Pure functions for working with zip archives , toArchive+ , toArchiveOrFail , fromArchive , filesInArchive , addEntryToArchive , deleteEntryFromArchive , findEntryByPath , fromEntry+ , fromEncryptedEntry+ , isEncryptedEntry , toEntry+#ifndef _WINDOWS+ , isEntrySymbolicLink+ , symbolicLinkEntryTarget+ , entryCMode+#endif -- * IO functions for working with zip archives , readEntry , writeEntry+#ifndef _WINDOWS+ , writeSymbolicLinkEntry+#endif , addFilesToArchive , extractFilesFromArchive ) where -import System.Time ( toUTCTime, addToClockTime, CalendarTime (..), ClockTime (..), TimeDiff (..) )-#if MIN_VERSION_directory(1,2,0)-import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds )-#else-#endif-import Data.Bits ( shiftL, shiftR, (.&.) )+import Data.Time.Calendar ( toGregorian, fromGregorian )+import Data.Time.Clock ( UTCTime(..) )+import Data.Time.LocalTime ( TimeZone(..), TimeOfDay(..), timeToTimeOfDay,+ getTimeZone )+import Data.Time.Clock.POSIX ( posixSecondsToUTCTime, utcTimeToPOSIXSeconds )+import Data.Bits ( shiftL, shiftR, (.&.), (.|.), xor, testBit, complement ) import Data.Binary import Data.Binary.Get import Data.Binary.Put-import Data.List ( nub, find )+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 )-import Control.Monad ( when, unless, zipWithM )-#if MIN_VERSION_directory(1,2,0)-import Control.Monad ( liftM )-#endif-import System.Directory ( getModificationTime )-import System.IO ( stderr, hPutStrLn )+import System.Directory+ (doesDirectoryExist, getDirectoryContents,+ 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, hClose, openBinaryTempFile ) import qualified Data.Digest.CRC32 as CRC32+import Data.Array.Unboxed ( UArray, listArray, (!) ) import qualified Data.Map as M-#if MIN_VERSION_binary(0, 6, 0)+import qualified Data.Set as Set import Control.Applicative-#endif-#ifndef _WINDOWS-import System.Posix.Files ( setFileTimes )+#ifdef _WINDOWS+import Data.Char (isLetter)+#else+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) #endif -- from bytestring+import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.Lazy.Char8 as C --- from utf8-string-import Data.ByteString.Lazy.UTF8 ( toString, fromString )+-- 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+import qualified Codec.Compression.Zlib.Internal as ZlibInt+import System.IO.Error (isAlreadyExistsError) -#if !MIN_VERSION_binary(0, 6, 0)+-- import Debug.Trace+ manySig :: Word32 -> Get a -> Get [a] manySig sig p = do sig' <- lookAhead getWord32le@@ -101,8 +142,8 @@ rs <- manySig sig p return $ r : rs else return []-#endif + ------------------------------------------------------------------------ -- | Structured representation of a zip archive, including directory@@ -110,22 +151,28 @@ data Archive = Archive { zEntries :: [Entry] -- ^ Files in zip archive , zSignature :: Maybe B.ByteString -- ^ Digital signature- , zComment :: B.ByteString -- ^ Comment for whole zip archive+ , zComment :: !B.ByteString -- ^ Comment for whole zip archive } deriving (Read, Show) +instance Binary Archive where+ put = putArchive+ get = getArchive+ -- | Representation of an archived file, including content and metadata. data Entry = Entry { eRelativePath :: FilePath -- ^ Relative path, using '/' as separator- , eCompressionMethod :: CompressionMethod -- ^ Compression method- , eLastModified :: Integer -- ^ Modification time (seconds since unix epoch)- , eCRC32 :: Word32 -- ^ CRC32 checksum- , eCompressedSize :: Word32 -- ^ Compressed size in bytes- , eUncompressedSize :: Word32 -- ^ Uncompressed size in bytes- , eExtraField :: B.ByteString -- ^ Extra field - unused by this library- , eFileComment :: B.ByteString -- ^ File comment - unused by this library- , eInternalFileAttributes :: Word16 -- ^ Internal file attributes - unused by this library- , eExternalFileAttributes :: Word32 -- ^ External file attributes (system-dependent)- , eCompressedData :: B.ByteString -- ^ Compressed contents of file+ , eCompressionMethod :: !CompressionMethod -- ^ Compression method+ , eEncryptionMethod :: !EncryptionMethod -- ^ Encryption method+ , 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+ , eExtraField :: !B.ByteString -- ^ Extra field - unused by this library+ , eFileComment :: !B.ByteString -- ^ File comment - unused by this library+ , eVersionMadeBy :: !Word16 -- ^ Version made by field+ , eInternalFileAttributes :: !Word16 -- ^ Internal file attributes - unused by this library+ , eExternalFileAttributes :: !Word32 -- ^ External file attributes (system-dependent)+ , eCompressedData :: !B.ByteString -- ^ Compressed contents of file } deriving (Read, Show, Eq) -- | Compression methods.@@ -133,12 +180,32 @@ | NoCompression deriving (Read, Show, Eq) +data EncryptionMethod = NoEncryption -- ^ Entry is not encrypted+ | PKWAREEncryption !Word8 -- ^ Entry is encrypted with the traditional PKWARE encryption+ deriving (Read, Show, Eq)++-- | The way the password should be verified during entry decryption+data PKWAREVerificationType = CheckTimeByte+ | CheckCRCByte+ deriving (Read, Show, Eq)+ -- | Options for 'addFilesToArchive' and 'extractFilesFromArchive'. data ZipOption = OptRecursive -- ^ Recurse into directories when adding files | 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. 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+ -- | A zip archive with no contents. emptyArchive :: Archive emptyArchive = Archive@@ -148,15 +215,28 @@ -- | Reads an 'Archive' structure from a raw zip archive (in a lazy bytestring). toArchive :: B.ByteString -> Archive-toArchive = runGet getArchive+toArchive = decode +-- | Like 'toArchive', but returns an 'Either' value instead of raising an+-- error if the archive cannot be decoded. NOTE: This function only+-- works properly when the library is compiled against binary >= 0.7.+-- With earlier versions, it will always return a Right value,+-- raising an error if parsing fails.+toArchiveOrFail :: B.ByteString -> Either String Archive+toArchiveOrFail bs = case decodeOrFail bs of+ Left (_,_,e) -> Left e+ 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 = runPut . putArchive+fromArchive = encode -- | Returns a list of files in a zip archive. filesInArchive :: Archive -> [FilePath]-filesInArchive = (map eRelativePath) . zEntries+filesInArchive = map eRelativePath . zEntries -- | Adds an entry to a zip archive, or updates an existing entry. addEntryToArchive :: Entry -> Archive -> Archive@@ -168,23 +248,37 @@ -- | Deletes an entry from a zip archive. deleteEntryFromArchive :: FilePath -> Archive -> Archive deleteEntryFromArchive path archive =- let path' = zipifyFilePath path- newEntries = filter (\e -> eRelativePath e /= path') $ zEntries archive- in archive { zEntries = newEntries }+ 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 == eRelativePath e) (zEntries archive)+findEntryByPath path archive =+ let path' = normalizePath path+ in find (\e -> path' == normalizePath (eRelativePath e))+ (zEntries archive) -- | Returns uncompressed contents of zip entry. fromEntry :: Entry -> B.ByteString fromEntry entry =- let uncompressedData = decompressData (eCompressionMethod entry) (eCompressedData entry)- in if eCRC32 entry == CRC32.crc32 uncompressedData- then uncompressedData- else error "CRC32 mismatch"+ decompressData (eCompressionMethod entry) (eCompressedData entry) +-- | Returns decrypted and uncompressed contents of zip entry.+fromEncryptedEntry :: String -> Entry -> Maybe B.ByteString+fromEncryptedEntry password entry =+ decompressData (eCompressionMethod entry) <$> decryptData password (eEncryptionMethod entry) (eCompressedData entry)++-- | Check if an 'Entry' is encrypted+isEncryptedEntry :: Entry -> Bool+isEncryptedEntry entry =+ case eEncryptionMethod entry of+ (PKWAREEncryption _) -> True+ _ -> 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@@ -199,14 +293,20 @@ then (NoCompression, contents, uncompressedSize) else (Deflate, compressedData, compressedSize) crc32 = CRC32.crc32 contents- in Entry { eRelativePath = 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 , eCRC32 = crc32 , eCompressedSize = fromIntegral finalSize , eUncompressedSize = fromIntegral uncompressedSize , eExtraField = B.empty , eFileComment = B.empty+ , eVersionMadeBy = 0 -- FAT , eInternalFileAttributes = 0 -- potentially non-text , eExternalFileAttributes = 0 -- appropriate if from stdin , eCompressedData = finalData@@ -216,33 +316,101 @@ readEntry :: [ZipOption] -> FilePath -> IO Entry readEntry opts path = do isDir <- doesDirectoryExist path- let path' = zipifyFilePath $ normalise $- path ++ if isDir then "/" else "" -- make sure directories end with /- contents <- if isDir- then return B.empty- else B.readFile path-#if MIN_VERSION_directory(1,2,0)- modEpochTime <- liftM (floor . utcTimeToPOSIXSeconds)- $ getModificationTime path+#ifdef _WINDOWS+ let isSymLink = False #else- (TOD modEpochTime _) <- getModificationTime path+ fs <- getSymbolicLinkStatus path+ let isSymLink = isSymbolicLink fs #endif+ -- make sure directories end in / and deal with the OptLocation option+ let path' = let p = path ++ (case reverse path of+ ('/':_) -> ""+ _ | isDir && not isSymLink -> "/"+ _ | isDir && isSymLink -> ""+ | otherwise -> "") in+ (case [(l,a) | OptLocation l a <- opts] of+ ((l,a):_) -> if a then l </> p else l </> takeFileName p+ _ -> p)+ contents <-+#ifndef _WINDOWS+ if isSymLink+ then do+ linkTarget <- readSymbolicLink path+ return $ C.pack linkTarget+ else+#endif+ if isDir+ then+ return B.empty+ else+ B.fromStrict <$> S.readFile path+ modTime <- getModificationTime path+ tzone <- getTimeZone modTime+ let modEpochTime = -- UNIX time computed relative to LOCAL time zone! (#67)+ floor (utcTimeToPOSIXSeconds modTime) ++ fromIntegral (timeZoneMinutes tzone * 60) let entry = toEntry path' modEpochTime contents++ entryE <-+#ifdef _WINDOWS+ return $ entry { eVersionMadeBy = 0x0000 } -- FAT/VFAT/VFAT32 file attributes+#else+ do+ let fm = if isSymLink+ then unionFileModes symbolicLinkMode (fileMode fs)+ else fileMode fs++ let modes = fromIntegral $ shiftL (toInteger fm) 16+ return $ entry { eExternalFileAttributes = modes,+ eVersionMadeBy = 0x0300 } -- UNIX file attributes+#endif+ when (OptVerbose `elem` opts) $ do- let compmethod = case eCompressionMethod entry of- Deflate -> "deflated"+ let compmethod = case eCompressionMethod entryE of+ Deflate -> ("deflated" :: String) NoCompression -> "stored" hPutStrLn stderr $- printf " adding: %s (%s %.f%%)" (eRelativePath entry)- compmethod (100 - (100 * compressionRatio entry))- return entry+ printf " adding: %s (%s %.f%%)" (eRelativePath entryE)+ compmethod (100 - (100 * compressionRatio entryE))+ return entryE --- | Writes contents of an 'Entry' to a file.+-- 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+ | 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 [])+ where+ go acc x = do+ xs <- acc+ case x of+ "." -> return xs+ ".." -> case xs of+ [] -> 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+-- does not match the uncompressed data. writeEntry :: [ZipOption] -> Entry -> IO () writeEntry opts entry = do- let path = case [d | OptDestination d <- opts] of- (x:_) -> x </> eRelativePath entry- _ -> eRelativePath entry+ when (isEncryptedEntry entry) $+ E.throwIO $ CannotWriteEncryptedEntry (eRelativePath entry)+ let relpath = eRelativePath entry+ checkPath relpath+ path <- case [d | OptDestination d <- opts] of+ (x:_) -> return (x </> relpath)+ [] -> return relpath -- create directories if needed let dir = takeDirectory path exists <- doesDirectoryExist dir@@ -250,49 +418,194 @@ createDirectoryIfMissing True dir when (OptVerbose `elem` opts) $ hPutStrLn stderr $ " creating: " ++ dir- if length path > 0 && last path == '/' -- path is a directory+ if not (null path) && last path == '/' -- path is a directory then return () else do- when (OptVerbose `elem` opts) $ do+ when (OptVerbose `elem` opts) $ hPutStrLn stderr $ case eCompressionMethod entry of Deflate -> " inflating: " ++ path NoCompression -> "extracting: " ++ path- B.writeFile path (fromEntry entry)+ -- 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+ 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. setFileTimeStamp path (eLastModified entry) +#ifndef _WINDOWS+-- | Write an 'Entry' representing a symbolic link to a file.+-- If the 'Entry' does not represent a symbolic link or+-- the options do not contain 'OptPreserveSymbolicLinks`, this+-- function behaves like `writeEntry`.+--+-- 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+ then writeEntry opts entry+ 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 </> 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 =+ createSymbolicLink target linkName `E.catch`+ (\e -> if isAlreadyExistsError e+ then removeLink linkName >> createSymbolicLink target linkName+ else ioError e)++-- | Get the target of a 'Entry' representing a symbolic link. This might fail+-- if the 'Entry' does not represent a symbolic link+symbolicLinkEntryTarget :: Entry -> Maybe FilePath+symbolicLinkEntryTarget entry | isEntrySymbolicLink entry = Just . C.unpack $ fromEntry entry+ | otherwise = Nothing++-- | Check if an 'Entry' represents a symbolic link+isEntrySymbolicLink :: Entry -> Bool+isEntrySymbolicLink entry = entryCMode entry .&. symbolicLinkMode == symbolicLinkMode++-- | Get the 'eExternalFileAttributes' of an 'Entry' as a 'CMode' a.k.a. 'FileMode'+entryCMode :: Entry -> CMode+entryCMode entry = CMode (fromIntegral $ shiftR (eExternalFileAttributes entry) 16)+#endif+ -- | Add the specified files to an 'Archive'. If 'OptRecursive' is specified,--- recursively add files contained in directories. If 'OptVerbose' is specified,+-- recursively add files contained in directories. if 'OptPreserveSymbolicLinks'+-- is specified, don't recurse into it. If 'OptVerbose' is specified, -- print messages to stderr. addFilesToArchive :: [ZipOption] -> Archive -> [FilePath] -> IO Archive addFilesToArchive opts archive files = do filesAndChildren <- if OptRecursive `elem` opts- then mapM getDirectoryContentsRecursive files >>= return . nub . concat+#ifdef _WINDOWS+ then ordNub . concat <$> mapM getDirectoryContentsRecursive files+#else+ 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.+-- See the warning on 'OptPreserveSymbolicLinks' before using it+-- with untrusted archives. extractFilesFromArchive :: [ZipOption] -> Archive -> IO ()-extractFilesFromArchive opts archive =- mapM_ (writeEntry opts) $ zEntries archive+extractFilesFromArchive opts archive = do+ let entries = zEntries archive+ if OptPreserveSymbolicLinks `elem` opts+ then do+#ifdef _WINDOWS+ mapM_ (writeEntry opts) entries+#else+ let (symbolicLinkEntries, nonSymbolicLinkEntries) = partition isEntrySymbolicLink entries+ mapM_ (writeEntry opts) nonSymbolicLinkEntries+ mapM_ (writeSymbolicLinkEntry opts) symbolicLinkEntries+#endif+ else mapM_ (writeEntry opts) entries -------------------------------------------------------------------------------- -- Internal functions for reading and writing zip binary format. -- Note that even on Windows, zip files use "/" internally as path separator.-zipifyFilePath :: FilePath -> String-zipifyFilePath path =- let dir = takeDirectory path- fn = takeFileName path- (_drive, dir') = splitDrive dir+normalizePath :: FilePath -> String+normalizePath path =+ let dir = takeDirectory path+ fn = takeFileName path+ dir' = case dir of+#ifdef _WINDOWS+ (c:':':d:xs) | isLetter c+ , d == '/' || d == '\\'+ -> xs -- remove drive+#endif+ _ -> dir -- note: some versions of filepath return ["."] if no dir- dirParts = dropWhile (==".") $ splitDirectories dir'- in (concat (map (++ "/") dirParts)) ++ fn+ dirParts = filter (/=".") $ splitDirectories dir'+ in intercalate "/" (dirParts ++ [fn]) -- | Uncompress a lazy bytestring. compressData :: CompressionMethod -> B.ByteString -> B.ByteString@@ -304,6 +617,58 @@ decompressData Deflate = Zlib.decompress decompressData NoCompression = id +-- | Decrypt a lazy bytestring+-- 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+ | 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 implementation of the PKWARE decryption algorithm+pkwareDecryptByte :: DecryptionCtx -> Word8 -> (DecryptionCtx, Word8)+pkwareDecryptByte keys@(_, _, key2) inB =+ let tmp = key2 .|. 2+ tmp' = fromIntegral ((tmp * (tmp `xor` 1)) `shiftR` 8) :: Word8+ outB = inB `xor` tmp'+ in (pkwareUpdateKeys keys outB, outB)++-- | Update decryption keys after a decrypted byte+pkwareUpdateKeys :: DecryptionCtx -> Word8 -> DecryptionCtx+pkwareUpdateKeys (key0, key1, key2) inB =+ let key0' = pkwareCrc32Byte key0 inB+ key1' = (key1 + (key0' .&. 0xff)) * 134775813 + 1+ key1Byte = fromIntegral (key1' `shiftR` 24) :: Word8+ 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 =@@ -327,56 +692,92 @@ 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 ut = toUTCTime (TOD epochtime 0)- dosTime = toEnum $ (ctSec ut `div` 2) + shiftL (ctMin ut) 5 + shiftL (ctHour ut) 11- dosDate = toEnum $ ctDay ut + shiftL (fromEnum (ctMonth ut) + 1) 5 + shiftL (ctYear ut - 1980) 9+ let+ UTCTime+ (toGregorian -> (fromInteger -> year, month, day))+ (timeToTimeOfDay -> (TimeOfDay hour minutes (floor -> sec)))+ = posixSecondsToUTCTime (fromIntegral epochtime)++ dosTime = toEnum $ (sec `div` 2) + shiftL minutes 5 + shiftL hour 11+ dosDate = toEnum $ day + shiftL month 5 + shiftL (year - 1980) 9 in MSDOSDateTime { msDOSDate = dosDate, msDOSTime = dosTime } -- | Convert a MSDOS datetime to a 'ClockTime'. msDOSDateTimeToEpochTime :: MSDOSDateTime -> Integer-msDOSDateTimeToEpochTime (MSDOSDateTime {msDOSDate = dosDate, msDOSTime = dosTime}) =+msDOSDateTimeToEpochTime MSDOSDateTime {msDOSDate = dosDate, msDOSTime = dosTime} = let seconds = fromIntegral $ 2 * (dosTime .&. 0O37)- minutes = fromIntegral $ (shiftR dosTime 5) .&. 0O77+ minutes = fromIntegral $ shiftR dosTime 5 .&. 0O77 hour = fromIntegral $ shiftR dosTime 11 day = fromIntegral $ dosDate .&. 0O37- month = fromIntegral $ ((shiftR dosDate 5) .&. 0O17) - 1+ month = fromIntegral ((shiftR dosDate 5) .&. 0O17) year = fromIntegral $ shiftR dosDate 9- timeSinceEpoch = TimeDiff- { tdYear = year + 10, -- dos times since 1980, unix epoch starts 1970- tdMonth = month,- tdDay = day - 1, -- dos days start from 1- tdHour = hour,- tdMin = minutes,- tdSec = seconds,- tdPicosec = 0 }- (TOD epochsecs _) = addToClockTime timeSinceEpoch (TOD 0 0)- in epochsecs+ utc = UTCTime (fromGregorian (1980 + year) month day) (3600 * hour + 60 * minutes + seconds)+ in floor (utcTimeToPOSIXSeconds utc) +#ifndef _WINDOWS+getDirectoryContentsRecursive' :: [ZipOption] -> FilePath -> IO [FilePath]+getDirectoryContentsRecursive' opts path =+ if OptPreserveSymbolicLinks `elem` opts+ then do+ isDir <- doesDirectoryExist path+ if isDir+ then do+ isSymLink <- fmap isSymbolicLink $ getSymbolicLinkStatus path+ if isSymLink+ then return [path]+ else getDirectoryContentsRecursivelyBy (getDirectoryContentsRecursive' opts) path+ else return [path]+ else getDirectoryContentsRecursive path+#endif+ getDirectoryContentsRecursive :: FilePath -> IO [FilePath] getDirectoryContentsRecursive path = do isDir <- doesDirectoryExist path if isDir- then do+ then getDirectoryContentsRecursivelyBy getDirectoryContentsRecursive path+ else return [path]++getDirectoryContentsRecursivelyBy :: (FilePath -> IO [FilePath]) -> FilePath -> IO [FilePath]+getDirectoryContentsRecursivelyBy exploreMethod path = do contents <- getDirectoryContents path let contents' = map (path </>) $ filter (`notElem` ["..","."]) contents- children <- mapM getDirectoryContentsRecursive contents'+ children <- mapM exploreMethod contents' if path == "." then return (concat children) else return (path : concat children)- else return [path] + setFileTimeStamp :: FilePath -> Integer -> IO ()-setFileTimeStamp file epochtime = do #ifdef _WINDOWS- return () -- TODO - figure out how to set the timestamp on Windows+setFileTimeStamp _ _ = return () -- TODO: figure out how to set the timestamp on Windows #else- let epochtime' = fromInteger epochtime+setFileTimeStamp file epochtime = do+ -- 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 @@ -429,15 +830,9 @@ getArchive :: Get Archive getArchive = do-#if MIN_VERSION_binary(0, 6, 0)- locals <- many getLocalFile- files <- many (getFileHeader (M.fromList locals))- digSig <- Just `fmap` getDigitalSignature <|> return Nothing-#else locals <- manySig 0x04034b50 getLocalFile files <- manySig 0x02014b50 (getFileHeader (M.fromList locals))- digSig <- lookAheadM getDigitalSignature-#endif+ digSig <- Just `fmap` getDigitalSignature <|> return Nothing endSig <- getWord32le unless (endSig == 0x06054b50) $ fail "Did not find end of central directory signature"@@ -449,7 +844,7 @@ skip 4 -- offset of central directory commentLength <- getWord16le zipComment <- getLazyByteString (toEnum $ fromEnum commentLength)- return $ Archive+ return Archive { zEntries = files , zSignature = digSig , zComment = zipComment@@ -457,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@@ -477,13 +877,15 @@ fileHeaderSize :: Entry -> Word32 fileHeaderSize f = fromIntegral $ 4 + 2 + 2 + 2 + 2 + 2 + 2 + 4 + 4 + 4 + 2 + 2 + 2 + 2 + 2 + 4 + 4 +- fromIntegral (B.length $ fromString $ zipifyFilePath $ eRelativePath f) ++ 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 $ zipifyFilePath $ 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:@@ -515,7 +917,11 @@ getWord32le >>= ensure (== 0x04034b50) skip 2 -- version bitflag <- getWord16le- skip 2 -- compressionMethod+ rawCompressionMethod <- getWord16le+ compressionMethod <- case rawCompressionMethod of+ 0 -> return NoCompression+ 8 -> return Deflate+ _ -> fail $ "Unknown compression method " ++ show rawCompressionMethod skip 2 -- last mod file time skip 2 -- last mod file date skip 4 -- crc32@@ -527,44 +933,31 @@ extraFieldLength <- getWord16le skip (fromIntegral fileNameLength) -- filename skip (fromIntegral extraFieldLength) -- extra field- compressedData <- if bitflag .&. 0O10 == 0+ compressedData <-+ if bitflag .&. 0O10 == 0 then getLazyByteString (fromIntegral compressedSize) else -- If bit 3 of general purpose bit flag is set, -- then we need to read until we get to the- -- data descriptor record. We assume that the- -- record has signature 0x08074b50; this is not required- -- by the specification but is common.- do raw <- getWordsTilSig 0x08074b50+ -- data descriptor record.+ do raw <- getCompressedData compressionMethod+ sig <- lookAhead getWord32le+ when (sig == 0x08074b50) $ skip 4 skip 4 -- crc32 cs <- getWord32le -- compressed size skip 4 -- uncompressed size- if fromIntegral cs == length raw- then return $ B.pack raw- else fail "Content size mismatch in data descriptor record" + if fromIntegral cs == B.length raw+ then return raw+ else fail $ printf+ ("Content size mismatch in data descriptor record: "+ ++ "expected %d, got %d bytes")+ cs (B.length raw) return (fromIntegral offset, compressedData) -getWordsTilSig :: Word32 -> Get [Word8]-getWordsTilSig sig = do-#if MIN_VERSION_binary(0, 6, 0)- (getWord32le >>= ensure (== sig) >> return []) <|>- do w <- getWord8- ws <- getWordsTilSig sig- return (w:ws)-#else- sig' <- lookAhead getWord32le- if sig == sig'- then skip 4 >> return []- else do- w <- getWord8- ws <- getWordsTilSig sig- return (w:ws)-#endif- putLocalFile :: Entry -> Put putLocalFile f = do putWord32le 0x04034b50 putWord16le 20 -- version needed to extract (>=2.0)- putWord16le 2 -- general purpose bit flag (max compression)+ putWord16le 0x800 -- general purpose bit flag (bit 11 = UTF-8) putWord16le $ case eCompressionMethod f of NoCompression -> 0 Deflate -> 8@@ -574,10 +967,10 @@ putWord32le $ eCRC32 f putWord32le $ eCompressedSize f putWord32le $ eUncompressedSize f- putWord16le $ fromIntegral $ B.length $ fromString- $ zipifyFilePath $ eRelativePath f+ let encodedPath = fromString $ normalizePath $ eRelativePath f+ putWord16le $ fromIntegral $ B.length encodedPath putWord16le $ fromIntegral $ B.length $ eExtraField f- putLazyByteString $ fromString $ zipifyFilePath $ eRelativePath f+ putLazyByteString encodedPath putLazyByteString $ eExtraField f putLazyByteString $ eCompressedData f @@ -609,12 +1002,12 @@ -> Get Entry getFileHeader locals = do getWord32le >>= ensure (== 0x02014b50)- skip 2 -- version made by+ vmb <- getWord16le -- version made by versionNeededToExtract <- getWord8 skip 1 -- upper byte indicates OS part of "version needed to extract" unless (versionNeededToExtract <= 20) $ fail "This archive requires zip >= 2.0 to extract."- skip 2 -- general purpose bit flag+ bitflag <- getWord16le rawCompressionMethod <- getWord16le compressionMethod <- case rawCompressionMethod of 0 -> return NoCompression@@ -623,6 +1016,12 @@ lastModFileTime <- getWord16le lastModFileDate <- getWord16le crc32 <- getWord32le+ encryptionMethod <- case (testBit bitflag 0, testBit bitflag 3, testBit bitflag 6) of+ (False, _, _) -> return NoEncryption+ (True, False, False) -> return $ PKWAREEncryption (fromIntegral (crc32 `shiftR` 24))+ (True, True, False) -> return $ PKWAREEncryption (fromIntegral (lastModFileTime `shiftR` 8))+ (True, _, True) -> fail "Strong encryption is not supported"+ compressedSize <- getWord32le uncompressedSize <- getWord32le fileNameLength <- getWord16le@@ -635,13 +1034,14 @@ fileName <- getLazyByteString (toEnum $ fromEnum fileNameLength) extraField <- getLazyByteString (toEnum $ fromEnum extraFieldLength) fileComment <- getLazyByteString (toEnum $ fromEnum fileCommentLength)- compressedData <- case (M.lookup relativeOffset locals) of+ compressedData <- case M.lookup relativeOffset locals of Just x -> return x Nothing -> fail $ "Unable to find data at offset " ++ show relativeOffset- return $ Entry- { eRelativePath = toString fileName+ return Entry+ { eRelativePath = decodeFileName bitflag fileName , eCompressionMethod = compressionMethod+ , eEncryptionMethod = encryptionMethod , eLastModified = msDOSDateTimeToEpochTime $ MSDOSDateTime { msDOSDate = lastModFileDate, msDOSTime = lastModFileTime }@@ -650,6 +1050,7 @@ , eUncompressedSize = uncompressedSize , eExtraField = extraField , eFileComment = fileComment+ , eVersionMadeBy = vmb , eInternalFileAttributes = internalFileAttributes , eExternalFileAttributes = externalFileAttributes , eCompressedData = compressedData@@ -660,9 +1061,9 @@ -> Put putFileHeader offset local = do putWord32le 0x02014b50- putWord16le 0 -- version made by+ putWord16le $ eVersionMadeBy local putWord16le 20 -- version needed to extract (>= 2.0)- putWord16le 2 -- general purpose bit flag (max compression)+ putWord16le 0x800 -- general purpose bit flag (bit 11 = UTF-8) putWord16le $ case eCompressionMethod local of NoCompression -> 0 Deflate -> 8@@ -672,15 +1073,15 @@ putWord32le $ eCRC32 local putWord32le $ eCompressedSize local putWord32le $ eUncompressedSize local- putWord16le $ fromIntegral $ B.length $ fromString- $ zipifyFilePath $ 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 $ zipifyFilePath $ eRelativePath local+ putLazyByteString encodedPath putLazyByteString $ eExtraField local putLazyByteString $ eFileComment local @@ -690,22 +1091,11 @@ -- > size of data 2 bytes -- > signature data (variable size) -#if MIN_VERSION_binary(0, 6, 0) getDigitalSignature :: Get B.ByteString getDigitalSignature = do getWord32le >>= ensure (== 0x05054b50) sigSize <- getWord16le getLazyByteString (toEnum $ fromEnum sigSize)-#else-getDigitalSignature :: Get (Maybe B.ByteString)-getDigitalSignature = do- hdrSig <- getWord32le- if hdrSig /= 0x05054b50- then return Nothing- else do- sigSize <- getWord16le- getLazyByteString (toEnum $ fromEnum sigSize) >>= return . Just-#endif putDigitalSignature :: Maybe B.ByteString -> Put putDigitalSignature Nothing = return ()@@ -719,3 +1109,100 @@ if p val then return () else fail "ensure not satisfied"++-- | 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++getCompressedData :: CompressionMethod -> Get B.ByteString+getCompressedData NoCompression = do+ -- we assume there will be a signature on the data descriptor,+ -- otherwise we have no way of identifying where the data ends!+ -- The signature 0x08074b50 is commonly used but not required by spec.+ let findSigPos = do+ w1 <- getWord8+ if w1 == 0x50+ then do+ w2 <- getWord8+ if w2 == 0x4b+ then do+ w3 <- getWord8+ if w3 == 0x07+ then do+ w4 <- getWord8+ if w4 == 0x08+ then (\x -> x - 4) <$> bytesRead+ else findSigPos+ else findSigPos+ else findSigPos+ else findSigPos+ pos <- bytesRead+ sigpos <- lookAhead findSigPos <|>+ fail "getCompressedData can't find data descriptor signature"+ let compressedBytes = sigpos - pos+ getLazyByteString compressedBytes+getCompressedData Deflate = do+ remainingBytes <- lookAhead getRemainingLazyByteString+ -- 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
@@ -1,100 +1,604 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-} -- Test suite for Codec.Archive.Zip -- runghc Test.hs import Codec.Archive.Zip-import System.Directory+import Control.Monad (unless)+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-import System.Process-import qualified Data.ByteString.Lazy as B-import Control.Applicative+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BLC import System.Exit+import System.IO.Temp (withTempDirectory) +#ifndef _WINDOWS+import System.FilePath.Posix+import System.Posix.Files+import System.Process (rawSystem)+#else+import System.FilePath.Windows+#endif+ -- 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 && (all id $ zipWith (\x y -> x { eLastModified = eLastModified x `div` 2 } == y { eLastModified = eLastModified y `div` 2 }) (zEntries a1) (zEntries a2)) +#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+ createDirectoryIfMissing True testDir+ createDirectoryIfMissing True (testDir </> "1")+ writeFile (testDir </> "1/file.txt") "hello"+ cwd <- getCurrentDirectory+ createSymbolicLink (cwd </> testDir </> "1/file.txt") (testDir </> "link_to_file")+ createSymbolicLink (cwd </> testDir </> "1") (testDir </> "link_to_directory")+ return testDir++#endif+++ main :: IO Counts-main = do- createDirectory "test-temp"- res <- runTestTT $ TestList [ testReadWriteArchive+main = withTempDirectory "." "test-zip-archive." $ \tmpDir -> do+#ifndef _WINDOWS+ ec <- catch (rawSystem "command" ["-v", "unzip"])+ (\(_ :: SomeException) -> rawSystem "which" ["unzip"])+ let unzipInPath = ec == ExitSuccess+ unless unzipInPath $+ putStrLn "\n\nunzip is not in path; skipping testArchiveAndUnzip\n"+#endif+ res <- runTestTT $ TestList $ map (\f -> f tmpDir) $+ [ testReadWriteArchive , testReadExternalZip , 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 ]- removeDirectoryRecursive "test-temp"- exitWith $ case errors res of+#ifndef _WINDOWS+ ++ [testArchiveAndUnzip | unzipInPath]+#endif+ exitWith $ case (failures res + errors res) of 0 -> ExitSuccess n -> ExitFailure n -testReadWriteArchive :: Test-testReadWriteArchive = TestCase $ do+testReadWriteArchive :: FilePath -> Test+testReadWriteArchive tmpDir = TestCase $ do archive <- addFilesToArchive [OptRecursive] emptyArchive ["LICENSE", "src"]- B.writeFile "test-temp/test1.zip" $ fromArchive archive- archive' <- toArchive <$> B.readFile "test-temp/test1.zip"+ BL.writeFile (tmpDir </> "test1.zip") $ fromArchive archive+ archive' <- toArchive <$> BL.readFile (tmpDir </> "test1.zip") assertEqual "for writing and reading test1.zip" archive archive' assertEqual "for writing and reading test1.zip" archive archive' -testReadExternalZip :: Test-testReadExternalZip = TestCase $ do- _ <- runCommand "/usr/bin/zip -q -9 test-temp/test4.zip zip-archive.cabal src/Codec/Archive/Zip.hs" >>= waitForProcess- archive <- toArchive <$> B.readFile "test-temp/test4.zip"+testReadExternalZip :: FilePath -> Test+testReadExternalZip _tmpDir = TestCase $ do+ archive <- toArchive <$> BL.readFile "tests/test4.zip" let files = filesInArchive archive- assertEqual "for results of filesInArchive" ["zip-archive.cabal", "src/Codec/Archive/Zip.hs"] files- cabalContents <- B.readFile "zip-archive.cabal"- case findEntryByPath "zip-archive.cabal" archive of - Nothing -> assertFailure "zip-archive.cabal not found in archive"- Just f -> assertEqual "for contents of zip-archive.cabal in archive" cabalContents (fromEntry f)+ assertEqual "for results of filesInArchive"+ ["test4/","test4/a.txt","test4/b.bin","test4/c/",+ "test4/c/with spaces.txt"] files+ bContents <- BL.readFile "tests/test4/b.bin"+ case findEntryByPath "test4/b.bin" archive of+ Nothing -> assertFailure "test4/b.bin not found in archive"+ Just f -> do+ assertEqual "for text4/b.bin file entry"+ NoEncryption (eEncryptionMethod f)+ assertEqual "for contents of test4/b.bin in archive"+ bContents (fromEntry f)+ case findEntryByPath "test4/" archive of+ Nothing -> assertFailure "test4/ not found in archive"+ Just f -> assertEqual "for contents of test4/ in archive"+ BL.empty (fromEntry f) -testFromToArchive :: Test-testFromToArchive = TestCase $ do- archive <- addFilesToArchive [OptRecursive] emptyArchive ["LICENSE", "src"]- assertEqual "for (toArchive $ fromArchive archive)" archive (toArchive $ fromArchive archive)+testFromToArchive :: FilePath -> Test+testFromToArchive tmpDir = TestCase $ do+ archive1 <- addFilesToArchive [OptRecursive] emptyArchive ["LICENSE", "src"]+ assertEqual "for (toArchive $ fromArchive archive)" archive1 (toArchive $ fromArchive archive1)+#ifndef _WINDOWS+ testDir <- createTestDirectoryWithSymlinks tmpDir "test_dir_with_symlinks"+ archive2 <- addFilesToArchive [OptRecursive, OptPreserveSymbolicLinks] emptyArchive [testDir]+ assertEqual "for (toArchive $ fromArchive archive)" archive2 (toArchive $ fromArchive archive2)+#endif -testReadWriteEntry :: Test-testReadWriteEntry = TestCase $ do+testReadWriteEntry :: FilePath -> Test+testReadWriteEntry tmpDir = TestCase $ do entry <- readEntry [] "zip-archive.cabal"- setCurrentDirectory "test-temp"+ setCurrentDirectory tmpDir writeEntry [] entry setCurrentDirectory ".."- entry' <- readEntry [] "test-temp/zip-archive.cabal"+ entry' <- readEntry [] (tmpDir </> "zip-archive.cabal") let entry'' = entry' { eRelativePath = eRelativePath entry, eLastModified = eLastModified entry } assertEqual "for readEntry -> writeEntry -> readEntry" entry entry'' -testAddFilesOptions :: Test-testAddFilesOptions = TestCase $ do+testAddFilesOptions :: FilePath -> Test+testAddFilesOptions tmpDir = TestCase $ do archive1 <- addFilesToArchive [OptVerbose] emptyArchive ["LICENSE", "src"] archive2 <- addFilesToArchive [OptRecursive, OptVerbose] archive1 ["LICENSE", "src"] assertBool "for recursive and nonrecursive addFilesToArchive" (length (filesInArchive archive1) < length (filesInArchive archive2))+#ifndef _WINDOWS+ testDir <- createTestDirectoryWithSymlinks tmpDir "test_dir_with_symlinks2"+ archive3 <- addFilesToArchive [OptVerbose, OptRecursive] emptyArchive [testDir]+ archive4 <- addFilesToArchive [OptVerbose, OptRecursive, OptPreserveSymbolicLinks] emptyArchive [testDir]+ mapM_ putStrLn $ filesInArchive archive3+ mapM_ putStrLn $ filesInArchive archive4+ assertBool "for recursive and recursive by preserving symlinks addFilesToArchive"+ (length (filesInArchive archive4) < length (filesInArchive archive3))+#endif -testDeleteEntries :: Test-testDeleteEntries = TestCase $ do++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"] let archive2 = deleteEntryFromArchive "LICENSE" archive1 let archive3 = deleteEntryFromArchive "src" archive2 assertEqual "for deleteFilesFromArchive" emptyArchive archive3 -testExtractFiles :: Test-testExtractFiles = TestCase $ do- createDirectory "test-temp/dir1"- createDirectory "test-temp/dir1/dir2"+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"+ result <- try $ extractFilesFromArchive [] archive :: IO (Either ZipException ())+ case result of+ Left err -> assertBool "Wrong exception" $ err == UnsafePath "../evil"+ Right _ -> assertFailure "extractFilesFromArchive should have failed"++testExtractFiles :: FilePath -> Test+testExtractFiles tmpDir = TestCase $ do+ createDirectory (tmpDir </> "dir1")+ createDirectory (tmpDir </> "dir1/dir2")+ let hiMsg = BS.pack "hello there"+ let helloMsg = BS.pack "Hello there. This file is very long. Longer than 31 characters."+ BS.writeFile (tmpDir </> "dir1/hi") hiMsg+ BS.writeFile (tmpDir </> "dir1/dir2/hello") helloMsg+ archive <- addFilesToArchive [OptRecursive] emptyArchive [(tmpDir </> "dir1")]+ removeDirectoryRecursive (tmpDir </> "dir1")+ extractFilesFromArchive [OptVerbose] archive+ hi <- BS.readFile (tmpDir </> "dir1/hi")+ hello <- BS.readFile (tmpDir </> "dir1/dir2/hello")+ assertEqual ("contents of " </> tmpDir </> "dir1/hi") hiMsg hi+ assertEqual ("contents of " </> tmpDir </> "dir1/dir2/hello") helloMsg hello++testExtractFilesFailOnEncrypted :: FilePath -> Test+testExtractFilesFailOnEncrypted tmpDir = TestCase $ do+ let dir = tmpDir </> "fail-encrypted"+ createDirectory dir++ archive <- toArchive <$> BL.readFile "tests/zip_with_password.zip"+ result <- try $ extractFilesFromArchive [OptDestination dir] archive :: IO (Either ZipException ())+ removeDirectoryRecursive dir++ case result of+ Left err -> assertBool "Wrong exception" $ err == CannotWriteEncryptedEntry "test.txt"+ Right _ -> assertFailure "extractFilesFromArchive should have failed"++testPasswordProtectedRead :: FilePath -> Test+testPasswordProtectedRead _tmpDir = TestCase $ do+ archive <- toArchive <$> BL.readFile "tests/zip_with_password.zip"++ assertEqual "for results of filesInArchive" ["test.txt"] (filesInArchive archive)+ case findEntryByPath "test.txt" archive of+ Nothing -> assertFailure "test.txt not found in archive"+ Just f -> do+ assertBool "for encrypted test.txt file entry"+ (isEncryptedEntry f)+ 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"+ case findEntryByPath "test.txt" archive of+ Nothing -> assertFailure "test.txt not found in archive"+ Just f -> do+ assertEqual "for contents of test.txt in archive"+ Nothing (fromEncryptedEntry "INCORRECT" f)++#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") let hiMsg = "hello there"- let helloMsg = "Hello there. This file is very long. Longer than 31 characters."- writeFile "test-temp/dir1/hi" hiMsg- writeFile "test-temp/dir1/dir2/hello" helloMsg- archive <- addFilesToArchive [OptRecursive] emptyArchive ["test-temp/dir1"]- removeDirectoryRecursive "test-temp/dir1"+ writeFile (tmpDir </> "dir3/hi") hiMsg+ let perms = unionFileModes ownerReadMode $ unionFileModes ownerWriteMode ownerExecuteMode+ setFileMode (tmpDir </> "dir3/hi") perms+ archive <- addFilesToArchive [OptRecursive] emptyArchive [(tmpDir </> "dir3")]+ removeDirectoryRecursive (tmpDir </> "dir3") extractFilesFromArchive [OptVerbose] archive- hi <- readFile "test-temp/dir1/hi"- hello <- readFile "test-temp/dir1/dir2/hello"- assertEqual "contents of test-temp/dir1/hi" hiMsg hi- assertEqual "contents of test-temp/dir1/dir2/hello" helloMsg hello+ hi <- readFile (tmpDir </> "dir3/hi")+ fm <- fmap fileMode $ getFileStatus (tmpDir </> "dir3/hi")+ assertEqual "file modes" perms (intersectFileModes perms fm)+ assertEqual ("contents of " </> tmpDir </> "dir3/hi") hiMsg hi +testArchiveExtractSymlinks :: FilePath -> Test+testArchiveExtractSymlinks tmpDir = TestCase $ do+ testDir <- createTestDirectoryWithSymlinks tmpDir "test_dir_with_symlinks3"+ let locationDir = "location_dir"+ archive <- addFilesToArchive [OptRecursive, OptPreserveSymbolicLinks, OptLocation locationDir True] emptyArchive [testDir]+ removeDirectoryRecursive testDir+ let destination = "test_dest"+ extractFilesFromArchive [OptPreserveSymbolicLinks, OptDestination destination] archive+ isDirSymlink <- pathIsSymbolicLink (destination </> locationDir </> testDir </> "link_to_directory")+ isFileSymlink <- pathIsSymbolicLink (destination </> locationDir </> testDir </> "link_to_file")+ assertBool "Symbolic link to directory is preserved" isDirSymlink+ assertBool "Symbolic link to file is preserved" isFileSymlink+ removeDirectoryRecursive destination++testExtractExternalZipWithSymlinks :: FilePath -> Test+testExtractExternalZipWithSymlinks tmpDir = TestCase $ do+ archive <- toArchive <$> BL.readFile "tests/zip_with_symlinks.zip"+ extractFilesFromArchive [OptPreserveSymbolicLinks, OptDestination tmpDir] archive+ let zipRootDir = "zip_test_dir_with_symlinks"+ symlinkDir = tmpDir </> zipRootDir </> "symlink_to_dir_1"+ symlinkFile = tmpDir </> zipRootDir </> "symlink_to_file_1"+ isDirSymlink <- pathIsSymbolicLink symlinkDir+ targetDirExists <- doesDirectoryExist symlinkDir+ isFileSymlink <- pathIsSymbolicLink symlinkFile+ targetFileExists <- doesFileExist symlinkFile+ assertBool "Symbolic link to directory is preserved" isDirSymlink+ assertBool "Target directory exists" targetDirExists+ assertBool "Symbolic link to file is preserved" isFileSymlink+ assertBool "Target file exists" targetFileExists+ removeDirectoryRecursive tmpDir++testExtractOverwriteExternalZipWithSymlinks :: FilePath -> Test+testExtractOverwriteExternalZipWithSymlinks tmpDir = TestCase $ do+ archive <- toArchive <$> BL.readFile "tests/zip_with_symlinks.zip"+ extractFilesFromArchive [OptPreserveSymbolicLinks, OptDestination tmpDir] archive+ asserts+ extractFilesFromArchive [OptPreserveSymbolicLinks, OptDestination tmpDir] archive+ asserts+ where+ zipRootDir = "zip_test_dir_with_symlinks"+ symlinkDir = tmpDir </> zipRootDir </> "symlink_to_dir_1"+ symlinkFile = tmpDir </> zipRootDir </> "symlink_to_file_1"+ asserts = do+ isDirSymlink <- pathIsSymbolicLink symlinkDir+ targetDirExists <- doesDirectoryExist symlinkDir+ isFileSymlink <- pathIsSymbolicLink symlinkFile+ targetFileExists <- doesFileExist symlinkFile+ assertBool "Symbolic link to directory is preserved" isDirSymlink+ assertBool "Target directory exists" targetDirExists+ assertBool "Symbolic link to file is preserved" isFileSymlink+ assertBool "Target file exists" targetFileExists++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+ let dir = "test_dir_with_symlinks4"+ testDir <- createTestDirectoryWithSymlinks tmpDir dir+ archive <- addFilesToArchive [OptRecursive, OptPreserveSymbolicLinks] emptyArchive [testDir]+ removeDirectoryRecursive testDir+ let zipFile = tmpDir </> "testUnzip.zip"+ BL.writeFile zipFile $ fromArchive archive+ ec <- rawSystem "unzip" [zipFile]+ assertBool "unzip succeeds" $ ec == ExitSuccess+ let symlinkDir = testDir </> "link_to_directory"+ symlinkFile = testDir </> "link_to_file"+ isDirSymlink <- pathIsSymbolicLink symlinkDir+ targetDirExists <- doesDirectoryExist symlinkDir+ isFileSymlink <- pathIsSymbolicLink symlinkFile+ targetFileExists <- doesFileExist symlinkFile+ assertBool "Symbolic link to directory is preserved" isDirSymlink+ assertBool "Target directory exists" targetDirExists+ assertBool "Symbolic link to file is preserved" isFileSymlink+ assertBool "Target file exists" targetFileExists+ removeDirectoryRecursive tmpDir++#endif
+ tests/test4.zip view
binary file changed (absent → 842 bytes)
+ tests/test4/a.txt view
@@ -0,0 +1,1 @@+Hello, this is a test!
+ tests/test4/b.bin view
@@ -0,0 +1,1 @@+ðã¿ölÑ«>Ô0Ø^ÌÔÚªñ@¬ ùÿ
+ tests/test4/c/with spaces.txt view
@@ -0,0 +1,1 @@+Another file.
+ tests/zip_with_evil_path.zip view
binary file changed (absent → 112 bytes)
+ tests/zip_with_password.zip view
binary file changed (absent → 202 bytes)
+ tests/zip_with_symlinks.zip view
binary file changed (absent → 1042 bytes)
zip-archive.cabal view
@@ -1,63 +1,107 @@ Name: zip-archive-Version: 0.1.4-Cabal-Version: >= 1.10+Version: 0.5+Cabal-Version: 2.0 Build-type: Simple Synopsis: Library for creating and modifying zip archives.-Description: The zip-archive library provides functions for creating, modifying,- and extracting files from zip archives.+Description:+ The zip-archive library provides functions for creating, modifying, and+ extracting files from zip archives. The zip archive format is+ documented in <http://www.pkware.com/documents/casestudies/APPNOTE.TXT>.+ .+ Certain simplifying assumptions are made about the zip archives: in+ particular, there is no support for strong encryption, zip files that+ span multiple disks, ZIP64, OS-specific file attributes, or compression+ methods other than Deflate. However, the library should be able to read+ the most common zip archives, and the archives it produces should be+ readable by all standard unzip programs.+ .+ Archives are built and extracted in memory, so manipulating large zip+ files will consume a lot of memory. If you work with large zip files or+ need features not supported by this library, a better choice may be+ <http://hackage.haskell.org/package/zip zip>, which uses a+ memory-efficient streaming approach. However, zip can only read and+ write archives inside instances of MonadIO, so zip-archive is a better+ 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+ extractor is provided in the source distribution. Category: Codec License: BSD3 License-file: LICENSE Homepage: http://github.com/jgm/zip-archive Author: John MacFarlane Maintainer: jgm@berkeley.edu-Build-Depends: base+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 splitBase- Description: Choose the new, smaller, split-up base package.- Default: True flag executable Description: Build the Zip executable. Default: False Library- if flag(splitBase)- Build-depends: base >= 3 && < 5, pretty, containers- else- Build-depends: base < 3- Build-depends: binary >= 0.5, zlib, filepath, bytestring >= 0.9.0, array, mtl, utf8-string >= 0.3.1, old-time, digest >= 0.0.0.1, directory, time+ Build-depends: base >= 4.11 && < 5,+ containers,+ binary >= 0.7.2,+ zlib,+ filepath,+ array,+ 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- Default-Extensions: CPP if os(windows) cpp-options: -D_WINDOWS else Build-depends: unix -Executable Zip+Executable zip-archive if flag(executable) Buildable: True else Buildable: False- Main-is: Zip.hs+ Main-is: Main.hs Hs-Source-Dirs: .- Build-Depends: base >= 4.2 && < 5, directory >= 1.1, bytestring >= 0.9.0,+ 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.2 && < 5,- directory, bytestring >= 0.9.0, process, time, old-time,- HUnit, zip-archive- Default-Language: Haskell98+ Build-Depends: base >= 4.5 && < 5,+ 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+ else+ Build-depends: unix