diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +## Zip 0.1.0 + +* Initial release. diff --git a/Codec/Archive/Zip.hs b/Codec/Archive/Zip.hs new file mode 100644 --- /dev/null +++ b/Codec/Archive/Zip.hs @@ -0,0 +1,529 @@ +-- | +-- Module : Codec.Archive.Zip +-- Copyright : © 2016 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- 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) diff --git a/Codec/Archive/Zip/CP437.hs b/Codec/Archive/Zip/CP437.hs new file mode 100644 --- /dev/null +++ b/Codec/Archive/Zip/CP437.hs @@ -0,0 +1,163 @@ +-- | +-- Module : Codec.Archive.Zip.CP437 +-- Copyright : © 2016 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- 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 diff --git a/Codec/Archive/Zip/Internal.hs b/Codec/Archive/Zip/Internal.hs new file mode 100644 --- /dev/null +++ b/Codec/Archive/Zip/Internal.hs @@ -0,0 +1,973 @@ +-- | +-- Module : Codec.Archive.Zip.Internal +-- Copyright : © 2016 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- 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) diff --git a/Codec/Archive/Zip/Type.hs b/Codec/Archive/Zip/Type.hs new file mode 100644 --- /dev/null +++ b/Codec/Archive/Zip/Type.hs @@ -0,0 +1,204 @@ +-- | +-- Module : Codec.Archive.Zip.Type +-- Copyright : © 2016 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- 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 diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,291 @@ +# Zip + +[![License BSD3](https://img.shields.io/badge/license-BSD3-brightgreen.svg)](http://opensource.org/licenses/BSD-3-Clause) +[![Hackage](https://img.shields.io/hackage/v/zip.svg?style=flat)](https://hackage.haskell.org/package/zip) +[![Stackage Nightly](http://stackage.org/package/zip/badge/nightly)](http://stackage.org/nightly/package/zip) +[![Build Status](https://travis-ci.org/mrkkrp/zip.svg?branch=master)](https://travis-ci.org/mrkkrp/zip) +[![Coverage Status](https://coveralls.io/repos/mrkkrp/zip/badge.svg?branch=master&service=github)](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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,38 @@ +-- +-- Benchmarks for the ‘zip’ package. +-- +-- 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. + +module Main (main) where + +import Criterion.Main + +main :: IO () +main = defaultMain [] -- TODO diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,723 @@ +-- +-- Tests for the ‘zip’ package. +-- +-- 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. + +{-# 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 "" + +---------------------------------------------------------------------------- +-- 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 ] diff --git a/zip.cabal b/zip.cabal new file mode 100644 --- /dev/null +++ b/zip.cabal @@ -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 +maintainer: Mark Karpov +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