zip (empty) → 0.1.0
raw patch · 11 files changed
+3084/−0 lines, 11 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, bzlib-conduit, case-insensitive, cereal, conduit, conduit-extra, containers, criterion, digest, exceptions, filepath, hspec, mtl, path, path-io, plan-b, resourcet, semigroups, text, time, transformers, zip
Files
- CHANGELOG.md +3/−0
- Codec/Archive/Zip.hs +529/−0
- Codec/Archive/Zip/CP437.hs +163/−0
- Codec/Archive/Zip/Internal.hs +973/−0
- Codec/Archive/Zip/Type.hs +204/−0
- LICENSE.md +28/−0
- README.md +291/−0
- Setup.hs +6/−0
- bench/Main.hs +38/−0
- tests/Main.hs +723/−0
- zip.cabal +126/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+## Zip 0.1.0++* Initial release.
+ Codec/Archive/Zip.hs view
@@ -0,0 +1,529 @@+-- |+-- Module : Codec.Archive.Zip+-- Copyright : © 2016 Mark Karpov+-- License : BSD 3 clause+--+-- Maintainer : Mark Karpov <markkarpov@openmailbox.org>+-- Stability : experimental+-- Portability : portable+--+-- The module provides everything you need to manipulate Zip archives. There+-- are three things that should be clarified right away, to avoid confusion+-- in the future.+--+-- First, we use 'EntrySelector' type that can be obtained from 'Path' 'Rel'+-- 'File' paths. This method may seem awkward at first, but it will protect+-- you from problems with portability when your archive is unpacked on a+-- different platform. Using of well-typed paths is also something you+-- should consider doing in your projects anyway. Even if you don't want to+-- use "Path" module in your project, it's easy to marshal 'FilePath' to+-- 'Path' just before using functions from the library.+--+-- The second thing, that is rather a consequence of the first, is that+-- there is no way to add directories, or to be precise, /empty directories/+-- to your archive. This approach is used in Git, and I find it quite sane.+--+-- Finally, the third feature of the library is that it does not modify+-- archive instantly, because doing so on every manipulation would often be+-- inefficient. Instead we maintain collection of pending actions that can+-- be turned into optimized procedure that efficiently modifies archive in+-- one pass. Normally this should be of no concern to you, because all+-- actions are performed automatically when you leave the realm of+-- 'ZipArchive' monad. If, however, you ever need to force update, 'commit'+-- function is your friend. There are even “undo” functions, by the way.++{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Codec.Archive.Zip+ ( -- * Types+ -- ** Entry selector+ EntrySelector+ , mkEntrySelector+ , unEntrySelector+ , getEntryName+ , EntrySelectorException (..)+ -- ** Entry description+ , EntryDescription (..)+ , CompressionMethod (..)+ -- ** Archive description+ , ArchiveDescription (..)+ -- ** Exceptions+ , ZipException (..)+ -- * Archive monad+ , ZipArchive+ , createArchive+ , withArchive+ -- * Retrieving information+ , getEntries+ , doesEntryExist+ , getEntryDesc+ , getEntry+ , sourceEntry+ , saveEntry+ , checkEntry+ , unpackInto+ , getArchiveComment+ , getArchiveDescription+ -- * Modifying archive+ -- ** Adding entries+ , addEntry+ , sinkEntry+ , loadEntry+ , copyEntry+ , packDirRecur+ -- ** Modifying entries+ , renameEntry+ , deleteEntry+ , recompress+ , setEntryComment+ , deleteEntryComment+ , setModTime+ , addExtraField+ , deleteExtraField+ , forEntries+ -- ** Operations on archive as a whole+ , setArchiveComment+ , deleteArchiveComment+ -- ** Control over editing+ , undoEntryChanges+ , undoArchiveChanges+ , undoAll+ , commit )+where++import Codec.Archive.Zip.Type+import Control.Monad+import Control.Monad.Catch+import Control.Monad.State.Strict+import Control.Monad.Trans.Resource (ResourceT, runResourceT)+import Data.ByteString (ByteString)+import Data.Conduit (Source, Sink, ($$), yield)+import Data.Map.Strict (Map, (!))+import Data.Sequence (Seq, (|>))+import Data.Text (Text)+import Data.Time.Clock (UTCTime)+import Data.Word (Word16)+import Path+import Path.IO+import qualified Codec.Archive.Zip.Internal as I+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL+import qualified Data.Map.Strict as M+import qualified Data.Sequence as S+import qualified Data.Set as E++----------------------------------------------------------------------------+-- Archive monad++-- | Monad that provides context necessary for performing operations on+-- archives. It's intentionally opaque and not a monad transformer to limit+-- number of actions that can be performed in it to those provided by this+-- module and their combinations.++newtype ZipArchive a = ZipArchive+ { unZipArchive :: StateT ZipState IO a+ } deriving ( Functor+ , Applicative+ , Monad+ , MonadIO+ , MonadThrow+ , MonadCatch+ , MonadMask )++-- | Internal state record used by the 'ZipArchive' monad.++data ZipState = ZipState+ { zsFilePath :: Path Abs File+ -- ^ Absolute path to zip archive+ , zsEntries :: Map EntrySelector EntryDescription+ -- ^ Actual collection of entries+ , zsArchive :: ArchiveDescription+ -- ^ Info about the whole archive+ , zsActions :: Seq I.PendingAction+ -- ^ Pending actions+ }++-- | Create new archive given its location and action that describes how to+-- create content in the archive. This will silently overwrite specified+-- file if it already exists. See 'withArchive' if you want to work with+-- existing archive.++createArchive :: (MonadIO m, MonadCatch m)+ => Path b File -- ^ Location of archive file to create+ -> ZipArchive a -- ^ Actions that form archive's content+ -> m a+createArchive path m = do+ apath <- makeAbsolute path+ ignoringAbsence (removeFile apath)+ let st = ZipState+ { zsFilePath = apath+ , zsEntries = M.empty+ , zsArchive = ArchiveDescription Nothing 0 0+ , zsActions = S.empty }+ action = unZipArchive (liftM2 const m commit)+ liftIO (evalStateT action st)++-- | Work with an existing archive. See 'createArchive' if you want to+-- create new archive instead.+--+-- This operation may fail with:+--+-- * @isAlreadyInUseError@ if the file is already open and cannot be+-- reopened;+--+-- * @isDoesNotExistError@ if the file does not exist;+--+-- * @isPermissionError@ if the user does not have permission to open+-- the file;+--+-- * 'ParsingFailed' when specified archive is something this library+-- cannot parse (this includes multi-disk archives, for example).+--+-- Please note that entries with invalid (non-portable) file names may be+-- missing in list of entries. Files that are compressed with unsupported+-- compression methods are skipped as well. Also, if several entries would+-- collide on some operating systems (such as Windows, because of its+-- case-insensitivity), only one of them will be available, because+-- 'EntrySelector' is case-insensitive. These are consequences of the design+-- decision to make it impossible to create non-portable archives with this+-- library.++withArchive :: (MonadIO m, MonadThrow m)+ => Path b File -- ^ Location of archive to work with+ -> ZipArchive a -- ^ Actions on that archive+ -> m a+withArchive path m = do+ apath <- canonicalizePath path+ (desc, entries) <- liftIO (I.scanArchive apath)+ let st = ZipState+ { zsFilePath = apath+ , zsEntries = entries+ , zsArchive = desc+ , zsActions = S.empty }+ action = unZipArchive (liftM2 const m commit)+ liftIO (evalStateT action st)++----------------------------------------------------------------------------+-- Retrieving information++-- | Retrieve description of all archive entries. This is an efficient+-- operation that can be used for example to list all entries in archive. Do+-- not hesitate to use the function frequently: scanning of archive happens+-- only once anyway.+--+-- Please note that returned value only reflects actual contents of archive+-- in file system, non-committed actions cannot influence list of entries,+-- see 'commit' for more information.++getEntries :: ZipArchive (Map EntrySelector EntryDescription)+getEntries = ZipArchive (gets zsEntries)++-- | Check whether specified entry exists in the archive. This is a simple+-- shortcut defined as:+--+-- > doesEntryExist s = M.member s <$> getEntries++doesEntryExist :: EntrySelector -> ZipArchive Bool+doesEntryExist s = M.member s <$> getEntries++-- | Get 'EntryDescription' for specified entry. This is a simple shortcut+-- defined as:+--+-- > getEntryDesc s = M.lookup s <$> getEntries++getEntryDesc :: EntrySelector -> ZipArchive (Maybe EntryDescription)+getEntryDesc s = M.lookup s <$> getEntries++-- | Get contents of specific archive entry as strict 'ByteString'. It's not+-- recommended to use this on big entries, because it will suck out a lot of+-- memory. For big entries, use conduits: 'sourceEntry'.+--+-- Throws: 'EntryDoesNotExist'.++getEntry+ :: EntrySelector -- ^ Selector that identifies archive entry+ -> ZipArchive ByteString -- ^ Contents of the entry+getEntry s = sourceEntry s (CL.foldMap id)++-- | Stream contents of archive entry to specified 'Sink'.+--+-- Throws: 'EntryDoesNotExist'.++sourceEntry+ :: EntrySelector+ -- ^ Selector that identifies archive entry+ -> Sink ByteString (ResourceT IO) a+ -- ^ Sink where to stream entry contents+ -> ZipArchive a+ -- ^ Contents of the entry (if found)+sourceEntry s sink = do+ path <- getFilePath+ mdesc <- M.lookup s <$> getEntries+ case mdesc of+ Nothing -> throwM (EntryDoesNotExist path s)+ Just desc -> liftIO . runResourceT $ I.sourceEntry path desc True $$ sink++-- | Save specific archive entry as a file in the file system.+--+-- Throws: 'EntryDoesNotExist'.++saveEntry+ :: EntrySelector -- ^ Selector that identifies archive entry+ -> Path b File -- ^ Where to save the file+ -> ZipArchive ()+saveEntry s path = sourceEntry s (CB.sinkFile (toFilePath path))++-- | Calculate CRC32 check sum and compare it with value read from+-- archive. The function returns 'True' when the check sums are the same —+-- that is, data is not corrupted.+--+-- Throws: 'EntryDoesNotExist'.++checkEntry+ :: EntrySelector -- ^ Selector that identifies archive entry+ -> ZipArchive Bool -- ^ Is the entry intact?+checkEntry s = do+ calculated <- sourceEntry s I.crc32Sink+ given <- edCRC32 . (! s) <$> getEntries+ -- ↑ NOTE We can assume that entry exists for sure because otherwise+ -- 'sourceEntry' would have thrown 'EntryDoesNotExist' already.+ return (calculated == given)++-- | Unpack entire archive into specified directory. The directory will be+-- created if it does not exist.++unpackInto :: Path b Dir -> ZipArchive ()+unpackInto dir' = do+ selectors <- M.keysSet <$> getEntries+ unless (null selectors) $ do+ dir <- liftIO (makeAbsolute dir')+ liftIO (ensureDir dir)+ let dirs = E.map (parent . (dir </>) . unEntrySelector) selectors+ forM_ dirs (liftIO . ensureDir)+ forM_ selectors $ \s ->+ saveEntry s (dir </> unEntrySelector s)++-- | Get archive comment.++getArchiveComment :: ZipArchive (Maybe Text)+getArchiveComment = adComment <$> getArchiveDescription++-- | Get archive description record.++getArchiveDescription :: ZipArchive ArchiveDescription+getArchiveDescription = ZipArchive (gets zsArchive)++----------------------------------------------------------------------------+-- Modifying archive++-- | Add a new entry to archive given its contents in binary form.++addEntry+ :: CompressionMethod -- ^ Compression method to use+ -> ByteString -- ^ Entry contents+ -> EntrySelector -- ^ Name of entry to add+ -> ZipArchive ()+addEntry t b s = addPending (I.SinkEntry t (yield b) s)++-- | Stream data from the specified source to an archive entry.++sinkEntry+ :: CompressionMethod -- ^ Compression method to use+ -> Source (ResourceT IO) ByteString -- ^ Source of entry contents+ -> EntrySelector -- ^ Name of entry to add+ -> ZipArchive ()+sinkEntry t src s = addPending (I.SinkEntry t src s)++-- | Load entry from given file.++loadEntry+ :: CompressionMethod -- ^ Compression method to use+ -> (Path Abs File -> ZipArchive EntrySelector) -- ^ How to get 'EntrySelector'+ -> Path b File -- ^ Path to file to add+ -> ZipArchive ()+loadEntry t f path = do+ apath <- liftIO (canonicalizePath path)+ s <- f apath+ modTime <- liftIO (getModificationTime path)+ let src = CB.sourceFile (toFilePath apath)+ addPending (I.SinkEntry t src s)+ addPending (I.SetModTime modTime s)++-- | Copy entry “as is” from another .ZIP archive. If the entry does not+-- exists in that archive, 'EntryDoesNotExist' will be eventually thrown.++copyEntry+ :: Path b File -- ^ Path to archive to copy from+ -> EntrySelector -- ^ Name of entry (in source archive) to copy+ -> EntrySelector -- ^ Name of entry to insert (in actual archive)+ -> ZipArchive ()+copyEntry path s' s = do+ apath <- liftIO (canonicalizePath path)+ addPending (I.CopyEntry apath s' s)++-- | Add entire directory to archive. Please note that due to design of the+-- library, empty sub-directories won't be added.+--+-- The action can throw the same exceptions as 'listDirRecur' and+-- 'InvalidEntrySelector'.++packDirRecur+ :: CompressionMethod -- ^ Compression method to use+ -> (Path Abs File -> ZipArchive EntrySelector) -- ^ How to get 'EntrySelector'+ -> Path b Dir -- ^ Path to directory to add+ -> ZipArchive ()+packDirRecur t f path = do+ files <- snd <$> liftIO (listDirRecur path)+ mapM_ (loadEntry t f) files++-- | Rename entry in archive. If the entry does not exist, nothing will+-- happen.++renameEntry+ :: EntrySelector -- ^ Original entry name+ -> EntrySelector -- ^ New entry name+ -> ZipArchive ()+renameEntry old new = addPending (I.RenameEntry old new)++-- | Delete entry from archive, if it does not exist, nothing will happen.++deleteEntry :: EntrySelector -> ZipArchive ()+deleteEntry s = addPending (I.DeleteEntry s)++-- | Change compression method of an entry, if it does not exist, nothing+-- will happen.++recompress+ :: CompressionMethod -- ^ New compression method+ -> EntrySelector -- ^ Name of entry to re-compress+ -> ZipArchive ()+recompress t s = addPending (I.Recompress t s)++-- | Set entry comment, if that entry does not exist, nothing will+-- happen. Note that if binary representation of comment is longer than+-- 65535 bytes, it will be truncated on writing.++setEntryComment+ :: Text -- ^ Text of the comment+ -> EntrySelector -- ^ Name of entry to comment upon+ -> ZipArchive ()+setEntryComment text s = addPending (I.SetEntryComment text s)++-- | Delete entry's comment, if that entry does not exist, nothing will+-- happen.++deleteEntryComment :: EntrySelector -> ZipArchive ()+deleteEntryComment s = addPending (I.DeleteEntryComment s)++-- | Set “last modification” date\/time. Specified entry may be missing, in+-- that case this action has no effect.++setModTime+ :: UTCTime -- ^ New modification time+ -> EntrySelector -- ^ Name of entry to modify+ -> ZipArchive ()+setModTime time s = addPending (I.SetModTime time s)++-- | Add an extra field. Specified entry may be missing, in that case this+-- action has no effect.++addExtraField+ :: Word16 -- ^ Tag (header id) of extra field to add+ -> ByteString -- ^ Body of the field+ -> EntrySelector -- ^ Name of entry to modify+ -> ZipArchive ()+addExtraField n b s = addPending (I.AddExtraField n b s)++-- | Delete an extra field by its type (tag). Specified entry may be+-- missing, in that case this action has no effect.++deleteExtraField+ :: Word16 -- ^ Tag (header id) of extra field to delete+ -> EntrySelector -- ^ Name of entry to modify+ -> ZipArchive ()+deleteExtraField n s = addPending (I.DeleteExtraField n s)++-- | Perform an action on every entry in archive.++forEntries+ :: (EntrySelector -> ZipArchive ()) -- ^ Action to perform+ -> ZipArchive ()+forEntries action = getEntries >>= mapM_ action . M.keysSet++-- | Set comment of entire archive.++setArchiveComment :: Text -> ZipArchive ()+setArchiveComment text = addPending (I.SetArchiveComment text)++-- | Delete archive comment if it's present.++deleteArchiveComment :: ZipArchive ()+deleteArchiveComment = addPending I.DeleteArchiveComment++-- | Undo changes to specific archive entry.++undoEntryChanges :: EntrySelector -> ZipArchive ()+undoEntryChanges s = modifyActions f+ where f = S.filter ((/= Just s) . I.targetEntry)++-- | Undo changes to archive as a whole (archive's comment).++undoArchiveChanges :: ZipArchive ()+undoArchiveChanges = modifyActions f+ where f = S.filter ((/= Nothing) . I.targetEntry)++-- | Undo all changes made in this editing session.++undoAll :: ZipArchive ()+undoAll = modifyActions (const S.empty)++-- | Archive contents are not modified instantly, but instead changes are+-- collected as “pending actions” that should be committed in order to+-- efficiently modify archive in one pass. The actions are committed+-- automatically when program leaves the realm of 'ZipArchive' monad+-- (i.e. as part of 'createArchive' or 'withArchive'), or can be forced+-- explicitly with help of this function. Once committed, changes take place+-- in the file system and cannot be undone.++commit :: ZipArchive ()+commit = do+ file <- getFilePath+ odesc <- getArchiveDescription+ oentries <- getEntries+ actions <- getPending+ exists <- doesFileExist file+ unless (S.null actions && exists) $ do+ liftIO (I.commit file odesc oentries actions)+ -- NOTE The most robust way to update internal description of the+ -- archive is to scan it again — manual manipulations with descriptions+ -- of entries are too error-prone. We also want to erase all pending+ -- actions because 'I.commit' executes them all by definition.+ (ndesc, nentries) <- liftIO (I.scanArchive file)+ ZipArchive . modify $ \st -> st+ { zsEntries = nentries+ , zsArchive = ndesc+ , zsActions = S.empty }++----------------------------------------------------------------------------+-- Helpers++-- | Get path of actual archive file from inside of 'ZipArchive' monad.++getFilePath :: ZipArchive (Path Abs File)+getFilePath = ZipArchive (gets zsFilePath)++-- | Get collection of pending actions.++getPending :: ZipArchive (Seq I.PendingAction)+getPending = ZipArchive (gets zsActions)++-- | Modify collection of pending actions in some way.++modifyActions :: (Seq I.PendingAction -> Seq I.PendingAction) -> ZipArchive ()+modifyActions f = ZipArchive (modify g)+ where g st = st { zsActions = f (zsActions st) }++-- | Add new action to the list of pending actions.++addPending :: I.PendingAction -> ZipArchive ()+addPending a = modifyActions (|> a)
+ Codec/Archive/Zip/CP437.hs view
@@ -0,0 +1,163 @@+-- |+-- Module : Codec.Archive.Zip.CP437+-- Copyright : © 2016 Mark Karpov+-- License : BSD 3 clause+--+-- Maintainer : Mark Karpov <markkarpov@openmailbox.org>+-- Stability : experimental+-- Portability : portable+--+-- Support for decoding of CP437 text.++module Codec.Archive.Zip.CP437+ ( decodeCP437 )+where++import Data.ByteString (ByteString)+import Data.Char+import Data.Monoid+import Data.Text (Text)+import Data.Text.Lazy (toStrict)+import Data.Word (Word8)+import qualified Data.ByteString as B+import qualified Data.Text.Lazy.Builder as LB++-- | Decode a 'ByteString' containing CP 437 encoded text.++decodeCP437 :: ByteString -> Text+decodeCP437 = toStrict . LB.toLazyText . B.foldl' f mempty+ where f xs b = xs <> LB.singleton (decodeByteCP437 b)++-- | Decode single byte of CP437 encoded text.++decodeByteCP437 :: Word8 -> Char+decodeByteCP437 byte = chr $ case byte of+ 128 -> 199+ 129 -> 252+ 130 -> 233+ 131 -> 226+ 132 -> 228+ 133 -> 224+ 134 -> 229+ 135 -> 231+ 136 -> 234+ 137 -> 235+ 138 -> 232+ 139 -> 239+ 140 -> 238+ 141 -> 236+ 142 -> 196+ 143 -> 197+ 144 -> 201+ 145 -> 230+ 146 -> 198+ 147 -> 244+ 148 -> 246+ 149 -> 242+ 150 -> 251+ 151 -> 249+ 152 -> 255+ 153 -> 214+ 154 -> 220+ 155 -> 162+ 156 -> 163+ 157 -> 165+ 158 -> 8359+ 159 -> 402+ 160 -> 225+ 161 -> 237+ 162 -> 243+ 163 -> 250+ 164 -> 241+ 165 -> 209+ 166 -> 170+ 167 -> 186+ 168 -> 191+ 169 -> 8976+ 170 -> 172+ 171 -> 189+ 172 -> 188+ 173 -> 161+ 174 -> 171+ 175 -> 187+ 176 -> 9617+ 177 -> 9618+ 178 -> 9619+ 179 -> 9474+ 180 -> 9508+ 181 -> 9569+ 182 -> 9570+ 183 -> 9558+ 184 -> 9557+ 185 -> 9571+ 186 -> 9553+ 187 -> 9559+ 188 -> 9565+ 189 -> 9564+ 190 -> 9563+ 191 -> 9488+ 192 -> 9492+ 193 -> 9524+ 194 -> 9516+ 195 -> 9500+ 196 -> 9472+ 197 -> 9532+ 198 -> 9566+ 199 -> 9567+ 200 -> 9562+ 201 -> 9556+ 202 -> 9577+ 203 -> 9574+ 204 -> 9568+ 205 -> 9552+ 206 -> 9580+ 207 -> 9575+ 208 -> 9576+ 209 -> 9572+ 210 -> 9573+ 211 -> 9561+ 212 -> 9560+ 213 -> 9554+ 214 -> 9555+ 215 -> 9579+ 216 -> 9578+ 217 -> 9496+ 218 -> 9484+ 219 -> 9608+ 220 -> 9604+ 221 -> 9612+ 222 -> 9616+ 223 -> 9600+ 224 -> 945+ 225 -> 223+ 226 -> 915+ 227 -> 960+ 228 -> 931+ 229 -> 963+ 230 -> 181+ 231 -> 964+ 232 -> 934+ 233 -> 920+ 234 -> 937+ 235 -> 948+ 236 -> 8734+ 237 -> 966+ 238 -> 949+ 239 -> 8745+ 240 -> 8801+ 241 -> 177+ 242 -> 8805+ 243 -> 8804+ 244 -> 8992+ 245 -> 8993+ 246 -> 247+ 247 -> 8776+ 248 -> 176+ 249 -> 8729+ 250 -> 183+ 251 -> 8730+ 252 -> 8319+ 253 -> 178+ 254 -> 9632+ 255 -> 160+ x -> fromIntegral x -- the rest of characters translate directly
+ Codec/Archive/Zip/Internal.hs view
@@ -0,0 +1,973 @@+-- |+-- Module : Codec.Archive.Zip.Internal+-- Copyright : © 2016 Mark Karpov+-- License : BSD 3 clause+--+-- Maintainer : Mark Karpov <markkarpov@openmailbox.org>+-- Stability : experimental+-- Portability : portable+--+-- Low-level, non-public concepts and operations.++{-# LANGUAGE ScopedTypeVariables #-}++module Codec.Archive.Zip.Internal+ ( PendingAction (..)+ , targetEntry+ , scanArchive+ , sourceEntry+ , crc32Sink+ , commit )+where++import Codec.Archive.Zip.CP437 (decodeCP437)+import Codec.Archive.Zip.Type+import Control.Applicative (many, (<|>))+import Control.Monad+import Control.Monad.Catch+import Control.Monad.Trans.Resource (ResourceT, runResourceT)+import Data.Bits+import Data.Bool (bool)+import Data.ByteString (ByteString)+import Data.Char (ord)+import Data.Conduit (Conduit, Source, Sink, (=$=), ($$), awaitForever, yield)+import Data.Conduit.Internal (zipSinks)+import Data.Digest.CRC32 (crc32Update)+import Data.Foldable (foldl')+import Data.Map.Strict (Map, (!))+import Data.Maybe (fromJust, catMaybes, isNothing)+import Data.Monoid ((<>))+import Data.Sequence (Seq, (><), (|>))+import Data.Serialize+import Data.Text (Text)+import Data.Time+import Data.Version+import Data.Word (Word16, Word32)+import Numeric.Natural (Natural)+import Path+import System.IO+import System.PlanB+import qualified Data.ByteString as B+import qualified Data.Conduit.BZlib as BZ+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL+import qualified Data.Conduit.Zlib as Z+import qualified Data.Map.Strict as M+import qualified Data.Sequence as S+import qualified Data.Set as E+import qualified Data.Text as T+import qualified Data.Text.Encoding as T++----------------------------------------------------------------------------+-- Data types++-- | The sum type describes all possible actions that can be performed on+-- archive.++data PendingAction+ = SinkEntry CompressionMethod (Source (ResourceT IO) ByteString) EntrySelector+ -- ^ Add entry given its 'Source'+ | CopyEntry (Path Abs File) EntrySelector EntrySelector+ -- ^ Copy an entry form another archive without re-compression+ | RenameEntry EntrySelector EntrySelector+ -- ^ Change name the entry inside archive+ | DeleteEntry EntrySelector+ -- ^ Delete entry from archive+ | Recompress CompressionMethod EntrySelector+ -- ^ Change compression method on an entry+ | SetEntryComment Text EntrySelector+ -- ^ Set comment for a particular entry+ | DeleteEntryComment EntrySelector+ -- ^ Delete comment of particular entry+ | SetModTime UTCTime EntrySelector+ -- ^ Set modification time of particular entry+ | AddExtraField Word16 ByteString EntrySelector+ -- ^ Add an extra field to specified entry+ | DeleteExtraField Word16 EntrySelector+ -- ^ Delete an extra filed of specified entry+ | SetArchiveComment Text+ -- ^ Set comment for entire archive+ | DeleteArchiveComment+ -- ^ Delete comment of entire archive++-- | Collection of maps describing how to produce entries in resulting+-- archive.++data ProducingActions = ProducingActions+ { paCopyEntry :: Map (Path Abs File) (Map EntrySelector EntrySelector)+ , paSinkEntry :: Map EntrySelector (Source (ResourceT IO) ByteString) }++-- | Collection of editing actions, that is, actions that modify already+-- existing entries.++data EditingActions = EditingActions+ { eaCompression :: Map EntrySelector CompressionMethod+ , eaEntryComment :: Map EntrySelector Text+ , eaDeleteComment :: Map EntrySelector ()+ , eaModTime :: Map EntrySelector UTCTime+ , eaExtraField :: Map EntrySelector (Map Word16 ByteString)+ , eaDeleteField :: Map EntrySelector (Map Word16 ()) }++-- | Origins of entries that can be streamed into archive.++data EntryOrigin+ = GenericOrigin+ | Borrowed EntryDescription++-- | Type of file header: local or central directory.++data HeaderType+ = LocalHeader+ | CentralDirHeader+ deriving Eq++-- | Data descriptor representation.++data DataDescriptor = DataDescriptor+ { ddCRC32 :: Word32+ , ddCompressedSize :: Natural+ , ddUncompressedSize :: Natural }++-- | A temporary data structure to hold Zip64 extra data field information.++data Zip64ExtraField = Zip64ExtraField+ { z64efUncompressedSize :: Natural+ , z64efCompressedSize :: Natural+ , z64efOffset :: Natural }++-- | MS-DOS date-time: a pair of 'Word16' (date, time) with the following+-- structure:+--+-- > DATE bit 0 - 4 5 - 8 9 - 15+-- > value day (1 - 31) month (1 - 12) years from 1980+-- > TIME bit 0 - 4 5 - 10 11 - 15+-- > value seconds* minute hour+-- > *stored in two-second increments++data MsDosTime = MsDosTime+ { msDosDate :: Word16+ , msDosTime :: Word16 }++----------------------------------------------------------------------------+-- Constants++-- | Version to specify when writing archive data. For now it's a constant.++zipVersion :: Version+zipVersion = Version [4,6] []++----------------------------------------------------------------------------+-- Higher-level operations++-- | Scan central directory of an archive and return its description+-- 'ArchiveDescription' as well as collection of its entries.+--+-- This operation may fail with:+--+-- * @isAlreadyInUseError@ if the file is already open and cannot be+-- reopened;+--+-- * @isDoesNotExistError@ if the file does not exist;+--+-- * @isPermissionError@ if the user does not have permission to open+-- the file;+--+-- * 'ParsingFailed' when specified archive is something this library+-- cannot parse (this includes multi-disk archives, for example).+--+-- Please note that entries with invalid (non-portable) file names may be+-- missing in list of entries. Files that are compressed with unsupported+-- compression methods are skipped as well. Also, if several entries would+-- collide on some operating systems (such as Windows, because of its+-- case-insensitivity), only one of them will be available, because+-- 'EntrySelector' is case-insensitive. These are consequences of the design+-- decision to make it impossible to create non-portable archives with this+-- library.++scanArchive+ :: Path Abs File -- ^ Path to archive to scan+ -> IO (ArchiveDescription, Map EntrySelector EntryDescription)+scanArchive path = withFile (toFilePath path) ReadMode $ \h -> do+ mecdOffset <- locateECD path h+ case mecdOffset of+ Just ecdOffset -> do+ hSeek h AbsoluteSeek ecdOffset+ ecdSize <- subtract ecdOffset <$> hFileSize h+ ecdRaw <- B.hGet h (fromIntegral ecdSize)+ case runGet getECD ecdRaw of+ Left msg -> throwM (ParsingFailed path msg)+ Right ecd -> do+ hSeek h AbsoluteSeek $ fromIntegral (adCDOffset ecd)+ cdRaw <- B.hGet h $ fromIntegral (adCDSize ecd)+ case runGet getCD cdRaw of+ Left msg -> throwM (ParsingFailed path msg)+ Right cd -> return (ecd, cd)+ Nothing ->+ throwM (ParsingFailed path "Cannot locate end of central directory")++-- | Given location of archive and information about specific archive entry+-- 'EntryDescription', return 'Source' of its data. Actual data can be+-- compressed or uncompressed depending on the third argument.++sourceEntry+ :: Path Abs File -- ^ Path to archive that contains the entry+ -> EntryDescription -- ^ Information needed to extract entry of interest+ -> Bool -- ^ Should we stream uncompressed data?+ -> Source (ResourceT IO) ByteString -- ^ Source of uncompressed data+sourceEntry path EntryDescription {..} d =+ source =$= CB.isolate (fromIntegral edCompressedSize) =$= decompress+ where+ source = CB.sourceIOHandle $ do+ h <- openFile (toFilePath path) ReadMode+ hSeek h AbsoluteSeek (fromIntegral edOffset)+ localHeader <- B.hGet h 30+ case runGet getLocalHeaderGap localHeader of+ Left msg -> throwM (ParsingFailed path msg)+ Right gap -> do+ hSeek h RelativeSeek gap+ return h+ decompress = if d+ then decompressingPipe edCompression+ else awaitForever yield++-- | Undertake /all/ actions specified as the fourth argument of the+-- function. This transforms given pending actions so they can be performed+-- in one pass, and then they are performed in the most efficient way.++commit+ :: Path Abs File -- ^ Location of archive file to edit or create+ -> ArchiveDescription -- ^ Archive description+ -> Map EntrySelector EntryDescription -- ^ Current list of entires+ -> Seq PendingAction -- ^ Collection of pending actions+ -> IO ()+commit path ArchiveDescription {..} entries xs =+ withNewFile (overrideIfExists <>+ nameTemplate ".zip" <>+ tempDir (parent path) <>+ moveByRenaming) path $ \temp -> do+ let (ProducingActions coping sinking, editing) =+ optimize (toRecreatingActions path entries >< xs)+ comment = predictComment adComment xs+ withFile (toFilePath temp) WriteMode $ \h -> do+ copiedCD <- M.unions <$> forM (M.keys coping) (\srcPath ->+ copyEntries h srcPath (coping ! srcPath) editing)+ let sinkingKeys = M.keys $ sinking `M.difference` copiedCD+ sunkCD <- M.fromList <$> forM sinkingKeys (\selector ->+ sinkEntry h selector GenericOrigin (sinking ! selector) editing)+ writeCD h comment (copiedCD `M.union` sunkCD)++-- | Determine what comment in new archive will look like given its original+-- value and collection of pending actions.++predictComment :: Maybe Text -> Seq PendingAction -> Maybe Text+predictComment original xs =+ case S.index xs <$> S.findIndexR (isNothing . targetEntry) xs of+ Nothing -> original+ Just DeleteArchiveComment -> Nothing+ Just (SetArchiveComment txt) -> Just txt+ Just _ -> Nothing++-- | Transform map representing existing entries into collection of actions+-- that re-create those entires.++toRecreatingActions+ :: Path Abs File -- ^ Name of archive file where entires are found+ -> Map EntrySelector EntryDescription -- ^ Actual list of entires+ -> Seq PendingAction -- ^ Actions that recreate the archive entries+toRecreatingActions path entries = E.foldl' f S.empty (M.keysSet entries)+ where f s e = s |> CopyEntry path e e++-- | Transform collection of 'PendingAction's into 'ProducingActions' and+-- 'EditingActions' — collection of data describing how to create resulting+-- archive.++optimize+ :: Seq PendingAction -- ^ Collection of pending actions+ -> (ProducingActions, EditingActions) -- ^ Optimized data+optimize = foldl' f+ ( ProducingActions M.empty M.empty+ , EditingActions M.empty M.empty M.empty M.empty M.empty M.empty )+ where+ f (pa, ea) a = case a of+ SinkEntry m src s ->+ ( pa { paSinkEntry = M.insert s src (paSinkEntry pa)+ , paCopyEntry = M.map (M.filter (/= s)) (paCopyEntry pa) }+ , (clearEditingFor s ea)+ { eaCompression = M.insert s m (eaCompression ea) } )+ CopyEntry path os ns ->+ ( pa { paSinkEntry = M.delete ns (paSinkEntry pa)+ , paCopyEntry = M.alter (ef os ns) path (paCopyEntry pa) }+ , clearEditingFor ns ea )+ RenameEntry os ns ->+ ( pa { paCopyEntry = M.map (M.map $ re os ns) (paCopyEntry pa)+ , paSinkEntry = renameKey os ns (paSinkEntry pa) }+ , ea { eaCompression = renameKey os ns (eaCompression ea)+ , eaEntryComment = renameKey os ns (eaEntryComment ea)+ , eaDeleteComment = renameKey os ns (eaDeleteComment ea)+ , eaModTime = renameKey os ns (eaModTime ea)+ , eaExtraField = renameKey os ns (eaExtraField ea)+ , eaDeleteField = renameKey os ns (eaDeleteField ea) } )+ DeleteEntry s ->+ ( pa { paSinkEntry = M.delete s (paSinkEntry pa)+ , paCopyEntry = M.map (M.delete s) (paCopyEntry pa) }+ , clearEditingFor s ea )+ Recompress m s ->+ (pa, ea { eaCompression = M.insert s m (eaCompression ea) })+ SetEntryComment txt s ->+ ( pa+ , ea { eaEntryComment = M.insert s txt (eaEntryComment ea)+ , eaDeleteComment = M.delete s (eaDeleteComment ea) } )+ DeleteEntryComment s ->+ ( pa+ , ea { eaEntryComment = M.delete s (eaEntryComment ea)+ , eaDeleteComment = M.insert s () (eaDeleteComment ea) } )+ SetModTime time s ->+ (pa, ea { eaModTime = M.insert s time (eaModTime ea) })+ AddExtraField n b s ->+ ( pa+ , ea { eaExtraField = M.alter (ef n b) s (eaExtraField ea)+ , eaDeleteField = M.delete s (eaDeleteField ea) } )+ DeleteExtraField n s ->+ ( pa+ , ea { eaExtraField = M.alter (er n) s (eaExtraField ea)+ , eaDeleteField = M.alter (ef n ()) s (eaDeleteField ea) } )+ _ -> (pa, ea)+ clearEditingFor s ea = ea+ { eaCompression = M.delete s (eaCompression ea)+ , eaEntryComment = M.delete s (eaEntryComment ea)+ , eaDeleteComment = M.delete s (eaDeleteComment ea)+ , eaModTime = M.delete s (eaModTime ea)+ , eaExtraField = M.delete s (eaExtraField ea)+ , eaDeleteField = M.delete s (eaDeleteField ea) }+ re o n x = if x == o then n else x+ ef k v (Just m) = Just (M.insert k v m)+ ef k v Nothing = Just (M.singleton k v)+ er k (Just m) = let n = M.delete k m in+ if M.null n then Nothing else Just n+ er _ Nothing = Nothing++-- | Copy entries from another archive and write them into file associated+-- with given handle. This actually can throw 'EntryDoesNotExist' if there+-- is no such entry in that archive.++copyEntries+ :: Handle -- ^ Opened 'Handle' of zip archive file+ -> Path Abs File -- ^ Path to file from which to copy the entries+ -> Map EntrySelector EntrySelector+ -- ^ 'Map' from original name to name to use in new archive+ -> EditingActions -- ^ Additional info that can influence result+ -> IO (Map EntrySelector EntryDescription)+ -- ^ Info to generate central directory file headers later+copyEntries h path m e = do+ entries <- snd <$> scanArchive path+ done <- forM (M.keys m) $ \s ->+ case s `M.lookup` entries of+ Nothing -> throwM (EntryDoesNotExist path s)+ Just desc -> sinkEntry h (m ! s) (Borrowed desc)+ (sourceEntry path desc False) e+ return (M.fromList done)++-- | Sink entry from given stream into file associated with given 'Handle'.++sinkEntry+ :: Handle -- ^ Opened 'Handle' of zip archive file+ -> EntrySelector -- ^ Name of entry to add+ -> EntryOrigin -- ^ Origin of entry (can contain additional info)+ -> Source (ResourceT IO) ByteString -- ^ Source of entry contents+ -> EditingActions -- ^ Additional info that can influence result+ -> IO (EntrySelector, EntryDescription)+ -- ^ Info to generate central directory file headers later+sinkEntry h s o src EditingActions {..} = do+ currentTime <- getCurrentTime+ offset <- hTell h+ let compressed = case o of+ GenericOrigin -> Store+ Borrowed ed -> edCompression ed+ compression = M.findWithDefault compressed s eaCompression+ recompression = compression /= compressed+ modTime = case o of+ GenericOrigin -> currentTime+ Borrowed ed -> edModTime ed+ oldExtraFields = case o of+ GenericOrigin -> M.empty+ Borrowed ed -> edExtraField ed+ extraField =+ (M.findWithDefault M.empty s eaExtraField `M.union` oldExtraFields)+ `M.difference` M.findWithDefault M.empty s eaDeleteField+ oldComment = case (o, M.lookup s eaDeleteComment) of+ (GenericOrigin, _) -> Nothing+ (Borrowed ed, Nothing) -> edComment ed+ (Borrowed _, Just ()) -> Nothing+ desc' = EntryDescription -- to write in local header+ { edVersionMadeBy = zipVersion+ , edVersionNeeded = zipVersion+ , edCompression = compression+ , edModTime = M.findWithDefault modTime s eaModTime+ , edCRC32 = 0 -- to be overwritten after streaming+ , edCompressedSize = 0 -- ↑+ , edUncompressedSize = 0 -- ↑+ , edOffset = fromIntegral offset+ , edComment = M.lookup s eaEntryComment <|> oldComment+ , edExtraField = extraField }+ B.hPut h (runPut (putHeader LocalHeader s desc'))+ DataDescriptor {..} <- runResourceT $+ if recompression+ then+ if compressed == Store+ then src $$ sinkData h compression+ else src =$= decompressingPipe compressed $$ sinkData h compression+ else src $$ sinkData h Store+ afterStreaming <- hTell h+ let desc = case o of+ GenericOrigin -> desc'+ { edCRC32 = ddCRC32+ , edCompressedSize = ddCompressedSize+ , edUncompressedSize = ddUncompressedSize }+ Borrowed ed -> desc'+ { edCRC32 =+ bool (edCRC32 ed) ddCRC32 recompression+ , edCompressedSize =+ bool (edCompressedSize ed) ddCompressedSize recompression+ , edUncompressedSize =+ bool (edUncompressedSize ed) ddUncompressedSize recompression }+ hSeek h AbsoluteSeek offset+ B.hPut h (runPut (putHeader LocalHeader s desc))+ hSeek h AbsoluteSeek afterStreaming+ return (s, desc)++-- | Create 'Sink' to stream data there. Once streaming is finished, return+-- 'DataDescriptor' for the streamed data. The action /does not/ close given+-- 'Handle'.++sinkData+ :: Handle -- ^ Opened 'Handle' of zip archive file+ -> CompressionMethod -- ^ Compression method to apply+ -> Sink ByteString (ResourceT IO) DataDescriptor+ -- ^ 'Sink' where to stream data+sinkData h compression = do+ let sizeSink = CL.fold (\acc input -> fromIntegral (B.length input) + acc) 0+ dataSink = fst <$> zipSinks sizeSink (CB.sinkHandle h)+ withCompression = zipSinks (zipSinks sizeSink crc32Sink)+ ((uncompressedSize, crc32), compressedSize) <-+ case compression of+ Store -> withCompression+ dataSink+ Deflate -> withCompression $+ Z.compress 9 (Z.WindowBits (-15)) =$= dataSink+ BZip2 -> withCompression $+ BZ.bzip2 =$= dataSink+ return DataDescriptor+ { ddCRC32 = fromIntegral crc32+ , ddCompressedSize = compressedSize+ , ddUncompressedSize = uncompressedSize }++-- | Append central directory entries and end of central directory record to+-- file that given 'Handle' is associated with. Note that this automatically+-- writes Zip64 end of central directory record and Zip64 end of central+-- directory locator when necessary.++writeCD+ :: Handle -- ^ Opened handle of zip archive file+ -> Maybe Text -- ^ Commentary to entire archive+ -> Map EntrySelector EntryDescription+ -- ^ Info about already written local headers and entry data+ -> IO ()+writeCD h comment m = do+ let cd = runPut (putCD m)+ cdOffset <- hTell h+ B.hPut h cd -- write central directory+ let totalCount = M.size m+ cdSize = B.length cd+ needZip64 = totalCount >= 0xffff+ || cdSize >= 0xffffffff+ || cdOffset >= 0xffffffff+ when needZip64 $ do+ zip64ecdOffset <- hTell h+ B.hPut h . runPut $ putZip64ECD totalCount cdSize cdOffset+ B.hPut h . runPut $ putZip64ECDLocator zip64ecdOffset+ B.hPut h . runPut $ putECD totalCount cdSize cdOffset comment++----------------------------------------------------------------------------+-- Binary serialization++-- | Extract number of bytes between start of file name in local header and+-- start of actual data.++getLocalHeaderGap :: Get Integer+getLocalHeaderGap = do+ getSignature 0x04034b50+ skip 2 -- version needed to extract+ skip 2 -- general purpose bit flag+ skip 2 -- compression method+ skip 2 -- last mod file time+ skip 2 -- last mod file date+ skip 4 -- crc-32 check sum+ skip 4 -- compressed size+ skip 4 -- uncompressed size+ fileNameSize <- fromIntegral <$> getWord16le -- file name length+ extraFieldSize <- fromIntegral <$> getWord16le -- extra field length+ return (fileNameSize + extraFieldSize)++-- | Parse central directory file headers and put them into 'Map'.++getCD :: Get (Map EntrySelector EntryDescription)+getCD = M.fromList . catMaybes <$> many getCDHeader++-- | Parse single central directory file header. If it's a directory or file+-- compressed with unsupported compression method, 'Nothing' is returned.++getCDHeader :: Get (Maybe (EntrySelector, EntryDescription))+getCDHeader = do+ getSignature 0x02014b50 -- central file header signature+ versionMadeBy <- toVersion <$> getWord16le -- version made by+ versionNeeded <- toVersion <$> getWord16le -- version needed to extract+ bitFlag <- getWord16le -- general purpose bit flag+ when (any (testBit bitFlag) [0,6,13]) $+ fail "Encrypted archives are not supported"+ let needUnicode = testBit bitFlag 11+ mcompression <- toCompressionMethod <$> getWord16le -- compression method+ modTime <- getWord16le -- last mod file time+ modDate <- getWord16le -- last mod file date+ crc32 <- getWord32le -- CRC32 check sum+ compressed <- fromIntegral <$> getWord32le -- compressed size+ uncompressed <- fromIntegral <$> getWord32le -- uncompressed size+ fileNameSize <- getWord16le -- file name length+ extraFieldSize <- getWord16le -- extra field length+ commentSize <- getWord16le -- file comment size+ skip 8 -- disk number start, internal/external file attributes+ offset <- fromIntegral <$> getWord32le -- offset of local header+ fileName <- decodeText needUnicode <$>+ getBytes (fromIntegral fileNameSize) -- file name+ extraField <- M.fromList <$>+ isolate (fromIntegral extraFieldSize) (many getExtraField)+ -- ↑ extra fields in their raw form+ comment <- decodeText needUnicode <$> getBytes (fromIntegral commentSize)+ -- ↑ file comment+ let dfltZip64 = Zip64ExtraField+ { z64efUncompressedSize = uncompressed+ , z64efCompressedSize = compressed+ , z64efOffset = offset }+ z64ef = case M.lookup 1 extraField of+ Nothing -> dfltZip64+ Just b -> parseZip64ExtraField dfltZip64 b+ case mcompression of+ Nothing -> return Nothing+ Just compression ->+ let desc = EntryDescription+ { edVersionMadeBy = versionMadeBy+ , edVersionNeeded = versionNeeded+ , edCompression = compression+ , edModTime = fromMsDosTime (MsDosTime modDate modTime)+ , edCRC32 = crc32+ , edCompressedSize = z64efCompressedSize z64ef+ , edUncompressedSize = z64efUncompressedSize z64ef+ , edOffset = z64efOffset z64ef+ , edComment = if commentSize == 0 then Nothing else comment+ , edExtraField = extraField }+ in return $ (,desc) <$>+ (fileName >>= parseRelFile . T.unpack >>= mkEntrySelector)++-- | Parse an extra-field.++getExtraField :: Get (Word16, ByteString)+getExtraField = do+ header <- getWord16le -- header id+ size <- getWord16le -- data size+ body <- getBytes (fromIntegral size) -- content+ return (header, body)++-- | Get signature. If extracted data is not equal to provided signature,+-- fail.++getSignature :: Word32 -> Get ()+getSignature sig = do+ x <- getWord32le -- grab 4-byte signature+ unless (x == sig) . fail $+ "Expected signature " ++ show sig ++ ", but got: " ++ show x++-- | Parse 'Zip64ExtraField' from its binary representation.++parseZip64ExtraField+ :: Zip64ExtraField -- ^ What is read from central directory file header+ -> ByteString -- ^ Actual binary representation+ -> Zip64ExtraField -- ^ Result+parseZip64ExtraField dflt@Zip64ExtraField {..} b =+ either (const dflt) id . flip runGet b $ do+ let ifsat v = if v >= 0xffffffff+ then fromIntegral <$> getWord64le+ else return v+ uncompressed <- ifsat z64efUncompressedSize -- uncompressed size+ compressed <- ifsat z64efCompressedSize -- compressed size+ offset <- ifsat z64efOffset -- offset of local file header+ return (Zip64ExtraField uncompressed compressed offset)++-- | Produce binary representation of 'Zip64ExtraField'.++makeZip64ExtraField+ :: HeaderType -- ^ Is this for local or central directory header?+ -> Zip64ExtraField -- ^ Zip64 extra field's data+ -> ByteString -- ^ Resulting representation+makeZip64ExtraField c Zip64ExtraField {..} = runPut $ do+ when (c == LocalHeader || z64efUncompressedSize >= 0xffffffff) $+ putWord64le (fromIntegral z64efUncompressedSize) -- uncompressed size+ when (c == LocalHeader || z64efCompressedSize >= 0xffffffff) $+ putWord64le (fromIntegral z64efCompressedSize) -- compressed size+ when (c == CentralDirHeader && z64efOffset >= 0xffffffff) $+ putWord64le (fromIntegral z64efOffset) -- offset of local file header++-- | Create 'ByteString' representing an extra field.++putExtraField :: Map Word16 ByteString -> Put+putExtraField m = forM_ (M.keys m) $ \headerId -> do+ let b = B.take 0xffff (m ! headerId)+ putWord16le headerId+ putWord16le (fromIntegral $ B.length b)+ putByteString b++-- | Create 'ByteString' representing entire central directory.++putCD :: Map EntrySelector EntryDescription -> Put+putCD m = forM_ (M.keys m) $ \s ->+ putHeader CentralDirHeader s (m ! s)++-- | Create 'ByteString' representing local file header if the first+-- argument is 'False' and central directory file header otherwise.++putHeader+ :: HeaderType -- ^ Type of header to generate+ -> EntrySelector -- ^ Name of entry to write+ -> EntryDescription -- ^ Description of entry+ -> Put+putHeader c' s EntryDescription {..} = do+ let c = c' == CentralDirHeader+ putWord32le (bool 0x04034b50 0x02014b50 c)+ -- ↑ local/central file header signature+ when c $+ putWord16le (fromVersion edVersionMadeBy) -- version made by+ putWord16le (fromVersion edVersionNeeded) -- version needed to extract+ let entryName = getEntryName s+ rawName = T.encodeUtf8 entryName+ comment = B.take 0xffff (maybe B.empty T.encodeUtf8 edComment)+ unicode = needsUnicode entryName+ || maybe False needsUnicode edComment+ modTime = toMsDosTime edModTime+ putWord16le (if unicode then setBit 0 11 else 0)+ -- ↑ general purpose bit-flag+ putWord16le (fromCompressionMethod edCompression) -- compression method+ putWord16le (msDosTime modTime) -- last mod file time+ putWord16le (msDosDate modTime) -- last mod file date+ putWord32le edCRC32 -- CRC-32 checksum+ putWord32le (withSaturation edCompressedSize) -- compressed size+ putWord32le (withSaturation edUncompressedSize) -- uncompressed size+ putWord16le (fromIntegral $ B.length rawName) -- file name length+ let zip64ef = makeZip64ExtraField c' Zip64ExtraField+ { z64efUncompressedSize = edUncompressedSize+ , z64efCompressedSize = edCompressedSize+ , z64efOffset = edOffset }+ extraField = B.take 0xffff . runPut . putExtraField $+ M.insert 1 zip64ef edExtraField+ putWord16le (fromIntegral $ B.length extraField) -- extra field length+ when c $ do+ putWord16le (fromIntegral $ B.length comment) -- file comment length+ putWord16le 0 -- disk number start+ putWord16le 0 -- internal file attributes+ putWord32le 0 -- external file attributes+ putWord32le (withSaturation edOffset) -- relative offset of local header+ putByteString rawName -- file name (variable size)+ putByteString extraField -- extra field (variable size)+ when c (putByteString comment) -- file comment (variable size)++-- | Create 'ByteString' representing Zip64 end of central directory record.++putZip64ECD+ :: Int -- ^ Total number of entries+ -> Int -- ^ Size of the central directory+ -> Integer -- ^ Offset of central directory record+ -> Put+putZip64ECD totalCount cdSize cdOffset = do+ putWord32le 0x06064b50 -- zip64 end of central dir signature+ putWord64le 44 -- size of zip64 end of central dir record+ putWord16le (fromVersion zipVersion) -- version made by+ putWord16le (fromVersion zipVersion) -- version needed to extract+ putWord32le 0 -- number of this disk+ putWord32le 0 -- number of the disk with the start of the central directory+ putWord64le (fromIntegral totalCount) -- total number of entries (this disk)+ putWord64le (fromIntegral totalCount) -- total number of entries+ putWord64le (fromIntegral cdSize) -- size of the central directory+ putWord64le (fromIntegral cdOffset) -- offset of central directory++-- | Create 'ByteString' representing Zip64 end of central directory+-- locator.++putZip64ECDLocator+ :: Integer -- ^ Offset of Zip64 end of central directory+ -> Put+putZip64ECDLocator ecdOffset = do+ putWord32le 0x07064b50 -- zip64 end of central dir locator signature+ putWord32le 0 -- number of the disk with the start of the zip64 end of+ -- central directory+ putWord64le (fromIntegral ecdOffset) -- relative offset of the zip64 end+ -- of central directory record+ putWord32le 1 -- total number of disks++-- | Parse end of central directory record or Zip64 end of central directory+-- record depending on signature binary data begins with.++getECD :: Get ArchiveDescription+getECD = do+ sig <- getWord32le -- end of central directory signature+ let zip64 = sig == 0x06064b50+ unless (sig == 0x06054b50 || sig == 0x06064b50) $+ fail "Cannot locate end of central directory"+ zip64size <- if zip64 then do+ x <- getWord64le -- size of zip64 end of central directory record+ skip 2 -- version made by+ skip 2 -- version needed to extract+ return (Just x)+ else return Nothing+ thisDisk <- bool (fromIntegral <$> getWord16le) getWord32le zip64+ -- ↑ number of this disk+ cdDisk <- bool (fromIntegral <$> getWord16le) getWord32le zip64+ -- ↑ number of the disk with the start of the central directory+ unless (thisDisk == 0 && cdDisk == 0) $+ fail "No support for multi-disk archives"+ skip (bool 2 8 zip64)+ -- ↑ total number of entries in the central directory on this disk+ skip (bool 2 8 zip64)+ -- ↑ total number of entries in the central directory+ cdSize <- bool (fromIntegral <$> getWord32le) getWord64le zip64+ -- ↑ size of the central directory+ cdOffset <- bool (fromIntegral <$> getWord32le) getWord64le zip64+ -- ↑ offset of start of central directory with respect to the starting+ -- disk number+ when zip64 . skip . fromIntegral $ fromJust zip64size - 4 -- obviously+ commentSize <- getWord16le -- .ZIP file comment length+ comment <- decodeText True <$> getBytes (fromIntegral commentSize)+ -- ↑ archive comment, it's uncertain how we should decide on encoding here+ return ArchiveDescription+ { adComment = if commentSize == 0 then Nothing else comment+ , adCDOffset = fromIntegral cdOffset+ , adCDSize = fromIntegral cdSize }++-- | Create 'ByteString' representing end of central directory record.++putECD+ :: Int -- ^ Total number of entries+ -> Int -- ^ Size of the central directory+ -> Integer -- ^ Offset of central directory record+ -> Maybe Text -- ^ Zip file comment+ -> Put+putECD totalCount cdSize cdOffset mcomment = do+ putWord32le 0x06054b50 -- end of central dir signature+ putWord16le 0 -- number of this disk+ putWord16le 0 -- number of the disk with the start of the central directory+ putWord16le (withSaturation totalCount)+ -- ↑ total number of entries on this disk+ putWord16le (withSaturation totalCount) -- total number of entries+ putWord32le (withSaturation cdSize) -- size of central directory+ putWord32le (withSaturation cdOffset) -- offset of start of central directory+ let comment = maybe B.empty T.encodeUtf8 mcomment+ putWord16le (fromIntegral $ B.length comment)+ putByteString comment++-- | Find absolute offset of end of central directory record or, if present,+-- Zip64 end of central directory record.++locateECD :: Path Abs File -> Handle -> IO (Maybe Integer)+locateECD path h = sizeCheck+ where++ sizeCheck = do+ tooSmall <- (< 22) <$> hFileSize h+ if tooSmall+ then return Nothing+ else hSeek h SeekFromEnd (-22) >> loop++ loop = do+ sig <- getNum getWord32le 4+ pos <- subtract 4 <$> hTell h+ let again = hSeek h AbsoluteSeek (pos - 1) >> loop+ done = pos == 0+ if sig == 0x06054b50+ then do+ result <- checkComment pos >>+ checkCDSig >>+ checkZip64+ case result of+ Nothing -> bool again (return Nothing) done+ Just ecd -> return (Just ecd)+ else bool again (return Nothing) done++ checkComment pos = do+ size <- hFileSize h+ hSeek h AbsoluteSeek (pos + 20)+ l <- fromIntegral <$> getNum getWord16le 2+ return $ if l + 22 == size - pos+ then Just pos+ else Nothing++ checkCDSig pos = do+ hSeek h AbsoluteSeek (pos + 16)+ sigPos <- fromIntegral <$> getNum getWord32le 4+ if sigPos == 0xffffffff -- Zip64 is probably used+ then return (Just pos)+ else do+ hSeek h AbsoluteSeek sigPos+ cdSig <- getNum getWord32le 4+ return $ if cdSig == 0x02014b50 || cdSig == 0x06054b50+ then Just pos+ else Nothing++ checkZip64 pos =+ if pos < 20+ then return (Just pos)+ else do+ hSeek h AbsoluteSeek (pos - 20)+ zip64locatorSig <- getNum getWord32le 4+ if zip64locatorSig == 0x07064b50+ then do+ hSeek h AbsoluteSeek (pos - 12)+ Just . fromIntegral <$> getNum getWord64le 8+ else return (Just pos)++ getNum f n = do+ result <- runGet f <$> B.hGet h n+ case result of+ Left msg -> throwM (ParsingFailed path msg)+ Right val -> return val++----------------------------------------------------------------------------+-- Helpers++-- | Chain 'Maybe' monad inside 'IO' monad.++infixl 1 >>+++(>>+) :: IO (Maybe a) -> (a -> IO (Maybe b)) -> IO (Maybe b)+a >>+ b = a >>= maybe (return Nothing) b++-- | Rename entry (key) in a 'Map'.++renameKey :: Ord k => k -> k -> Map k a -> Map k a+renameKey ok nk m = case M.lookup ok m of+ Nothing -> m+ Just e -> M.insert nk e (M.delete ok m)++-- | Like 'fromIntegral', but with saturation when converting to bounded+-- types.++withSaturation :: forall a b. (Integral a, Integral b, Bounded b) => a -> b+withSaturation x =+ if x > fromIntegral (maxBound :: b)+ then maxBound :: b+ else fromIntegral x++-- | Determine target entry of action.++targetEntry :: PendingAction -> Maybe EntrySelector+targetEntry (SinkEntry _ _ s) = Just s+targetEntry (CopyEntry _ _ s) = Just s+targetEntry (RenameEntry s _) = Just s+targetEntry (DeleteEntry s) = Just s+targetEntry (Recompress _ s) = Just s+targetEntry (SetEntryComment _ s) = Just s+targetEntry (DeleteEntryComment s) = Just s+targetEntry (SetModTime _ s) = Just s+targetEntry (AddExtraField _ _ s) = Just s+targetEntry (DeleteExtraField _ s) = Just s+targetEntry (SetArchiveComment _) = Nothing+targetEntry DeleteArchiveComment = Nothing++-- | Decode 'ByteString'. The first argument indicates whether we should+-- treat it as UTF-8 (in case bit 11 of general-purpose bit flag is set),+-- otherwise the function assumes CP437. Note that since not every stream of+-- bytes constitute valid UTF-8 text, this function can fail. In that case+-- 'Nothing' is returned.++decodeText+ :: Bool -- ^ Whether bit 11 of general-purpose bit flag is set+ -> ByteString -- ^ Binary data to decode+ -> Maybe Text -- ^ Decoded 'Text' in case of success+decodeText False = Just . decodeCP437+decodeText True = either (const Nothing) Just . T.decodeUtf8'++-- | Detect if the given text needs newer Unicode-aware features to be+-- properly encoded in archive.++needsUnicode :: Text -> Bool+needsUnicode = not . T.all validCP437+ where validCP437 x = ord x <= 127++-- | Convert numeric representation (as per .ZIP specification) of version+-- into 'Version'.++toVersion :: Word16 -> Version+toVersion x = makeVersion [major, minor]+ where (major, minor) = quotRem (fromIntegral $ x .&. 0x00ff) 10++-- | Covert 'Version' to its numeric representation as per .ZIP+-- specification.++fromVersion :: Version -> Word16+fromVersion v = fromIntegral (major * 10 + minor)+ where (major:minor:_) = versionBranch v ++ repeat 0++-- | Get compression method form its numeric representation.++toCompressionMethod :: Word16 -> Maybe CompressionMethod+toCompressionMethod 0 = Just Store+toCompressionMethod 8 = Just Deflate+toCompressionMethod 12 = Just BZip2+toCompressionMethod _ = Nothing++-- | Convert 'CompressionMethod' to its numeric representation as per .ZIP+-- specification.++fromCompressionMethod :: CompressionMethod -> Word16+fromCompressionMethod Store = 0+fromCompressionMethod Deflate = 8+fromCompressionMethod BZip2 = 12++-- | Return decompressing 'Conduit' corresponding to given compression+-- method.++decompressingPipe+ :: CompressionMethod+ -> Conduit ByteString (ResourceT IO) ByteString+decompressingPipe Store = awaitForever yield+decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)+decompressingPipe BZip2 = BZ.bunzip2++-- | Sink that calculates CRC32 check sum for incoming stream.++crc32Sink :: Sink ByteString (ResourceT IO) Word32+crc32Sink = CL.fold crc32Update 0++-- | Convert 'UTCTime' to MS-DOS time format.++toMsDosTime :: UTCTime -> MsDosTime+toMsDosTime UTCTime {..} = MsDosTime dosDate dosTime+ where+ dosTime = fromIntegral (seconds + shiftL minutes 5 + shiftL hours 11)+ dosDate = fromIntegral (day + shiftL month 5 + shiftL year 9)++ seconds = fromEnum (todSec tod) `quot` 2000000000000+ minutes = todMin tod+ hours = todHour tod+ tod = timeToTimeOfDay utctDayTime++ year = fromIntegral year' - 1980+ (year', month, day) = toGregorian utctDay++-- | Convert MS-DOS date-time to 'UTCTime'.++fromMsDosTime :: MsDosTime -> UTCTime+fromMsDosTime MsDosTime {..} = UTCTime+ (fromGregorian year month day)+ (secondsToDiffTime $ hours * 3600 + minutes * 60 + seconds)+ where+ seconds = fromIntegral $ 2 * (msDosTime .&. 0x1f)+ minutes = fromIntegral (shiftR msDosTime 5 .&. 0x3f)+ hours = fromIntegral (shiftR msDosTime 11 .&. 0x1f)++ day = fromIntegral (msDosDate .&. 0x1f)+ month = fromIntegral $ shiftR msDosDate 5 .&. 0x0f+ year = 1980 + fromIntegral (shiftR msDosDate 9)
+ Codec/Archive/Zip/Type.hs view
@@ -0,0 +1,204 @@+-- |+-- Module : Codec.Archive.Zip.Type+-- Copyright : © 2016 Mark Karpov+-- License : BSD 3 clause+--+-- Maintainer : Mark Karpov <markkarpov@openmailbox.org>+-- Stability : experimental+-- Portability : portable+--+-- Types used by the package. You don't usually need to import this module,+-- because "Codec.Archive.Zip" re-exports everything you may need, import+-- that module instead.++{-# LANGUAGE DeriveDataTypeable #-}++module Codec.Archive.Zip.Type+ ( -- * Entry selector+ EntrySelector+ , mkEntrySelector+ , unEntrySelector+ , getEntryName+ , EntrySelectorException (..)+ -- * Entry description+ , EntryDescription (..)+ , CompressionMethod (..)+ -- * Archive desrciption+ , ArchiveDescription (..)+ -- * Exceptions+ , ZipException (..) )+where++import Control.Arrow ((>>>))+import Control.Exception (Exception)+import Control.Monad.Catch (MonadThrow (..))+import Data.ByteString (ByteString)+import Data.CaseInsensitive (CI)+import Data.List.NonEmpty (NonEmpty)+import Data.Map (Map)+import Data.Maybe (mapMaybe, fromJust)+import Data.Text (Text)+import Data.Time.Clock (UTCTime)+import Data.Typeable (Typeable)+import Data.Version (Version)+import Data.Word (Word16, Word32)+import Numeric.Natural+import Path+import qualified Data.ByteString as B+import qualified Data.CaseInsensitive as CI+import qualified Data.List.NonEmpty as NE+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified System.FilePath as FP+import qualified System.FilePath.Posix as Posix+import qualified System.FilePath.Windows as Windows++----------------------------------------------------------------------------+-- Entry selector++-- | This data type serves for naming and selection of archive+-- entries. It can be created only with help of smart constructor+-- 'mkEntrySelector', and it's the only “key” that can be used to select+-- files in archive or to name new files.+--+-- The abstraction is crucial for ensuring that created archives are+-- portable across operating systems, file systems, and different+-- platforms. Since on some operating systems, file paths are+-- case-insensitive, this selector is also case-insensitive. It makes sure+-- that only relative paths are used to name files inside archive, as it's+-- recommended in the specification. It also guarantees that forward slashes+-- are used when the path is stored inside archive for compatibility with+-- Unix-like operating systems (as it is recommended in the+-- specification). On the other hand, in can be rendered as ordinary+-- relative file path in OS-specific format, when needed.++newtype EntrySelector = EntrySelector+ { unES :: NonEmpty (CI String)+ -- ^ Path pieces of relative path inside archive+ } deriving (Eq, Ord)++instance Show EntrySelector where+ show = show . unEntrySelector++-- | Create 'EntrySelector' from @Path Rel File@. To avoid problems with+-- distribution of the archive, characters that some operating systems do+-- not expect in paths are not allowed. Proper paths should pass these+-- checks:+--+-- * 'System.FilePath.Posix.isValid'+-- * 'System.FilePath.Windows.isValid'+-- * binary representation of normalized path should be not longer than+-- 65535 bytes+--+-- This function can throw 'EntrySelectorException' exception.++mkEntrySelector :: MonadThrow m => Path Rel File -> m EntrySelector+mkEntrySelector path =+ let fp = toFilePath path+ g x = if null x then Nothing else Just (CI.mk x)+ preparePiece = g . filter (not . FP.isPathSeparator)+ pieces = mapMaybe preparePiece (FP.splitPath fp)+ selector = EntrySelector (NE.fromList pieces)+ binLength = B.length . T.encodeUtf8 . getEntryName+ in if Posix.isValid fp &&+ Windows.isValid fp &&+ fp /= "." && -- work around bug in path package+ not (null pieces) &&+ binLength selector <= 0xffff+ then return selector+ else throwM (InvalidEntrySelector path)++-- | Make a relative path from 'EntrySelector'. Every 'EntrySelector'+-- produces single @Path Rel File@ that corresponds to it.++unEntrySelector :: EntrySelector -> Path Rel File+unEntrySelector = unES+ >>> NE.toList+ >>> fmap CI.original+ >>> FP.joinPath+ >>> parseRelFile+ >>> fromJust++-- | Get entry name given 'EntrySelector' in from that is suitable for+-- writing to file header.++getEntryName :: EntrySelector -> Text+getEntryName = unES+ >>> fmap CI.original+ >>> NE.intersperse "/"+ >>> NE.toList+ >>> concat+ >>> T.pack++-- | Exception describing various troubles you can have with+-- 'EntrySelector'.++data EntrySelectorException+ = InvalidEntrySelector (Path Rel File)+ -- ^ Selector cannot be created from this path+ deriving (Typeable)++instance Show EntrySelectorException where+ show (InvalidEntrySelector path) = "Cannot build selector from " ++ show path++instance Exception EntrySelectorException++----------------------------------------------------------------------------+-- Entry description++-- | This record represents all information about archive entry that can be+-- stored in a .ZIP archive. It does not mirror local file header or central+-- directory file header, but their binary representation can be built given+-- this date structure and actual archive contents.++data EntryDescription = EntryDescription+ { edVersionMadeBy :: Version -- ^ Version made by+ , edVersionNeeded :: Version -- ^ Version needed to extract+ , edCompression :: CompressionMethod -- ^ Compression method+ , edModTime :: UTCTime -- ^ Last modification date and time+ , edCRC32 :: Word32 -- ^ CRC32 check sum+ , edCompressedSize :: Natural -- ^ Size of compressed entry+ , edUncompressedSize :: Natural -- ^ Size of uncompressed entry+ , edOffset :: Natural -- ^ Absolute offset of local file header+ , edComment :: Maybe Text -- ^ Entry comment+ , edExtraField :: Map Word16 ByteString -- ^ All extra fields found+ } deriving Eq++-- | Supported compression methods.++data CompressionMethod+ = Store -- ^ Store file uncompressed+ | Deflate -- ^ Deflate+ | BZip2 -- ^ Compressed using BZip2 algorithm+ deriving (Eq, Enum, Read, Show)++----------------------------------------------------------------------------+-- Archive description++-- | Information about archive as a whole.++data ArchiveDescription = ArchiveDescription+ { adComment :: Maybe Text -- ^ Comment of entire archive+ , adCDOffset :: Natural -- ^ Absolute offset of start of central directory+ , adCDSize :: Natural -- ^ Size of central directory record+ } deriving (Eq, Show)++----------------------------------------------------------------------------+-- Exceptions++-- | Bad things that can happen when you use the library.++data ZipException+ = EntryDoesNotExist (Path Abs File) EntrySelector+ -- ^ Thrown when you try to get contents of non-existing entry+ | ParsingFailed (Path Abs File) String+ -- ^ Thrown when archive structure cannot be parsed+ deriving (Typeable)++instance Show ZipException where+ show (EntryDoesNotExist file s) =+ "No such entry found: " ++ show s ++ " in " ++ show file+ show (ParsingFailed file msg) =+ "Parsing of archive structure failed: \n" ++ msg ++ "\nin " ++ show file++instance Exception ZipException
+ LICENSE.md view
@@ -0,0 +1,28 @@+Copyright © 2016 Mark Karpov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++* 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.++* Neither the name Mark Karpov nor the names of contributors may be used to+ endorse or promote products derived from this software without specific+ prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “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 COPYRIGHT HOLDERS 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.
+ README.md view
@@ -0,0 +1,291 @@+# Zip++[](http://opensource.org/licenses/BSD-3-Clause)+[](https://hackage.haskell.org/package/zip)+[](http://stackage.org/nightly/package/zip)+[](https://travis-ci.org/mrkkrp/zip)+[](https://coveralls.io/github/mrkkrp/zip?branch=master)++* [Why this library is written](#why-this-library-is-written)+ * [zip-archive](#zip-archive)+ * [LibZip](#libzip)+ * [zip-conduit](#zip-conduit)+* [Features](#features)+ * [Compression methods](#compression-methods)+ * [Encryption](#encryption)+ * [Sources of file data](#sources-of-file-data)+ * [ZIP64](#zip64)+ * [Filenames](#filenames)+ * [Meta-information about files](#meta-information-about-files)+* [Quick start](#quick-start)+* [Contribution](#contribution)+* [License](#license)++This is a feature-rich, memory-efficient, and type-safe library to+manipulate Zip archives in Haskell. The library is the most complete and+efficient implementation of .ZIP specification in pure Haskell (at least+from open-sourced ones). In particular, it's created with large multimedia+data in mind and provides all features users might expect, comparable in+terms of feature-set with libraries like `libzip` in C.++## Why this library is written++There are a few libraries to work with Zip archives, yet every one of them+provides only subset of all functionality user may need (obviously the+libraries provide functionality that their authors needed) and otherwise is+flawed in some way so it cannot be easily used in some situations. Let's+examine all libraries available on Hackage to understand motivation for this+package.++### zip-archive++`zip-archive` is a widely used library. It's quite old, well-known and+simple to use. However it creates Zip archives purely, as `ByteStrings`s in+memory that you can then write to the file system. This is not acceptable if+you work with more-or-less big data. For example, if you have collection of+files with total size of 500 MB and you want to pack them into an archive,+you can easily consume up to 1 GB of memory (files plus resulting+archive). Not always you can afford to do this or do this at scale. Even if+you want just to look at list of archive entries it will read it into memory+in all its entirety. For my use-case it's not acceptable.++### LibZip++This is bindings to C library+[`libzip`](https://en.wikipedia.org/wiki/Libzip). There is always certain+kind of trouble when you are using bindings. For example, you need to take+care that target library is installed and its version is compatible with+version of your binding. Yes, this means additional headaches. It should be+just “plug and play” (if you're using Stack), but now you need to watch out+for compatibility.++It's not that bad with libraries that do not break their API for years, but+it's not the case with `libzip`. As maintainer of `LibZip` puts it:++> libzip 0.10, 0.11, and 1.0 are not binary compatible. If your C library is+> 0.11.x, then you should use LibZip 0.11. If your C library is 1.0, then+> you should use LibZip master branch (not yet released to Hackage).++Now, on my machine I have version 1.0. To put the package on Stackage we had+to use version 0.10, because Stackage uses Ubuntu to build packages and+libraries on Ubuntu are always ancient. This means that I cannot use version+of the library from Stackage, and I don't yet know what will be on the+server.++After much frustration with all these things I decided to avoid using of+`LibZip`, because after all, this is not that sort of project that shouldn't+be done in pure Haskell. By rewriting this in Haskell, I also can make it+safer to use.++### zip-conduit++This one uses the right approach: leverage good streaming library+(`conduit`) for memory-efficient processing. This is however is not+feature-rich and has certain problems (including programming style, it uses+`error` if an entry is missing in archive, among other things), some of them+are reported on its issue tracker. It also does not appear to be maintained+(last sign of activity was on December 23, 2014).++## Features++The library supports all features specified in modern .ZIP specification+except for encryption and multi-disk archives. See more about this below.++For reference, here is a [copy of the specification](https://pkware.cachefly.net/webdocs/casestudies/APPNOTE.TXT).++### Compression methods++`zip` supports the following compression methods:++* Store (no compression, just store files “as is”)+* [DEFLATE](https://en.wikipedia.org/wiki/DEFLATE)+* [Bzip2](https://en.wikipedia.org/wiki/Bzip2)++The best way to add new compression method to the library is to write+conduit that will do the compression and publish it as a library. `zip` can+then depend on it and add it to the list of supported compression+methods. Current list of compression methods reflects what is available on+Hackage at the moment.++### Encryption++Encryption is currently not supported. Encryption system described in Zip+specification is known to be seriously flawed, so it's probably not the best+way to protect your data anyway. The encryption method seems to be+proprietary technology of PKWARE (at least that's what stated about it in+the .ZIP specification), so to hell with it.++### Sources of file data++The library gives you many options how to get file contents to compress and+how to get extracted data. The following methods are supported:++* *File name.* This is an efficient method to perform compression or+ decompression. You just specify where to get data or where to save it and+ the rest is handled by the library.++* *Conduit source or sink.*++* *ByteString.* Use it only with small data.++* *Copy file from another archive.* Efficient operation, file is copied “as+ is” — no re-compression is performed.++### ZIP64++When necessary, the `ZIP64` extension is automatically used. It's necessary+when anything from this list takes place:++* Total size of archive is greater than 4 GB.++* Size of compressed/uncompressed file in archive is greater than 4 GB.++* There are more than 65535 entries in archive.++The library is particularly suited for processing of large files. For+example, I've been able to easily create 6.5 GB archive with reasonable+speed and without any significant memory consumption.++### Filenames++The library has API that makes it impossible to create archive with+non-portable or invalid file names in it.++As of .ZIP specification 6.3.2, files with Unicode symbols in their names+can be put into Zip archives. The library supports mechanisms for this and+uses them automatically when needed. Besides UTF-8, CP437 is also supported+as it's required in the specification.++### Meta-information about files++The library allows to attach comments to entire archive or individual files,+and also gives its user full control over extra fields that are written to+file headers, so the user can store arbitrary information about file in the+archive.++## Quick start++The module `Codec.Archive.Zip` provides everything you need to manipulate+Zip archives. There are three things that should be clarified right away, to+avoid confusion in the future.++First, we use `EntrySelector` type that can be obtained from `Path Rel File`+paths. This method may seem awkward at first, but it will protect you from+problems with portability when your archive is unpacked on a different+platform. Using of well-typed paths is also something you should consider+doing in your projects anyway. Even if you don't want to use `Path` module+in your project, it's easy to marshal `FilePath` to `Path` just before using+functions from the library.++The second thing, that is rather a consequence of the first, is that there+is no way to add directories, or to be precise, *empty directories* to your+archive. This approach is used in Git, and I find it quite sane.++Finally, the third feature of the library is that it does not modify archive+instantly, because doing so on every manipulation would often be+inefficient. Instead we maintain collection of pending actions that can be+turned into optimized procedure that efficiently modifies archive in one+pass. Normally this should be of no concern to you, because all actions are+performed automatically when you leave the realm of `ZipArchive` monad. If,+however, you ever need to force update, `commit` function is your+friend. There are even “undo” functions, by the way.++Let's take a look at some examples that show how to accomplish most typical+tasks with help of the library.++To get full information about archive entries, use `getEntries`:++```haskell+λ> withArchive archivePath (M.keys <$> getEntries)+```++This will return list of all entries in archive at `archivePath`. It's+possible to extract contents of archive as strict `ByteString`:++```haskell+λ> withArchive archivePath (getEntry entrySelector)+```++…to stream them to given sink:++```haskell+λ> withArchive archivePath (sourceEntry entrySelector mySink)+```++…to save specific entry to a file:++```haskell+λ> withArchive archivePath (saveEntry entrySelector pathToFile)+```++…and finally just unpack entire archive into some directory:++```haskell+λ> withArchive archivePath (unpackInto destDir)+```++See also `getArchiveComment` and `getArchiveDescription`.++Modifying is also easy, efficient, and powerful. When you want to create new+archive use `createArchive`, otherwise `withArchive` will do. To add entry+from `ByteString`:++```haskell+λ> createArchive archivePath (addEntry Store "Hello, World!" entrySelector)+```++You can stream from `Source` as well:++```haskell+λ> createArchive archivePath (sinkEntry Deflate source entrySelector)+```++To add contents from some file, use `loadEntry`:++```haskell+λ> let toSelector = const $ parseRelFile "my-entry.txt" >>= mkEntrySelector+λ> createArchive archivePath (loadEntry BZip2 toSelector myFilePath)+```++Finally, you can copy entry from another archive without re-compression+(unless you use `recompress`, see below):++```haskell+λ> createArchive archivePath (copyEntry srcArchivePath selector selector)+```++It's often desirable to just pack a directory:++```haskell+λ> let f = stripDir dir >=> mkEntrySelector+λ> createArchive archivePath (packDirRecur Deflate f dir)+```++It's also possible to:++* rename an entry with `renameEntry`+* delete an entry with `deleteEntry`+* change compression method with `recompress`+* change comment associated with an entry with `setEntryComment`+* delete comment with `deleteEntryComment`+* set modification time with `setModTime`+* manipulate extra fields with `addExtraField` and `deleteExtraField`+* check if entry is intact with `checkEntry`+* undo changes with `undoEntryCanges`, `undoArchiveChanges`, and `undoAll`+* force changes to be written to file system with `commit`++This should cover all your needs. Feel free to open an issue if you're+missing something.++## Contribution++You can contact the maintainer via+[the issue tracker](https://github.com/mrkkrp/zip/issues).++We are open to pull requests, they will be merged quickly if they are good!++## License++Copyright © 2016 Mark Karpov++Distributed under BSD 3 clause license.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ bench/Main.hs view
@@ -0,0 +1,38 @@+--+-- Benchmarks for the ‘zip’ package.+--+-- Copyright © 2016 Mark Karpov <markkarpov@openmailbox.org>+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+-- * Redistributions of source code must retain the above copyright notice,+-- this list of conditions and the following disclaimer.+--+-- * 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.+--+-- * Neither the name Mark Karpov nor the names of contributors may be used+-- to endorse or promote products derived from this software without+-- specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “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 COPYRIGHT HOLDERS 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.++module Main (main) where++import Criterion.Main++main :: IO ()+main = defaultMain [] -- TODO
+ tests/Main.hs view
@@ -0,0 +1,723 @@+--+-- Tests for the ‘zip’ package.+--+-- Copyright © 2016 Mark Karpov <markkarpov@openmailbox.org>+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+-- * Redistributions of source code must retain the above copyright notice,+-- this list of conditions and the following disclaimer.+--+-- * 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.+--+-- * Neither the name Mark Karpov nor the names of contributors may be used+-- to endorse or promote products derived from this software without+-- specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “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 COPYRIGHT HOLDERS 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.++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS -fno-warn-orphans #-}++module Main (main) where++import Codec.Archive.Zip+import Codec.Archive.Zip.CP437+import Control.Monad+import Control.Monad.Catch (catchIOError)+import Control.Monad.IO.Class+import Data.Bits (complement)+import Data.ByteString (ByteString)+import Data.Conduit (yield)+import Data.Foldable (foldl')+import Data.List (intercalate)+import Data.Map (Map, (!))+import Data.Maybe (fromJust)+import Data.Monoid+import Data.Text (Text)+import Data.Time+import Path+import Path.IO+import System.IO+import System.IO.Error (isDoesNotExistError)+import Test.Hspec+import Test.QuickCheck+import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as LB+import qualified Data.ByteString.Lazy as LB+import qualified Data.Conduit.List as CL+import qualified Data.Map as M+import qualified Data.Set as E+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified System.FilePath.Windows as Windows++-- | Zip tests. Please note that Zip64 feature is not currently tested+-- automatically because for it to expose itself we need > 4GB of+-- data. Handling such quantities of data locally is problematic and even+-- more problematic in the context of CI server.++main :: IO ()+main = hspec $ do+ describe "mkEntrySelector" mkEntrySelectorSpec+ describe "unEntrySelector" unEntrySelectorSpec+ describe "getEntryName" getEntryNameSpec+ describe "decodeCP437" decodeCP437Spec+ around withSandbox $ do+ describe "createArchive" createArchiveSpec+ describe "withArchive" withArchiveSpec+ describe "archive comment" archiveCommentSpec+ describe "getEntryDesc" getEntryDescSpec+ describe "addEntry" addEntrySpec+ describe "sinkEntry" sinkEntrySpec+ describe "loadEntry" loadEntrySpec+ describe "copyEntry" copyEntrySpec+ describe "checkEntry" checkEntrySpec+ describe "recompress" recompressSpec+ describe "entry comment" entryCommentSpec+ describe "setModTime" setModTimeSpec+ describe "extra field" extraFieldSpec+ describe "renameEntry" renameEntrySpec+ describe "deleteEntry" deleteEntrySpec+ describe "forEntries" forEntriesSpec+ describe "undoEntryChanges" undoEntryChangesSpec+ describe "undoArchiveChanges" undoArchiveChangesSpec+ describe "undoAll" undoAllSpec+ describe "consistencySpec" consistencySpec+ describe "packDirRecur" packDirRecurSpec+ describe "unpackInto" unpackIntoSpec++----------------------------------------------------------------------------+-- Arbitrary instances and generators++instance Arbitrary Text where+ arbitrary = T.pack <$> listOf1 arbitrary++instance Arbitrary ByteString where+ arbitrary = B.pack <$> listOf arbitrary++instance Arbitrary CompressionMethod where+ arbitrary = elements [Store, Deflate, BZip2]++instance Arbitrary UTCTime where+ arbitrary = UTCTime+ <$> (ModifiedJulianDay <$> choose (44239, 90989))+ <*> (secondsToDiffTime <$> choose (0, 86399))++instance Arbitrary (Path Rel File) where+ arbitrary = do+ x <- intercalate "/" <$> listOf1 (listOf1 charGen)+ case parseRelFile x of+ Nothing -> arbitrary+ Just path -> return path++instance Arbitrary EntrySelector where+ arbitrary = do+ x <- arbitrary+ case mkEntrySelector x of+ Nothing -> arbitrary+ Just s -> return s++data EM = EM EntrySelector EntryDescription (ZipArchive ()) deriving Show++instance Arbitrary EM where+ arbitrary = do+ s <- arbitrary+ method <- arbitrary+ content <- arbitrary+ modTime <- arbitrary+ comment <- arbitrary+ extraFieldTag <- arbitrary `suchThat` (/= 1)+ extraFieldContent <- arbitrary `suchThat` ((< 0xffff) . B.length)+ let action = do+ addEntry method content s+ setModTime modTime s+ setEntryComment comment s+ addExtraField extraFieldTag extraFieldContent s+ return $ EM s EntryDescription+ { edVersionMadeBy = undefined+ , edVersionNeeded = undefined+ , edCompression = method+ , edModTime = modTime+ , edCRC32 = undefined+ , edCompressedSize = undefined+ , edUncompressedSize = fromIntegral (B.length content)+ , edOffset = undefined+ , edComment = Just comment+ , edExtraField = M.singleton extraFieldTag extraFieldContent }+ action++data EC = EC (Map EntrySelector EntryDescription) (ZipArchive ()) deriving Show++instance Arbitrary EC where+ arbitrary = foldl' f (EC M.empty (return ())) <$> listOf1 arbitrary+ where f (EC m z') (EM s desc z) = EC (M.insert s desc m) (z' >> z)++charGen :: Gen Char+charGen = frequency+ [ (3, choose ('a', 'z'))+ , (3, choose ('A', 'Z'))+ , (3, choose ('0', '9'))+ , (1, arbitrary `suchThat` (>= ' ')) ]++binASCII :: Gen ByteString+binASCII = LB.toStrict . LB.toLazyByteString <$> go+ where go = frequency+ [ (10, (<>) <$> (LB.word8 <$> choose (0, 127)) <*> go)+ , (1, return mempty) ]++instance Show EntryDescription where+ show ed = "{ edCompression = " ++ show (edCompression ed) +++ "\n, edModTime = " ++ show (edModTime ed) +++ "\n, edUncompressedSize = " ++ show (edUncompressedSize ed) +++ "\n, edComment = " ++ show (edComment ed) +++ "\n, edExtraField = " ++ show (edExtraField ed) +++ " }"++instance Show (ZipArchive a) where+ show = const "<zip archive>"++----------------------------------------------------------------------------+-- Pure operations and periphery++mkEntrySelectorSpec :: Spec+mkEntrySelectorSpec = do+ context "when incorrect Windows paths are passed" $+ it "rejects them" . property $ \path ->+ (not . Windows.isValid . toFilePath $ path)+ ==> mkEntrySelector path === Nothing+ context "when too long paths are passed" $+ it "rejects them" $ do+ path <- parseRelFile (replicate 0x10000 'a')+ mkEntrySelector path `shouldThrow` isEntrySelectorException path+ context "when correct paths are passed" $+ it "adequately represents them" $ do+ let c str = do+ s <- parseRelFile str >>= mkEntrySelector+ getEntryName s `shouldBe` T.pack str+ c "one/two/three"+ c "something.txt"++unEntrySelectorSpec :: Spec+unEntrySelectorSpec =+ context "when entry selector exists" $+ it "has corresponding path" . property $ \s ->+ not . null . toFilePath . unEntrySelector $ s++getEntryNameSpec :: Spec+getEntryNameSpec =+ context "when entry selector exists" $+ it "has corresponding representation" . property $ \s ->+ not . T.null . getEntryName $ s++decodeCP437Spec :: Spec+decodeCP437Spec = do+ context "when ASCII-compatible subset is used" $+ it "has the same result as decoding UTF-8" . property $+ forAll binASCII $ \bin ->+ decodeCP437 bin `shouldBe` T.decodeUtf8 bin+ context "when non-ASCII subset is used" $+ it "is decoded correctly" $ do+ let c b t = decodeCP437 (B.pack b ) `shouldBe` t+ c [0x80..0x9f] "ÇüéâäàåçêëèïîìÄÅÉæÆôöòûùÿÖÜ¢£¥₧ƒ"+ c [0xa0..0xbf] "áíóúñѪº¿⌐¬½¼¡«»░▒▓│┤╡╢╖╕╣║╗╝╜╛┐"+ c [0xc0..0xdf] "└┴┬├─┼╞╟╚╔╩╦╠═╬╧╨╤╥╙╘╒╓╫╪┘┌█▄▌▐▀"+ c [0xe0..0xff] "αßΓπΣσµτΦΘΩδ∞φε∩≡±≥≤⌠⌡÷≈°∙·√ⁿ²■ "++----------------------------------------------------------------------------+-- Primitive editing/querying actions++createArchiveSpec :: SpecWith (Path Abs File)+createArchiveSpec = do+ context "when called with non-existent path and empty recipe" $+ it "creates correct representation of empty archive" $ \path -> do+ createArchive path (return ())+ B.readFile (toFilePath path) `shouldReturn` emptyArchive+ context "when called with occupied path" $+ it "overwrites it" $ \path -> do+ B.writeFile (toFilePath path) B.empty+ createArchive path (return ())+ B.readFile (toFilePath path) `shouldNotReturn` B.empty++withArchiveSpec :: SpecWith (Path Abs File)+withArchiveSpec = do+ context "when called with non-existent path" $+ it "throws 'isDoesNotExistError' exception" $ \path ->+ withArchive path (return ()) `shouldThrow` isDoesNotExistError+ context "when called with occupied path (empty file)" $+ it "throws 'ParsingFailed' exception" $ \path -> do+ B.writeFile (toFilePath path) B.empty+ withArchive path (return ()) `shouldThrow`+ isParsingFailed path "Cannot locate end of central directory"+ context "when called with occupied path (empty archive)" $+ it "does not overwrite the file unnecessarily" $ \path -> do+ let fp = toFilePath path+ B.writeFile fp emptyArchive+ withArchive path . liftIO $ B.writeFile fp B.empty+ B.readFile fp `shouldNotReturn` emptyArchive++archiveCommentSpec :: SpecWith (Path Abs File)+archiveCommentSpec = do+ context "when new archive is created" $+ it "returns no archive comment" $ \path ->+ createArchive path getArchiveComment `shouldReturn` Nothing+ context "when comment contains end of central directory signature" $+ it "reads it without problems" $ \path -> do+ entries <- createArchive path $ do+ setArchiveComment "I saw you want to have PK\ENQ\ACK here."+ commit+ getEntries+ entries `shouldBe` M.empty+ context "when comment is committed (delete/set)" $+ it "reads it and updates" $ \path -> property $ \txt -> do+ comment <- createArchive path $ do+ deleteArchiveComment+ setArchiveComment txt+ commit+ getArchiveComment+ comment `shouldBe` Just txt+ context "when comment is committed (set/delete)" $+ it "reads it and updates" $ \path -> property $ \txt -> do+ comment <- createArchive path $ do+ setArchiveComment txt+ deleteArchiveComment+ commit+ getArchiveComment+ comment `shouldBe` Nothing+ context "when pre-existing comment is overwritten" $+ it "returns the new comment" $ \path -> property $ \txt txt' -> do+ comment <- createArchive path $ do+ setArchiveComment txt+ commit+ setArchiveComment txt'+ commit+ getArchiveComment+ comment `shouldBe` Just txt'+ context "when pre-existing comment is deleted" $+ it "actually deletes it" $ \path -> property $ \txt -> do+ comment <- createArchive path $ do+ setArchiveComment txt+ commit+ deleteArchiveComment+ commit+ getArchiveComment+ comment `shouldBe` Nothing++getEntryDescSpec :: SpecWith (Path Abs File)+getEntryDescSpec =+ it "always returns correct description" $+ \path -> property $ \(EM s desc z) -> do+ desc' <- fromJust <$> createArchive path (z >> commit >> getEntryDesc s)+ desc' `shouldSatisfy` softEq desc++addEntrySpec :: SpecWith (Path Abs File)+addEntrySpec =+ context "when an entry is added" $+ it "is there" $ \path -> property $ \m b s -> do+ info <- createArchive path $ do+ addEntry m b s+ commit+ (,) <$> getEntry s <*> (edCompression . (! s) <$> getEntries)+ info `shouldBe` (b, m)++sinkEntrySpec :: SpecWith (Path Abs File)+sinkEntrySpec =+ context "when an entry is sunk" $+ it "is there" $ \path -> property $ \m b s -> do+ info <- createArchive path $ do+ sinkEntry m (yield b) s+ commit+ (,) <$> sourceEntry s (CL.foldMap id)+ <*> (edCompression . (! s) <$> getEntries)+ info `shouldBe` (b, m)++loadEntrySpec :: SpecWith (Path Abs File)+loadEntrySpec =+ context "when an entry is loaded" $+ it "is there" $ \path -> property $ \m b s -> do+ let vpath = deriveVacant path+ B.writeFile (toFilePath vpath) b+ createArchive path $ do+ loadEntry m (const $ return s) vpath+ commit+ liftIO (removeFile vpath)+ saveEntry s vpath+ B.readFile (toFilePath vpath) `shouldReturn` b++copyEntrySpec :: SpecWith (Path Abs File)+copyEntrySpec =+ context "when entry is copied form another archive" $+ it "is there" $ \path -> property $ \m b s -> do+ let vpath = deriveVacant path+ createArchive vpath (addEntry m b s)+ info <- createArchive path $ do+ copyEntry vpath s s+ commit+ (,) <$> getEntry s <*> (edCompression . (! s) <$> getEntries)+ info `shouldBe` (b, m)++checkEntrySpec :: SpecWith (Path Abs File)+checkEntrySpec = do+ context "when entry is intact" $+ it "passes the check" $ \path -> property $ \m b s -> do+ check <- createArchive path $ do+ addEntry m b s+ commit+ checkEntry s+ check `shouldBe` True+ context "when entry is corrupted" $+ it "does not pass the check" $ \path -> property $ \b s ->+ not (B.null b) ==> do+ let r = 50 + (B.length . T.encodeUtf8 . getEntryName $ s)+ offset <- createArchive path $ do+ addEntry Store b s+ commit+ fromIntegral . edOffset . (! s) <$> getEntries+ withFile (toFilePath path) ReadWriteMode $ \h -> do+ hSeek h AbsoluteSeek (offset + fromIntegral r)+ byte <- B.map complement <$> B.hGet h 1+ hSeek h RelativeSeek (-1)+ B.hPut h byte+ withArchive path (checkEntry s) `shouldReturn` False++recompressSpec :: SpecWith (Path Abs File)+recompressSpec =+ context "when recompression is used" $+ it "gets recompressed" $ \path -> property $ \m m' b s -> do+ info <- createArchive path $ do+ addEntry m b s+ commit+ recompress m' s+ commit+ (,) <$> getEntry s <*> (edCompression . (! s) <$> getEntries)+ info `shouldBe` (b, m')++entryCommentSpec :: SpecWith (Path Abs File)+entryCommentSpec = do+ context "when comment is committed (delete/set)" $+ it "reads it and updates" $ \path -> property $ \txt s -> do+ comment <- createArchive path $ do+ addEntry Store "foo" s+ deleteEntryComment s+ setEntryComment txt s+ commit+ edComment . (! s) <$> getEntries+ comment `shouldBe` Just txt+ context "when comment is committed (set/delete)" $+ it "reads it and updates" $ \path -> property $ \txt s -> do+ comment <- createArchive path $ do+ addEntry Store "foo" s+ setEntryComment txt s+ deleteEntryComment s+ commit+ edComment . (! s) <$> getEntries+ comment `shouldBe` Nothing+ context "when pre-existing comment is overwritten" $+ it "returns the new comment" $ \path -> property $ \txt txt' s -> do+ comment <- createArchive path $ do+ addEntry Store "foo" s+ setEntryComment txt s+ commit+ setEntryComment txt' s+ commit+ edComment . (! s) <$> getEntries+ comment `shouldBe` Just txt'+ context "when pre-existing comment is deleted" $+ it "actually deletes it" $ \path -> property $ \txt s -> do+ comment <- createArchive path $ do+ addEntry Store "foo" s+ setEntryComment txt s+ commit+ deleteEntryComment s+ commit+ edComment . (! s) <$> getEntries+ comment `shouldBe` Nothing++setModTimeSpec :: SpecWith (Path Abs File)+setModTimeSpec = do+ context "when mod time is set (after creation)" $+ it "reads it and updates" $ \path -> property $ \time s -> do+ modTime <- createArchive path $ do+ addEntry Store "foo" s+ setModTime time s+ commit+ edModTime . (! s) <$> getEntries+ modTime `shouldSatisfy` isCloseTo time+ context "when mod time is set (before creation)" $+ it "has no effect" $ \path -> property $ \time time' s ->+ not (isCloseTo time time') ==> do+ modTime <- createArchive path $ do+ setModTime time s+ addEntry Store "foo" s+ commit+ edModTime . (! s) <$> getEntries+ modTime `shouldNotSatisfy` isCloseTo time++extraFieldSpec :: SpecWith (Path Abs File)+extraFieldSpec = do+ context "when extra field is committed (delete/set)" $+ it "reads it and updates" $ \path -> property $ \n b s ->+ n /= 1 ==> do+ efield <- createArchive path $ do+ addEntry Store "foo" s+ deleteExtraField n s+ addExtraField n b s+ commit+ M.lookup n . edExtraField . (! s) <$> getEntries+ efield `shouldBe` Just b+ context "when extra field is committed (set/delete)" $+ it "reads it and updates" $ \path -> property $ \n b s ->+ n /= 1 ==> do+ efield <- createArchive path $ do+ addEntry Store "foo" s+ addExtraField n b s+ deleteExtraField n s+ commit+ M.lookup n . edExtraField . (! s) <$> getEntries+ efield `shouldBe` Nothing+ context "when pre-existing extra field is overwritten" $+ it "reads it and updates" $ \path -> property $ \n b b' s ->+ n /= 1 ==> do+ efield <- createArchive path $ do+ addEntry Store "foo" s+ addExtraField n b s+ commit+ addExtraField n b' s+ commit+ M.lookup n . edExtraField . (! s) <$> getEntries+ efield `shouldBe` Just b'+ context "when pre-existing extra field is deleted" $+ it "actually deletes it" $ \path -> property $ \n b s ->+ n /= 1 ==> do+ efield <- createArchive path $ do+ addEntry Store "foo" s+ addExtraField n b s+ commit+ deleteExtraField n s+ commit+ M.lookup n . edExtraField . (! s) <$> getEntries+ efield `shouldBe` Nothing++renameEntrySpec :: SpecWith (Path Abs File)+renameEntrySpec = do+ context "when renaming after editing of new entry" $+ it "produces correct result" $ \path -> property $ \(EM s desc z) s' -> do+ desc' <- createArchive path $ do+ z+ renameEntry s s'+ commit+ (! s') <$> getEntries+ desc' `shouldSatisfy` softEq desc+ context "when renaming existing entry" $+ it "gets renamed" $ \path -> property $ \(EM s desc z) s' -> do+ desc' <- createArchive path $ do+ z+ commit+ renameEntry s s'+ commit+ (! s') <$> getEntries+ desc' `shouldSatisfy` softEq desc++deleteEntrySpec :: SpecWith (Path Abs File)+deleteEntrySpec = do+ context "when deleting after editing of new entry" $+ it "produces correct result" $ \path -> property $ \(EM s _ z) -> do+ member <- createArchive path $ do+ z+ deleteEntry s+ commit+ doesEntryExist s+ member `shouldBe` False+ context "when deleting existing entry" $+ it "gets deleted" $ \path -> property $ \(EM s _ z) -> do+ member <- createArchive path $ do+ z+ commit+ deleteEntry s+ commit+ doesEntryExist s+ member `shouldBe` False++forEntriesSpec :: SpecWith (Path Abs File)+forEntriesSpec =+ it "affects all existing entries" $ \path -> property $ \(EC m z) txt -> do+ m' <- createArchive path $ do+ z+ commit+ forEntries (setEntryComment txt)+ commit+ getEntries+ let f ed = ed { edComment = Just txt }+ m' `shouldSatisfy` softEqMap (M.map f m)++undoEntryChangesSpec :: SpecWith (Path Abs File)+undoEntryChangesSpec =+ it "cancels all actions for specified entry" $+ \path -> property $ \(EM s _ z) -> do+ member <- createArchive path $ do+ z+ undoEntryChanges s+ commit+ doesEntryExist s+ member `shouldBe` False++undoArchiveChangesSpec :: SpecWith (Path Abs File)+undoArchiveChangesSpec = do+ it "cancels archive comment editing" $ \path -> property $ \txt -> do+ comment <- createArchive path $ do+ setArchiveComment txt+ undoArchiveChanges+ commit+ getArchiveComment+ comment `shouldBe` Nothing+ it "cancels archive comment deletion" $ \path -> property $ \txt -> do+ comment <- createArchive path $ do+ setArchiveComment txt+ commit+ deleteArchiveComment+ undoArchiveChanges+ commit+ getArchiveComment+ comment `shouldBe` Just txt++undoAllSpec :: SpecWith (Path Abs File)+undoAllSpec =+ it "cancels all editing at once" $ \path -> property $ \(EC _ z) txt -> do+ let fp = toFilePath path+ createArchive path (return ())+ withArchive path $ do+ z+ setArchiveComment txt+ undoAll+ liftIO (B.writeFile fp B.empty)+ B.readFile fp `shouldReturn` B.empty++----------------------------------------------------------------------------+-- Complex construction/restoration++consistencySpec :: SpecWith (Path Abs File)+consistencySpec =+ it "can save and restore arbitrary archive" $+ \path -> property $ \(EC m z) txt -> do+ (txt', m') <- createArchive path $ do+ z+ setArchiveComment txt+ commit+ (,) <$> getArchiveComment <*> getEntries+ txt' `shouldBe` Just txt+ m' `shouldSatisfy` softEqMap m++packDirRecurSpec :: SpecWith (Path Abs File)+packDirRecurSpec =+ it "packs arbitrary directory recursively" $+ \path -> property $ \contents -> do+ let dir = parent path+ f = stripDir dir >=> mkEntrySelector+ blew <- catchIOError (do+ forM_ contents $ \s -> do+ let item = dir </> unEntrySelector s+ ensureDir (parent item)+ B.writeFile (toFilePath item) "foo"+ return False)+ (const $ return True)+ when blew discard -- TODO+ selectors <- M.keysSet <$>+ createArchive path (packDirRecur Store f dir >> commit >> getEntries)+ selectors `shouldBe` E.fromList contents++unpackIntoSpec :: SpecWith (Path Abs File)+unpackIntoSpec =+ it "unpacks archive contents into directory" $+ \path -> property $ \(EC m z) -> do+ let dir = parent path+ blew <- createArchive path $ do+ z+ commit+ catchIOError+ (unpackInto dir >> return False)+ (const $ return True)+ when blew discard -- TODO+ removeFile path+ selectors <- listDirRecur dir >>=+ mapM (stripDir dir >=> mkEntrySelector) . snd+ E.fromList selectors `shouldBe` M.keysSet m++----------------------------------------------------------------------------+-- Helpers++-- | Check whether given exception is 'EntrySelectorException' with specific+-- path inside.++isEntrySelectorException :: Path Rel File -> EntrySelectorException -> Bool+isEntrySelectorException path (InvalidEntrySelector p) = p == path++-- | Check whether given exception is 'ParsingFailed' exception with+-- specific path and error message inside.++isParsingFailed :: Path Abs File -> String -> ZipException -> Bool+isParsingFailed path msg (ParsingFailed path' msg') =+ path == path' && msg == msg'+isParsingFailed _ _ _ = False++-- | Create sandbox directory to model some situation in it and run some+-- tests. Note that we're using new unique sandbox directory for each test+-- case to avoid contamination and it's unconditionally deleted after test+-- case finishes. The function returns vacant file path in that directory.++withSandbox :: ActionWith (Path Abs File) -> IO ()+withSandbox action = withSystemTempDir "zip-sandbox" $ \dir ->+ action (dir </> $(mkRelFile "foo.zip"))++-- | Given primary name (name of archive), generate a name that does not+-- collide with it.++deriveVacant :: Path Abs File -> Path Abs File+deriveVacant = (</> $(mkRelFile "bar")) . parent++-- | Compare times forgiving minor difference.++isCloseTo :: UTCTime -> UTCTime -> Bool+isCloseTo a b = abs (diffUTCTime a b) < 2++-- | Compare only some fields of 'EntryDescription' record.++softEq :: EntryDescription -> EntryDescription -> Bool+softEq a b =+ edCompression a == edCompression b &&+ isCloseTo (edModTime a) (edModTime b) &&+ edUncompressedSize a == edUncompressedSize b &&+ edComment a == edComment b &&+ M.delete 1 (edExtraField a) == M.delete 1 (edExtraField b)++-- | Compare two maps describing archive entries in such a way that only+-- some fields in 'EntryDescription' record are tested.++softEqMap+ :: Map EntrySelector EntryDescription+ -> Map EntrySelector EntryDescription+ -> Bool+softEqMap n m = M.null (M.differenceWith f n m)+ where f a b = if softEq a b then Nothing else Just a++-- | Canonical representation of empty Zip archive.++emptyArchive :: ByteString+emptyArchive = B.pack+ [ 0x50, 0x4b, 0x05, 0x06, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00+ , 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 ]
+ zip.cabal view
@@ -0,0 +1,126 @@+--+-- Cabal configuration for ‘zip’.+--+-- Copyright © 2016 Mark Karpov+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+-- * Redistributions of source code must retain the above copyright notice,+-- this list of conditions and the following disclaimer.+--+-- * 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.+--+-- * Neither the name Mark Karpov nor the names of contributors may be used+-- to endorse or promote products derived from this software without+-- specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “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 COPYRIGHT HOLDERS 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.++name: zip+version: 0.1.0+cabal-version: >= 1.10+license: BSD3+license-file: LICENSE.md+author: Mark Karpov <markkarpov@opmbx.org>+maintainer: Mark Karpov <markkarpov@opmbx.org>+homepage: https://github.com/mrkkrp/zip+bug-reports: https://github.com/mrkkrp/zip/issues+category: Codec+synopsis: Operations on zip archives+build-type: Simple+description: Operations on zip archives.+extra-source-files: CHANGELOG.md+ , README.md++flag dev+ description: Turn on development settings.+ manual: True+ default: False++library+ build-depends: base >= 4.8 && < 5+ , bytestring >= 0.9+ , bzlib-conduit >= 0.2+ , case-insensitive >= 1.2.0.2+ , cereal >= 0.3+ , conduit >= 1.1+ , conduit-extra >= 1.1+ , containers >= 0.5.6.2+ , digest+ , exceptions >= 0.8+ , filepath >= 1.2+ , mtl >= 2.0+ , path >= 0.5+ , path-io >= 1.0.1+ , plan-b >= 0.2.0+ , resourcet >= 1.0+ , semigroups >= 0.5+ , text >= 0.2+ , time >= 1.4+ , transformers >= 0.3+ default-extensions: RecordWildCards+ , TupleSections+ exposed-modules: Codec.Archive.Zip+ , Codec.Archive.Zip.CP437+ , Codec.Archive.Zip.Type+ other-modules: Codec.Archive.Zip.Internal+ if flag(dev)+ ghc-options: -Wall -Werror+ else+ ghc-options: -O2 -Wall+ default-language: Haskell2010++test-suite tests+ main-is: Main.hs+ hs-source-dirs: tests+ type: exitcode-stdio-1.0+ if flag(dev)+ ghc-options: -Wall -Werror+ else+ ghc-options: -O2 -Wall+ build-depends: base >= 4.8 && < 5+ , bytestring >= 0.9+ , conduit >= 1.1+ , containers >= 0.5.6.2+ , exceptions >= 0.8+ , filepath >= 1.2+ , QuickCheck >= 2.4 && < 3+ , hspec >= 2.0+ , path >= 0.5+ , path-io >= 1.0.1+ , text >= 0.2+ , time >= 1.4+ , transformers >= 0.3+ , zip >= 0.1+ default-language: Haskell2010++benchmark bench+ main-is: Main.hs+ hs-source-dirs: bench+ type: exitcode-stdio-1.0+ if flag(dev)+ ghc-options: -O2 -Wall -Werror+ else+ ghc-options: -O2 -Wall+ build-depends: base >= 4.8 && < 5+ , criterion >= 1.0+ , zip >= 0.1+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/mrkkrp/zip.git