zip 1.5.0 → 1.6.0

raw patch · 9 files changed

+2162/−1884 lines, 9 filesdep +conduit-zstddep ~basedep ~bytestring

Dependencies added: conduit-zstd

Dependency ranges changed: base, bytestring

Files

• CHANGELOG.md +7/−0
• Codec/Archive/Zip.hs +280/−256
• Codec/Archive/Zip/CP437.hs +10/−11
• Codec/Archive/Zip/Internal.hs +1193/−1078
• Codec/Archive/Zip/Type.hs +106/−74
• Codec/Archive/Zip/Unix.hs +3/−5
• README.md +3/−1
• tests/Main.hs +421/−354
• zip.cabal +139/−105

@@ -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.

@@ -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

@@ -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

@@ -1,1081 +1,1196 @@--- |--- Module      :  Codec.Archive.Zip.Internal--- Copyright   :  © 2016–present Mark Karpov--- License     :  BSD 3 clause------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- 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 <markkarpov92@gmail.com>+-- 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

@@ -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

@@ -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

@@ -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

@@ -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 "<zip archive>"@@ -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

@@ -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 <markkarpov92@gmail.com>-maintainer:           Mark Karpov <markkarpov92@gmail.com>-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 <markkarpov92@gmail.com>+author:          Mark Karpov <markkarpov92@gmail.com>+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