diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +## Zip 1.6.0 + +* Added support for Zstandard (zstd) compression + +* Added a Cabal flag `-fdisable-zstd` to remove the zstd C library + dependency and hence support for Zstd entries. + ## Zip 1.5.0 * Added the `packDirRecur'` function. diff --git a/Codec/Archive/Zip.hs b/Codec/Archive/Zip.hs --- a/Codec/Archive/Zip.hs +++ b/Codec/Archive/Zip.hs @@ -1,3 +1,9 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + -- | -- Module : Codec.Archive.Zip -- Copyright : © 2016–present Mark Karpov @@ -67,74 +73,80 @@ -- > s <- mkEntrySelector f -- > bs <- withArchive path (getEntry s) -- > B.putStrLn bs - -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} - module Codec.Archive.Zip ( -- * Types + -- ** Entry selector - EntrySelector - , mkEntrySelector - , unEntrySelector - , getEntryName - , EntrySelectorException (..) + EntrySelector, + mkEntrySelector, + unEntrySelector, + getEntryName, + EntrySelectorException (..), + -- ** Entry description - , EntryDescription (..) - , CompressionMethod (..) + EntryDescription (..), + CompressionMethod (..), + -- ** Archive description - , ArchiveDescription (..) + ArchiveDescription (..), + -- ** Exceptions - , ZipException (..) + ZipException (..), + -- * Archive monad - , ZipArchive - , ZipState - , createArchive - , withArchive + ZipArchive, + ZipState, + createArchive, + withArchive, + -- * Retrieving information - , getEntries - , doesEntryExist - , getEntryDesc - , getEntry - , getEntrySource - , sourceEntry - , saveEntry - , checkEntry - , unpackInto - , getArchiveComment - , getArchiveDescription + getEntries, + doesEntryExist, + getEntryDesc, + getEntry, + getEntrySource, + sourceEntry, + saveEntry, + checkEntry, + unpackInto, + getArchiveComment, + getArchiveDescription, + -- * Modifying archive + -- ** Adding entries - , addEntry - , sinkEntry - , loadEntry - , copyEntry - , packDirRecur - , packDirRecur' + addEntry, + sinkEntry, + loadEntry, + copyEntry, + packDirRecur, + packDirRecur', + -- ** Modifying entries - , renameEntry - , deleteEntry - , recompress - , setEntryComment - , deleteEntryComment - , setModTime - , addExtraField - , deleteExtraField - , setExternalFileAttrs - , forEntries + renameEntry, + deleteEntry, + recompress, + setEntryComment, + deleteEntryComment, + setModTime, + addExtraField, + deleteExtraField, + setExternalFileAttrs, + forEntries, + -- ** Operations on archive as a whole - , setArchiveComment - , deleteArchiveComment + setArchiveComment, + deleteArchiveComment, + -- ** Control over editing - , undoEntryChanges - , undoArchiveChanges - , undoAll - , commit ) + undoEntryChanges, + undoArchiveChanges, + undoAll, + commit, + ) where +import qualified Codec.Archive.Zip.Internal as I import Codec.Archive.Zip.Type import Conduit (PrimMonad) import Control.Monad @@ -142,27 +154,26 @@ import Control.Monad.Catch import Control.Monad.State.Strict import Control.Monad.Trans.Control (MonadBaseControl (..)) -import Control.Monad.Trans.Resource (ResourceT, MonadResource) +import Control.Monad.Trans.Resource (MonadResource, ResourceT) import Data.ByteString (ByteString) import Data.Conduit (ConduitT, (.|)) +import qualified Data.Conduit as C +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL +import qualified Data.DList as DList import Data.Map.Strict (Map, (!)) +import qualified Data.Map.Strict as M import Data.Sequence (Seq, (|>)) +import qualified Data.Sequence as S +import qualified Data.Set as E import Data.Text (Text) import Data.Time.Clock (UTCTime) import Data.Void import Data.Word (Word16, Word32) import System.Directory import System.FilePath (()) +import qualified System.FilePath as FP import System.IO.Error (isDoesNotExistError) -import qualified Codec.Archive.Zip.Internal as I -import qualified Data.Conduit as C -import qualified Data.Conduit.Binary as CB -import qualified Data.Conduit.List as CL -import qualified Data.DList as DList -import qualified Data.Map.Strict as M -import qualified Data.Sequence as S -import qualified Data.Set as E -import qualified System.FilePath as FP ---------------------------------------------------------------------------- -- Archive monad @@ -171,65 +182,68 @@ -- archives. It's intentionally opaque and not a monad transformer to limit -- the 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 ) + } + deriving + ( Functor, + Applicative, + Monad, + MonadIO, + MonadThrow, + MonadCatch, + MonadMask + ) -- | @since 0.2.0 - instance MonadBase IO ZipArchive where liftBase = liftIO -- | @since 0.2.0 - instance MonadBaseControl IO ZipArchive where type StM ZipArchive a = (a, ZipState) liftBaseWith f = ZipArchive . StateT $ \s -> - (, s) <$> f (flip runStateT s . unZipArchive) + (,s) <$> f (flip runStateT s . unZipArchive) {-# INLINEABLE liftBaseWith #-} - restoreM = ZipArchive . StateT . const . return + restoreM = ZipArchive . StateT . const . return {-# INLINEABLE restoreM #-} -- | Internal state record used by the 'ZipArchive' monad. This is only -- exported for use with 'MonadBaseControl' methods, you can't look inside. -- -- @since 0.2.0 - data ZipState = ZipState - { zsFilePath :: FilePath - -- ^ 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 + { -- | Path to zip archive + zsFilePath :: FilePath, + -- | Actual collection of entries + zsEntries :: Map EntrySelector EntryDescription, + -- | Info about the whole archive + zsArchive :: ArchiveDescription, + -- | Pending actions + zsActions :: Seq I.PendingAction } -- | Create a new archive given its location and an action that describes -- how to create contents of the archive. This will silently overwrite the -- specified file if it already exists. See 'withArchive' if you want to -- work with an existing archive. - -createArchive :: MonadIO m - => FilePath -- ^ Location of archive file to create - -> ZipArchive a -- ^ Actions that form archive's content - -> m a +createArchive :: + MonadIO m => + -- | Location of archive file to create + FilePath -> + -- | Actions that form archive's content + ZipArchive a -> + m a createArchive path m = liftIO $ do apath <- makeAbsolute path ignoringAbsence (removeFile apath) - let st = ZipState - { zsFilePath = apath - , zsEntries = M.empty - , zsArchive = ArchiveDescription Nothing 0 0 - , zsActions = S.empty } + let st = + ZipState + { zsFilePath = apath, + zsEntries = M.empty, + zsArchive = ArchiveDescription Nothing 0 0, + zsActions = S.empty + } action = unZipArchive (m <* commit) evalStateT action st @@ -257,19 +271,23 @@ -- 'EntrySelector' is case-insensitive. These are the consequences of the -- design decision to make it impossible to create non-portable archives -- with this library. - -withArchive :: MonadIO m - => FilePath -- ^ Location of archive to work with - -> ZipArchive a -- ^ Actions on that archive - -> m a +withArchive :: + MonadIO m => + -- | Location of archive to work with + FilePath -> + -- | Actions on that archive + ZipArchive a -> + m a withArchive path m = liftIO $ do - apath <- canonicalizePath path + apath <- canonicalizePath path (desc, entries) <- liftIO (I.scanArchive apath) - let st = ZipState - { zsFilePath = apath - , zsEntries = entries - , zsArchive = desc - , zsActions = S.empty } + let st = + ZipState + { zsFilePath = apath, + zsEntries = entries, + zsArchive = desc, + zsActions = S.empty + } action = unZipArchive (m <* commit) liftIO (evalStateT action st) @@ -284,7 +302,6 @@ -- Please note that the returned value only reflects actual contents of the -- archive in file system, non-committed actions do not influence the list -- of entries, see 'commit' for more information. - getEntries :: ZipArchive (Map EntrySelector EntryDescription) getEntries = ZipArchive (gets zsEntries) @@ -292,7 +309,6 @@ -- simple shortcut defined as: -- -- > doesEntryExist s = M.member s <$> getEntries - doesEntryExist :: EntrySelector -> ZipArchive Bool doesEntryExist s = M.member s <$> getEntries @@ -300,7 +316,6 @@ -- defined as: -- -- > getEntryDesc s = M.lookup s <$> getEntries - getEntryDesc :: EntrySelector -> ZipArchive (Maybe EntryDescription) getEntryDesc s = M.lookup s <$> getEntries @@ -309,10 +324,11 @@ -- 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 :: + -- | Selector that identifies archive entry + EntrySelector -> + -- | Contents of the entry + ZipArchive ByteString getEntry s = sourceEntry s (CL.foldMap id) -- | Get an entry source. @@ -320,29 +336,28 @@ -- Throws: 'EntryDoesNotExist'. -- -- @since 0.1.3 - -getEntrySource - :: (PrimMonad m, MonadThrow m, MonadResource m) - => EntrySelector -- ^ Selector that identifies archive entry - -> ZipArchive (ConduitT () ByteString m ()) +getEntrySource :: + (PrimMonad m, MonadThrow m, MonadResource m) => + -- | Selector that identifies archive entry + EntrySelector -> + ZipArchive (ConduitT () ByteString m ()) getEntrySource s = do - path <- getFilePath + path <- getFilePath mdesc <- M.lookup s <$> getEntries case mdesc of - Nothing -> throwM (EntryDoesNotExist path s) + Nothing -> throwM (EntryDoesNotExist path s) Just desc -> return (I.sourceEntry path desc True) -- | Stream contents of an archive entry to the given 'Sink'. -- -- Throws: 'EntryDoesNotExist'. - -sourceEntry - :: EntrySelector - -- ^ Selector that identifies archive entry - -> ConduitT ByteString Void (ResourceT IO) a - -- ^ Sink where to stream entry contents - -> ZipArchive a - -- ^ Contents of the entry (if found) +sourceEntry :: + -- | Selector that identifies archive entry + EntrySelector -> + -- | Sink where to stream entry contents + ConduitT ByteString Void (ResourceT IO) a -> + -- | Contents of the entry (if found) + ZipArchive a sourceEntry s sink = do src <- getEntrySource s (liftIO . C.runConduitRes) (src .| sink) @@ -350,11 +365,12 @@ -- | Save a specific archive entry as a file in the file system. -- -- Throws: 'EntryDoesNotExist'. - -saveEntry - :: EntrySelector -- ^ Selector that identifies archive entry - -> FilePath -- ^ Where to save the file - -> ZipArchive () +saveEntry :: + -- | Selector that identifies archive entry + EntrySelector -> + -- | Where to save the file + FilePath -> + ZipArchive () saveEntry s path = do sourceEntry s (CB.sinkFile path) med <- getEntryDesc s @@ -365,20 +381,20 @@ -- same—that is, the data is not corrupted. -- -- Throws: 'EntryDoesNotExist'. - -checkEntry - :: EntrySelector -- ^ Selector that identifies archive entry - -> ZipArchive Bool -- ^ Is the entry intact? +checkEntry :: + -- | Selector that identifies archive entry + EntrySelector -> + -- | Is the entry intact? + ZipArchive Bool checkEntry s = do calculated <- sourceEntry s I.crc32Sink - given <- edCRC32 . (! s) <$> getEntries + 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 the entire archive into the specified directory. The directory -- will be created if it does not exist. - unpackInto :: FilePath -> ZipArchive () unpackInto dir' = do selectors <- M.keysSet <$> getEntries @@ -391,12 +407,10 @@ saveEntry s (dir unEntrySelector s) -- | Get the archive comment. - getArchiveComment :: ZipArchive (Maybe Text) getArchiveComment = adComment <$> getArchiveDescription -- | Get the archive description record. - getArchiveDescription :: ZipArchive ArchiveDescription getArchiveDescription = ZipArchive (gets zsArchive) @@ -404,32 +418,38 @@ -- Modifying archive -- | Add a new entry to the archive given its contents in binary form. - -addEntry - :: CompressionMethod -- ^ Compression method to use - -> ByteString -- ^ Entry contents - -> EntrySelector -- ^ Name of entry to add - -> ZipArchive () +addEntry :: + -- | Compression method to use + CompressionMethod -> + -- | Entry contents + ByteString -> + -- | Name of entry to add + EntrySelector -> + ZipArchive () addEntry t b s = addPending (I.SinkEntry t (C.yield b) s) -- | Stream data from the specified source to an archive entry. - -sinkEntry - :: CompressionMethod -- ^ Compression method to use - -> ConduitT () ByteString (ResourceT IO) () -- ^ Source of entry contents - -> EntrySelector -- ^ Name of entry to add - -> ZipArchive () +sinkEntry :: + -- | Compression method to use + CompressionMethod -> + -- | Source of entry contents + ConduitT () ByteString (ResourceT IO) () -> + -- | Name of entry to add + EntrySelector -> + ZipArchive () sinkEntry t src s = addPending (I.SinkEntry t src s) -- | Load an entry from a given file. - -loadEntry - :: CompressionMethod -- ^ Compression method to use - -> EntrySelector -- ^ Name of entry to add - -> FilePath -- ^ Path to file to add - -> ZipArchive () +loadEntry :: + -- | Compression method to use + CompressionMethod -> + -- | Name of entry to add + EntrySelector -> + -- | Path to file to add + FilePath -> + ZipArchive () loadEntry t s path = do - apath <- liftIO (canonicalizePath path) + apath <- liftIO (canonicalizePath path) modTime <- liftIO (getModificationTime path) let src = CB.sourceFile apath addPending (I.SinkEntry t src s) @@ -437,12 +457,14 @@ -- | Copy an entry “as is” from another zip archive. If the entry does not -- exist in that archive, 'EntryDoesNotExist' will be eventually thrown. - -copyEntry - :: FilePath -- ^ Path to archive to copy from - -> EntrySelector -- ^ Name of entry (in source archive) to copy - -> EntrySelector -- ^ Name of entry to insert (in current archive) - -> ZipArchive () +copyEntry :: + -- | Path to archive to copy from + FilePath -> + -- | Name of entry (in source archive) to copy + EntrySelector -> + -- | Name of entry to insert (in current archive) + EntrySelector -> + ZipArchive () copyEntry path s' s = do apath <- liftIO (canonicalizePath path) addPending (I.CopyEntry apath s' s) @@ -451,30 +473,32 @@ -- design of the library, empty sub-directories won't be added. -- -- The action can throw 'InvalidEntrySelector'. - -packDirRecur - :: CompressionMethod -- ^ Compression method to use - -> (FilePath -> ZipArchive EntrySelector) - -- ^ How to get 'EntrySelector' from a path relative to the root of the - -- directory we pack - -> FilePath -- ^ Path to directory to add - -> ZipArchive () +packDirRecur :: + -- | Compression method to use + CompressionMethod -> + -- | How to get 'EntrySelector' from a path relative to the root of the + -- directory we pack + (FilePath -> ZipArchive EntrySelector) -> + -- | Path to directory to add + FilePath -> + ZipArchive () packDirRecur t f = packDirRecur' t f (const $ return ()) -- | The same as 'packDirRecur' but allows us to perform modifying actions -- on the created entities as we go. -- -- @since 1.5.0 - -packDirRecur' - :: CompressionMethod -- ^ Compression method to use - -> (FilePath -> ZipArchive EntrySelector) - -- ^ How to get 'EntrySelector' from a path relative to the root of the - -- directory we pack - -> (EntrySelector -> ZipArchive ()) - -- ^ How to modify an entry after creation - -> FilePath -- ^ Path to directory to add - -> ZipArchive () +packDirRecur' :: + -- | Compression method to use + CompressionMethod -> + -- | How to get 'EntrySelector' from a path relative to the root of the + -- directory we pack + (FilePath -> ZipArchive EntrySelector) -> + -- | How to modify an entry after creation + (EntrySelector -> ZipArchive ()) -> + -- | Path to directory to add + FilePath -> + ZipArchive () packDirRecur' t f patch path = do files <- liftIO (listDirRecur path) forM_ files $ \x -> do @@ -484,70 +508,75 @@ -- | Rename an entry in the archive. If the entry does not exist, nothing -- will happen. - -renameEntry - :: EntrySelector -- ^ Original entry name - -> EntrySelector -- ^ New entry name - -> ZipArchive () +renameEntry :: + -- | Original entry name + EntrySelector -> + -- | New entry name + EntrySelector -> + ZipArchive () renameEntry old new = addPending (I.RenameEntry old new) -- | Delete an entry from the 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 :: + -- | New compression method + CompressionMethod -> + -- | Name of entry to re-compress + EntrySelector -> + ZipArchive () recompress t s = addPending (I.Recompress t s) -- | Set an entry comment, if that entry does not exist, nothing will -- happen. Note that if binary representation of the comment is longer than -- 65535 bytes, it will be truncated on writing. - -setEntryComment - :: Text -- ^ Text of the comment - -> EntrySelector -- ^ Name of entry to comment on - -> ZipArchive () +setEntryComment :: + -- | Text of the comment + Text -> + -- | Name of entry to comment on + EntrySelector -> + ZipArchive () setEntryComment text s = addPending (I.SetEntryComment text s) -- | Delete an entry's comment, if that entry does not exist, nothing will -- happen. - deleteEntryComment :: EntrySelector -> ZipArchive () deleteEntryComment s = addPending (I.DeleteEntryComment s) -- | Set the “last modification” date\/time. The specified entry may be -- missing, in that case the action has no effect. - -setModTime - :: UTCTime -- ^ New modification time - -> EntrySelector -- ^ Name of entry to modify - -> ZipArchive () +setModTime :: + -- | New modification time + UTCTime -> + -- | Name of entry to modify + EntrySelector -> + ZipArchive () setModTime time s = addPending (I.SetModTime time s) -- | Add an extra field. The 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 :: + -- | Tag (header id) of extra field to add + Word16 -> + -- | Body of the field + ByteString -> + -- | Name of entry to modify + EntrySelector -> + ZipArchive () addExtraField n b s = addPending (I.AddExtraField n b s) -- | Delete an extra field by its type (tag). The 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 :: + -- | Tag (header id) of extra field to delete + Word16 -> + -- | Name of entry to modify + EntrySelector -> + ZipArchive () deleteExtraField n s = addPending (I.DeleteExtraField n s) -- | Set external file attributes. This function can be used to set file @@ -556,45 +585,43 @@ -- See also: "Codec.Archive.Zip.Unix". -- -- @since 1.2.0 - -setExternalFileAttrs - :: Word32 -- ^ External file attributes - -> EntrySelector -- ^ Name of entry to modify - -> ZipArchive () +setExternalFileAttrs :: + -- | External file attributes + Word32 -> + -- | Name of entry to modify + EntrySelector -> + ZipArchive () setExternalFileAttrs attrs s = addPending (I.SetExternalFileAttributes attrs s) -- | Perform an action on every entry in the archive. - -forEntries - :: (EntrySelector -> ZipArchive ()) -- ^ Action to perform - -> ZipArchive () +forEntries :: + -- | Action to perform + (EntrySelector -> ZipArchive ()) -> + ZipArchive () forEntries action = getEntries >>= mapM_ action . M.keysSet -- | Set comment of the entire archive. - setArchiveComment :: Text -> ZipArchive () setArchiveComment text = addPending (I.SetArchiveComment text) -- | Delete the archive comment if it's present. - deleteArchiveComment :: ZipArchive () deleteArchiveComment = addPending I.DeleteArchiveComment -- | Undo changes to a specific archive entry. - undoEntryChanges :: EntrySelector -> ZipArchive () undoEntryChanges s = modifyActions f - where f = S.filter ((/= Just s) . I.targetEntry) + where + f = S.filter ((/= Just s) . I.targetEntry) -- | Undo changes to the archive as a whole (archive's comment). - undoArchiveChanges :: ZipArchive () undoArchiveChanges = modifyActions f - where f = S.filter ((/= Nothing) . I.targetEntry) + where + f = S.filter ((/= Nothing) . I.targetEntry) -- | Undo all changes made in this editing session. - undoAll :: ZipArchive () undoAll = modifyActions (const S.empty) @@ -605,14 +632,13 @@ -- (i.e. as part of 'createArchive' or 'withArchive'), or can be forced -- explicitly with the 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 + file <- getFilePath + odesc <- getArchiveDescription oentries <- getEntries - actions <- getPending - exists <- liftIO (doesFileExist file) + actions <- getPending + exists <- liftIO (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 @@ -620,38 +646,36 @@ -- 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 } + ZipArchive . modify $ \st -> + st + { zsEntries = nentries, + zsArchive = ndesc, + zsActions = S.empty + } ---------------------------------------------------------------------------- -- Helpers -- | Get the path of the actual archive file from inside of 'ZipArchive' -- monad. - getFilePath :: ZipArchive FilePath getFilePath = ZipArchive (gets zsFilePath) -- | Get the collection of pending actions. - getPending :: ZipArchive (Seq I.PendingAction) getPending = ZipArchive (gets zsActions) -- | Modify the 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) } + where + g st = st {zsActions = f (zsActions st)} -- | Add a new action to the list of pending actions. - addPending :: I.PendingAction -> ZipArchive () addPending a = modifyActions (|> a) -- | Recursively list a directory. Do not return paths to empty directories. - listDirRecur :: FilePath -> IO [FilePath] listDirRecur path = DList.toList <$> go "" where @@ -659,22 +683,22 @@ let cdir = path adir raw <- listDirectory cdir fmap mconcat . forM raw $ \case - "" -> return mempty - "." -> return mempty + "" -> return mempty + "." -> return mempty ".." -> return mempty - x -> do + x -> do let fullx = cdir x adir' = adir x - isFile <- doesFileExist fullx - isDir <- doesDirectoryExist fullx + isFile <- doesFileExist fullx + isDir <- doesDirectoryExist fullx if isFile then return (DList.singleton adir') - else if isDir - then go adir' - else return mempty + else + if isDir + then go adir' + else return mempty -- | Perform an action ignoring IO exceptions it may throw. - ignoringAbsence :: IO () -> IO () ignoringAbsence io = catchJust select io handler where diff --git a/Codec/Archive/Zip/CP437.hs b/Codec/Archive/Zip/CP437.hs --- a/Codec/Archive/Zip/CP437.hs +++ b/Codec/Archive/Zip/CP437.hs @@ -8,29 +8,28 @@ -- Portability : portable -- -- Support for decoding of CP 437 text. - module Codec.Archive.Zip.CP437 - ( decodeCP437 ) + ( decodeCP437, + ) where import Control.Arrow (first) import Data.ByteString (ByteString) +import qualified Data.ByteString as B import Data.Char import Data.Text (Text) +import qualified Data.Text as T import Data.Word (Word8) -import qualified Data.ByteString as B -import qualified Data.Text as T -- | Decode a 'ByteString' containing CP 437 encoded text. - decodeCP437 :: ByteString -> Text -decodeCP437 bs = T.unfoldrN - (B.length bs) - (fmap (first decodeByteCP437) . B.uncons) - bs +decodeCP437 bs = + T.unfoldrN + (B.length bs) + (fmap (first decodeByteCP437) . B.uncons) + bs -- | Decode a single byte of CP437 encoded text. - decodeByteCP437 :: Word8 -> Char decodeByteCP437 byte = chr $ case byte of 128 -> 199 @@ -161,4 +160,4 @@ 253 -> 178 254 -> 9632 255 -> 160 - x -> fromIntegral x -- the rest of characters translate directly + x -> fromIntegral x -- the rest of characters translate directly diff --git a/Codec/Archive/Zip/Internal.hs b/Codec/Archive/Zip/Internal.hs --- a/Codec/Archive/Zip/Internal.hs +++ b/Codec/Archive/Zip/Internal.hs @@ -1,1081 +1,1196 @@ --- | --- Module : Codec.Archive.Zip.Internal --- Copyright : © 2016–present Mark Karpov --- License : BSD 3 clause --- --- Maintainer : Mark Karpov --- Stability : experimental --- Portability : portable --- --- Low-level, non-public concepts and operations. - -{-# LANGUAGE CPP #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} - -module Codec.Archive.Zip.Internal - ( PendingAction (..) - , targetEntry - , scanArchive - , sourceEntry - , crc32Sink - , commit ) -where - -import Codec.Archive.Zip.CP437 (decodeCP437) -import Codec.Archive.Zip.Type -import Conduit (PrimMonad) -import Control.Applicative (many, (<|>)) -import Control.Exception (bracketOnError, catchJust) -import Control.Monad -import Control.Monad.Catch (MonadThrow (..)) -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Resource (ResourceT, MonadResource) -import Data.Bits -import Data.Bool (bool) -import Data.ByteString (ByteString) -import Data.Char (ord) -import Data.Conduit (ConduitT, (.|), ZipSink (..)) -import Data.Digest.CRC32 (crc32Update) -import Data.Fixed (Fixed (..)) -import Data.Foldable (foldl') -import Data.Map.Strict (Map, (!)) -import Data.Maybe (fromJust, catMaybes, isNothing) -import Data.Sequence (Seq, (><), (|>)) -import Data.Serialize -import Data.Text (Text) -import Data.Time -import Data.Version -import Data.Void -import Data.Word (Word16, Word32) -import Numeric.Natural (Natural) -import System.Directory -import System.FilePath -import System.IO -import System.IO.Error (isDoesNotExistError) -import qualified Data.ByteString as B -import qualified Data.Conduit as C -#ifdef ENABLE_BZIP2 -import qualified Data.Conduit.BZlib as BZ -#endif -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 - (ConduitT () ByteString (ResourceT IO) ()) - EntrySelector - -- ^ Add entry given its 'Source' - | CopyEntry FilePath 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 - | SetExternalFileAttributes Word32 EntrySelector - -- ^ Set an external file attribute for specified entry - --- | Collection of maps describing how to produce entries in resulting --- archive. - -data ProducingActions = ProducingActions - { paCopyEntry :: Map FilePath (Map EntrySelector EntrySelector) - , paSinkEntry :: Map EntrySelector (ConduitT () ByteString (ResourceT IO) ()) - } - --- | 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 ()) - , eaExtFileAttr :: Map EntrySelector Word32 } - --- | Origin 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 created by” to specify when writing archive data. - -zipVersion :: Version -zipVersion = Version [4,6] [] - ----------------------------------------------------------------------------- --- Higher-level operations - --- | Scan the central directory of an archive and return its description --- 'ArchiveDescription' as well as a 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 the 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 the consequences of the --- design decision to make it impossible to create non-portable archives --- with this library. - -scanArchive - :: FilePath -- ^ Path to archive to scan - -> IO (ArchiveDescription, Map EntrySelector EntryDescription) -scanArchive path = withBinaryFile 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 - :: (PrimMonad m, MonadThrow m, MonadResource m) - => FilePath -- ^ Path to archive that contains the entry - -> EntryDescription -- ^ Information needed to extract entry of interest - -> Bool -- ^ Should we stream uncompressed data? - -> ConduitT () ByteString m () -- ^ Source of uncompressed data -sourceEntry path EntryDescription {..} d = - source .| CB.isolate (fromIntegral edCompressedSize) .| decompress - where - source = CB.sourceIOHandle $ do - h <- openFile 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 C.awaitForever C.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 - :: FilePath -- ^ 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 path $ \h -> do - let (ProducingActions coping sinking, editing) = - optimize (toRecreatingActions path entries >< xs) - comment = predictComment adComment xs - 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) - --- | Create a new file with the guarantee that in case of exception the old --- file will be preserved intact. The file is only updated\/replaced if the --- second argument finishes without exceptions. - -withNewFile - :: FilePath -- ^ Name of file to create - -> (Handle -> IO ()) -- ^ Action that writes to given 'Handle' - -> IO () -withNewFile fpath action = - bracketOnError allocate release $ \(path, h) -> do - action h - hClose h - renameFile path fpath - where - allocate = openBinaryTempFile (takeDirectory fpath) ".zip" - release (path, h) = do - hClose h - -- Despite using `bracketOnError` the file is not guaranteed to exist here - -- since we could be interrupted with an async exception after the file has - -- been renamed. Therefore, we silentely ignore `DoesNotExistError`. - catchJust (guard . isDoesNotExistError) (removeFile path) (const $ pure ()) - --- | Determine what comment in new archive will look like given its original --- value and a 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 a map representing existing entries into a collection of --- actions that re-create those entires. - -toRecreatingActions - :: FilePath -- ^ Name of the 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 a collection of 'PendingAction's into 'ProducingActions' and --- 'EditingActions'—data that describes 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 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) } ) - SetExternalFileAttributes b s -> - ( pa - , ea { eaExtFileAttr = M.insert s b (eaExtFileAttr 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) - , eaExtFileAttr = M.delete s (eaExtFileAttr 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 the file --- associated with given handle. This can throw 'EntryDoesNotExist' if there --- is no such entry in that archive. - -copyEntries - :: Handle -- ^ Opened 'Handle' of zip archive file - -> FilePath -- ^ Path to the file to copy the entries from - -> 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 the 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) - -> ConduitT () ByteString (ResourceT IO) () -- ^ 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 - extFileAttr = case o of - GenericOrigin -> M.findWithDefault 0 s eaExtFileAttr - Borrowed _ -> M.findWithDefault 0 s eaExtFileAttr - 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 - desc0 = 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 - , edExternalFileAttrs = extFileAttr } - B.hPut h (runPut (putHeader LocalHeader s desc0)) - DataDescriptor {..} <- C.runConduitRes $ - 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 desc1 = case o of - GenericOrigin -> desc0 - { edCRC32 = ddCRC32 - , edCompressedSize = ddCompressedSize - , edUncompressedSize = ddUncompressedSize } - Borrowed ed -> desc0 - { edCRC32 = - bool (edCRC32 ed) ddCRC32 recompression - , edCompressedSize = - bool (edCompressedSize ed) ddCompressedSize recompression - , edUncompressedSize = - bool (edUncompressedSize ed) ddUncompressedSize recompression } - desc2 = desc1 - { edVersionNeeded = - getZipVersion (needsZip64 desc1) (Just compression) } - hSeek h AbsoluteSeek offset - B.hPut h (runPut (putHeader LocalHeader s desc2)) - hSeek h AbsoluteSeek afterStreaming - return (s, desc2) - --- | 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 - -> ConduitT ByteString Void (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 = getZipSink $ - ZipSink sizeSink <* ZipSink (CB.sinkHandle h) - withCompression sink = getZipSink $ - (,,) <$> ZipSink sizeSink - <*> ZipSink crc32Sink - <*> ZipSink sink - (uncompressedSize, crc32, compressedSize) <- - case compression of - Store -> withCompression - dataSink - Deflate -> withCompression $ - Z.compress 9 (Z.WindowBits (-15)) .| dataSink -#ifdef ENABLE_BZIP2 - BZip2 -> withCompression $ - BZ.bzip2 .| dataSink -#else - BZip2 -> throwM BZip2Unsupported -#endif - return DataDescriptor - { ddCRC32 = fromIntegral crc32 - , ddCompressedSize = compressedSize - , ddUncompressedSize = uncompressedSize } - --- | Append central directory entries and end of central directory record to --- the 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 <- fromIntegral <$> hTell h - B.hPut h cd -- write central directory - let totalCount = fromIntegral (M.size m) - cdSize = fromIntegral (B.length cd) - needZip64 = - totalCount >= ffff - || cdSize >= ffffffff - || cdOffset >= ffffffff - when needZip64 $ do - zip64ecdOffset <- fromIntegral <$> 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 the 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 a 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 - when (versionNeeded > zipVersion) . fail $ - "Version required to extract the archive is " - ++ showVersion versionNeeded ++ " (can do " - ++ showVersion zipVersion ++ ")" - 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 4 -- disk number start, internal file attributes - externalFileAttrs <- getWord32le -- 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 - , edExternalFileAttrs = externalFileAttrs } - in return $ (,desc) <$> (fileName >>= mkEntrySelector . T.unpack) - --- | 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 the 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 >= ffffffff - 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 >= ffffffff) $ - putWord64le (fromIntegral z64efUncompressedSize) -- uncompressed size - when (c == LocalHeader || z64efCompressedSize >= ffffffff) $ - putWord64le (fromIntegral z64efCompressedSize) -- compressed size - when (c == CentralDirHeader && z64efOffset >= ffffffff) $ - 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 edExternalFileAttrs -- 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 - :: Natural -- ^ Total number of entries - -> Natural -- ^ Size of the central directory - -> Natural -- ^ 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 $ getZipVersion True Nothing) - -- ↑ 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 - :: Natural -- ^ 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 - :: Natural -- ^ Total number of entries - -> Natural -- ^ Size of the central directory - -> Natural -- ^ 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 :: FilePath -> Handle -> IO (Maybe Integer) -locateECD path h = sizeCheck - where - - sizeCheck = do - fsize <- hFileSize h - let limit = max 0 (fsize - 0xffff - 22) - if fsize < 22 - then return Nothing - else hSeek h SeekFromEnd (-22) >> loop limit - - loop limit = do - sig <- getNum getWord32le 4 - pos <- subtract 4 <$> hTell h - let again = hSeek h AbsoluteSeek (pos - 1) >> loop limit - done = pos <= limit - if sig == 0x06054b50 - then do - result <- runMaybeT $ - MaybeT (checkComment pos) >>= - MaybeT . checkCDSig >>= - MaybeT . 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 || - -- ↑ normal case: central directory file header signature - cdSig == 0x06064b50 || - -- ↑ happens when zip 64 archive is empty - cdSig == 0x06054b50 - -- ↑ happens when vanilla archive is empty - 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 - --- | Rename an 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 (fromIntegral x :: Integer) > (fromIntegral bound :: Integer) - then bound - else fromIntegral x - where bound = maxBound :: b - --- | 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 (SetExternalFileAttributes _ 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 constitutes 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 ((ZIP_OS `shiftL` 8) .|. (major * 10 + minor)) - where (major,minor) = - case versionBranch v of - v0:v1:_ -> (v0, v1) - v0:_ -> (v0, 0) - [] -> (0, 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 - --- | Check if an entry with these parameters needs Zip64 extension. - -needsZip64 :: EntryDescription -> Bool -needsZip64 EntryDescription {..} = any (>= ffffffff) - [edOffset, edCompressedSize, edUncompressedSize] - --- | Determine “version needed to extract” that should be written to headers --- given need of Zip64 feature and compression method. - -getZipVersion :: Bool -> Maybe CompressionMethod -> Version -getZipVersion zip64 m = max zip64ver mver - where zip64ver = makeVersion (if zip64 then [4,5] else [2,0]) - mver = makeVersion $ case m of - Nothing -> [2,0] - Just Store -> [2,0] - Just Deflate -> [2,0] - Just BZip2 -> [4,6] - --- | Return decompressing 'Conduit' corresponding to the given compression --- method. - -decompressingPipe - :: (PrimMonad m, MonadThrow m, MonadResource m) - => CompressionMethod - -> ConduitT ByteString ByteString m () -decompressingPipe Store = C.awaitForever C.yield -decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15) -#ifdef ENABLE_BZIP2 -decompressingPipe BZip2 = BZ.bunzip2 -#else -decompressingPipe BZip2 = throwM BZip2Unsupported -#endif - --- | Sink that calculates CRC32 check sum for incoming stream. - -crc32Sink :: ConduitT ByteString Void (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 = - let (MkFixed x) = todSec tod - in fromIntegral (x `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) - --- We use the constants of the type 'Natural' instead of literals to protect --- ourselves from overflows on 32 bit systems. --- --- If we're in development mode, use lower values so the tests get a chance --- to check all cases (otherwise we would need to generate way too big --- archives on CI). - -ffff, ffffffff :: Natural +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Codec.Archive.Zip.Internal +-- Copyright : © 2016–present Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Low-level, non-public concepts and operations. +module Codec.Archive.Zip.Internal + ( PendingAction (..), + targetEntry, + scanArchive, + sourceEntry, + crc32Sink, + commit, + ) +where + +import Codec.Archive.Zip.CP437 (decodeCP437) +import Codec.Archive.Zip.Type +import Conduit (PrimMonad) +import Control.Applicative (many, (<|>)) +import Control.Exception (bracketOnError, catchJust) +import Control.Monad +import Control.Monad.Catch (MonadThrow (..)) +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Resource (MonadResource, ResourceT) +import Data.Bits +import Data.Bool (bool) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Char (ord) +import Data.Conduit (ConduitT, ZipSink (..), (.|)) +import qualified Data.Conduit as C +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL +import qualified Data.Conduit.Zlib as Z +import Data.Digest.CRC32 (crc32Update) +import Data.Fixed (Fixed (..)) +import Data.Foldable (foldl') +import Data.Map.Strict (Map, (!)) +import qualified Data.Map.Strict as M +import Data.Maybe (catMaybes, fromJust, isNothing) +import Data.Sequence (Seq, (><), (|>)) +import qualified Data.Sequence as S +import Data.Serialize +import qualified Data.Set as E +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time +import Data.Version +import Data.Void +import Data.Word (Word16, Word32) +import Numeric.Natural (Natural) +import System.Directory +import System.FilePath +import System.IO +import System.IO.Error (isDoesNotExistError) + +#ifdef ENABLE_BZIP2 +import qualified Data.Conduit.BZlib as BZ +#endif + +#ifdef ENABLE_ZSTD +import qualified Data.Conduit.Zstd as Zstandard +#endif + +---------------------------------------------------------------------------- +-- Data types + +-- | The sum type describes all possible actions that can be performed on +-- archive. +data PendingAction + = -- | Add entry given its 'Source' + SinkEntry + CompressionMethod + (ConduitT () ByteString (ResourceT IO) ()) + EntrySelector + | -- | Copy an entry form another archive without re-compression + CopyEntry FilePath EntrySelector EntrySelector + | -- | Change name the entry inside archive + RenameEntry EntrySelector EntrySelector + | -- | Delete entry from archive + DeleteEntry EntrySelector + | -- | Change compression method on an entry + Recompress CompressionMethod EntrySelector + | -- | Set comment for a particular entry + SetEntryComment Text EntrySelector + | -- | Delete comment of particular entry + DeleteEntryComment EntrySelector + | -- | Set modification time of particular entry + SetModTime UTCTime EntrySelector + | -- | Add an extra field to specified entry + AddExtraField Word16 ByteString EntrySelector + | -- | Delete an extra filed of specified entry + DeleteExtraField Word16 EntrySelector + | -- | Set comment for entire archive + SetArchiveComment Text + | -- | Delete comment of entire archive + DeleteArchiveComment + | -- | Set an external file attribute for specified entry + SetExternalFileAttributes Word32 EntrySelector + +-- | Collection of maps describing how to produce entries in resulting +-- archive. +data ProducingActions = ProducingActions + { paCopyEntry :: Map FilePath (Map EntrySelector EntrySelector), + paSinkEntry :: Map EntrySelector (ConduitT () ByteString (ResourceT IO) ()) + } + +-- | 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 ()), + eaExtFileAttr :: Map EntrySelector Word32 + } + +-- | Origin 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 created by” to specify when writing archive data. +zipVersion :: Version +zipVersion = Version [6, 3] [] + +---------------------------------------------------------------------------- +-- Higher-level operations + +-- | Scan the central directory of an archive and return its description +-- 'ArchiveDescription' as well as a 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 the 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 the consequences of the +-- design decision to make it impossible to create non-portable archives +-- with this library. +scanArchive :: + -- | Path to archive to scan + FilePath -> + IO (ArchiveDescription, Map EntrySelector EntryDescription) +scanArchive path = withBinaryFile 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 :: + (PrimMonad m, MonadThrow m, MonadResource m) => + -- | Path to archive that contains the entry + FilePath -> + -- | Information needed to extract entry of interest + EntryDescription -> + -- | Should we stream uncompressed data? + Bool -> + -- | Source of uncompressed data + ConduitT () ByteString m () +sourceEntry path EntryDescription {..} d = + source .| CB.isolate (fromIntegral edCompressedSize) .| decompress + where + source = CB.sourceIOHandle $ do + h <- openFile 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 C.awaitForever C.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 :: + -- | Location of archive file to edit or create + FilePath -> + -- | Archive description + ArchiveDescription -> + -- | Current list of entires + Map EntrySelector EntryDescription -> + -- | Collection of pending actions + Seq PendingAction -> + IO () +commit path ArchiveDescription {..} entries xs = + withNewFile path $ \h -> do + let (ProducingActions coping sinking, editing) = + optimize (toRecreatingActions path entries >< xs) + comment = predictComment adComment xs + 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) + +-- | Create a new file with the guarantee that in case of exception the old +-- file will be preserved intact. The file is only updated\/replaced if the +-- second argument finishes without exceptions. +withNewFile :: + -- | Name of file to create + FilePath -> + -- | Action that writes to given 'Handle' + (Handle -> IO ()) -> + IO () +withNewFile fpath action = + bracketOnError allocate release $ \(path, h) -> do + action h + hClose h + renameFile path fpath + where + allocate = openBinaryTempFile (takeDirectory fpath) ".zip" + release (path, h) = do + hClose h + -- Despite using `bracketOnError` the file is not guaranteed to exist here + -- since we could be interrupted with an async exception after the file has + -- been renamed. Therefore, we silentely ignore `DoesNotExistError`. + catchJust (guard . isDoesNotExistError) (removeFile path) (const $ pure ()) + +-- | Determine what comment in new archive will look like given its original +-- value and a 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 a map representing existing entries into a collection of +-- actions that re-create those entires. +toRecreatingActions :: + -- | Name of the archive file where entires are found + FilePath -> + -- | Actual list of entires + Map EntrySelector EntryDescription -> + -- | Actions that recreate the archive entries + Seq PendingAction +toRecreatingActions path entries = E.foldl' f S.empty (M.keysSet entries) + where + f s e = s |> CopyEntry path e e + +-- | Transform a collection of 'PendingAction's into 'ProducingActions' and +-- 'EditingActions'—data that describes how to create resulting archive. +optimize :: + -- | Collection of pending actions + Seq PendingAction -> + -- | Optimized data + (ProducingActions, EditingActions) +optimize = + foldl' + f + ( ProducingActions M.empty M.empty, + EditingActions M.empty 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) + } + ) + SetExternalFileAttributes b s -> + ( pa, + ea {eaExtFileAttr = M.insert s b (eaExtFileAttr 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), + eaExtFileAttr = M.delete s (eaExtFileAttr 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 the file +-- associated with given handle. This can throw 'EntryDoesNotExist' if there +-- is no such entry in that archive. +copyEntries :: + -- | Opened 'Handle' of zip archive file + Handle -> + -- | Path to the file to copy the entries from + FilePath -> + -- | 'Map' from original name to name to use in new archive + Map EntrySelector EntrySelector -> + -- | Additional info that can influence result + EditingActions -> + -- | Info to generate central directory file headers later + IO (Map EntrySelector EntryDescription) +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 the file associated with given +-- 'Handle'. +sinkEntry :: + -- | Opened 'Handle' of zip archive file + Handle -> + -- | Name of entry to add + EntrySelector -> + -- | Origin of entry (can contain additional info) + EntryOrigin -> + -- | Source of entry contents + ConduitT () ByteString (ResourceT IO) () -> + -- | Additional info that can influence result + EditingActions -> + -- | Info to generate central directory file headers later + IO (EntrySelector, EntryDescription) +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 + extFileAttr = case o of + GenericOrigin -> M.findWithDefault 0 s eaExtFileAttr + Borrowed _ -> M.findWithDefault 0 s eaExtFileAttr + 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 + desc0 = + 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, + edExternalFileAttrs = extFileAttr + } + B.hPut h (runPut (putHeader LocalHeader s desc0)) + DataDescriptor {..} <- + C.runConduitRes $ + 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 desc1 = case o of + GenericOrigin -> + desc0 + { edCRC32 = ddCRC32, + edCompressedSize = ddCompressedSize, + edUncompressedSize = ddUncompressedSize + } + Borrowed ed -> + desc0 + { edCRC32 = + bool (edCRC32 ed) ddCRC32 recompression, + edCompressedSize = + bool (edCompressedSize ed) ddCompressedSize recompression, + edUncompressedSize = + bool (edUncompressedSize ed) ddUncompressedSize recompression + } + desc2 = + desc1 + { edVersionNeeded = + getZipVersion (needsZip64 desc1) (Just compression) + } + hSeek h AbsoluteSeek offset + B.hPut h (runPut (putHeader LocalHeader s desc2)) + hSeek h AbsoluteSeek afterStreaming + return (s, desc2) + +-- | Create 'Sink' to stream data there. Once streaming is finished, return +-- 'DataDescriptor' for the streamed data. The action /does not/ close given +-- 'Handle'. +sinkData :: + -- | Opened 'Handle' of zip archive file + Handle -> + -- | Compression method to apply + CompressionMethod -> + -- | 'Sink' where to stream data + ConduitT ByteString Void (ResourceT IO) DataDescriptor +sinkData h compression = do + let sizeSink = CL.fold (\acc input -> fromIntegral (B.length input) + acc) 0 + dataSink = + getZipSink $ + ZipSink sizeSink <* ZipSink (CB.sinkHandle h) + withCompression sink = + getZipSink $ + (,,) <$> ZipSink sizeSink + <*> ZipSink crc32Sink + <*> ZipSink sink + (uncompressedSize, crc32, compressedSize) <- + case compression of + Store -> + withCompression + dataSink + Deflate -> + withCompression $ + Z.compress 9 (Z.WindowBits (-15)) .| dataSink +#ifdef ENABLE_BZIP2 + BZip2 -> + withCompression $ + BZ.bzip2 .| dataSink +#else + BZip2 -> throwM BZip2Unsupported +#endif +#ifdef ENABLE_ZSTD + Zstd -> + withCompression $ + Zstandard.compress 1 .| dataSink +#else + Zstd -> throwM ZstdUnsupported +#endif + return + DataDescriptor + { ddCRC32 = fromIntegral crc32, + ddCompressedSize = compressedSize, + ddUncompressedSize = uncompressedSize + } + +-- | Append central directory entries and end of central directory record to +-- the 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 :: + -- | Opened handle of zip archive file + Handle -> + -- | Commentary to entire archive + Maybe Text -> + -- | Info about already written local headers and entry data + Map EntrySelector EntryDescription -> + IO () +writeCD h comment m = do + let cd = runPut (putCD m) + cdOffset <- fromIntegral <$> hTell h + B.hPut h cd -- write central directory + let totalCount = fromIntegral (M.size m) + cdSize = fromIntegral (B.length cd) + needZip64 = + totalCount >= ffff + || cdSize >= ffffffff + || cdOffset >= ffffffff + when needZip64 $ do + zip64ecdOffset <- fromIntegral <$> 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 the 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 a 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 + when (versionNeeded > zipVersion) . fail $ + "Version required to extract the archive is " + ++ showVersion versionNeeded + ++ " (can do " + ++ showVersion zipVersion + ++ ")" + 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 4 -- disk number start, internal file attributes + externalFileAttrs <- getWord32le -- 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, + edExternalFileAttrs = externalFileAttrs + } + in return $ (,desc) <$> (fileName >>= mkEntrySelector . T.unpack) + +-- | 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 the 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 :: + -- | What is read from central directory file header + Zip64ExtraField -> + -- | Actual binary representation + ByteString -> + -- | Result + Zip64ExtraField +parseZip64ExtraField dflt@Zip64ExtraField {..} b = + either (const dflt) id . flip runGet b $ do + let ifsat v = + if v >= ffffffff + 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 :: + -- | Is this for local or central directory header? + HeaderType -> + -- | Zip64 extra field's data + Zip64ExtraField -> + -- | Resulting representation + ByteString +makeZip64ExtraField c Zip64ExtraField {..} = runPut $ do + when (c == LocalHeader || z64efUncompressedSize >= ffffffff) $ + putWord64le (fromIntegral z64efUncompressedSize) -- uncompressed size + when (c == LocalHeader || z64efCompressedSize >= ffffffff) $ + putWord64le (fromIntegral z64efCompressedSize) -- compressed size + when (c == CentralDirHeader && z64efOffset >= ffffffff) $ + 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 :: + -- | Type of header to generate + HeaderType -> + -- | Name of entry to write + EntrySelector -> + -- | Description of entry + EntryDescription -> + 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 edExternalFileAttrs -- 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 :: + -- | Total number of entries + Natural -> + -- | Size of the central directory + Natural -> + -- | Offset of central directory record + Natural -> + 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 $ getZipVersion True Nothing) + -- ↑ 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 :: + -- | Offset of Zip64 end of central directory + Natural -> + 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 :: + -- | Total number of entries + Natural -> + -- | Size of the central directory + Natural -> + -- | Offset of central directory record + Natural -> + -- | Zip file comment + Maybe Text -> + 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 :: FilePath -> Handle -> IO (Maybe Integer) +locateECD path h = sizeCheck + where + sizeCheck = do + fsize <- hFileSize h + let limit = max 0 (fsize - 0xffff - 22) + if fsize < 22 + then return Nothing + else hSeek h SeekFromEnd (-22) >> loop limit + loop limit = do + sig <- getNum getWord32le 4 + pos <- subtract 4 <$> hTell h + let again = hSeek h AbsoluteSeek (pos - 1) >> loop limit + done = pos <= limit + if sig == 0x06054b50 + then do + result <- + runMaybeT $ + MaybeT (checkComment pos) + >>= MaybeT . checkCDSig + >>= MaybeT . 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 + || + -- ↑ normal case: central directory file header signature + cdSig == 0x06064b50 + || + -- ↑ happens when zip 64 archive is empty + cdSig == 0x06054b50 + then -- ↑ happens when vanilla archive is empty + 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 + +-- | Rename an 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 (fromIntegral x :: Integer) > (fromIntegral bound :: Integer) + then bound + else fromIntegral x + where + bound = maxBound :: b + +-- | 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 (SetExternalFileAttributes _ 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 constitutes valid UTF-8 text, this function can fail. In that case +-- 'Nothing' is returned. +decodeText :: + -- | Whether bit 11 of general-purpose bit flag is set + Bool -> + -- | Binary data to decode + ByteString -> + -- | Decoded 'Text' in case of success + Maybe Text +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 ((ZIP_OS `shiftL` 8) .|. (major * 10 + minor)) + where + (major, minor) = + case versionBranch v of + v0 : v1 : _ -> (v0, v1) + v0 : _ -> (v0, 0) + [] -> (0, 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 93 = Just Zstd +toCompressionMethod _ = Nothing + +-- | Convert 'CompressionMethod' to its numeric representation as per .ZIP +-- specification. +fromCompressionMethod :: CompressionMethod -> Word16 +fromCompressionMethod Store = 0 +fromCompressionMethod Deflate = 8 +fromCompressionMethod BZip2 = 12 +fromCompressionMethod Zstd = 93 + +-- | Check if an entry with these parameters needs Zip64 extension. +needsZip64 :: EntryDescription -> Bool +needsZip64 EntryDescription {..} = + any + (>= ffffffff) + [edOffset, edCompressedSize, edUncompressedSize] + +-- | Determine “version needed to extract” that should be written to headers +-- given need of Zip64 feature and compression method. +getZipVersion :: Bool -> Maybe CompressionMethod -> Version +getZipVersion zip64 m = max zip64ver mver + where + zip64ver = makeVersion (if zip64 then [4, 5] else [2, 0]) + mver = makeVersion $ case m of + Nothing -> [2, 0] + Just Store -> [2, 0] + Just Deflate -> [2, 0] + Just BZip2 -> [4, 6] + Just Zstd -> [6, 3] + +-- | Return decompressing 'Conduit' corresponding to the given compression +-- method. +decompressingPipe :: + (PrimMonad m, MonadThrow m, MonadResource m) => + CompressionMethod -> + ConduitT ByteString ByteString m () +decompressingPipe Store = C.awaitForever C.yield +decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15) + +#ifdef ENABLE_BZIP2 +decompressingPipe BZip2 = BZ.bunzip2 +#else +decompressingPipe BZip2 = throwM BZip2Unsupported +#endif + +#ifdef ENABLE_ZSTD +decompressingPipe Zstd = Zstandard.decompress +#else +decompressingPipe Zstd = throwM ZstdUnsupported +#endif + +-- | Sink that calculates CRC32 check sum for incoming stream. +crc32Sink :: ConduitT ByteString Void (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 = + let (MkFixed x) = todSec tod + in fromIntegral (x `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) + +-- We use the constants of the type 'Natural' instead of literals to protect +-- ourselves from overflows on 32 bit systems. +-- +-- If we're in development mode, use lower values so the tests get a chance +-- to check all cases (otherwise we would need to generate way too big +-- archives on CI). + +ffff, ffffffff :: Natural + #ifdef HASKELL_ZIP_DEV_MODE ffff = 200 ffffffff = 5000 diff --git a/Codec/Archive/Zip/Type.hs b/Codec/Archive/Zip/Type.hs --- a/Codec/Archive/Zip/Type.hs +++ b/Codec/Archive/Zip/Type.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} + -- | -- Module : Codec.Archive.Zip.Type -- Copyright : © 2016–present Mark Karpov @@ -8,47 +11,47 @@ -- Portability : portable -- -- Types used by the package. - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} - module Codec.Archive.Zip.Type ( -- * Entry selector - EntrySelector - , mkEntrySelector - , unEntrySelector - , getEntryName - , EntrySelectorException (..) + EntrySelector, + mkEntrySelector, + unEntrySelector, + getEntryName, + EntrySelectorException (..), + -- * Entry description - , EntryDescription (..) - , CompressionMethod (..) + EntryDescription (..), + CompressionMethod (..), + -- * Archive description - , ArchiveDescription (..) + ArchiveDescription (..), + -- * Exceptions - , ZipException (..) ) + ZipException (..), + ) where import Control.Exception (Exception) import Control.Monad.Catch (MonadThrow (..)) import Data.ByteString (ByteString) +import qualified Data.ByteString as B import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI import Data.Data (Data) import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE import Data.Map (Map) import Data.Maybe (mapMaybe) import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Data.Time.Clock (UTCTime) import Data.Typeable (Typeable) import Data.Version (Version) import Data.Word (Word16, Word32) import Numeric.Natural -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 as FP +import qualified System.FilePath.Posix as Posix import qualified System.FilePath.Windows as Windows ---------------------------------------------------------------------------- @@ -69,11 +72,11 @@ -- systems (as recommended in the specification). On the other hand, in can -- be rendered as an 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, Typeable) + { -- | Path pieces of relative path inside archive + unES :: NonEmpty (CI String) + } + deriving (Eq, Ord, Typeable) instance Show EntrySelector where show = show . unEntrySelector @@ -91,7 +94,6 @@ -- 65535 bytes -- -- This function can throw an 'EntrySelectorException'. - mkEntrySelector :: MonadThrow m => FilePath -> m EntrySelector mkEntrySelector path = let f x = @@ -99,40 +101,37 @@ [] -> Nothing xs -> Just (CI.mk xs) giveup = throwM (InvalidEntrySelector path) - in case NE.nonEmpty (mapMaybe f (FP.splitPath path)) of - Nothing -> giveup - Just pieces -> - let selector = EntrySelector pieces - binLength = B.length . T.encodeUtf8 . getEntryName - in if Posix.isValid path && - Windows.isValid path && - not (FP.isAbsolute path || FP.hasTrailingPathSeparator path) && - (CI.mk "." `notElem` pieces) && - (CI.mk ".." `notElem` pieces) && - binLength selector <= 0xffff - then return selector - else giveup + in case NE.nonEmpty (mapMaybe f (FP.splitPath path)) of + Nothing -> giveup + Just pieces -> + let selector = EntrySelector pieces + binLength = B.length . T.encodeUtf8 . getEntryName + in if Posix.isValid path + && Windows.isValid path + && not (FP.isAbsolute path || FP.hasTrailingPathSeparator path) + && (CI.mk "." `notElem` pieces) + && (CI.mk ".." `notElem` pieces) + && binLength selector <= 0xffff + then return selector + else giveup -- | Restore a relative path from 'EntrySelector'. Every 'EntrySelector' -- corresponds to a single 'FilePath'. - unEntrySelector :: EntrySelector -> FilePath unEntrySelector = FP.joinPath . fmap CI.original . NE.toList . unES -- | Get an entry name in the from that is suitable for writing to file -- header, given an 'EntrySelector'. - getEntryName :: EntrySelector -> Text getEntryName = T.pack . concat . NE.toList . NE.intersperse "/" . fmap CI.original . unES -- | The exception represents various troubles you can have with -- 'EntrySelector'. - newtype EntrySelectorException - = InvalidEntrySelector FilePath - -- ^ 'EntrySelector' cannot be created from this path + = -- | 'EntrySelector' cannot be created from this path + InvalidEntrySelector FilePath deriving (Eq, Ord, Typeable) instance Show EntrySelectorException where @@ -147,59 +146,85 @@ -- stored in a zip archive. It does not mirror local file header or central -- directory file header, but their binary representations can be built -- given this data structure and the 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 - , edExternalFileAttrs :: Word32 -- ^ External file attributes - -- - -- @since 1.2.0 - } deriving (Eq, Typeable) + { -- | Version made by + edVersionMadeBy :: Version, + -- | Version needed to extract + edVersionNeeded :: Version, + -- | Compression method + edCompression :: CompressionMethod, + -- | Last modification date and time + edModTime :: UTCTime, + -- | CRC32 check sum + edCRC32 :: Word32, + -- | Size of compressed entry + edCompressedSize :: Natural, + -- | Size of uncompressed entry + edUncompressedSize :: Natural, + -- | Absolute offset of local file header + edOffset :: Natural, + -- | Entry comment + edComment :: Maybe Text, + -- | All extra fields found + edExtraField :: Map Word16 ByteString, + -- | External file attributes + -- + -- @since 1.2.0 + edExternalFileAttrs :: Word32 + } + deriving (Eq, Typeable) -- | Supported compression methods. - data CompressionMethod - = Store -- ^ Store file uncompressed - | Deflate -- ^ Deflate - | BZip2 -- ^ Compressed using BZip2 algorithm + = -- | Store file uncompressed + Store + | -- | Deflate + Deflate + | -- | Compressed using BZip2 algorithm + BZip2 + | -- | Compressed using Zstandard algorithm + -- + -- @since 1.6.0 + Zstd deriving (Show, Read, Eq, Ord, Enum, Bounded, Data, Typeable) ---------------------------------------------------------------------------- -- 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 (Show, Read, Eq, Ord, Typeable, Data) + { -- | Comment of entire archive + adComment :: Maybe Text, + -- | Absolute offset of start of central directory + adCDOffset :: Natural, + -- | Size of central directory record + adCDSize :: Natural + } + deriving (Show, Read, Eq, Ord, Typeable, Data) ---------------------------------------------------------------------------- -- Exceptions -- | The bad things that can happen when you use the library. - data ZipException - = EntryDoesNotExist FilePath EntrySelector - -- ^ Thrown when you try to get contents of non-existing entry - | ParsingFailed FilePath String - -- ^ Thrown when archive structure cannot be parsed + = -- | Thrown when you try to get contents of non-existing entry + EntryDoesNotExist FilePath EntrySelector + | -- | Thrown when archive structure cannot be parsed #ifndef ENABLE_BZIP2 - | BZip2Unsupported - -- ^ Thrown when attempting to decompress a 'BZip2' entry and the + -- | Thrown when attempting to decompress a 'BZip2' entry and the -- library is compiled without support for it. -- -- @since 1.3.0 + | BZip2Unsupported #endif +#ifndef ENABLE_ZSTD + -- | Thrown when attempting to decompress a 'Zstd' entry and the + -- library is compiled without support for it. + -- + -- @since 1.6.0 + | ZstdUnsupported +#endif + ParsingFailed FilePath String deriving (Eq, Ord, Typeable) instance Show ZipException where @@ -207,10 +232,17 @@ "No such entry found: " ++ show s ++ " in " ++ show file show (ParsingFailed file msg) = "Parsing of archive structure failed: \n" ++ msg ++ "\nin " ++ show file + #ifndef ENABLE_BZIP2 show BZip2Unsupported = "Encountered a zipfile entry with BZip2 compression, but " ++ "the zip library has been built with bzip2 disabled." +#endif + +#ifndef ENABLE_ZSTD + show ZstdUnsupported = + "Encountered a zipfile entry with Zstd compression, but " ++ + "the zip library has been built with zstd disabled." #endif instance Exception ZipException diff --git a/Codec/Archive/Zip/Unix.hs b/Codec/Archive/Zip/Unix.hs --- a/Codec/Archive/Zip/Unix.hs +++ b/Codec/Archive/Zip/Unix.hs @@ -10,10 +10,10 @@ -- Unix specific functionality of zip archives. -- -- @since 1.4.0 - module Codec.Archive.Zip.Unix - ( toFileMode - , fromFileMode ) + ( toFileMode, + fromFileMode, + ) where import Data.Bits @@ -26,7 +26,6 @@ -- 0o0755 -- -- @since 1.4.0 - toFileMode :: Word32 -> CMode toFileMode attrs = fromIntegral $ (attrs `shiftR` 16) .&. 0x0fff @@ -37,6 +36,5 @@ -- 2179792896 -- -- @since 1.4.0 - fromFileMode :: CMode -> Word32 fromFileMode cmode = (0o100000 .|. fromIntegral cmode) `shiftL` 16 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ [![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) [![Stackage LTS](http://stackage.org/package/zip/badge/lts)](http://stackage.org/lts/package/zip) -[![Build Status](https://travis-ci.org/mrkkrp/zip.svg?branch=master)](https://travis-ci.org/mrkkrp/zip) +![CI](https://github.com/mrkkrp/zip/workflows/CI/badge.svg?branch=master) * [Why this library is written](#why-this-library-is-written) * [zip-archive](#zip-archive) @@ -98,6 +98,7 @@ * Store (no compression, just store files “as is”) * [DEFLATE](deflate) * [Bzip2](bzip2) +* [Zstandard](zstd) The best way to add a new compression method to the library is to write a conduit that will do the compression and publish it as a library. `zip` can @@ -284,3 +285,4 @@ [specification]: https://pkware.cachefly.net/webdocs/APPNOTE/APPNOTE-6.3.3.TXT [deflate]: https://en.wikipedia.org/wiki/DEFLATE [bzip2]: https://en.wikipedia.org/wiki/Bzip2 +[zstd]: https://en.wikipedia.org/wiki/Zstandard diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where @@ -13,31 +13,31 @@ import Control.Monad.IO.Class import Data.Bits import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as LB +import qualified Data.ByteString.Lazy as LB +import qualified Data.Conduit as C +import qualified Data.Conduit.List as CL +import qualified Data.DList as DList import Data.List (intercalate) import Data.Map (Map, (!)) +import qualified Data.Map.Strict as M import Data.Maybe (fromJust) +import qualified Data.Set as E import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Data.Time import Data.Version import Data.Word import System.Directory import System.FilePath (()) +import qualified System.FilePath as FP import System.IO import System.IO.Error (isDoesNotExistError) import System.IO.Temp import Test.Hspec import Test.QuickCheck hiding ((.&.)) -import qualified Data.ByteString as B -import qualified Data.ByteString.Builder as LB -import qualified Data.ByteString.Lazy as LB -import qualified Data.Conduit as C -import qualified Data.Conduit.List as CL -import qualified Data.DList as DList -import qualified Data.Map.Strict 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 as FP #if !MIN_VERSION_base(4,13,0) import Data.Semigroup ((<>)) @@ -47,39 +47,38 @@ -- 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 - describe "fromFileMode" fromFileModeSpec + describe "getEntryName" getEntryNameSpec + describe "decodeCP437" decodeCP437Spec + describe "fromFileMode" fromFileModeSpec around withSandbox $ do - describe "createArchive" createArchiveSpec - describe "withArchive" withArchiveSpec - describe "archive comment" archiveCommentSpec - describe "getEntryDesc" getEntryDescSpec - describe "version needed" versionNeededSpec - 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 "createArchive" createArchiveSpec + describe "withArchive" withArchiveSpec + describe "archive comment" archiveCommentSpec + describe "getEntryDesc" getEntryDescSpec + describe "version needed" versionNeededSpec + 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 "setExternalFileAttrsSpec" setExternalFileAttrsSpec - describe "renameEntry" renameEntrySpec - describe "deleteEntry" deleteEntrySpec - describe "forEntries" forEntriesSpec - describe "undoEntryChanges" undoEntryChangesSpec + describe "renameEntry" renameEntrySpec + describe "deleteEntry" deleteEntrySpec + describe "forEntries" forEntriesSpec + describe "undoEntryChanges" undoEntryChangesSpec describe "undoArchiveChanges" undoArchiveChangesSpec - describe "undoAll" undoAllSpec - describe "consistency" consistencySpec - describe "packDirRecur'" packDirRecur'Spec - describe "unpackInto" unpackIntoSpec + describe "undoAll" undoAllSpec + describe "consistency" consistencySpec + describe "packDirRecur'" packDirRecur'Spec + describe "unpackInto" unpackIntoSpec ---------------------------------------------------------------------------- -- Arbitrary instances and generators @@ -91,18 +90,23 @@ arbitrary = B.pack <$> listOf arbitrary instance Arbitrary CompressionMethod where - arbitrary = elements - [ Store - , Deflate + arbitrary = + elements + [ Store, #ifdef ENABLE_BZIP2 - , BZip2 + BZip2, #endif - ] +#ifdef ENABLE_ZSTD + Zstd, +#endif + Deflate + ] instance Arbitrary UTCTime where - arbitrary = UTCTime - <$> (ModifiedJulianDay <$> choose (44239, 90989)) - <*> (secondsToDiffTime <$> choose (0, 86399)) + arbitrary = + UTCTime + <$> (ModifiedJulianDay <$> choose (44239, 90989)) + <*> (secondsToDiffTime <$> choose (0, 86399)) newtype RelPath = RelPath FilePath @@ -111,26 +115,29 @@ instance Arbitrary RelPath where arbitrary = do - p <- intercalate "/" <$> listOf1 - ((++) <$> vectorOf 3 charGen - <*> listOf1 charGen) + p <- + intercalate "/" + <$> listOf1 + ( (++) <$> vectorOf 3 charGen + <*> listOf1 charGen + ) case mkEntrySelector p of Nothing -> arbitrary - Just _ -> return (RelPath p) + Just _ -> return (RelPath p) instance Arbitrary EntrySelector where arbitrary = do RelPath x <- arbitrary case mkEntrySelector x of Nothing -> arbitrary - Just s -> return s + Just s -> return s -data EM = EM EntrySelector EntryDescription (ZipArchive ()) deriving Show +data EM = EM EntrySelector EntryDescription (ZipArchive ()) deriving (Show) instance Arbitrary EM where arbitrary = do - s <- arbitrary - method <- arbitrary + s <- arbitrary + method <- arbitrary content <- arbitrary modTime <- arbitrary comment <- arbitrary @@ -143,21 +150,25 @@ setEntryComment comment s addExtraField extraFieldTag extraFieldContent s setExternalFileAttrs externalFileAttrs 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 - , edExternalFileAttrs = externalFileAttrs } - action + 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, + edExternalFileAttrs = externalFileAttrs + } + action -data EC = EC (Map EntrySelector EntryDescription) (ZipArchive ()) deriving Show +data EC = EC (Map EntrySelector EntryDescription) (ZipArchive ()) deriving (Show) instance Arbitrary EC where arbitrary = do @@ -166,26 +177,37 @@ return (EC (M.map fst m) (sequence_ $ snd <$> M.elems m)) charGen :: Gen Char -charGen = frequency - [ (3, choose ('a', 'z')) - , (3, choose ('A', 'Z')) - , (3, choose ('0', '9')) - , (1, arbitrary `suchThat` (>= ' ')) ] +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) ] + 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) ++ - "\n, edExtFileAttr = " ++ show (edExternalFileAttrs ed) ++ - " }" + 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) + ++ "\n, edExtFileAttr = " + ++ show (edExternalFileAttrs ed) + ++ " }" instance Show (ZipArchive a) where show = const "" @@ -201,8 +223,9 @@ s <- mkEntrySelector x getEntryName s `shouldBe` T.pack x context "when absolute paths are passed" $ - it "they are rejected" $ property $ \(RelPath x) -> - rejects ('/' : x) + it "they are rejected" $ + property $ \(RelPath x) -> + rejects ('/' : x) context "when paths with trailing path separator are passed" $ it "they are rejected" $ do rejects "foo/" @@ -247,11 +270,11 @@ 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] "αßΓπΣσµτΦΘΩδ∞φε∩≡±≥≤⌠⌡÷≈°∙·√ⁿ²■ " + let c b t = decodeCP437 (B.pack b) `shouldBe` t + c [0x80 .. 0x9f] "ÇüéâäàåçêëèïîìÄÅÉæÆôöòûùÿÖÜ¢£¥₧ƒ" + c [0xa0 .. 0xbf] "áíóúñѪº¿⌐¬½¼¡«»░▒▓│┤╡╢╖╕╣║╗╝╜╛┐" + c [0xc0 .. 0xdf] "└┴┬├─┼╞╟╚╔╩╦╠═╬╧╨╤╥╙╘╒╓╫╪┘┌█▄▌▐▀" + c [0xe0 .. 0xff] "αßΓπΣσµτΦΘΩδ∞φε∩≡±≥≤⌠⌡÷≈°∙·√ⁿ²■ " fromFileModeSpec :: Spec fromFileModeSpec = @@ -260,7 +283,7 @@ (toFileMode . fromFileMode) (fromIntegral mode) == fromIntegral (mode .&. (0x0fff :: Word16)) it "toFileMode == toFileMode . fromFileMode . toFileMode" . property $ \mode -> - toFileMode mode == (toFileMode.fromFileMode.toFileMode) mode + toFileMode mode == (toFileMode . fromFileMode . toFileMode) mode ---------------------------------------------------------------------------- -- Primitive editing/querying actions @@ -285,13 +308,14 @@ context "when called with occupied path (empty file)" $ it "throws 'ParsingFailed' exception" $ \path -> do B.writeFile path B.empty - withArchive path (return ()) `shouldThrow` - isParsingFailed path "Cannot locate end of central directory" + 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 B.writeFile path emptyArchive withArchive path $ - liftIO $ B.writeFile path B.empty + liftIO $ + B.writeFile path B.empty B.readFile path `shouldNotReturn` emptyArchive archiveCommentSpec :: SpecWith FilePath @@ -307,301 +331,330 @@ 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 + 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 + 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' + 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 + it "actually deletes it" $ \path -> + property $ \txt -> do + comment <- createArchive path $ do + setArchiveComment txt + commit + deleteArchiveComment + commit + getArchiveComment + comment `shouldBe` Nothing getEntryDescSpec :: SpecWith FilePath getEntryDescSpec = - it "always returns correct description" $ - \path -> property $ \(EM s desc z) -> do + it "always returns correct description" $ \path -> + property $ \(EM s desc z) -> do desc' <- fromJust <$> createArchive path (z >> commit >> getEntryDesc s) desc' `shouldSatisfy` softEq desc versionNeededSpec :: SpecWith FilePath versionNeededSpec = - it "writes correct version that is needed to extract archive" $ + it "writes correct version that is needed to extract archive" $ \path -> -- NOTE for now we check only how version depends on compression method, -- it should be mentioned that the version also depends on Zip64 feature - \path -> property $ \(EM s desc z) -> do + property $ \(EM s desc z) -> do desc' <- fromJust <$> createArchive path (z >> commit >> getEntryDesc s) - edVersionNeeded desc' `shouldBe` makeVersion - (case edCompression desc of - Store -> [2,0] - Deflate -> [2,0] - BZip2 -> [4,6]) + edVersionNeeded desc' + `shouldBe` makeVersion + ( case edCompression desc of + Store -> [2, 0] + Deflate -> [2, 0] + BZip2 -> [4, 6] + Zstd -> [6, 3] + ) addEntrySpec :: SpecWith FilePath 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) + 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 FilePath sinkEntrySpec = context "when an entry is sunk" $ - it "is there" $ \path -> property $ \m b s -> do - info <- createArchive path $ do - sinkEntry m (C.yield b) s - commit - (,) <$> sourceEntry s (CL.foldMap id) - <*> (edCompression . (! s) <$> getEntries) - info `shouldBe` (b, m) + it "is there" $ \path -> + property $ \m b s -> do + info <- createArchive path $ do + sinkEntry m (C.yield b) s + commit + (,) <$> sourceEntry s (CL.foldMap id) + <*> (edCompression . (! s) <$> getEntries) + info `shouldBe` (b, m) loadEntrySpec :: SpecWith FilePath loadEntrySpec = context "when an entry is loaded" $ - it "is there" $ \path -> property $ \m b s t -> do - let vpath = deriveVacant path - B.writeFile vpath b - setModificationTime vpath t - createArchive path $ do - loadEntry m s vpath - commit - liftIO (removeFile vpath) - saveEntry s vpath - B.readFile vpath `shouldReturn` b - modTime <- getModificationTime vpath - modTime `shouldSatisfy` isCloseTo t + it "is there" $ \path -> + property $ \m b s t -> do + let vpath = deriveVacant path + B.writeFile vpath b + setModificationTime vpath t + createArchive path $ do + loadEntry m s vpath + commit + liftIO (removeFile vpath) + saveEntry s vpath + B.readFile vpath `shouldReturn` b + modTime <- getModificationTime vpath + modTime `shouldSatisfy` isCloseTo t copyEntrySpec :: SpecWith FilePath 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) + 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 FilePath 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 + it "passes the check" $ \path -> + property $ \m b s -> do + check <- createArchive path $ do + addEntry m b s commit - fromIntegral . edOffset . (! s) <$> getEntries - withFile 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 + 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 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 FilePath 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') + 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 FilePath 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 + 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 + 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' + 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 + 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 FilePath 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 + it "reads it and updates" $ \path -> + property $ \time s -> do modTime <- createArchive path $ do - setModTime time s addEntry Store "foo" s + setModTime time s commit edModTime . (! s) <$> getEntries - modTime `shouldNotSatisfy` isCloseTo time + 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 FilePath 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 + 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 + 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' + 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 + 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 setExternalFileAttrsSpec :: SpecWith FilePath setExternalFileAttrsSpec = context "when an external file attribute is added (after creation)" $ - it "sets a custom external file attribute" $ \path -> property $ \attr s -> do - attr' <- createArchive path $ do - addEntry Store "foo" s - setExternalFileAttrs attr s - commit - edExternalFileAttrs . (! s) <$> getEntries - attr' `shouldBe` attr + it "sets a custom external file attribute" $ \path -> + property $ \attr s -> do + attr' <- createArchive path $ do + addEntry Store "foo" s + setExternalFileAttrs attr s + commit + edExternalFileAttrs . (! s) <$> getEntries + attr' `shouldBe` attr renameEntrySpec :: SpecWith FilePath 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 + 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 + 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 FilePath 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 + 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 + 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 FilePath forEntriesSpec = @@ -612,7 +665,7 @@ forEntries (setEntryComment txt) commit getEntries - let f ed = ed { edComment = Just txt } + let f ed = ed {edComment = Just txt} m' `shouldSatisfy` softEqMap (M.map f m) undoEntryChangesSpec :: SpecWith FilePath @@ -661,8 +714,8 @@ consistencySpec :: SpecWith FilePath consistencySpec = - it "can save and restore arbitrary archive" $ - \path -> property $ \(EC m z) txt -> do + it "can save and restore arbitrary archive" $ \path -> + property $ \(EC m z) txt -> do (txt', m') <- createArchive path $ do z setArchiveComment txt @@ -673,8 +726,8 @@ packDirRecur'Spec :: SpecWith FilePath packDirRecur'Spec = - it "packs arbitrary directory recursively" $ - \path -> property $ + it "packs arbitrary directory recursively" $ \path -> + property $ forAll (downScale arbitrary) $ \contents -> withSystemTempDirectory "zip-sandbox" $ \dir -> do forM_ contents $ \s -> do @@ -697,8 +750,8 @@ unpackIntoSpec :: SpecWith FilePath unpackIntoSpec = - it "unpacks archive contents into directory" $ - \path -> property $ \(EC m z) -> + it "unpacks archive contents into directory" $ \path -> + property $ \(EC m z) -> withSystemTempDirectory "zip-sandbox" $ \dir -> do createArchive path $ do z @@ -713,19 +766,16 @@ -- Helpers -- | Change the size parameter of generator by dividing it by 2. - downScale :: Gen a -> Gen a downScale = scale (`div` 2) -- | Check whether given exception is 'EntrySelectorException' with specific -- path inside. - isEntrySelectorException :: FilePath -> EntrySelectorException -> Bool isEntrySelectorException path (InvalidEntrySelector p) = p == path -- | Check whether given exception is 'ParsingFailed' exception with -- specific path and error message inside. - isParsingFailed :: FilePath -> String -> ZipException -> Bool isParsingFailed path msg (ParsingFailed path' msg') = path == path' && msg == msg' @@ -735,51 +785,67 @@ -- 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 FilePath -> IO () withSandbox action = withSystemTempDirectory "zip-sandbox" $ \dir -> action (dir "foo.zip") -- | Given primary name (name of archive), generate a name that does not -- collide with it. - deriveVacant :: FilePath -> FilePath deriveVacant = ( "bar") . FP.takeDirectory -- | 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) + 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 :: + 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 + 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 ] +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 + ] -- | Recursively list a directory. Do not return paths to empty directories. - listDirRecur :: FilePath -> IO [FilePath] listDirRecur path = DList.toList <$> go "" where @@ -787,16 +853,17 @@ let cdir = path adir raw <- listDirectory cdir fmap mconcat . forM raw $ \case - "" -> return mempty - "." -> return mempty + "" -> return mempty + "." -> return mempty ".." -> return mempty - x -> do + x -> do let fullx = cdir x adir' = adir x - isFile <- doesFileExist fullx - isDir <- doesDirectoryExist fullx + isFile <- doesFileExist fullx + isDir <- doesDirectoryExist fullx if isFile then return (DList.singleton adir') - else if isDir - then go adir' - else return mempty + else + if isDir + then go adir' + else return mempty diff --git a/zip.cabal b/zip.cabal --- a/zip.cabal +++ b/zip.cabal @@ -1,116 +1,150 @@ -name: zip -version: 1.5.0 -cabal-version: 1.18 -tested-with: GHC==8.6.5, GHC==8.8.3, GHC==8.10.1 -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-doc-files: CHANGELOG.md - , README.md +cabal-version: 1.18 +name: zip +version: 1.6.0 +license: BSD3 +license-file: LICENSE.md +maintainer: Mark Karpov +author: Mark Karpov +tested-with: ghc ==8.6.5 ghc ==8.8.4 ghc ==8.10.1 +homepage: https://github.com/mrkkrp/zip +bug-reports: https://github.com/mrkkrp/zip/issues +synopsis: Operations on zip archives +description: Operations on zip archives. +category: Codec +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md +source-repository head + type: git + location: https://github.com/mrkkrp/zip.git + flag dev - description: Turn on development settings. - manual: True - default: False + description: Turn on development settings. + default: False + manual: True flag disable-bzip2 - description: Removes dependency on bzip2 C library and hence support for BZip2 entries. - default: False - manual: True + description: + Removes dependency on bzip2 C library and hence support for BZip2 entries. + default: False + manual: True + +flag disable-zstd + description: + Removes dependency on zstd C library and hence support for Zstandard entries. + + default: False + manual: True + library - build-depends: base >= 4.11 && < 5.0 - , bytestring >= 0.9 && < 0.11 - , case-insensitive >= 1.2.0.2 && < 1.3 - , cereal >= 0.3 && < 0.6 - , conduit >= 1.3 && < 1.4 - , conduit-extra >= 1.3 && < 1.4 - , containers >= 0.5 && < 0.7 - , digest < 0.1 - , directory >= 1.2.2 && < 1.4 - , dlist >= 0.8 && < 0.9 - , exceptions >= 0.6 && < 0.11 - , filepath >= 1.2 && < 1.5 - , monad-control >= 1.0 && < 1.1 - , mtl >= 2.0 && < 3.0 - , resourcet >= 1.2 && < 1.3 - , text >= 0.2 && < 1.3 - , time >= 1.4 && < 1.10 - , transformers >= 0.4 && < 0.6 - , transformers-base - if !flag(disable-bzip2) - build-depends: bzlib-conduit >= 0.3 && < 0.4 - exposed-modules: Codec.Archive.Zip - , Codec.Archive.Zip.CP437 - , Codec.Archive.Zip.Unix - other-modules: Codec.Archive.Zip.Internal - , Codec.Archive.Zip.Type - if flag(dev) - ghc-options: -O0 -Wall -Werror -Wcompat - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wnoncanonical-monad-instances - cpp-options: -DHASKELL_ZIP_DEV_MODE - else - ghc-options: -O2 -Wall - if !flag(disable-bzip2) - cpp-options: -DENABLE_BZIP2 - default-language: Haskell2010 + exposed-modules: + Codec.Archive.Zip + Codec.Archive.Zip.CP437 + Codec.Archive.Zip.Unix - if os(windows) - cpp-options: -DZIP_OS=0 - else - cpp-options: -DZIP_OS=3 + other-modules: + Codec.Archive.Zip.Internal + Codec.Archive.Zip.Type -test-suite tests - main-is: Main.hs - hs-source-dirs: tests - type: exitcode-stdio-1.0 - build-depends: base >= 4.11 && < 5.0 - , QuickCheck >= 2.4 && < 3.0 - , bytestring >= 0.9 && < 0.11 - , conduit >= 1.3 && < 1.4 - , containers >= 0.5 && < 0.7 - , directory >= 1.2.2 && < 1.4 - , dlist >= 0.8 && < 0.9 - , exceptions >= 0.6 && < 0.11 - , filepath >= 1.2 && < 1.5 - , hspec >= 2.0 && < 3.0 - , temporary >= 1.1 && < 1.4 - , text >= 0.2 && < 1.3 - , time >= 1.4 && < 1.10 - , transformers >= 0.4 && < 0.6 - , zip - if flag(dev) - ghc-options: -O0 -Wall -Werror - else - ghc-options: -O2 -Wall - if !flag(disable-bzip2) - cpp-options: -DENABLE_BZIP2 - default-language: Haskell2010 + default-language: Haskell2010 + build-depends: + base >=4.12 && <5.0, + bytestring >=0.9 && <0.11, + case-insensitive >=1.2.0.2 && <1.3, + cereal >=0.3 && <0.6, + conduit >=1.3 && <1.4, + conduit-extra >=1.3 && <1.4, + containers >=0.5 && <0.7, + digest <0.1, + directory >=1.2.2 && <1.4, + dlist >=0.8 && <2.0, + exceptions >=0.6 && <0.11, + filepath >=1.2 && <1.5, + monad-control >=1.0 && <1.1, + mtl >=2.0 && <3.0, + resourcet >=1.2 && <1.3, + text >=0.2 && <1.3, + time >=1.4 && <1.10, + transformers >=0.4 && <0.6, + transformers-base -any -source-repository head - type: git - location: https://github.com/mrkkrp/zip.git + if !flag(disable-bzip2) + build-depends: bzlib-conduit >=0.3 && <0.4 + if !flag(disable-zstd) + build-depends: conduit-zstd >=0.0.2 && <0.1 + + if flag(dev) + cpp-options: -DHASKELL_ZIP_DEV_MODE + ghc-options: + -O0 -Wall -Werror -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wnoncanonical-monad-instances + + else + ghc-options: -O2 -Wall + + if !flag(disable-bzip2) + cpp-options: -DENABLE_BZIP2 + + if !flag(disable-zstd) + cpp-options: -DENABLE_ZSTD + + if os(windows) + cpp-options: -DZIP_OS=0 + + else + cpp-options: -DZIP_OS=3 + executable haskell-zip-app - main-is: Main.hs - hs-source-dirs: bench-app - build-depends: base >= 4.11 && < 5.0 - , filepath >= 1.2 && < 1.5 - , zip - if flag(dev) - ghc-options: -Wall -Werror -Wcompat - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wnoncanonical-monad-instances - else - ghc-options: -O2 -Wall - default-language: Haskell2010 + main-is: Main.hs + hs-source-dirs: bench-app + default-language: Haskell2010 + build-depends: + base >=4.12 && <5.0, + filepath >=1.2 && <1.5, + zip -any + + if flag(dev) + ghc-options: + -Wall -Werror -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wnoncanonical-monad-instances + + else + ghc-options: -O2 -Wall + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: tests + default-language: Haskell2010 + build-depends: + base >=4.12 && <5.0, + QuickCheck >=2.4 && <3.0, + bytestring >=0.9 && <0.11, + conduit >=1.3 && <1.4, + containers >=0.5 && <0.7, + directory >=1.2.2 && <1.4, + dlist >=0.8 && <2.0, + exceptions >=0.6 && <0.11, + filepath >=1.2 && <1.5, + hspec >=2.0 && <3.0, + temporary >=1.1 && <1.4, + text >=0.2 && <1.3, + time >=1.4 && <1.10, + transformers >=0.4 && <0.6, + zip -any + + if flag(dev) + ghc-options: -O0 -Wall -Werror + + else + ghc-options: -O2 -Wall + + if !flag(disable-bzip2) + cpp-options: -DENABLE_BZIP2 + + if !flag(disable-zstd) + cpp-options: -DENABLE_ZSTD