module Codec.Archive.LibZip
(
Archive
, Entry
, ZipStat(..)
, 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
, fromFile, fromFileIx
, readBytes, skipBytes, readContents
, fileContents, fileContentsIx
, OpenFlag(..)
, FileFlag(..)
, ZipCompMethod(..)
, ZipEncryptionMethod(..)
, ZipError(..)
, catchZipError
, 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
type Archive a = StateT Zip IO a
type Entry a = StateT
(ZipFile,Integer,[FileFlag])
(StateT Zip IO)
a
withArchive :: [OpenFlag]
-> FilePath
-> Archive a
-> 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
withEncryptedArchive :: [OpenFlag]
-> String
-> FilePath
-> Archive a
-> 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
numFiles :: [FileFlag]
-> Archive Integer
numFiles flags = do
z <- getZip
lift $ fromIntegral `liftM` c'zip_get_num_entries z (combine flags)
fileName :: [FileFlag]
-> Integer
-> Archive FilePath
fileName flags i = do
z <- getZip
lift $ do
n <- c'zip_get_name z (fromIntegral i) (combine flags)
doIf' (n /= nullPtr) z $ peekCString n
nameLocate :: [FileFlag]
-> FilePath
-> Archive (Maybe Integer)
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)
fileNames :: [FileFlag]
-> Archive [FilePath]
fileNames flags = do
n <- numFiles flags
mapM (fileName flags) [0..n1]
fileSize :: [FileFlag]
-> FilePath
-> Archive Integer
fileSize flags name = fileStat flags name >>= return . zs'size
fileSizeIx :: [FileFlag]
-> Integer
-> Archive Integer
fileSizeIx flags i = fileStatIx flags i >>= return . zs'size
fileStat :: [FileFlag]
-> FilePath
-> Archive ZipStat
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
fileStatIx :: [FileFlag]
-> Integer
-> Archive ZipStat
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
deleteFile :: [FileFlag]
-> FilePath
-> Archive ()
deleteFile flags name = do
mbi <- nameLocate flags name
maybe (lift $ E.throwIO ErrNOENT) deleteFileIx mbi
deleteFileIx :: Integer
-> 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
renameFile :: [FileFlag]
-> FilePath
-> FilePath
-> 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
renameFileIx :: Integer
-> BS.ByteString
-> [FileFlag]
-> 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
addFile :: FilePath
-> ZipSource
-> Archive Int
addFile name src =
let utf8name = UTF8.fromString name
in addFileWithFlags [FileENC_UTF_8] utf8name src
addFileWithFlags
:: [FileFlag]
-> BS.ByteString
-> ZipSource
-> Archive Int
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
addDirectory :: FilePath
-> Archive Int
addDirectory name =
let utf8name = UTF8.fromString name
in addDirectoryWithFlags [FileENC_UTF_8] utf8name
addDirectoryWithFlags
:: [FileFlag]
-> BS.ByteString
-> Archive Int
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)
replaceFile :: [FileFlag]
-> FilePath
-> ZipSource
-> 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
setFileCompression
:: [FileFlag]
-> FilePath
-> ZipCompMethod
-> Archive ()
setFileCompression flags name method = do
mbi <- nameLocate flags name
maybe (lift $ E.throwIO ErrNOENT) (\i -> setFileCompressionIx i method) mbi
setFileCompressionIx
:: Integer
-> ZipCompMethod
-> 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 ()
replaceFileIx :: Integer
-> ZipSource
-> 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 ()
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
sourceFile :: FilePath
-> Integer
-> Integer
-> 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
sourceZip :: [FileFlag]
-> Zip
-> Integer
-> Integer
-> Integer
-> 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
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
data PureSource a st szt = PureSource {
srcState :: st
, srcSize :: szt
, srcMTime :: Maybe UTCTime
, readSrc :: szt -> st -> Maybe (szt, [a], st)
}
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)
getComment :: [FileFlag]
-> 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
setComment :: String
-> 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 ()
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 ()
getFileComment :: [FileFlag]
-> FilePath
-> Archive (Maybe String)
getFileComment flags name = do
mbi <- nameLocate flags name
let comment_flags = filter (== FileUNCHANGED) flags
maybe (lift $ E.throwIO ErrNOENT)
(\i -> do
mbs <- getFileCommentIx comment_flags i
return $ liftM UTF8.toString mbs
) mbi
getFileCommentIx :: [FileFlag]
-> Integer
-> 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
setFileComment :: [FileFlag]
-> FilePath
-> String
-> 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
setFileCommentIx :: Integer
-> BS.ByteString
-> [FileFlag]
-> 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 ()
removeFileComment :: [FileFlag]
-> FilePath
-> Archive ()
removeFileComment flags path = do
mbi <- nameLocate flags path
maybe (lift $ E.throwIO ErrNOENT) removeFileCommentIx mbi
removeFileCommentIx :: Integer
-> Archive ()
removeFileCommentIx i = do
let flags = 0
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 ()
unchangeFile :: [FileFlag]
-> FilePath
-> Archive ()
unchangeFile flags name = do
mbi <- nameLocate flags name
maybe (lift $ E.throw ErrNOENT) unchangeFileIx mbi
unchangeFileIx :: Integer
-> 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 ()
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 ()
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 ()
fromFile :: [FileFlag]
-> FilePath
-> Entry a
-> 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
fromFileIx :: [FileFlag]
-> Integer
-> Entry a
-> 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
readBytes ::
(Enum a)
=> Integer
-> Entry [a]
readBytes n = do
lift . lift $
when (n > toInteger (maxBound::Int))
(E.throwIO ErrMEMORY)
(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
skipBytes :: Integer -> Entry ()
skipBytes n = (readBytes n :: Entry [Word8]) >> return ()
readContents ::
(Enum a)
=> Entry [a]
readContents = do
(_,i,flags) <- get
sz <- lift $ fileSizeIx flags i
readBytes sz
fileContents :: (Enum a)
=> [FileFlag]
-> FilePath
-> Archive [a]
fileContents flags name = fromFile flags name readContents
fileContentsIx :: (Enum a)
=> [FileFlag]
-> Integer
-> Archive [a]
fileContentsIx flags i = fromFileIx flags i readContents
getZip :: Archive Zip
getZip = do
z <- get
if z == nullPtr
then lift $ E.throwIO ErrINVAL
else return z
doIf :: Bool -> Zip -> (Zip -> IO a) -> IO a
doIf cnd z action =
if cnd
then action z
else get_error z >>= E.throwIO
doIf' :: Bool -> Zip -> (IO a) -> IO a
doIf' cnd z action = doIf cnd z (const action)