diff --git a/Codec/Archive/LibZip.hs b/Codec/Archive/LibZip.hs --- a/Codec/Archive/LibZip.hs +++ b/Codec/Archive/LibZip.hs @@ -62,14 +62,16 @@ , Entry , ZipStat(..) -- * Archive operations - , withArchive, getZip + , withArchive, withEncryptedArchive, getZip , numFiles, fileName, nameLocate, fileNames , fileSize, fileSizeIx , fileStat, fileStatIx , deleteFile, deleteFileIx , renameFile, renameFileIx - , addFile, addDirectory + , addFile, addFileWithFlags + , addDirectory, addDirectoryWithFlags , replaceFile, replaceFileIx + , setFileCompression, setFileCompressionIx , sourceBuffer, sourceFile, sourceZip , PureSource(..), sourcePure , getComment, setComment, removeComment @@ -105,7 +107,7 @@ import Control.Monad.State.Strict (StateT(..), MonadState(..), MonadTrans(..), lift, liftM) import Foreign.C.Error (Errno(..), eINVAL) -import Foreign.C.String (withCString, withCStringLen, peekCString) +import Foreign.C.String (withCString, peekCString) import Foreign.C.Types (CInt, CULLong) import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Array (allocaArray, peekArray, withArrayLen, pokeArray) @@ -113,6 +115,8 @@ import Foreign.Ptr (Ptr, nullPtr, castPtr) import Foreign.Storable (Storable, peek, poke, pokeElemOff, sizeOf) import qualified Control.Exception as E +import qualified Data.ByteString as BS +import qualified Data.ByteString.UTF8 as UTF8 -- -- Types @@ -145,21 +149,51 @@ c'zip_open path' (combine flags) errp >>= \z -> if z == nullPtr then peek errp >>= E.throwIO. errFromCInt - else do + else withOpenArchive z action + + +-- | Top-level wrapper for operations with an open encrypted archive. +-- 'withEncryptedArchive' opens and closes the file automatically. +-- On error it throws 'ZipError'. +withEncryptedArchive :: [OpenFlag] -- ^ Checks for consistency or existence. + -> String -- ^ Encryption password. + -> FilePath -- ^ Filename of the zip archive. + -> Archive a -- ^ Action to don with the archive. + -> IO a +withEncryptedArchive flags password path action = + withCString password $ \password' -> + withCString path $ \path' -> + alloca $ \errp -> + c'zip_open path' (combine flags) errp >>= \z -> + if z == nullPtr + then peek errp >>= E.throwIO. errFromCInt + else do + r <- c'zip_set_default_password z password' + if r /= 0 + then get_error z >>= E.throwIO + else withOpenArchive z action + + +withOpenArchive :: Zip -> Archive a -> IO a +withOpenArchive z action = do r <- fst `liftM` runStateT action z e <- c'zip_close z if e /= 0 then get_error z >>= E.throwIO else return r + -- | Get the number of entries in the archive. -numFiles :: [FileFlag] -> Archive Integer +numFiles :: [FileFlag] -- ^ 'FileUNCHANGED' can be used to return + -- the original unchanged number of entries. + -> Archive Integer numFiles flags = do z <- getZip lift $ fromIntegral `liftM` c'zip_get_num_entries z (combine flags) -- | Get name of an entry in the archive by its index. -fileName :: [FileFlag] -- ^ 'FileUNCHANGED' flag can be used. +fileName :: [FileFlag] -- ^ 'FileUNCHANGED' flag can be used to + -- return the original unchanged filename. -> Integer -- ^ Position index of a file in the archive. -> Archive FilePath -- ^ Name of the file in the archive. fileName flags i = do @@ -169,7 +203,19 @@ doIf' (n /= nullPtr) z $ peekCString n -- | Locate an entry (get its index) in the archive by its name. -nameLocate :: [FileFlag] -- ^ Filename lookup mode. +nameLocate :: [FileFlag] + -- ^ Filename lookup mode. + -- 'FileNOCASE': ignore case distinctions (only for ASCII). + -- 'FileNODIR': ignore directory part of the file name. + -- 'FileENC_RAW': compare against unmodified names as it is + -- in the ZIP archive. + -- 'FileENC_GUESS': (default) guess encoding of the name in + -- the ZIP archive and convert it to UTF-8, + -- if necessary. + -- 'FileENC_STRICT': follow the ZIP specification and expect + -- CP-437 encoded names in the ZIP archive + -- (except if they are explicitly marked as + -- UTF-8). Convert it to UTF-8 before comparing. -> FilePath -- ^ Name of the file in the archive. -> Archive (Maybe Integer) -- ^ 'Just' position index if found. nameLocate flags name = do @@ -225,7 +271,7 @@ doIf' (r == 0) z $ toZipStat =<< peek stat -- | Delete file from the archive. -deleteFile :: [FileFlag] -- ^ Filename lookup mode. +deleteFile :: [FileFlag] -- ^ Filename lookup mode (see 'nameLocate'). -> FilePath -- ^ Filename. -> Archive () deleteFile flags name = do @@ -243,21 +289,28 @@ else lift $ get_error z >>= E.throwIO -- | Rename file in the archive. -renameFile :: [FileFlag] -- ^ Filename lookup mode. +renameFile :: [FileFlag] -- ^ Filename lookup mode (see 'nameLocate'). -> FilePath -- ^ Old name. -> FilePath -- ^ New name. -> Archive () renameFile flags oldname newname = do mbi <- nameLocate flags oldname - maybe (lift $ E.throwIO ErrNOENT) (\i -> renameFileIx i newname) mbi + maybe (lift $ E.throwIO ErrNOENT) + (\i -> renameFileIx i (UTF8.fromString newname) [FileENC_UTF_8]) + mbi -- | Rename file (referenced by position index) in the archive. -renameFileIx :: Integer -- ^ Position index of a file in the archive. - -> FilePath -- ^ New name. +renameFileIx :: Integer -- ^ Position index of a file in the archive. + -> BS.ByteString -- ^ New name. + -> [FileFlag] -- ^ Name encoding flags. + -- 'FileENC_GUESS': guess encoding of the name (default). + -- 'FileENC_UTF_8': interpret name as UTF-8. + -- 'FileENC_CP437': interpret name as CP-437. -> Archive () -renameFileIx i newname = do +renameFileIx i newname flags = do z <- getZip - r <- lift $ withCString newname $ c'zip_rename z (fromIntegral i) + r <- lift $ BS.useAsCString newname $ \s -> + c'zip_file_rename z (fromIntegral i) s (combine flags) if r == 0 then return () else lift $ get_error z >>= E.throwIO @@ -266,10 +319,21 @@ addFile :: FilePath -- ^ Name of the file to create. -> ZipSource -- ^ Source where file data is obtained from. -> Archive Int -- ^ Position index of the new file. -addFile name src = do +addFile name src = + let utf8name = UTF8.fromString name + in addFileWithFlags [FileENC_UTF_8] utf8name src + +addFileWithFlags + :: [FileFlag] -- ^ Can be a combination of 'FileOVERWRITE' and/or one of + -- filename encoding flags: 'FileENC_GUESS' (default), + -- 'FileENC_UTF_8', 'FileENC_CP437'. + -> BS.ByteString -- ^ Name of the file to create. + -> ZipSource -- ^ Source where file data is obtained from. + -> Archive Int -- ^ Position index of the new file. +addFileWithFlags flags namebytes src = do z <- getZip - lift $ withCString name $ \name' -> do - i <- c'zip_add z name' src + lift $ BS.useAsCString namebytes $ \name' -> do + i <- c'zip_file_add z name' src (combine flags) if i < 0 then c'zip_source_free src >> get_error z >>= E.throwIO else return $ fromIntegral i @@ -277,15 +341,26 @@ -- | Add a directory to the archive. addDirectory :: FilePath -- ^ Directory's name in the archive. -> Archive Int -- ^ Position index of the new directory entry. -addDirectory name = do +addDirectory name = + let utf8name = UTF8.fromString name + in addDirectoryWithFlags [FileENC_UTF_8] utf8name + +-- | Add a directory to the archive. +addDirectoryWithFlags + :: [FileFlag] -- ^ Can be one of filename encoding flags: + -- 'FileENC_GUESS (default), 'FileENC_UTF_8', 'FileENC_CP437'. + -> BS.ByteString -- ^ Directory's name in the archive. + -> Archive Int -- ^ Position index of the new directory entry. +addDirectoryWithFlags flags name = do z <- getZip - r <- lift $ withCString name $ c'zip_add_dir z + r <- lift $ BS.useAsCString name $ + \name'-> c'zip_dir_add z name' (combine flags) if r < 0 then lift $ get_error z >>= E.throwIO else return (fromIntegral r) -- | Replace a file in the archive. -replaceFile :: [FileFlag] -- ^ Filename lookup mode. +replaceFile :: [FileFlag] -- ^ Filename lookup mode (see 'nameLocate'). -> FilePath -- ^ File to replace. -> ZipSource -- ^ Source where the new file data is obtained from. -> Archive () @@ -294,6 +369,33 @@ maybe (lift $ c'zip_source_free src >> E.throwIO ErrNOENT) (\i -> replaceFileIx i src >> return ()) mbi +-- | Set compression method for a file in the archive. +setFileCompression + :: [FileFlag] -- ^ Filename lookup mode (see 'nameLocate'). + -> FilePath -- ^ Filename. + -> ZipCompMethod -- ^ Compression method. + -- As of libzip 0.11, the following methods are supported: + -- 'CompDEFAULT', 'CompSTORE', 'CompDEFLATE'. + -> Archive () +setFileCompression flags name method = do + mbi <- nameLocate flags name + maybe (lift $ E.throwIO ErrNOENT) (\i -> setFileCompressionIx i method) mbi + +-- | Set compression method for a file in the archive. +setFileCompressionIx + :: Integer -- ^ Position index of a file in the archive. + -> ZipCompMethod -- ^ Compression method. + -- As of libzip 0.11, the following methods are supported: + -- 'CompDEFAULT', 'CompSTORE', 'CompDEFLATE'. + -> Archive () +setFileCompressionIx i method = do + z <- getZip + lift $ do + r <- c'zip_set_file_compression z (fromIntegral i) (fromIntegral . fromEnum $ method) 0 + if r /= 0 + then get_error z >>= E.throwIO + else return () + -- | Replace a file in the archive (referenced by position index). replaceFileIx :: Integer -- ^ Position index of a file in the archive. -> ZipSource -- ^ Source where the new file data is obtained from @@ -301,7 +403,7 @@ replaceFileIx i src = do z <- getZip lift $ do - r <- c'zip_replace z (fromIntegral i) src + r <- c'zip_file_replace z (fromIntegral i) src 0 if r < 0 then c'zip_source_free src >> get_error z >>= E.throwIO else return () @@ -412,7 +514,8 @@ | otherwise = return (-1) -- | Get zip archive comment. -getComment :: [FileFlag] -- ^ 'FileUNCHANGED' can be used. +getComment :: [FileFlag] -- ^ Can be a combination of 'FileUNCHANGED' and/or + -- one of 'FileENC_GUESS' (default), 'FileENC_STRICT' (CP-437). -> Archive (Maybe String) getComment flags = do z <- getZip @@ -422,14 +525,15 @@ return (c,n) if c == nullPtr then return Nothing - else lift $ peekCString c >>= return . Just . take (fromIntegral n) + else lift $ BS.packCStringLen (c, fromIntegral n) >>= return . Just . UTF8.toString -- | Set zip archive comment. setComment :: String -- ^ Comment message. -> Archive () setComment msg = do z <- getZip - r <- lift $ withCStringLen msg $ \(msg',i') -> + let utf8msg = UTF8.fromString msg + r <- lift $ BS.useAsCStringLen utf8msg $ \(msg',i') -> c'zip_set_archive_comment z msg' (fromIntegral i') if r < 0 then lift $ get_error z >>= E.throwIO @@ -445,50 +549,75 @@ else return () -- | Get comment for a file in the archive. -getFileComment :: [FileFlag] -- ^ Filename lookup mode. +getFileComment :: [FileFlag] -- ^ Filename lookup mode (see 'nameLocate'). -> FilePath -- ^ Filename -> Archive (Maybe String) getFileComment flags name = do mbi <- nameLocate flags name - maybe (lift $ E.throwIO ErrNOENT) (getFileCommentIx flags) mbi + -- Backwards compatibility with LibZip < 0.11: FileUNCHANGED flag from + -- the filename lookup mode was used to get the original unchanged comment. + -- Please don't rely on this feature and use 'getFileCommentIx' instead. + let comment_flags = filter (== FileUNCHANGED) flags + maybe (lift $ E.throwIO ErrNOENT) + (\i -> do + mbs <- getFileCommentIx comment_flags i + -- 'FileENC_GUESS' is default => mbs is UTF-8 encoded + return $ liftM UTF8.toString mbs + ) mbi -- | Get comment for a file in the archive (referenced by position index). -getFileCommentIx :: [FileFlag] -- ^ FileUNCHANGED can be used. +getFileCommentIx :: [FileFlag] -- ^ Comment lookup flags. + -- 'FileUNCHANGED': return the original unchanged comment. + -- 'FileENC_RAW': return the unmodified commment as it is. + -- 'FileENC_GUESS': (default) guess the encoding of the comment + -- and convert it to UTF-8, if necessary. + -- 'FileENC_STRICT': follow the ZIP specification for file names + -- and extend it to file comments, expect + -- them to be encoded in CP-437. Convert it + -- to UTF-8. -> Integer -- ^ Position index of the file. - -> Archive (Maybe String) + -> Archive (Maybe BS.ByteString) getFileCommentIx flags i = do z <- getZip (c,n) <- lift $ alloca $ \lenp -> do - c <- c'zip_get_file_comment z (fromIntegral i) lenp (combine flags) + c <- c'zip_file_get_comment z (fromIntegral i) lenp (combine flags) n <- peek lenp return (c,n) if c == nullPtr then return Nothing - else lift $ peekCString c >>= return . Just . take (fromIntegral n) + else lift $ BS.packCStringLen (c,fromIntegral n) >>= return . Just -- | Set comment for a file in the archive. -setFileComment :: [FileFlag] -- ^ Name lookup mode. +setFileComment :: [FileFlag] -- ^ Filename lookup mode (see 'nameLocate'). -> FilePath -- ^ Filename. -> String -- ^ New file comment. -> Archive () setFileComment flags path comment = do mbi <- nameLocate flags path - maybe (lift $ E.throwIO ErrNOENT) (flip setFileCommentIx comment) mbi + let utf8comment = UTF8.fromString comment + let cflags = [FileENC_UTF_8] + maybe (lift $ E.throwIO ErrNOENT) + (\i -> setFileCommentIx i utf8comment cflags) + mbi -- | Set comment for a file in the archive (referenced by position index). -setFileCommentIx :: Integer -- ^ Position index of a file in the archive. - -> String -- ^ New file comment. +setFileCommentIx :: Integer -- ^ Position index of a file in the archive. + -> BS.ByteString -- ^ New file comment. + -> [FileFlag] -- ^ Comment encoding flags. + -- 'FileENC_GUESS': guess encoding of the comment (default). + -- 'FileENC_UTF_8': interpret comment as UTF-8. + -- 'FileENC_CP437': interpret comment as CP-437. -> Archive () -setFileCommentIx i comment = do +setFileCommentIx i comment cflags = do z <- getZip - r <- lift $ withCStringLen comment $ \(msg,len) -> - c'zip_set_file_comment z (fromIntegral i) msg (fromIntegral len) + r <- lift $ BS.useAsCStringLen comment $ \(msg,len) -> + c'zip_file_set_comment z (fromIntegral i) msg (fromIntegral len) (combine cflags) if r < 0 then lift $ get_error z >>= E.throwIO else return () -- | Remove comment for a file in the archive. -removeFileComment :: [FileFlag] -- ^ Filename lookup mode. +removeFileComment :: [FileFlag] -- ^ Filename lookup mode (see 'nameLocate'). -> FilePath -- ^ Filename. -> Archive () removeFileComment flags path = do @@ -499,14 +628,15 @@ removeFileCommentIx :: Integer -- ^ Position index of a file in the archive. -> Archive () removeFileCommentIx i = do + let flags = 0 -- file name encoding flags (*_FL_*) are irrelevant z <- getZip - r <- lift $ c'zip_set_file_comment z (fromIntegral i) nullPtr 0 + r <- lift $ c'zip_file_set_comment z (fromIntegral i) nullPtr 0 flags if r < 0 then lift $ get_error z >>= E.throwIO else return () -- | Undo changes to a file in the archive. -unchangeFile :: [FileFlag] -- ^ Filename lookup mode. +unchangeFile :: [FileFlag] -- ^ Filename lookup mode (see 'nameLocate'). -> FilePath -- ^ Filename. -> Archive () unchangeFile flags name = do diff --git a/Codec/Archive/LibZip/Types.hs b/Codec/Archive/LibZip/Types.hs --- a/Codec/Archive/LibZip/Types.hs +++ b/Codec/Archive/LibZip/Types.hs @@ -15,7 +15,7 @@ , ZipEncryptionMethod(..) , combine ) where - + import Data.Bits ((.|.)) import Data.Time (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) @@ -35,6 +35,7 @@ type ZipFile = Ptr C'zip_file -- | Handler of data source for new files in the zip archive. +-- Constructors: 'sourceBuffer', 'sourceFile', 'sourceZip', 'sourcePure'. type ZipSource = Ptr C'zip_source -- | File statistics expressed in native Haskell types. @@ -67,22 +68,25 @@ let flags = toEnum . fromIntegral $ c'zip_stat'flags s return $ ZipStat valid name idx size comp_size mtime crc comp_meth enc_meth flags - + -- | Flags for opening an archive. data OpenFlag = CreateFlag -- ^ Create an archive if it does not exist. | ExclFlag -- ^ Error if the archive already exists. | CheckConsFlag -- ^ Check archive's consistency and error on failure. + | TruncateFlag -- ^ If archive exists, ignore its current content. deriving (Show,Eq) instance Enum OpenFlag where fromEnum CheckConsFlag = c'ZIP_CHECKCONS fromEnum CreateFlag = c'ZIP_CREATE fromEnum ExclFlag = c'ZIP_EXCL + fromEnum TruncateFlag = c'ZIP_TRUNCATE toEnum x | x == c'ZIP_CHECKCONS = CheckConsFlag toEnum x | x == c'ZIP_CREATE = CreateFlag toEnum x | x == c'ZIP_EXCL = ExclFlag + toEnum x | x == c'ZIP_TRUNCATE = TruncateFlag toEnum _ = undefined -- | Flags for accessing files in the archive. @@ -94,6 +98,14 @@ | FileUNCHANGED -- ^ Read the original data, ignore changes. | FileRECOMPRESS -- ^ Force recompression of data. | FileENCRYPTED -- ^ Read encrypted data (implies FileCOMPRESSED). + | FileENC_GUESS -- ^ Guess string encoding (default). + | FileENC_RAW -- ^ Get unmodified string. + | FileENC_STRICT -- ^ Follow specification strictly. + | FileLOCAL -- ^ In local header. + | FileCENTRAL -- ^ In central directory. + | FileENC_UTF_8 -- ^ String is UTF-8 encoded. + | FileENC_CP437 -- ^ String is CP437 encoded. + | FileOVERWRITE -- ^ When adding files: if file name exists, overwrite. deriving (Show,Eq) instance Enum FileFlag where @@ -103,12 +115,28 @@ fromEnum FileRECOMPRESS = c'ZIP_FL_RECOMPRESS fromEnum FileUNCHANGED = c'ZIP_FL_UNCHANGED fromEnum FileENCRYPTED = c'ZIP_FL_ENCRYPTED + fromEnum FileENC_GUESS = c'ZIP_FL_ENC_GUESS + fromEnum FileENC_RAW = c'ZIP_FL_ENC_RAW + fromEnum FileENC_STRICT = c'ZIP_FL_ENC_STRICT + fromEnum FileLOCAL = c'ZIP_FL_LOCAL + fromEnum FileCENTRAL = c'ZIP_FL_CENTRAL + fromEnum FileENC_UTF_8 = c'ZIP_FL_ENC_UTF_8 + fromEnum FileENC_CP437 = c'ZIP_FL_ENC_CP437 + fromEnum FileOVERWRITE = c'ZIP_FL_OVERWRITE toEnum x | x == c'ZIP_FL_COMPRESSED = FileCOMPRESSED toEnum x | x == c'ZIP_FL_NOCASE = FileNOCASE toEnum x | x == c'ZIP_FL_NODIR = FileNODIR toEnum x | x == c'ZIP_FL_RECOMPRESS = FileRECOMPRESS toEnum x | x == c'ZIP_FL_UNCHANGED = FileUNCHANGED toEnum x | x == c'ZIP_FL_ENCRYPTED = FileENCRYPTED + toEnum x | x == c'ZIP_FL_ENC_GUESS = FileENC_GUESS + toEnum x | x == c'ZIP_FL_ENC_RAW = FileENC_RAW + toEnum x | x == c'ZIP_FL_ENC_STRICT = FileENC_STRICT + toEnum x | x == c'ZIP_FL_LOCAL = FileLOCAL + toEnum x | x == c'ZIP_FL_CENTRAL = FileCENTRAL + toEnum x | x == c'ZIP_FL_ENC_UTF_8 = FileENC_UTF_8 + toEnum x | x == c'ZIP_FL_ENC_CP437 = FileENC_CP437 + toEnum x | x == c'ZIP_FL_OVERWRITE = FileOVERWRITE toEnum _ = undefined @@ -127,11 +155,16 @@ -- | @libzip@ flags for compression and encryption sources -data CodecFlag = CodecENCODE deriving (Show, Eq) +data CodecFlag + = CodecENCODE + | CodecDECODE + deriving (Show, Eq) instance Enum CodecFlag where fromEnum CodecENCODE = c'ZIP_CODEC_ENCODE + fromEnum CodecDECODE = c'ZIP_CODEC_DECODE toEnum x | x == c'ZIP_CODEC_ENCODE = CodecENCODE + toEnum x | x == c'ZIP_CODEC_DECODE = CodecDECODE toEnum _ = undefined @@ -254,7 +287,7 @@ show ErrREMOVE = "Can't remove file" show ErrDELETED = "Entry has been deleted" show ErrENCRNOTSUPP = "Encryption method not supported" - show ErrRDONLY = "Read-only archive" + show ErrRDONLY = "Read-only archive" show ErrNOPASSWD = "No password provided" show ErrWRONGPASSWD = "Wrong password provided" @@ -334,4 +367,3 @@ combine :: (Enum a, Num b) => [a] -> b combine fs = fromIntegral . foldr (.|.) 0 $ map fromEnum fs - diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2009, 2010, Sergey Astanin +Copyright (c) 2009-2013, Sergey Astanin All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/LibZip.cabal b/LibZip.cabal --- a/LibZip.cabal +++ b/LibZip.cabal @@ -1,5 +1,5 @@ Name: LibZip -Version: 0.10.2 +Version: 0.11 License: BSD3 License-File: LICENSE Author: Sergey Astanin @@ -14,8 +14,7 @@ This package allows to use it from Haskell code. Build-Type: Simple -Cabal-Version: >= 1.2.3 -Tested-With: GHC == 7.4.1, GHC == 7.6.1 +Cabal-Version: >= 1.8 Extra-Source-Files: examples/hzip.hs @@ -30,10 +29,27 @@ Codec.Archive.LibZip.Errors Build-Depends: base >= 4.0 && < 5.0 - , bindings-libzip >= 0.10 && < 0.11 + , bindings-libzip >= 0.11 && < 0.12 , bytestring , filepath , time , mtl + , bytestring + , utf8-string GHC-Options: -Wall + +Test-Suite test-libzip + Type: exitcode-stdio-1.0 + Main-Is: runTests.hs + Build-Depends: + LibZip + , base >= 4.0 && < 5.0 + , bindings-libzip >= 0.11 && < 0.12 + , directory + , filepath + , HUnit + , mtl + , time + , bytestring + , utf8-string diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,20 +1,7 @@ #!/usr/bin/env runhaskell -> import Distribution.Simple -> import System.Cmd (system) -> import System.Exit (ExitCode(..)) -> import Distribution.PackageDescription (emptyHookedBuildInfo) -> -> main = defaultMainWithHooks simpleUserHooks -> { runTests = runUnitTests -> } -> +> module Main where > -> runUnitTests _ _ _ _ = -> system "runhaskell -lzip -fno-warn-warnings-deprecations runTests.hs" >>= -> onExit "\nSome tests did not pass." () +> import Distribution.Simple > -> onExit :: String -> a -> ExitCode -> IO a -> onExit errmsg okvalue r = -> case r of -> ExitSuccess -> return okvalue -> _ -> fail errmsg +> main :: IO () +> main = defaultMain diff --git a/Tests/Common.hs b/Tests/Common.hs --- a/Tests/Common.hs +++ b/Tests/Common.hs @@ -1,5 +1,5 @@ module Tests.Common - ( testzip, testfiles, lastfile, lastfilesize + ( testzip, encryptedzip, testfiles, lastfile, lastfilesize , world_txt , toUpper, toLower, map2 ) where @@ -7,6 +7,7 @@ import Data.Char (toUpper, toLower) testzip = "Tests/test.zip" +encryptedzip = "Tests/encrypted.zip" testfiles = [ "hello/", "hello/world.txt" ] lastfile = last testfiles lastfilesize = 71 :: Integer diff --git a/Tests/MonadicTests.hs b/Tests/MonadicTests.hs --- a/Tests/MonadicTests.hs +++ b/Tests/MonadicTests.hs @@ -8,45 +8,57 @@ import Foreign.Storable import Foreign.Ptr (Ptr, castPtr) +import Control.Monad (liftM2) import System.Directory (doesFileExist, getTemporaryDirectory, removeFile) import System.FilePath (()) +import System.IO (openFile, hClose, hFileSize, IOMode(..)) import Test.HUnit import qualified Control.Exception as E +import qualified Data.ByteString as BS +import qualified Data.ByteString.UTF8 as UTF8 monadicTests = TestList [ "read list of files" ~: do files <- withArchive [] testzip $ fileNames [] files @?= testfiles + , "read file size" ~: do sz <- withArchive [] testzip $ fileSize [] lastfile sz @?= lastfilesize + , "case-insensitive file names" ~: do sz <- withArchive [] testzip $ fileSize [FileNOCASE] (map2 toUpper toLower $ lastfile) sz @?= lastfilesize + , "open error if exists (with ExclFlag)" ~: do err <- catchZipError (withArchive [ExclFlag] testzip $ lift $ E.throwIO ErrOK) (return . id) err @?= ErrEXISTS + , "open error if archive does not exists" ~: do err <- catchZipError (withArchive [] "notexists.zip" $ return ErrOK) (return . id) err @?= ErrOPEN + , "read file" ~: do txt <- withArchive [] testzip $ fileContents [] lastfile txt @?= world_txt + , "read file by index" ~: do let i = toInteger (length testfiles - 1) txt <- withArchive [] testzip $ fileContentsIx [] i txt @?= world_txt + , "skipBytes/readBytes" ~: do txt <- withArchive [] testzip $ fromFile [] lastfile $ do skipBytes 13 readBytes 10 txt @?= (take 10 . drop 13 $ world_txt) + , "create an archive/use sourceBuffer" ~: do tmpzip <- getTmpFileName "test_LibZip_sourceBuffer.zip" i <- withArchive [CreateFlag] tmpzip $ do @@ -56,6 +68,21 @@ txt <- withArchive [] f $ fileContents [] "hello/world.txt" removeFile f (txt, i) @?= (world_txt, 1) + + , "create an archive with Unicode filenames" ~: do + tmpzip <- getTmpFileName "test_LibZip_unicode_filenames.zip" + let dir = "\x4e16\x754c" + let name1 = "\x4e16\x754c/привет.txt" + let name2 = "\x4e16\x754c/мир.txt" + i <- withArchive [CreateFlag] tmpzip $ do + addDirectory dir + addFile name1 =<< sourceBuffer world_txt + addFileWithFlags [FileENC_UTF_8] (UTF8.fromString name2) =<< sourceBuffer world_txt + tmpzip `doesExistAnd` \f -> do + names <- withArchive [] f $ fileNames [] + removeFile f + names @?= [dir ++ "/", name1, name2] + , "create an archive/use sourceFile" ~: do tmpzip <- getTmpFileName "test_LibZip_sourceFile.zip" tmpsrc <- getTmpFileName "test_LibZip_sourceFile.txt" @@ -67,6 +94,7 @@ removeFile tmpzip removeFile tmpsrc txt @?= world_txt + , "create an archive/use sourceZip" ~: do tmpzip <- getTmpFileName "test_LibZip_sourceZip.zip" withArchive [] testzip $ do @@ -77,6 +105,7 @@ txt <- withArchive [] f $ fileContents [] "world.txt" removeFile tmpzip txt @?= world_txt + , "create an archive/use sourcePure" ~: do tmpzip <- getTmpFileName "test_LibZip_sourcePure.zip" let src = PureSource @@ -94,6 +123,7 @@ txt <- withArchive [] f $ fileContents [] "world.txt" removeFile tmpzip txt @?= world_txt + , "delete a file" ~: do let orig = [("one", "one"), ("two", "two")] let final = init orig @@ -104,6 +134,7 @@ fs_final <- withArchive [] tmpzip $ fileNames [] removeFile tmpzip (fs_orig, fs_final) @?= (map fst orig, map fst final) + , "attempt to delete a non-existing file" ~: do tmpzip <- getTmpFileName "test_LibZip_delete_ne.zip" mkArchive tmpzip [("world.txt", world_txt)] @@ -117,6 +148,7 @@ (return . id) removeFile tmpzip (r1, r2) @?= (ErrNOENT, ErrINVAL) + , "rename a file" ~: do tmpzip <- getTmpFileName "test_LibZip_rename.zip" mkArchive tmpzip [("world.txt", world_txt)] @@ -125,6 +157,7 @@ fileNames [] removeFile tmpzip fs @?= ["hello.txt"] + , "attempt to rename a non-existing file" ~: do tmpzip <- getTmpFileName "test_LibZip_rename_ne.zip" mkArchive tmpzip [("world.txt", world_txt)] @@ -135,16 +168,21 @@ (return . id) removeFile tmpzip r @?= ErrNOENT - , "attempt to rename to an empty name" ~: do - tmpzip <- getTmpFileName "test_LibZip_rename_inval.zip" - mkArchive tmpzip [("world.txt", world_txt)] - r <- catchZipError - (withArchive [] tmpzip $ do - renameFile [] "world.txt" "" - return ErrOK) - (return . id) - removeFile tmpzip - r @?= ErrINVAL + + -- -- libzip 0.11 renames an entry to an empty string without errors; + -- the test is disabled. + -- + -- , "attempt to rename to an empty name" ~: do + -- tmpzip <- getTmpFileName "test_LibZip_rename_inval.zip" + -- mkArchive tmpzip [("world.txt", world_txt)] + -- r <- catchZipError + -- (withArchive [] tmpzip $ do + -- renameFile [] "world.txt" "" + -- return ErrOK) + -- (return . id) + -- removeFile tmpzip + -- r @?= ErrINVAL + , "replace a file" ~: do tmpzip <- getTmpFileName "test_LibZip_replace.zip" mkArchive tmpzip [("hello/",""), ("hello/world.txt", "old contents")] @@ -152,6 +190,39 @@ replaceFile [] "hello/world.txt" =<< sourceBuffer world_txt txt <- withArchive [] tmpzip $ fileContents [] "hello/world.txt" txt @?= world_txt + removeFile tmpzip + + , "set file compression method" ~: do + tmpzip1 <- getTmpFileName "test_LibZip_compression_DEFLATE.zip" + tmpzip2 <- getTmpFileName "test_LibZip_compression_some.zip" + tmpzip3 <- getTmpFileName "test_LibZip_compression_STORE.zip" + -- archive contents with high level of duplicity (compressibility) + let long_text = concat $ replicate 100 world_txt + let contents = [ ("hello.txt", long_text), ("world.txt", long_text) ] + -- all files are compressed + mkArchive tmpzip1 contents + withArchive [] tmpzip1 $ do + n <- numFiles [] + flip mapM_ [0..n-1] $ \i -> setFileCompressionIx i CompDEFLATE + -- only some files are compessed + mkArchive tmpzip2 contents + withArchive [] tmpzip2 $ do + setFileCompression [] "hello.txt" CompSTORE + setFileCompression [] "world.txt" CompDEFLATE + -- uncompressed archive + mkArchive tmpzip3 contents + withArchive [] tmpzip3 $ do + n <- numFiles [] + flip mapM_ [0..n-1] $ \i -> setFileCompressionIx i CompSTORE + -- compare file sizes + sz1 <- getFileSize tmpzip1 + sz2 <- getFileSize tmpzip2 + sz3 <- getFileSize tmpzip3 + removeFile tmpzip1 + removeFile tmpzip2 + removeFile tmpzip3 + (liftM2 (<) sz1 sz2, liftM2 (<) sz2 sz3) @?= (Just True, Just True) + , "set/get/remove archive comment" ~: do c1 <- withArchive [] testzip $ getComment [] tmpzip <- getTmpFileName "test_LibZip_comment.zip" @@ -163,7 +234,19 @@ withArchive [] tmpzip $ removeComment c2_removed <- withArchive [] tmpzip $ getComment [] removeFile tmpzip - (c1, c2, c2_added, c2_removed) @?= (Nothing, Nothing, Just com, Nothing) + -- libzip-0.11 returns an empty string, instead of NULL pointer in 0.10. + -- Haskell LibZip reflects it by returning Just "" rather than Nothing. + (c1, c2, c2_added, c2_removed) @?= (Just "", Just "", Just com, Just "") + + , "set/get Unicode archive comment" ~: do + tmpzip <- getTmpFileName "test_LibZip_Unicode_comment.zip" + mkArchive tmpzip [("hello/",""), ("hello/world.txt", world_txt)] + let unicodeComment = "Привет, мир!" + withArchive [] tmpzip $ setComment unicodeComment + comment <- withArchive [] tmpzip $ getComment [] + removeFile tmpzip + comment @?= (Just unicodeComment) + , "set/get/remove file comment" ~: do tmpzip <- getTmpFileName "test_LibZip_file_comment.zip" let world_path = "hello/world.txt" @@ -176,7 +259,25 @@ withArchive [] tmpzip $ removeFileComment [] world_path c_off' <- get_comm removeFile tmpzip - (c_off, c_on, c_off') @?= (Nothing, Just world_comm, Nothing) + -- libzip-0.11 returns an empty string, instead of NULL pointer in 0.10. + -- Haskell LibZip reflects it by returning Just "" rather than Nothing. + (c_off, c_on, c_off') @?= (Just "", Just world_comm, Just "") + + , "set/get Unicode file comment" ~: do + tmpzip <- getTmpFileName "test_LibZip_file_comment.zip" + let world_path = "hello/world.txt" + let world_comm = "\1087\1088\1080\1074\1077\1090" + let world_comm2 = [208,188,208,184,209,128] + mkArchive tmpzip [("hello/",undefined), (world_path,world_txt)] + let get_comm = withArchive [] tmpzip $ getFileComment [] world_path + c_off <- get_comm + withArchive [] tmpzip $ setFileComment [] world_path world_comm + c_on <- get_comm + withArchive [] tmpzip $ setFileCommentIx 1 (BS.pack world_comm2) [FileENC_UTF_8] + c_on2 <- get_comm + removeFile tmpzip + (c_off, c_on, c_on2) @?= (Just "", Just "привет", Just "мир") + , "unchange file" ~: do tmpzip <- getTmpFileName "test_LibZip_unchange_file.zip" mkArchive tmpzip [("world.txt",world_txt)] @@ -185,7 +286,10 @@ unchangeFile [] "world.txt" getFileComment [] "world.txt" removeFile tmpzip - c @?= Nothing + -- libzip-0.11 returns an empty string, instead of NULL pointer in 0.10. + -- Haskell LibZip reflects it by returning Just "" rather than Nothing. + c @?= Just "" + , "unchange archive" ~: do tmpzip <- getTmpFileName "test_LibZip_unchange.zip" mkArchive tmpzip [("world.txt",world_txt)] @@ -194,7 +298,10 @@ unchangeArchive getComment [] removeFile tmpzip - c @?= Nothing + -- libzip-0.11 returns an empty string, instead of NULL pointer in 0.10. + -- Haskell LibZip reflects it by returning Just "" rather than Nothing. + c @?= Just "" + , "unchange all" ~: do tmpzip <- getTmpFileName "test_LibZip_unchange_all.zip" mkArchive tmpzip [("world.txt",world_txt)] @@ -206,8 +313,14 @@ c2 <- getFileComment [] "world.txt" return (c1,c2) removeFile tmpzip - c @?= (Nothing,Nothing) + -- libzip-0.11 returns an empty string, instead of NULL pointer in 0.10. + -- Haskell LibZip reflects it by returning Just "" rather than Nothing. + c @?= (Just "", Just "") + , "read a file from an encrypted archive" ~: do + txt <- withEncryptedArchive [] "purity" encryptedzip $ fileContents [] lastfile + txt @?= world_txt + -- libzip-0.11 doesn't support creating encrypted archives yet ] getTmpFileName basename = do @@ -240,12 +353,23 @@ mkArchive :: (Enum a) => FilePath -> [(FilePath, [a])] -> IO () mkArchive zipname contents = - withArchive [CreateFlag] zipname $ + withArchive [CreateFlag] zipname $ populateArchive contents + +populateArchive :: (Enum a) => [(FilePath, [a])] -> Archive () +populateArchive contents = mapM_ (\(f,d) -> if last f == '/' then addDirectory f else addFile f =<< sourceBuffer d ) contents - - +getFileSize :: FilePath -> IO (Maybe Integer) +getFileSize path = + E.handle handler $ + E.bracket (openFile path ReadMode) (hClose) $ + \h -> do + size <- hFileSize h + return $ Just size + where + handler :: E.SomeException -> IO (Maybe Integer) + handler _ = return Nothing