diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,26 @@ +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). diff --git a/src/Codec/Archive/Zip.hs b/src/Codec/Archive/Zip.hs --- a/src/Codec/Archive/Zip.hs +++ b/src/Codec/Archive/Zip.hs @@ -90,11 +90,9 @@ import System.IO ( stderr, hPutStrLn ) import qualified Data.Digest.CRC32 as CRC32 import qualified Data.Map as M -#if MIN_VERSION_binary(0,6,0) import Control.Applicative -#endif #ifndef _WINDOWS -import System.Posix.Files ( setFileTimes, setFileMode, fileMode, getSymbolicLinkStatus, symbolicLinkMode, readSymbolicLink, isSymbolicLink, unionFileModes, createSymbolicLink ) +import System.Posix.Files ( setFileTimes, setFileMode, fileMode, getSymbolicLinkStatus, symbolicLinkMode, readSymbolicLink, isSymbolicLink, unionFileModes, createSymbolicLink, removeLink ) import System.Posix.Types ( CMode(..) ) import Data.List (partition) import Data.Maybe (fromJust) @@ -111,8 +109,8 @@ -- from zlib import qualified Codec.Compression.Zlib.Raw as Zlib +import System.IO.Error (isAlreadyExistsError) -#if !MIN_VERSION_binary(0, 6, 0) manySig :: Word32 -> Get a -> Get [a] manySig sig p = do sig' <- lookAhead getWord32le @@ -122,7 +120,6 @@ rs <- manySig sig p return $ r : rs else return [] -#endif ------------------------------------------------------------------------ @@ -335,13 +332,32 @@ when (OptVerbose `elem` opts) $ do let compmethod = case eCompressionMethod entryE of - Deflate -> "deflated" + Deflate -> ("deflated" :: String) NoCompression -> "stored" hPutStrLn stderr $ printf " adding: %s (%s %.f%%)" (eRelativePath entryE) compmethod (100 - (100 * compressionRatio entryE)) return entryE +-- check path, resolving .. and . components, raising +-- UnsafePath exception if this takes you outside of the root. +checkPath :: FilePath -> IO () +checkPath fp = + maybe (E.throwIO (UnsafePath fp)) (\_ -> return ()) + (resolve . splitDirectories $ fp) + 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) + -- | 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. @@ -350,15 +366,11 @@ when (isEncryptedEntry entry) $ E.throwIO $ CannotWriteEncryptedEntry (eRelativePath entry) let relpath = eRelativePath entry - let isUnsafePath = ".." `elem` splitDirectories relpath - when isUnsafePath $ - E.throwIO $ UnsafePath relpath + checkPath relpath path <- case [d | OptDestination d <- opts] of - (x:_) -> return (x relpath) - _ | isAbsolute relpath - -> E.throwIO $ UnsafePath relpath - | otherwise - -> return relpath + (x:_) -> return (x relpath) + [] | isAbsolute relpath -> E.throwIO $ UnsafePath relpath + | otherwise -> return relpath -- create directories if needed let dir = takeDirectory path exists <- doesDirectoryExist dir @@ -405,10 +417,18 @@ let symlinkPath = prefixPath eRelativePath entry when (OptVerbose `elem` opts) $ do hPutStrLn stderr $ "linking " ++ symlinkPath ++ " to " ++ targetPath - createSymbolicLink targetPath symlinkPath + forceSymLink targetPath symlinkPath else writeEntry opts entry +-- | 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 @@ -467,7 +487,13 @@ normalizePath path = let dir = takeDirectory path fn = takeFileName path - (_drive, dir') = splitDrive dir + 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 = filter (/=".") $ splitDirectories dir' in intercalate "/" (dirParts ++ [fn]) @@ -661,15 +687,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" @@ -776,7 +796,6 @@ return (fromIntegral offset, compressedData) getWordsTilSig :: Word32 -> Get B.ByteString -#if MIN_VERSION_binary(0, 6, 0) getWordsTilSig sig = (B.fromChunks . reverse) `fmap` go Nothing [] where sig' = S.pack [fromIntegral $ sig .&. 0xFF, @@ -824,17 +843,6 @@ where len = S.length chunk prefixes' = Just $ (S.index chunk (len - 3), S.index chunk (len - 2), S.index chunk (len - 1)) -#else -getWordsTilSig sig = B.pack `fmap` go [] - where - go acc = do - sig' <- lookAhead getWord32le - if sig == sig' - then skip 4 >> return (reverse acc) - else do - w <- getWord8 - go (w:acc) -#endif putLocalFile :: Entry -> Put putLocalFile f = do @@ -974,22 +982,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 () diff --git a/tests/test-zip-archive.hs b/tests/test-zip-archive.hs --- a/tests/test-zip-archive.hs +++ b/tests/test-zip-archive.hs @@ -4,7 +4,6 @@ -- runghc Test.hs import Codec.Archive.Zip -import Control.Applicative import Control.Monad (unless) import Control.Exception (try) import System.Directory hiding (isSymbolicLink) @@ -73,6 +72,7 @@ , testExtractFilesWithPosixAttrs , testArchiveExtractSymlinks , testExtractExternalZipWithSymlinks + , testExtractOverwriteExternalZipWithSymlinks #endif ] #ifndef _WINDOWS @@ -260,6 +260,27 @@ 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 testArchiveAndUnzip :: FilePath -> Test testArchiveAndUnzip tmpDir = TestCase $ do diff --git a/zip-archive.cabal b/zip-archive.cabal --- a/zip-archive.cabal +++ b/zip-archive.cabal @@ -1,5 +1,5 @@ Name: zip-archive -Version: 0.4.1 +Version: 0.4.2 Cabal-Version: 2.0 Build-type: Simple Synopsis: Library for creating and modifying zip archives. @@ -26,8 +26,8 @@ As an example of the use of the library, a standalone zip archiver and extracter is provided in the source distribution. Category: Codec -Tested-with: GHC == 7.8.2, GHC == 7.10.3, GHC == 8.0.2, - GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1 +Tested-with: GHC == 8.6.5, GHC == 8.8.1, GHC == 8.10.4, GHC == 9.0.1, + GHC == 8.8.3, GHC == 9.2.1 License: BSD3 License-file: LICENSE Homepage: http://github.com/jgm/zip-archive @@ -52,7 +52,7 @@ Default: False Library - Build-depends: base >= 3 && < 5, + Build-depends: base >= 4.5 && < 5, pretty, containers, binary >= 0.6, @@ -81,7 +81,7 @@ Buildable: False Main-is: Main.hs Hs-Source-Dirs: . - Build-Depends: base >= 4.2 && < 5, + Build-Depends: base >= 4.5 && < 5, directory >= 1.1, bytestring >= 0.9.0, zip-archive @@ -94,7 +94,7 @@ Type: exitcode-stdio-1.0 Main-Is: test-zip-archive.hs Hs-Source-Dirs: tests - Build-Depends: base >= 4.2 && < 5, + Build-Depends: base >= 4.5 && < 5, directory >= 1.3, bytestring >= 0.9.0, process, time, HUnit, zip-archive, temporary, filepath Default-Language: Haskell98 @@ -103,4 +103,3 @@ cpp-options: -D_WINDOWS else Build-depends: unix - build-tools: unzip