LibZip 0.0.2 → 1.0.1
raw patch · 14 files changed
Files
- C2HS.hs +0/−220
- Codec/Archive/LibZip.chs +0/−352
- Codec/Archive/LibZip.hs +795/−0
- Codec/Archive/LibZip/Errors.hs +42/−0
- Codec/Archive/LibZip/Types.hs +351/−0
- LICENSE +1/−1
- LibZip.cabal +43/−22
- Setup.lhs +4/−21
- Tests/Common.hs +21/−0
- Tests/MonadicTests.hs +375/−0
- Tests/encrypted.zip binary
- Tests/test.zip binary
- examples/hzip.hs +108/−0
- runTests.hs +15/−0
− C2HS.hs
@@ -1,220 +0,0 @@--- C->Haskell Compiler: Marshalling library------ Copyright (c) [1999...2005] Manuel M T Chakravarty------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are met:--- --- 1. Redistributions of source code must retain the above copyright notice,--- this list of conditions and the following disclaimer. --- 2. Redistributions in binary form must reproduce the above copyright--- notice, this list of conditions and the following disclaimer in the--- documentation and/or other materials provided with the distribution. --- 3. The name of the author may not be used to endorse or promote products--- derived from this software without specific prior written permission. ------ THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR--- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES--- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN--- NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED--- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR--- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF--- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING--- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS--- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.------- Description --------------------------------------------------------------------- Language: Haskell 98------ This module provides the marshaling routines for Haskell files produced by --- C->Haskell for binding to C library interfaces. It exports all of the--- low-level FFI (language-independent plus the C-specific parts) together--- with the C->HS-specific higher-level marshalling routines.-----module C2HS (-- -- * Re-export the language-independent component of the FFI - module Foreign,-- -- * Re-export the C language component of the FFI- module CForeign,-- -- * Composite marshalling functions- withCStringLenIntConv, peekCStringLenIntConv, withIntConv, withFloatConv,- peekIntConv, peekFloatConv, withBool, peekBool, withEnum, peekEnum,-- -- * Conditional results using 'Maybe'- nothingIf, nothingIfNull,-- -- * Bit masks- combineBitMasks, containsBitMask, extractBitMasks,-- -- * Conversion between C and Haskell types- cIntConv, cFloatConv, cToBool, cFromBool, cToEnum, cFromEnum-) where ---import Foreign- hiding (Word)- -- Should also hide the Foreign.Marshal.Pool exports in- -- compilers that export them-import CForeign--import Monad (when, liftM)----- Composite marshalling functions--- ----------------------------------- Strings with explicit length----withCStringLenIntConv s f = withCStringLen s $ \(p, n) -> f (p, cIntConv n)-peekCStringLenIntConv (s, n) = peekCStringLen (s, cIntConv n)---- Marshalling of numerals-----withIntConv :: (Storable b, Integral a, Integral b) - => a -> (Ptr b -> IO c) -> IO c-withIntConv = with . cIntConv--withFloatConv :: (Storable b, RealFloat a, RealFloat b) - => a -> (Ptr b -> IO c) -> IO c-withFloatConv = with . cFloatConv--peekIntConv :: (Storable a, Integral a, Integral b) - => Ptr a -> IO b-peekIntConv = liftM cIntConv . peek--peekFloatConv :: (Storable a, RealFloat a, RealFloat b) - => Ptr a -> IO b-peekFloatConv = liftM cFloatConv . peek---- Passing Booleans by reference-----withBool :: (Integral a, Storable a) => Bool -> (Ptr a -> IO b) -> IO b-withBool = with . fromBool--peekBool :: (Integral a, Storable a) => Ptr a -> IO Bool-peekBool = liftM toBool . peek----- Passing enums by reference-----withEnum :: (Enum a, Integral b, Storable b) => a -> (Ptr b -> IO c) -> IO c-withEnum = with . cFromEnum--peekEnum :: (Enum a, Integral b, Storable b) => Ptr b -> IO a-peekEnum = liftM cToEnum . peek----- Storing of 'Maybe' values--- ---------------------------instance Storable a => Storable (Maybe a) where- sizeOf _ = sizeOf (undefined :: Ptr ())- alignment _ = alignment (undefined :: Ptr ())-- peek p = do- ptr <- peek (castPtr p)- if ptr == nullPtr- then return Nothing- else liftM Just $ peek ptr-- poke p v = do- ptr <- case v of- Nothing -> return nullPtr- Just v' -> new v'- poke (castPtr p) ptr----- Conditional results using 'Maybe'--- ------------------------------------- Wrap the result into a 'Maybe' type.------ * the predicate determines when the result is considered to be non-existing,--- ie, it is represented by `Nothing'------ * the second argument allows to map a result wrapped into `Just' to some--- other domain----nothingIf :: (a -> Bool) -> (a -> b) -> a -> Maybe b-nothingIf p f x = if p x then Nothing else Just $ f x---- |Instance for special casing null pointers.----nothingIfNull :: (Ptr a -> b) -> Ptr a -> Maybe b-nothingIfNull = nothingIf (== nullPtr)----- Support for bit masks--- ------------------------- Given a list of enumeration values that represent bit masks, combine these--- masks using bitwise disjunction.----combineBitMasks :: (Enum a, Bits b) => [a] -> b-combineBitMasks = foldl (.|.) 0 . map (fromIntegral . fromEnum)---- Tests whether the given bit mask is contained in the given bit pattern--- (i.e., all bits set in the mask are also set in the pattern).----containsBitMask :: (Bits a, Enum b) => a -> b -> Bool-bits `containsBitMask` bm = let bm' = fromIntegral . fromEnum $ bm- in- bm' .&. bits == bm'---- |Given a bit pattern, yield all bit masks that it contains.------ * This does *not* attempt to compute a minimal set of bit masks that when--- combined yield the bit pattern, instead all contained bit masks are--- produced.----extractBitMasks :: (Bits a, Enum b, Bounded b) => a -> [b]-extractBitMasks bits = - [bm | bm <- [minBound..maxBound], bits `containsBitMask` bm]----- Conversion routines--- ----------------------- |Integral conversion----cIntConv :: (Integral a, Integral b) => a -> b-cIntConv = fromIntegral---- |Floating conversion----cFloatConv :: (RealFloat a, RealFloat b) => a -> b-cFloatConv = realToFrac--- As this conversion by default goes via `Rational', it can be very slow...-{-# RULES - "cFloatConv/Float->Float" forall (x::Float). cFloatConv x = x;- "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x- #-}---- |Obtain C value from Haskell 'Bool'.----cFromBool :: Num a => Bool -> a-cFromBool = fromBool---- |Obtain Haskell 'Bool' from C value.----cToBool :: Num a => a -> Bool-cToBool = toBool---- |Convert a C enumeration to Haskell.----cToEnum :: (Integral i, Enum e) => i -> e-cToEnum = toEnum . cIntConv---- |Convert a Haskell enumeration to C.----cFromEnum :: (Enum e, Integral i) => e -> i-cFromEnum = cIntConv . fromEnum
− Codec/Archive/LibZip.chs
@@ -1,352 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}---- | Partial Haskell bindings to @libzip@ library.--- These bindings provide read-only access to zip archives.--- Produced with @c2hs@ for @libzip@ ver. 0.9.------ API is not stabilized yet, especially high-level part. If you use it, please--- let me know. Feedback and suggestions are welcome.-module Codec.Archive.LibZip- (-- * Types- Zip,ZipFile,OpenFlag(..),FileFlag(..),ZipError(..)- ,Word8- -- * High-level interface- -- These functions are intended to reduce boiler-plate. They acquire and- -- release relevant resources automatically (open and close archives, files).- ,withZip,getFiles,getFileSize- ,readZipFile,readZipFile',readZipFileHead,readZipFileHead'- -- * Low-level direct bindings to @libzip@ functions- -- These functions correspond to their C namesakes with @zip_@ prefix.- -- Please refer to @libzip@ documentation to learn about their semantics.- ,open,close,get_num_files,get_name- ,fopen,fclose,fread- -- * Utilities- ,catchZipError,isFile,isDir- ) where--import C2HS--import qualified Control.Exception as E-import qualified Data.ByteString as B-import Control.Applicative ((<$>))-import Data.Typeable--#include "zip.h"--{# context lib="zip" prefix="zip_" #}---- | Flags for 'withZip'.-{# enum define OpenFlag- { ZIP_CREATE as CreateFlag- , ZIP_EXCL as ExclFlag- , ZIP_CHECKCONS as CheckConsFlag- } deriving (Show,Eq) #}---- | Flags for 'getFiles', 'getFileSize', 'readZipFile', ...--- Please consult @libzip@ documentation about their use.-{# enum define FileFlag- { ZIP_FL_NOCASE as FileNOCASE- , ZIP_FL_NODIR as FileNODIR- , ZIP_FL_COMPRESSED as FileCOMPRESSED- , ZIP_FL_UNCHANGED as FileUNCHANGED- , ZIP_FL_RECOMPRESS as FileRECOMPRESS- } deriving (Show,Eq) #}---- | @libzip@ error codes.-{# enum define ZipError- { ZIP_ER_OK as ErrOK- , ZIP_ER_MULTIDISK as ErrMULTIDISK- , ZIP_ER_RENAME as ErrRENAME- , ZIP_ER_CLOSE as ErrCLOSE- , ZIP_ER_SEEK as ErrSEEK- , ZIP_ER_READ as ErrREAD- , ZIP_ER_WRITE as ErrWRITE- , ZIP_ER_CRC as ErrCRC- , ZIP_ER_ZIPCLOSED as ErrZIPCLOSED- , ZIP_ER_NOENT as ErrNOENT- , ZIP_ER_EXISTS as ErrEXISTS- , ZIP_ER_OPEN as ErrOPEN- , ZIP_ER_TMPOPEN as ErrTMPOPEN- , ZIP_ER_ZLIB as ErrZLIB- , ZIP_ER_MEMORY as ErrMEMORY- , ZIP_ER_CHANGED as ErrCHANGED- , ZIP_ER_COMPNOTSUPP as ErrCOMPNOTSUPP- , ZIP_ER_EOF as ErrEOF- , ZIP_ER_INVAL as ErrINVAL- , ZIP_ER_NOZIP as ErrNOZIP- , ZIP_ER_INTERNAL as ErrINTERNAL- , ZIP_ER_INCONS as ErrINCONS- , ZIP_ER_REMOVE as ErrREMOVE- , ZIP_ER_DELETED as ErrDELETED- } deriving (Eq,Typeable) #}--instance E.Exception ZipError--instance Show ZipError where- show ErrOK = "No error"- show ErrMULTIDISK = "Multi-disk zip archives not supported"- show ErrRENAME = "Renaming temporary file failed"- show ErrCLOSE = "Closing zip archive failed"- show ErrSEEK = "Seek error"- show ErrREAD = "Read error"- show ErrWRITE = "Write error"- show ErrCRC = "CRC error"- show ErrZIPCLOSED = "Containing zip archive was closed"- show ErrNOENT = "No such file"- show ErrEXISTS = "File already exists"- show ErrOPEN = "Can't open file"- show ErrTMPOPEN = "Failure to create temporary file"- show ErrZLIB = "Zlib error"- show ErrMEMORY = "Malloc failure"- show ErrCHANGED = "Entry has been changed"- show ErrCOMPNOTSUPP = "Compression method not supported"- show ErrEOF = "Premature EOF"- show ErrINVAL = "Invalid argument"- show ErrNOZIP = "Not a zip archive"- show ErrINTERNAL = "Internal error"- show ErrINCONS = "Zip archive inconsistent"- show ErrREMOVE = "Can't remove file"- show ErrDELETED = "Entry has been deleted"---- | Handler of the open zip file.-{# pointer *zip as Zip newtype #}--instance Show Zip where- show z@(Zip p)- | isOpen z = "Zip[open:" ++ (show p) ++ "]"- | otherwise = "Zip[closed]"--isOpen :: Zip -> Bool-isOpen (Zip p) = p /= nullPtr---- | Handler for an open file in the zip archive.-{# pointer *zip_file as ZipFile newtype #}--instance Show ZipFile where- show (ZipFile p)- | p /= nullPtr = "ZipFile[open:" ++ (show p) ++ "]"- | otherwise = "ZipFile[closed]"--#c-typedef struct zip_stat *zip_stat_t;-#endc--{--{# enum define CompMethod- { ZIP_CM_DEFAULT as CompDEFAULT- , ZIP_CM_STORE as CompSTORE- , ZIP_CM_SHRINK as CompSHRINK- , ZIP_CM_REDUCE_1 as CompREDUCE_1- , ZIP_CM_REDUCE_2 as CompREDUCE_2- , ZIP_CM_REDUCE_3 as CompREDUCE_3- , ZIP_CM_REDUCE_4 as CompREDUCE_4- , ZIP_CM_IMPLODE as CompIMPLODE- , ZIP_CM_DEFLATE as CompDEFLATE- , ZIP_CM_DEFLATE64 as CompDEFLATE64- , ZIP_CM_PKWARE_IMPLODE as CompPKWARE_IMPLODE- , ZIP_CM_BZIP2 as CompBZIP2- , ZIP_CM_LZMA as CompLZMA- , ZIP_CM_TERSE as CompTERSE- , ZIP_CM_LZ77 as CompLZ77- , ZIP_CM_WAVPACK as CompWAVPACK- , ZIP_CM_PPMD as CompPPMD- } deriving (Show,Eq) #}--{# enum define EncryptMethod- { ZIP_EM_NONE as EncryptNONE- , ZIP_EM_TRAD_PKWARE as EncryptTRAD_PKWARE- , ZIP_EM_UNKNOWN as EncryptUNKNOWN- } deriving (Show,Eq) #}--}---- struct zip *zip_open(const char *, int, int *);-{# fun open as open_- { `String'- , combineBitMasks `[OpenFlag]'- , alloca- `ZipError' peekError*- } -> `Zip' id #}- where peekError i = peek i >>= return . toEnum . cIntConv---- | Open zip archive specified by /path/ and return its handler on success.-open :: String -- ^ /path/ of the file to open- -> [OpenFlag] -- ^ open mode- -> IO Zip-open path flags = do- (z,e) <- open_ path flags- if isOpen z- then return z- else E.throwIO e---- int zip_close(struct zip *);-{# fun close as close_- { id `Zip'- } -> `Int' #}---- | Close zip archive.-close :: Zip -> IO ()-close z = do- r <- close_ z- if r == 0- then return ()- else E.throwIO ErrINTERNAL -- FIXME---- int zip_get_num_files(struct zip *);------ | Return the number of files in the archive.-{# fun get_num_files- { id `Zip'- } -> `Int' errorOnNegative* #}- where errorOnNegative i | i < 0 = E.throwIO ErrZIPCLOSED- errorOnNegative i = return $ cIntConv i---- const char *zip_get_name(struct zip *, int, int);------ | Get name of file by index.-{# fun get_name- { id `Zip'- , `Int'- , combineBitMasks `[FileFlag]'- } -> `String' errorOnNull* #}- where errorOnNull p | p /= nullPtr = peekCString p- errorOnNull _ | otherwise = E.throwIO ErrINVAL -- FIXME---- struct zip_file *zip_fopen(struct zip *, const char *, int);-{# fun zip_fopen as fopen_- { id `Zip'- , `String'- , combineBitMasks `[FileFlag]'- } -> `ZipFile' id #}---- | Open file in zip archive for reading.-fopen :: Zip -> String -> [FileFlag] -> IO ZipFile-fopen z fn flags = do- zf@(ZipFile ptr) <- fopen_ z fn flags- if ptr == nullPtr- then E.throwIO ErrNOENT -- FIXME- else return zf---- int zip_fclose(struct zip_file *);------ | Close file in zip archive.-{# fun zip_fclose as fclose- { id `ZipFile'- } -> `()' errorOrNothing* #}- where errorOrNothing 0 = return ()- errorOrNothing _ = E.throwIO ErrINVAL -- FIXME---- ssize_t zip_fread(struct zip_file *, void *, size_t);------ | Read from file in zip archive.-fread :: ZipFile -> Int -> IO [Word8]-fread zf count = do- allocaBuf $ \ptr -> do- rcount <- {#call zip_fread#} zf ptr (cIntConv count)- if rcount < 0- then E.throwIO ErrREAD- else peekBuf ptr >>= return . take (cIntConv rcount)- where- -- Nasty pointer casts to deal with void*- allocaBuf :: (Ptr () -> IO [Word8]) -> IO [Word8]- allocaBuf f =- let alloc = allocaArray count :: (Ptr Word8 -> IO [Word8]) -> IO [Word8]- castFun :: (Ptr () -> IO [a]) -> (Ptr a -> IO [a])- castFun fun = \ptrb -> let ptra = castPtr ptrb in fun ptra- in alloc $ castFun f- peekBuf :: Ptr () -> IO [Word8]- peekBuf p = peekArray count $ castPtr p---- High level Haskell wrappers---- | Open zip archive, do something, and close the archive.-withZip :: String -- ^ /path/ of the file to open- -> [OpenFlag] -- ^ open mode- -> (Zip -> IO a) -- ^ action to do on zip arhive- -> IO a-withZip filename flags action = do- z <- open filename flags- result <- action z- close z- return result---- | Get names of the files in archive.-getFiles :: Zip -> [FileFlag] -> IO [String]-getFiles z flags = do- n <- get_num_files z- mapM (\i -> get_name z i flags) [0..(n-1)]---- | Get size of the file in archive.-getFileSize :: Zip -- ^ zip archive- -> String -- ^ name of the file in the archive- -> [FileFlag] -- ^ file name mode- -> IO Int-getFileSize z name flags =- withCString name $ \name' ->- allocaBytes {# sizeof zip_stat_t #} $ \st -> do- {# call zip_stat_init #} st- ret <- {# call zip_stat #} z name' (combineBitMasks flags) st- if ret /= 0- then E.throwIO ErrINTERNAL -- FIXME- else fromIntegral <$> {# get zip_stat_t->size #} st---- | Read uncompressed file from the archive. Produce a strict ByteString.-readZipFile :: Zip -- ^ zip archive- -> String -- ^ name of the file in the archive- -> [FileFlag] -- ^ file name mode- -> IO B.ByteString-readZipFile z fname flags = return . B.pack =<< readZipFile' z fname flags---- | Read uncompressed file from the archive. Produce a list of 'Word8'.-readZipFile' :: Zip -- ^ zip archive- -> String -- ^ name of the file in the archive- -> [FileFlag] -- ^ file name mode- -> IO [Word8]-readZipFile' z fname flags = do- sz <- getFileSize z fname flags- readZipFileHead' z fname flags sz---- | Read beginning of the uncompressed file from the archive. Produce a list of 'Word8'.-readZipFileHead' :: Zip -- ^ zip archive- -> String -- ^ name of the file in the archive- -> [FileFlag] -- ^ file name mode- -> Int -- ^ how many bytes to read- -> IO [Word8]-readZipFileHead' z fname flags n = do- f <- fopen z fname flags- bytes <- fread f n- fclose f- return bytes---- | Read beginning of the uncompressed file from the archive. Produce a strict ByteString.-readZipFileHead :: Zip -- ^ zip archive- -> String -- ^ name of the file in the archive- -> [FileFlag] -- ^ file name mode- -> Int -- ^ how many bytes to read- -> IO B.ByteString-readZipFileHead z fname flags n = return . B.pack =<< readZipFileHead' z fname flags n---- Helpers---- | Wrapper to catch library errors.-catchZipError :: IO a -> (ZipError -> IO a) -> IO a-catchZipError f h = E.catchJust ifZipError f h- where- ifZipError :: (Typeable e, E.Exception e) => e -> Maybe e- ifZipError x | typeOf x == typeOf ErrOK = Just x- ifZipError _ | otherwise = Nothing---- | Return True if path is a file name, not a directory name (does not end with '/').-isFile :: String -> Bool-isFile filename = (lastMay filename /= Just '/')---- | Return True if path is a directory name (ends with '/').-isDir :: String -> Bool-isDir = not . isFile--lastMay :: [a] -> Maybe a-lastMay [] = Nothing-lastMay xs = Just $ last xs---- vim: set expandtab ts=2 sw=2 ai si:
+ Codec/Archive/LibZip.hs view
@@ -0,0 +1,795 @@+{- | Monadic interface to @libzip@.++Most of the operations on zip archive happen within 'Archive' monad+(see 'withArchive').+Partial reading of the files in the archive may be performed from+within 'Entry' monad (see 'fromFile').+Both 'Archive' and 'Entry' are monad transformers over 'IO', and allow+for IO with single and double 'lift'ing respectingly.++Note: LibZip does not handle text encodings. Even if its API accepts+'String's (e.g. in 'sourceBuffer'), character codes above 255 should+not be used. The user is responsible of proper encoding the text+data.++/Examples/++List files in the zip archive:++@+import System.Environment (getArgs)+import Codec.Archive.LibZip++main = do+ (zipfile:_) <- getArgs+ files <- withArchive [] zipfile $ fileNames []+ mapM_ putStrLn files+@++Create a zip archive and a add file to the archive:++@+import System.Environment (getArgs)+import Codec.Archive.LibZip++main = do+ (zipfile:_) <- getArgs+ withArchive [CreateFlag] zipfile $ do+ zs <- sourceBuffer \"Hello World!\"+ addFile \"hello.txt\" zs+@++Extract and print a file from the zip archive:++@+import System.Environment (getArgs)+import Codec.Archive.LibZip++main = do+ (zipfile:file:_) <- getArgs+ bytes <- withArchive [] zipfile $ fileContents [] file+ putStrLn bytes+@++See also an implementation of a simple zip archiver @hzip.hs@ in the+@examples/@ directory of the source distribution.++-}+module Codec.Archive.LibZip+ (+ -- * Types+ Archive+ , Entry+ , ZipStat(..)+ -- * Archive operations+ , withArchive, withEncryptedArchive, getZip+ , numFiles, fileName, nameLocate, fileNames+ , fileSize, fileSizeIx+ , fileStat, fileStatIx+ , deleteFile, deleteFileIx+ , renameFile, renameFileIx+ , addFile, addFileWithFlags+ , addDirectory, addDirectoryWithFlags+ , replaceFile, replaceFileIx+ , setFileCompression, setFileCompressionIx+ , sourceBuffer, sourceFile, sourceZip+ , PureSource(..), sourcePure+ , getComment, setComment, removeComment+ , getFileComment, getFileCommentIx+ , setFileComment, setFileCommentIx+ , removeFileComment, removeFileCommentIx+ , unchangeFile, unchangeFileIx+ , unchangeArchive, unchangeAll+ -- * File reading operations+ , fromFile, fromFileIx+ , readBytes, skipBytes, readContents+ , fileContents, fileContentsIx+ -- * Flags and options+ , OpenFlag(..)+ , FileFlag(..)+ , ZipCompMethod(..)+ , ZipEncryptionMethod(..)+ -- * Exception handling+ , ZipError(..)+ , catchZipError+ -- * Re-exports+ , lift+ ) where++import Bindings.LibZip+import Codec.Archive.LibZip.Types+import Codec.Archive.LibZip.Errors++import Data.Time.Clock (UTCTime, getCurrentTime)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+import Data.Word (Word8)+import Control.Monad (when)+import Control.Monad.State.Strict+ (StateT(..), MonadState(..), MonadTrans(..), lift, liftM)+import Foreign.C.Error (Errno(..), eINVAL)+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)+import Foreign.Marshal.Utils (with)+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+--++-- | Monadic computation with a zip archive. See 'withArchive'.+type Archive a = StateT Zip IO a++-- | Monadic computation to read from open archive entries.+-- See 'fromFile' and 'fromFileIx'.+type Entry a = StateT+ (ZipFile,Integer,[FileFlag]) -- (file, position index, access flags)+ (StateT Zip IO) -- archive monad+ a++--+-- Archive operations+--++-- | Top-level wrapper for operations with an open+-- archive. 'withArchive' opens and closes the file+-- automatically. On error it throws 'ZipError'.+withArchive :: [OpenFlag] -- ^ Checks for consistency or existence.+ -> FilePath -- ^ Filename of the zip archive.+ -> Archive a -- ^ Action to do with the archive.+ -> IO a+withArchive flags path action =+ withCString path $ \path' ->+ alloca $ \errp ->+ c'zip_open path' (combine flags) errp >>= \z ->+ if z == nullPtr+ then peek errp >>= E.throwIO. errFromCInt+ 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] -- ^ '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 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+ z <- getZip+ lift $ do+ n <- c'zip_get_name z (fromIntegral i) (combine flags)+ doIf' (n /= nullPtr) z $ peekCString n++-- | Locate an entry (get its index) in the archive by its name.+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+ z <- getZip+ lift $+ withCString name $ \name' -> do+ i <- fromIntegral `liftM` c'zip_name_locate z name' (combine flags)+ if i < 0+ then return Nothing+ else return (Just i)++-- | Get names of all entries (files and directories) in the archive.+fileNames :: [FileFlag] -- ^ 'FileUNCHANGED' flag is accepted.+ -> Archive [FilePath]+fileNames flags = do+ n <- numFiles flags+ mapM (fileName flags) [0..n-1]++-- | Get size of a file in the archive.+fileSize :: [FileFlag] -- ^ Filename lookup mode, 'FileUNCHANGED' can be used.+ -> FilePath -- ^ Name of the file in the archive.+ -> Archive Integer -- ^ File size.+fileSize flags name = fileStat flags name >>= return . zs'size++-- | Get size of a file in the archive (by index).+fileSizeIx :: [FileFlag] -- ^ 'FileUNCHANGED' is accepted.+ -> Integer -- ^ Position index of a file in the archive.+ -> Archive Integer -- ^ File size.+fileSizeIx flags i = fileStatIx flags i >>= return . zs'size++-- | Get information about a file in the archive.+fileStat :: [FileFlag] -- ^ Filename lookup mode, 'FileUNCHANGED' can be used.+ -> FilePath -- ^ Name of the file in the archive.+ -> Archive ZipStat -- ^ Infomation about the file.+fileStat flags name = do+ z <- getZip+ lift $+ withCString name $ \name' ->+ alloca $ \stat -> do+ c'zip_stat_init stat+ r <- c'zip_stat z name' (combine flags) stat+ doIf' (r == 0) z $ toZipStat =<< peek stat++-- | Get information about a file in the archive (by index).+fileStatIx :: [FileFlag] -- ^ 'FileUNCHANGED' can be used.+ -> Integer -- ^ Position index of a file in the archive.+ -> Archive ZipStat -- ^ Information about the file.+fileStatIx flags i = do+ z <- getZip+ lift $+ alloca $ \stat -> do+ r <- c'zip_stat_index z (fromIntegral i) (combine flags) stat+ doIf' (r == 0) z $ toZipStat =<< peek stat++-- | Delete file from the archive.+deleteFile :: [FileFlag] -- ^ Filename lookup mode (see 'nameLocate').+ -> FilePath -- ^ Filename.+ -> Archive ()+deleteFile flags name = do+ mbi <- nameLocate flags name+ maybe (lift $ E.throwIO ErrNOENT) deleteFileIx mbi++-- | Delete file (referenced by position index) from the archive.+deleteFileIx :: Integer -- ^ Position index of a file in the archive.+ -> Archive ()+deleteFileIx i = do+ z <- getZip+ r <- lift $ c'zip_delete z (fromIntegral i)+ if r == 0+ then return ()+ else lift $ get_error z >>= E.throwIO++-- | Rename file in the archive.+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 (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.+ -> 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 flags = do+ z <- getZip+ 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++-- | Add a file to the archive.+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 =+ 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 $ 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++-- | 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 =+ 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 $ 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 (see 'nameLocate').+ -> FilePath -- ^ File to replace.+ -> ZipSource -- ^ Source where the new file data is obtained from.+ -> Archive ()+replaceFile flags name src = do+ mbi <- nameLocate flags name+ 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+ -> Archive ()+replaceFileIx i src = do+ z <- getZip+ lift $ do+ 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 ()++-- | Create a data source. Note: input is converted to @[Word8]@ internally.+sourceBuffer :: (Enum a)+ => [a]+ -> Archive ZipSource+sourceBuffer src = do+ let ws = map (toEnum . fromEnum) src :: [Word8]+ z <- getZip+ lift $ withArrayLen ws $ \len buf -> do+ zs <- c'zip_source_buffer z (castPtr buf) (fromIntegral len) 0+ if zs == nullPtr+ then get_error z >>= E.throwIO+ else return zs++-- | Create a data source from a file.+sourceFile :: FilePath -- ^ File to open.+ -> Integer -- ^ Offset from the beginning of the file.+ -> Integer -- ^ The number of bytes to read. If @0@ or @-1@,+ -- the read till the end of file.+ -> Archive ZipSource+sourceFile name offset len = do+ z <- getZip+ lift $ withCString name $ \name' -> do+ zs <- c'zip_source_file z name' (fromIntegral offset) (fromIntegral len)+ if zs == nullPtr+ then get_error z >>= E.throwIO+ else return zs++-- | Create a data source from a file in the zip archive.+sourceZip :: [FileFlag] -- ^ 'FileUNCHANGED' and 'FileRECOMPRESS' can be used.+ -> Zip -- ^ Source archive.+ -> Integer -- ^ Position index of a file in the source archive.+ -> Integer -- ^ Offset from the beginning of the file.+ -> Integer -- ^ The number of bytes to read. If @0@ or @-1@,+ -- then read till the end of file.+ -> Archive ZipSource+sourceZip flags srcz srcidx offset len = do+ z <- getZip+ lift $ do+ zs <- c'zip_source_zip z srcz (fromIntegral srcidx)+ (combine flags) (fromIntegral offset) (fromIntegral len)+ if zs == nullPtr+ then get_error z >>= E.throwIO+ else return zs++-- | Create a data source from a 'PureSource'.+-- Note: input of @[a]@ is converted to @[Word8]@ internally.+sourcePure :: (Enum a, Storable a, Storable st, Integral szt)+ => PureSource a st szt -> Archive ZipSource+sourcePure pureSrc = do+ z <- getZip+ lift $ do+ cb <- mk'zip_source_callback (runPureSource pureSrc)+ zs <- with (srcState pureSrc) $+ \pState -> c'zip_source_function z cb (castPtr pState)+ if zs == nullPtr+ then get_error z >>= E.throwIO+ else return zs++-- | Wrapper for a user-provided pure function to be used with 'sourcePure'.+-- Data size should be known in advance ('srcSize').+-- The function should support reading by chunks ('readSrc').+data PureSource a st szt = PureSource {+ srcState :: st -- ^ Initial state of the source.+ , srcSize :: szt -- ^ Total size of the data.+ , srcMTime :: Maybe UTCTime+ -- ^ Modification time (current time if Nothing).+ , readSrc :: szt -> st -> Maybe (szt, [a], st)+ -- ^ Read a chunk of the data, return @Just@ the size+ -- of data read, the data themselves and the new state+ -- of the source, or @Nothing@ on error.+ }++runPureSource :: (Enum a, Storable a, Storable st, Integral szt) =>+ PureSource a st szt+ -> (Ptr () -> Ptr () -> CULLong -> C'zip_source_cmd -> IO CULLong)+runPureSource src pState pData len cmd+ | cmd == c'ZIP_SOURCE_OPEN = return 0+ | cmd == c'ZIP_SOURCE_READ = do+ s <- peek (castPtr pState :: Ptr st)+ case readSrc (src { srcState = s }) (fromIntegral len) s of+ Just (len',bs,s') -> do+ pokeArray (castPtr pData :: Ptr Word8) (map (toEnum.fromEnum) bs)+ poke (castPtr pState) s'+ return (fromIntegral len')+ Nothing -> return (-1)+ | cmd == c'ZIP_SOURCE_CLOSE = return 0+ | cmd == c'ZIP_SOURCE_STAT = do+ t <- maybe getCurrentTime return (srcMTime src)+ let pt = fromInteger . round . utcTimeToPOSIXSeconds $ t+ let pStat = castPtr pData+ c'zip_stat_init pStat+ stat <- peek pStat+ let stat' = stat { c'zip_stat'mtime = pt+ , c'zip_stat'size = fromIntegral $ srcSize src }+ poke pStat stat'+ return $ fromIntegral (sizeOf stat')+ | cmd == c'ZIP_SOURCE_ERROR = do+ let pErrs = castPtr pData :: Ptr CInt+ poke pErrs (fromIntegral . fromEnum $ ErrINVAL)+ let (Errno esys) = eINVAL+ pokeElemOff pErrs 1 esys+ return $ fromIntegral (2 * sizeOf esys)+ | cmd == c'ZIP_SOURCE_FREE = return 0+ | otherwise = return (-1)++-- | Get zip archive comment.+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+ (c,n) <- lift $ alloca $ \lenp -> do+ c <- c'zip_get_archive_comment z lenp (combine flags)+ n <- peek lenp+ return (c,n)+ if c == nullPtr+ then return Nothing+ 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+ 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+ else return ()++-- | Remove zip archive comment.+removeComment :: Archive ()+removeComment = do+ z <- getZip+ r <- lift $ c'zip_set_archive_comment z nullPtr 0+ if r < 0+ then lift $ get_error z >>= E.throwIO+ else return ()++-- | Get comment for a file in the archive.+getFileComment :: [FileFlag] -- ^ Filename lookup mode (see 'nameLocate').+ -> FilePath -- ^ Filename+ -> Archive (Maybe String)+getFileComment flags name = do+ mbi <- nameLocate flags name+ -- 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] -- ^ 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 BS.ByteString)+getFileCommentIx flags i = do+ z <- getZip+ (c,n) <- lift $ alloca $ \lenp -> do+ 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 $ BS.packCStringLen (c,fromIntegral n) >>= return . Just++-- | Set comment for a file in the archive.+setFileComment :: [FileFlag] -- ^ Filename lookup mode (see 'nameLocate').+ -> FilePath -- ^ Filename.+ -> String -- ^ New file comment.+ -> Archive ()+setFileComment flags path comment = do+ mbi <- nameLocate flags path+ 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.+ -> 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 cflags = do+ z <- getZip+ 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 (see 'nameLocate').+ -> FilePath -- ^ Filename.+ -> Archive ()+removeFileComment flags path = do+ mbi <- nameLocate flags path+ maybe (lift $ E.throwIO ErrNOENT) removeFileCommentIx mbi++-- | Remove comment for a file in the archive (referenced by position index).+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_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 (see 'nameLocate').+ -> FilePath -- ^ Filename.+ -> Archive ()+unchangeFile flags name = do+ mbi <- nameLocate flags name+ maybe (lift $ E.throw ErrNOENT) unchangeFileIx mbi++-- | Undo changes to a file in the archive (referenced by position index).+unchangeFileIx :: Integer -- ^ Position index of a file in the archive.+ -> Archive ()+unchangeFileIx i = do+ z <- getZip+ lift $ do+ r <- c'zip_unchange z (fromIntegral i)+ if r < 0+ then get_error z >>= E.throwIO+ else return ()++-- | Undo global changes to zip archive (revert changes to the archive+-- comment and global flags).+unchangeArchive :: Archive ()+unchangeArchive = do+ z <- getZip+ lift $ do+ r <- c'zip_unchange_archive z+ if r < 0+ then get_error z >>= E.throwIO+ else return ()++-- | Undo all changes in a zip archive.+unchangeAll :: Archive ()+unchangeAll = do+ z <- getZip+ lift $ do+ r <- c'zip_unchange_all z+ if r < 0+ then get_error z >>= E.throwIO+ else return ()++--+-- File reading operations+--++-- | Wrapper for operations with a file in the archive. 'fromFile' is normally+-- called from within an 'Archive' action (see also 'withArchive').+-- 'fromFile' can be replaced with 'fileContents' to read an entire file at+-- once.+fromFile :: [FileFlag] -- ^ Filename lookup mode,+ -- 'FileCOMPRESSED' and 'FileUNCHANGED' can be used.+ -> FilePath -- ^ Name of the file in the arhive.+ -> Entry a -- ^ Action with the file.+ -> Archive a+fromFile flags name action = do+ z <- getZip+ nameLocate flags name >>= maybe (lift $ get_error z >>= E.throwIO) runAction+ where+ runAction i = do+ z <- getZip+ zf <- lift $ withCString name $ \n -> c'zip_fopen z n (combine flags)+ if zf == nullPtr+ then lift $ get_error z >>= E.throwIO+ else do+ r <- fst `liftM` runStateT action (zf,i,flags)+ e <- lift $ c'zip_fclose zf+ if e /= 0+ then lift $ E.throwIO $ (toEnum . fromIntegral $ e :: ZipError)+ else return r++-- | Wrapper for operations with a file in the archive. File is referenced+-- by index (position). 'fromFileIx' is normally called from within+-- an 'Archive' action (see also 'withArchive'). 'fromFileIx' can be replaced+-- with 'fileContentsIx' to read an entire file at once.+fromFileIx :: [FileFlag] -- ^ 'FileCOMPRESSED' and 'FileUNCHANGED' can be used.+ -> Integer -- ^ Position index of a file in the archive.+ -> Entry a -- ^ Action with the file.+ -> Archive a+fromFileIx flags i action = do+ z <- getZip+ zf <- lift $ c'zip_fopen_index z (fromIntegral i) (combine flags)+ if zf == nullPtr+ then lift $ get_error z >>= E.throwIO+ else do+ r <- fst `liftM` runStateT action (zf,i,flags)+ e <- lift $ c'zip_fclose zf+ if e /= 0+ then lift $ E.throwIO $ (toEnum . fromIntegral $ e :: ZipError)+ else return r++-- | Read at most @n@ bytes from the file.+readBytes ::+ (Enum a)+ => Integer -- ^ The number of bytes to read.+ -> Entry [a] -- ^ Bytes read.+readBytes n = do+ lift . lift $+ when (n > toInteger (maxBound::Int))+ (E.throwIO ErrMEMORY) -- allocaArray can't allocate > (maxBound::Int)+ (zf,_,_) <- get+ lift . lift $ allocaArray (fromIntegral n) $ \buf -> do+ nread <- c'zip_fread zf (castPtr buf) (fromIntegral n)+ if nread < 0+ then+ get_file_error zf >>= E.throwIO+ else do+ bs <- peekArray (fromIntegral nread) buf :: IO [Word8]+ return . map (toEnum . fromEnum) $ bs++-- | Skip @n@ bytes from the open file. Note: this is not faster than reading.+skipBytes :: Integer -> Entry ()+skipBytes n = (readBytes n :: Entry [Word8]) >> return ()++-- | Read entire file contents.+readContents ::+ (Enum a)+ => Entry [a] -- ^ Contents of the file.+readContents = do+ (_,i,flags) <- get+ sz <- lift $ fileSizeIx flags i+ readBytes sz++-- | Read entire file. Shortcut for 'readContents' from within 'Archive' monad.+fileContents :: (Enum a)+ => [FileFlag]+ -> FilePath+ -> Archive [a]+fileContents flags name = fromFile flags name readContents++-- | Read entire file (referenced by position index). Shortcut for+-- 'readContents' from within 'Archive' monad.+fileContentsIx :: (Enum a)+ => [FileFlag]+ -> Integer+ -> Archive [a]+fileContentsIx flags i = fromFileIx flags i readContents++--+-- Helpers+--++-- | Get archive handler. Throw 'ErrINVAL' if the archive is closed.+getZip :: Archive Zip+getZip = do+ z <- get+ if z == nullPtr+ then lift $ E.throwIO ErrINVAL+ else return z++-- | Get and throw a 'ZipError' if condition fails. Otherwise work normally.+doIf :: Bool -> Zip -> (Zip -> IO a) -> IO a+doIf cnd z action =+ if cnd+ then action z+ else get_error z >>= E.throwIO++-- | Get and throw a 'ZipError' if condition fails. See also 'doIf'.+doIf' :: Bool -> Zip -> (IO a) -> IO a+doIf' cnd z action = doIf cnd z (const action)
+ Codec/Archive/LibZip/Errors.hs view
@@ -0,0 +1,42 @@+-- | Error handling functions.+module Codec.Archive.LibZip.Errors+ ( errFromCInt+ , get_error+ , get_file_error+ , catchZipError+ ) where++import Data.Typeable (Typeable, typeOf)+import Foreign.C.Types+import Foreign.Marshal.Alloc (alloca)+import Foreign.Ptr (nullPtr)+import Foreign.Storable (peek)+import qualified Control.Exception as E++import Bindings.LibZip+import Codec.Archive.LibZip.Types++errFromCInt :: CInt -> ZipError+errFromCInt = toEnum . fromEnum++get_error :: Zip -> IO ZipError+get_error z | z == nullPtr = E.throwIO ErrINVAL+get_error z = alloca $ \zep -> do+ c'zip_error_get z zep nullPtr+ peek zep >>= return . errFromCInt++get_file_error :: ZipFile -> IO ZipError+get_file_error zf+ | zf == nullPtr = E.throwIO ErrINVAL+ | otherwise = alloca $ \zep -> do+ c'zip_file_error_get zf zep nullPtr+ peek zep >>= return . errFromCInt++-- | Wrapper to catch library errors.+catchZipError :: IO a -> (ZipError -> IO a) -> IO a+catchZipError f h = E.catchJust ifZipError f h+ where+ ifZipError :: (Typeable e, E.Exception e) => e -> Maybe e+ ifZipError x | typeOf x == typeOf ErrOK = Just x+ ifZipError _ | otherwise = Nothing+
+ Codec/Archive/LibZip/Types.hs view
@@ -0,0 +1,351 @@+{-# LANGUAGE DeriveDataTypeable#-}++module Codec.Archive.LibZip.Types+ ( Zip+ , ZipFile+ , ZipSource+ , ZipStat(..)+ , toZipStat+ , OpenFlag(..)+ , FileFlag(..)+ , ArchiveFlag(..)+ , ZipError(..)+ , ZipCompMethod(..)+ , ZipEncryptionMethod(..)+ , combine+ ) where++import Data.Bits ((.|.))+import Data.Time (UTCTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.Typeable (Typeable)+import Data.Word (Word32, Word64)+import Foreign.C.String (peekCString)+import Foreign.C.Types ()+import Foreign.Ptr (Ptr, nullPtr)+import qualified Control.Exception as E++import Bindings.LibZip++-- | Handler of the open zip file.+type Zip = Ptr C'zip++-- | Handler of an open file in the zip archive.+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.+data ZipStat = ZipStat {+ zs'valid :: Word64+ , zs'name :: String+ , zs'index :: Integer+ , zs'size :: Integer+ , zs'comp_size :: Integer+ , zs'mtime :: UTCTime+ , zs'crc :: Word+ , zs'comp_method :: ZipCompMethod+ , zs'encryption_method :: ZipEncryptionMethod+ , zs'flags :: Word32+ } deriving (Show, Eq)++-- | Convert marshalled stat record.+toZipStat :: C'zip_stat -> IO ZipStat+toZipStat s = do+ let valid = fromIntegral $ c'zip_stat'valid s+ let np = c'zip_stat'name s+ name <- if (np /= nullPtr) then peekCString np else return ""+ let idx = fromIntegral $ c'zip_stat'index s+ let crc = fromIntegral $ c'zip_stat'crc s+ let mtime = posixSecondsToUTCTime . realToFrac $ c'zip_stat'mtime s+ let size = fromIntegral $ c'zip_stat'size s+ let comp_size = fromIntegral $ c'zip_stat'comp_size s+ let comp_meth = toEnum . fromIntegral $ c'zip_stat'comp_method s+ let enc_meth = toEnum . fromIntegral $ c'zip_stat'encryption_method s+ 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.+-- Please consult @libzip@ documentation about their use.+data FileFlag+ = FileNOCASE -- ^ Ignore case on name lookup.+ | FileNODIR -- ^ Ignore directory component.+ | FileCOMPRESSED -- ^ Read the compressed data.+ | 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+ fromEnum FileCOMPRESSED = c'ZIP_FL_COMPRESSED+ fromEnum FileNOCASE = c'ZIP_FL_NOCASE+ fromEnum FileNODIR = c'ZIP_FL_NODIR+ 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+++-- | @libzip@ archive global flags+data ArchiveFlag+ = ArchiveRDONLY+ deriving (Show, Eq)++instance Enum ArchiveFlag where+ fromEnum ArchiveRDONLY = c'ZIP_AFL_RDONLY+ toEnum x | x == c'ZIP_AFL_RDONLY = ArchiveRDONLY+ toEnum _ = undefined+++-- | @libzip@ error codes.+data ZipError+ = ErrOK -- ^ No error.+ | ErrMULTIDISK -- ^ Multi-disk zip archives not supported.+ | ErrRENAME -- ^ Renaming temporary file failed.+ | ErrCLOSE -- ^ Closing zip archive failed.+ | ErrSEEK -- ^ Seek error.+ | ErrREAD -- ^ Read error.+ | ErrWRITE -- ^ Write error.+ | ErrCRC -- ^ CRC error.+ | ErrZIPCLOSED -- ^ Containing zip archive was closed.+ | ErrNOENT -- ^ No such file.+ | ErrEXISTS -- ^ File already exists.+ | ErrOPEN -- ^ Can't open file.+ | ErrTMPOPEN -- ^ Failure to create temporary file.+ | ErrZLIB -- ^ Zlib error.+ | ErrMEMORY -- ^ Malloc error.+ | ErrCHANGED -- ^ Entry has been changed.+ | ErrCOMPNOTSUPP -- ^ Compression method not supported.+ | ErrEOF -- ^ Premature EOF.+ | ErrINVAL -- ^ Invalid argument.+ | ErrNOZIP -- ^ Not a zip archive.+ | ErrINTERNAL -- ^ Internal error.+ | ErrINCONS -- ^ Zip archive inconsistent.+ | ErrREMOVE -- ^ Can't remove file.+ | ErrDELETED -- ^ Entry has been deleted.+ | ErrENCRNOTSUPP -- ^ Encryption method not supported.+ | ErrRDONLY -- ^ Read-only archive.+ | ErrNOPASSWD -- ^ No password provided.+ | ErrWRONGPASSWD -- ^ Wrong password provided.+ deriving (Eq, Typeable)++instance Enum ZipError where+ fromEnum ErrCHANGED = c'ZIP_ER_CHANGED+ fromEnum ErrCLOSE = c'ZIP_ER_CLOSE+ fromEnum ErrCOMPNOTSUPP = c'ZIP_ER_COMPNOTSUPP+ fromEnum ErrCRC = c'ZIP_ER_CRC+ fromEnum ErrDELETED = c'ZIP_ER_DELETED+ fromEnum ErrEOF = c'ZIP_ER_EOF+ fromEnum ErrEXISTS = c'ZIP_ER_EXISTS+ fromEnum ErrINCONS = c'ZIP_ER_INCONS+ fromEnum ErrINTERNAL = c'ZIP_ER_INTERNAL+ fromEnum ErrINVAL = c'ZIP_ER_INVAL+ fromEnum ErrMEMORY = c'ZIP_ER_MEMORY+ fromEnum ErrMULTIDISK = c'ZIP_ER_MULTIDISK+ fromEnum ErrNOENT = c'ZIP_ER_NOENT+ fromEnum ErrNOZIP = c'ZIP_ER_NOZIP+ fromEnum ErrOK = c'ZIP_ER_OK+ fromEnum ErrOPEN = c'ZIP_ER_OPEN+ fromEnum ErrREAD = c'ZIP_ER_READ+ fromEnum ErrREMOVE = c'ZIP_ER_REMOVE+ fromEnum ErrRENAME = c'ZIP_ER_RENAME+ fromEnum ErrSEEK = c'ZIP_ER_SEEK+ fromEnum ErrTMPOPEN = c'ZIP_ER_TMPOPEN+ fromEnum ErrWRITE = c'ZIP_ER_WRITE+ fromEnum ErrZIPCLOSED = c'ZIP_ER_ZIPCLOSED+ fromEnum ErrZLIB = c'ZIP_ER_ZLIB+ fromEnum ErrENCRNOTSUPP = c'ZIP_ER_ENCRNOTSUPP+ fromEnum ErrRDONLY = c'ZIP_ER_RDONLY+ fromEnum ErrNOPASSWD = c'ZIP_ER_NOPASSWD+ fromEnum ErrWRONGPASSWD = c'ZIP_ER_WRONGPASSWD+ toEnum x | x == c'ZIP_ER_CHANGED = ErrCHANGED+ toEnum x | x == c'ZIP_ER_CLOSE = ErrCLOSE+ toEnum x | x == c'ZIP_ER_COMPNOTSUPP = ErrCOMPNOTSUPP+ toEnum x | x == c'ZIP_ER_CRC = ErrCRC+ toEnum x | x == c'ZIP_ER_DELETED = ErrDELETED+ toEnum x | x == c'ZIP_ER_EOF = ErrEOF+ toEnum x | x == c'ZIP_ER_EXISTS = ErrEXISTS+ toEnum x | x == c'ZIP_ER_INCONS = ErrINCONS+ toEnum x | x == c'ZIP_ER_INTERNAL = ErrINTERNAL+ toEnum x | x == c'ZIP_ER_INVAL = ErrINVAL+ toEnum x | x == c'ZIP_ER_MEMORY = ErrMEMORY+ toEnum x | x == c'ZIP_ER_MULTIDISK = ErrMULTIDISK+ toEnum x | x == c'ZIP_ER_NOENT = ErrNOENT+ toEnum x | x == c'ZIP_ER_NOZIP = ErrNOZIP+ toEnum x | x == c'ZIP_ER_OK = ErrOK+ toEnum x | x == c'ZIP_ER_OPEN = ErrOPEN+ toEnum x | x == c'ZIP_ER_READ = ErrREAD+ toEnum x | x == c'ZIP_ER_REMOVE = ErrREMOVE+ toEnum x | x == c'ZIP_ER_RENAME = ErrRENAME+ toEnum x | x == c'ZIP_ER_SEEK = ErrSEEK+ toEnum x | x == c'ZIP_ER_TMPOPEN = ErrTMPOPEN+ toEnum x | x == c'ZIP_ER_WRITE = ErrWRITE+ toEnum x | x == c'ZIP_ER_ZIPCLOSED = ErrZIPCLOSED+ toEnum x | x == c'ZIP_ER_ZLIB = ErrZLIB+ toEnum x | x == c'ZIP_ER_ENCRNOTSUPP = ErrENCRNOTSUPP+ toEnum x | x == c'ZIP_ER_RDONLY = ErrRDONLY+ toEnum x | x == c'ZIP_ER_NOPASSWD = ErrNOPASSWD+ toEnum x | x == c'ZIP_ER_WRONGPASSWD = ErrWRONGPASSWD+ toEnum _ = undefined++instance E.Exception ZipError++instance Show ZipError where+ show ErrOK = "No error"+ show ErrMULTIDISK = "Multi-disk zip archives not supported"+ show ErrRENAME = "Renaming temporary file failed"+ show ErrCLOSE = "Closing zip archive failed"+ show ErrSEEK = "Seek error"+ show ErrREAD = "Read error"+ show ErrWRITE = "Write error"+ show ErrCRC = "CRC error"+ show ErrZIPCLOSED = "Containing zip archive was closed"+ show ErrNOENT = "No such file"+ show ErrEXISTS = "File already exists"+ show ErrOPEN = "Can't open file"+ show ErrTMPOPEN = "Failure to create temporary file"+ show ErrZLIB = "Zlib error"+ show ErrMEMORY = "Malloc failure"+ show ErrCHANGED = "Entry has been changed"+ show ErrCOMPNOTSUPP = "Compression method not supported"+ show ErrEOF = "Premature EOF"+ show ErrINVAL = "Invalid argument"+ show ErrNOZIP = "Not a zip archive"+ show ErrINTERNAL = "Internal error"+ show ErrINCONS = "Zip archive inconsistent"+ show ErrREMOVE = "Can't remove file"+ show ErrDELETED = "Entry has been deleted"+ show ErrENCRNOTSUPP = "Encryption method not supported"+ show ErrRDONLY = "Read-only archive"+ show ErrNOPASSWD = "No password provided"+ show ErrWRONGPASSWD = "Wrong password provided"++-- | Compression methods.+data ZipCompMethod+ = CompDEFAULT -- ^ Better of deflate or store.+ | CompSTORE -- ^ Stored (uncompressed).+ | CompSHRINK -- ^ Shrunk.+ | CompREDUCE_1 -- ^ Reduced with factor 1+ | CompREDUCE_2 -- ^ Reduced with factor 2+ | CompREDUCE_3 -- ^ Reduced with factor 3+ | CompREDUCE_4 -- ^ Reduced with factor 4+ | CompIMPLODE -- ^ Imploded.+ | CompDEFLATE -- ^ Deflated.+ | CompDEFLATE64 -- ^ Deflate64.+ | CompPKWARE_IMPLODE -- ^ PKWARE imploding.+ | CompBZIP2 -- ^ Compressed using BZIP2 algorithm.+ | CompLZMA -- ^ LZMA (EFS)+ | CompTERSE -- ^ Compressed using IBM TERSE (new).+ | CompLZ77 -- ^ IBM LZ77 z Architecture (PFS).+ | CompWAVPACK -- ^ WavPack compressed data.+ | CompPPMD -- ^ PPMd version I, Rev 1.+ deriving (Show, Eq)++instance Enum ZipCompMethod where+ fromEnum CompDEFAULT = c'ZIP_CM_DEFAULT+ fromEnum CompSTORE = c'ZIP_CM_STORE+ fromEnum CompSHRINK = c'ZIP_CM_SHRINK+ fromEnum CompREDUCE_1 = c'ZIP_CM_REDUCE_1+ fromEnum CompREDUCE_2 = c'ZIP_CM_REDUCE_2+ fromEnum CompREDUCE_3 = c'ZIP_CM_REDUCE_3+ fromEnum CompREDUCE_4 = c'ZIP_CM_REDUCE_4+ fromEnum CompIMPLODE = c'ZIP_CM_IMPLODE+ fromEnum CompDEFLATE = c'ZIP_CM_DEFLATE+ fromEnum CompDEFLATE64 = c'ZIP_CM_DEFLATE64+ fromEnum CompPKWARE_IMPLODE = c'ZIP_CM_PKWARE_IMPLODE+ fromEnum CompBZIP2 = c'ZIP_CM_BZIP2+ fromEnum CompLZMA = c'ZIP_CM_LZMA+ fromEnum CompTERSE = c'ZIP_CM_TERSE+ fromEnum CompLZ77 = c'ZIP_CM_LZ77+ fromEnum CompWAVPACK = c'ZIP_CM_WAVPACK+ fromEnum CompPPMD = c'ZIP_CM_PPMD+ toEnum x | x == c'ZIP_CM_DEFAULT = CompDEFAULT+ toEnum x | x == c'ZIP_CM_STORE = CompSTORE+ toEnum x | x == c'ZIP_CM_SHRINK = CompSHRINK+ toEnum x | x == c'ZIP_CM_REDUCE_1 = CompREDUCE_1+ toEnum x | x == c'ZIP_CM_REDUCE_2 = CompREDUCE_2+ toEnum x | x == c'ZIP_CM_REDUCE_3 = CompREDUCE_3+ toEnum x | x == c'ZIP_CM_REDUCE_4 = CompREDUCE_4+ toEnum x | x == c'ZIP_CM_IMPLODE = CompIMPLODE+ toEnum x | x == c'ZIP_CM_DEFLATE = CompDEFLATE+ toEnum x | x == c'ZIP_CM_DEFLATE64 = CompDEFLATE64+ toEnum x | x == c'ZIP_CM_PKWARE_IMPLODE = CompPKWARE_IMPLODE+ toEnum x | x == c'ZIP_CM_BZIP2 = CompBZIP2+ toEnum x | x == c'ZIP_CM_LZMA = CompLZMA+ toEnum x | x == c'ZIP_CM_TERSE = CompTERSE+ toEnum x | x == c'ZIP_CM_LZ77 = CompLZ77+ toEnum x | x == c'ZIP_CM_WAVPACK = CompWAVPACK+ toEnum x | x == c'ZIP_CM_PPMD = CompPPMD+ toEnum _ = undefined++-- | Encryption methods.+data ZipEncryptionMethod+ = EncryptNONE -- ^ Not encrypted.+ | EncryptTRAD_PKWARE -- ^ Traditional PKWARE encryption.+ | EncryptUNKNOWN -- ^ Unknown algorithm.+ deriving (Show,Eq)++instance Enum ZipEncryptionMethod where+ fromEnum EncryptNONE = c'ZIP_EM_NONE+ fromEnum EncryptTRAD_PKWARE = c'ZIP_EM_TRAD_PKWARE+ fromEnum EncryptUNKNOWN = c'ZIP_EM_UNKNOWN+ toEnum x | x == c'ZIP_EM_NONE = EncryptNONE+ toEnum x | x == c'ZIP_EM_TRAD_PKWARE = EncryptTRAD_PKWARE+ toEnum x | x == c'ZIP_EM_UNKNOWN = EncryptUNKNOWN+ toEnum _ = undefined++combine :: (Enum a, Num b) => [a] -> b+combine fs = fromIntegral . foldr (.|.) 0 $ map fromEnum fs
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2009, Sergey Astanin+Copyright (c) 2009-2013, Sergey Astanin All rights reserved. Redistribution and use in source and binary forms, with or without
LibZip.cabal view
@@ -1,34 +1,55 @@ Name: LibZip-Version: 0.0.2+Version: 1.0.1 License: BSD3 License-File: LICENSE Author: Sergey Astanin Maintainer: Sergey Astanin <s.astanin@gmail.com>-Homepage: http://bitbucket.org/jetxee/hs-libzip/-Bug-reports: http://bitbucket.org/jetxee/hs-libzip/issues/+Homepage: http://bitbucket.org/astanin/hs-libzip/+Bug-reports: http://bitbucket.org/astanin/hs-libzip/issues/ Category: Codec, Foreign-Synopsis: Partial bindings to libzip to read zip archives.+Synopsis: Bindings to libzip, a library for manipulating zip archives. Description:- This package provides basic read-only access to zip-archives.- It is produced with @c2hs@ for @libzip@ ver. 0.9.-Exposed-modules: Codec.Archive.LibZip-Other-modules: C2HS+ libzip is a C library for reading, creating, and modifying zip archives.+ This package allows to use it from Haskell code. Build-Type: Simple-Cabal-Version: >= 1.2.3-Extra-Tmp-Files:- Codec/Archive/LibZip.hs- , Codec/Archive/LibZip.chs.h-Build-Tools: c2hs-Build-Depends: base >= 4.0 && < 4.2- , bytestring- , haskell98-GHC-Options: -Wall-Extensions: ForeignFunctionInterface- , FlexibleContexts- , DeriveDataTypeable- , CPP+Cabal-Version: >= 1.8 -Tested-with: GHC == 6.10.4+Extra-Source-Files:+ examples/hzip.hs+ , runTests.hs, Tests/Common.hs+ , Tests/MonadicTests.hs, Tests/test.zip, Tests/encrypted.zip +Library+ Exposed-Modules:+ Codec.Archive.LibZip+ Codec.Archive.LibZip.Types+ Other-Modules:+ Codec.Archive.LibZip.Errors+ Build-Depends:+ base >= 4.0 && < 5.0+ , bindings-libzip >= 1.0 && < 1.1+ , 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 >= 1.0 && < 1.1+ , directory+ , filepath+ , HUnit+ , mtl+ , time+ , bytestring+ , utf8-string
Setup.lhs view
@@ -1,24 +1,7 @@ #!/usr/bin/env runhaskell-> import Distribution.Simple-> import System.Cmd (system)-> import System.Exit (ExitCode(..))-> import Distribution.PackageDescription (emptyHookedBuildInfo)->-> main = defaultMainWithHooks simpleUserHooks-> { preBuild = generateC2HSdoths-> , runTests = runUnitTests-> }->-> generateC2HSdoths _ _ =-> system "c2hs -l" >>=-> onExit "Cannot copy C2HS.hs library module in." emptyHookedBuildInfo+> module Main where >-> runUnitTests _ _ _ _ =-> system "cd tests && runhaskell -lzip Tests.hs" >>=-> onExit "Some 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
+ Tests/Common.hs view
@@ -0,0 +1,21 @@+module Tests.Common+ ( testzip, encryptedzip, testfiles, lastfile, lastfilesize+ , world_txt+ , toUpper, toLower, map2+ ) where++import Data.Char (toUpper, toLower)++testzip = "Tests/test.zip"+encryptedzip = "Tests/encrypted.zip"+testfiles = [ "hello/", "hello/world.txt" ]+lastfile = last testfiles+lastfilesize = 71 :: Integer++world_txt = "And God saw everything that he had made,\+ \ and behold, it was very good.\n"++-- map odd positions with f, even positions with g+map2 :: (a -> b) -> (a -> b) -> [a] -> [b]+map2 f g [] = []+map2 f g (x:xs) = (f x):map2 g f xs
+ Tests/MonadicTests.hs view
@@ -0,0 +1,375 @@+{-# LANGUAGE FlexibleInstances #-}+module Tests.MonadicTests where++import Codec.Archive.LibZip+import Tests.Common++import Data.Int (Int64)+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 @?= ErrNOENT++ , "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+ addDirectory "hello"+ addFile "hello/world.txt" =<< sourceBuffer world_txt+ tmpzip `doesExistAnd` \f -> do+ 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"+ writeFile tmpsrc world_txt+ withArchive [CreateFlag] tmpzip $+ addFile "world.txt" =<< sourceFile tmpsrc 0 0+ tmpzip `doesExistAnd` \f -> do+ txt <- withArchive [] f $ fileContents [] "world.txt"+ removeFile tmpzip+ removeFile tmpsrc+ txt @?= world_txt++ , "create an archive/use sourceZip" ~: do+ tmpzip <- getTmpFileName "test_LibZip_sourceZip.zip"+ withArchive [] testzip $ do+ zsrc <- getZip+ lift $ withArchive [CreateFlag] tmpzip $+ addFile "world.txt" =<< sourceZip [] zsrc 1 0 0+ tmpzip `doesExistAnd` \f -> do+ 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+ { srcState = (0, length world_txt) -- needs a Storable instance+ , srcSize = length world_txt+ , srcMTime = Nothing+ , readSrc = \len (pos,lft) ->+ let n = min len lft+ buf = take n . drop pos $ world_txt+ in Just (n, buf, (pos+n,lft-n))+ }+ withArchive [CreateFlag] tmpzip $ do+ addFile "world.txt" =<< sourcePure src+ tmpzip `doesExistAnd` \f -> do+ 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+ tmpzip <- getTmpFileName "test_LibZip_delete.zip"+ mkArchive tmpzip orig+ fs_orig <- withArchive [] tmpzip $ fileNames []+ withArchive [] tmpzip $ deleteFile [] "two"+ 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)]+ r1 <- catchZipError+ (withArchive [] tmpzip $+ deleteFile [] "doesnotexist" >> return ErrOK)+ (return . id)+ r2 <- catchZipError+ (withArchive [] tmpzip $+ deleteFileIx 100 >> return ErrOK)+ (return . id)+ removeFile tmpzip+ (r1, r2) @?= (ErrNOENT, ErrINVAL)++ , "rename a file" ~: do+ tmpzip <- getTmpFileName "test_LibZip_rename.zip"+ mkArchive tmpzip [("world.txt", world_txt)]+ fs <- withArchive [] tmpzip $ do+ renameFile [] "world.txt" "hello.txt"+ 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)]+ r <- catchZipError+ (withArchive [] tmpzip $ do+ renameFile [] "doesnotexist" "hello.txt"+ return ErrOK)+ (return . id)+ removeFile tmpzip+ r @?= ErrNOENT++ -- -- 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")]+ withArchive [] tmpzip $+ 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"+ mkArchive tmpzip [("hello/",""), ("hello/world.txt", world_txt)]+ c2 <- withArchive [] tmpzip $ getComment []+ let com = "this is a test"+ withArchive [] tmpzip $ setComment com+ c2_added <- withArchive [] tmpzip $ getComment []+ withArchive [] tmpzip $ removeComment+ c2_removed <- withArchive [] tmpzip $ getComment []+ removeFile tmpzip+ -- 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"+ let world_comm = "this is a test"+ 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 $ removeFileComment [] world_path+ c_off' <- get_comm+ removeFile tmpzip+ -- 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)]+ c <- withArchive [] tmpzip $ do+ setFileComment [] "world.txt" "a comment to undo"+ unchangeFile [] "world.txt"+ getFileComment [] "world.txt"+ removeFile tmpzip+ -- 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)]+ c <- withArchive [] tmpzip $ do+ setComment "a comment to undo"+ unchangeArchive+ getComment []+ removeFile tmpzip+ -- 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)]+ c <- withArchive [] tmpzip $ do+ setComment "a comment to undo"+ setFileComment [] "world.txt" "a file comment to undo"+ unchangeAll+ c1 <- getComment []+ c2 <- getFileComment [] "world.txt"+ return (c1,c2)+ removeFile tmpzip+ -- 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+ tmpdir <- getTemporaryDirectory+ let tmpfile = tmpdir </> basename+ doesFileExist tmpfile >>= \b ->+ if b+ then removeFile tmpfile >> return tmpfile+ else return tmpfile++doesExistAnd filepath assertion = do+ exists <- doesFileExist filepath+ if exists+ then assertion filepath+ else False @? ( "File " ++ filepath ++ " does not exist." )++-- for sourcePure, requires FlexibleInstances+instance Storable (Int,Int) where+ sizeOf _ = 2 * sizeOf (0::Int)+ alignment _ = alignment (0::Int)+ peek ptr = do+ let ptr' = castPtr ptr :: Ptr Int+ a <- peekElemOff ptr' 0+ b <- peekElemOff ptr' 1+ return (a, b)+ poke ptr (a,b) = do+ let ptr' = castPtr ptr :: Ptr Int+ pokeElemOff ptr' 0 $ a+ pokeElemOff ptr' 1 $ b++mkArchive :: (Enum a) => FilePath -> [(FilePath, [a])] -> IO ()+mkArchive zipname contents =+ 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
+ Tests/encrypted.zip view
binary file changed (absent → 295 bytes)
+ Tests/test.zip view
binary file changed (absent → 283 bytes)
+ examples/hzip.hs view
@@ -0,0 +1,108 @@+-- A utility to list, add or extract files in a zip archive.+--+-- This is an example of using LibZip library.+--+-- (c) Sergey Astanin 2010+-- License: BSD3+--+import Codec.Archive.LibZip++import Control.Monad (liftM, when)+import Data.List (intercalate)+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, getCurrentDirectory, getDirectoryContents, makeRelativeToCurrentDirectory)+import System.Environment (getArgs)+import System.FilePath (joinPath, splitDirectories, takeDirectory)+import System.IO (stderr, hPutStr, hPutStrLn)++usage :: String+usage = unlines+ [ "Usage: hzip [l|a|x] archive.zip [files]"+ , " l list files in the archives"+ , " a add/update files or directories in the archive recursively"+ , " x extract files from the archive to the current direcotory"+ ]++main :: IO ()+main = do+ args <- getArgs+ case args of+ ("l":archive:_) -> list archive+ ("a":archive:files) -> mapM mkRel files >>= add archive+ ("x":archive:files) -> getCurrentDirectory >>= \d -> extract d archive files+ _ -> hPutStr stderr usage+ where+ mkRel = makeRelativeToCurrentDirectory++list :: FilePath -> IO ()+list archive = do+ stats <- withArchive [] archive $ do+ n <- numFiles []+ mapM (fileStatIx []) [0..(n-1)]+ mapM_ printEntry stats+ where+ printEntry e =+ let sz = padLeft 8 . show $ zs'size e+ mt = take 16 . show $ zs'mtime e+ nm = zs'name e+ in putStrLn $ intercalate " " [ sz, mt, nm ]+ padLeft n s = let m = max 0 (n - length s) in replicate m ' ' ++ s++add :: FilePath -> [FilePath] -> IO ()+add archive paths = mapM_ (addEntry archive) paths++-- not very effective: it opens the archive many times, but it should work+addEntry :: FilePath -> FilePath -> IO ()+addEntry a path = do+ isADir <- doesDirectoryExist path+ if isADir+ then printErrors a path $ do+ withArchive flags a $ mapM_ checkAddDirectory $ parents path+ paths <- filter (`notElem` [".",".."]) `liftM` getDirectoryContents path+ let rpaths = map (\e -> joinPath [path,e]) paths+ add a rpaths+ else do+ printErrors a path $+ withArchive flags a $ addOrUpdate path =<< sourceFile path 0 0+ where+ flags = [CreateFlag]+ parents = scanl1 (\p c -> joinPath [p,c]) . splitDirectories+ checkAddDirectory p = do+ e1 <- nameLocate [] p+ e2 <- nameLocate [] (p ++ "/")+ if e1 == Nothing && e2 == Nothing+ then addDirectory p+ else return (-1)+ addOrUpdate p src = do+ exists <- nameLocate [] p+ case exists of+ (Just i) -> replaceFileIx i src+ Nothing -> addFile p src >> return ()+ printErrors a p action =+ catchZipError+ ( action >> return () )+ ( \ze -> hPutStrLn stderr $ intercalate ": " [a, p, show ze] )++extract :: FilePath -> FilePath -> [FilePath] -> IO ()+extract outdir archive onlyFiles =+ withArchive [] archive $ do+ n <- numFiles []+ mapM_ (extractEntry outdir onlyFiles) [0..(n-1)]++-- silently overwrites existing files+extractEntry :: FilePath -> [FilePath] -> Integer -> Archive ()+extractEntry outdir onlyFiles i = do+ name <- fileName [] i+ let fspath = joinPath [outdir, name]+ let fsdir = takeDirectory fspath+ when (null onlyFiles || name `elem` onlyFiles) $+ if isDir name+ then lift $ createDirectoryIfMissing True fsdir+ else do+ b <- fileContentsIx [] i+ lift $ do+ createDirectoryIfMissing True fsdir+ writeFile fspath b -- FIXME: should be binary + where+ isDir "" = False+ isDir f = last f == '/'+
+ runTests.hs view
@@ -0,0 +1,15 @@+import Tests.MonadicTests (monadicTests)++import System.Exit+import Test.HUnit++allTests = TestList+ [ "Monadic API" ~: monadicTests+ ]++main = do+ result <- runTestTT allTests+ if (errors result + failures result) > 0+ then exitFailure+ else exitSuccess+