zip 0.1.11 → 2.2.2

raw patch · 13 files changed

Files

• CHANGELOG.md +129/−0
• Codec/Archive/Zip.hs +421/−298
• Codec/Archive/Zip/CP437.hs +11/−12
• Codec/Archive/Zip/Internal.hs +1256/−1018
• Codec/Archive/Zip/Internal/Type.hs +230/−0
• Codec/Archive/Zip/Type.hs +0/−207
• Codec/Archive/Zip/Unix.hs +40/−0
• LICENSE.md +1/−1
• README.md +88/−94
• Setup.hs +0/−6
• bench-app/Main.hs +19/−0
• tests/Main.hs +939/−706
• zip.cabal +143/−76

@@ -1,3 +1,132 @@+## Zip 2.2.2++* Make `sourceEntry` close file handles promptly. [Issue+  142](https://github.com/mrkkrp/zip/issues/142).++## Zip 2.2.1++* Don't add Zip64 fields when copying entries from another archive+  unless the source entry has them. [PR+  128](https://github.com/mrkkrp/zip/pull/128).++## Zip 2.2.0++* Skip the addition of Zip64 extra fields when sufficiently short strict+  input is provided (e.g. via `addEntry`). [Issue+  126](https://github.com/mrkkrp/zip/issues/126).++## Zip 2.1.0++* Exposed `Codec.Archive.Zip.Internal` and `Codec.Archive.Zip.Internal.Type`+  modules. [PR 115](https://github.com/mrkkrp/zip/pull/115).++* Derived `Show` for `EntryDescription`. [PR+  115](https://github.com/mrkkrp/zip/pull/115).++## Zip 2.0.1++* Fixed corruption of large entries when zip64 is used. [Issue+  111](https://github.com/mrkkrp/zip/issues/111).++## Zip 2.0.0++* Unified `BZip2Unsupported` and `ZstdUnsupported` into a single data+  constructor `UnsupportedCompressionMethod` with a `CompressionMethod`+  field.++## Zip 1.7.2++* Now the ZIP64 extra field is only written when it is necessary. Previously+  it was written unconditionally and it confused some tools.++## Zip 1.7.1++* Fixed compilation with zstd and/or bzip2 disabled.++## Zip 1.7.0++* Set user permissions on linux platform as follows: if an existing file is+  added, use its permissions; if an entry is generated from a bytestring or+  a stream, use 0600. This behavior mimics the zip utility.++## 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.++* Dropped support for GHC 8.4.++## Zip 1.4.1++* Fixed the build on Mac.++## Zip 1.4.0++* The “version made by” info inside archive now correctly sets Unix as the+  OS that produced the archive when the library is compiled on Unix. This+  allows other utilities such as `unzip` to read and correctly restore file+  permissions. [Issue 62](https://github.com/mrkkrp/zip/issues/62).++* Added the `Codec.Archive.Zip.Unix` module.++## Zip 1.3.2++* Fix a bug where removing a temporary file failed in the prescence of+  async exceptions.++## Zip 1.3.1++* The test suite is now faster.++## Zip 1.3.0++* Dropped support for GHC 8.2 and older.++* Added a Cabal flag `-fdisable-bzip2` to remove the bzip2 C library+  dependency and hence support for BZip2 entries.++## Zip 1.2.0++* Added the `setExternalFileAttrs` function and the `edExternalFileAttrs`+  field in the `EntryDescription` record.++## Zip 1.1.0++* Made `saveEntry` and `unpackInto` restore modification time of files.++## Zip 1.0.0++* Works with `conduit-1.3.0`, `conduit-extra-1.3.0`, `resourcet-1.2.0` and+  `bzlib-conduit-0.3.0`.++* Stop depending on `path`, `path-io`, and `plub-b`.++* Made the module `Codec.Archive.Zip.Type` non-public.++* Remove derived instances of `Data` and `Generic` for `EntrySelector` not+  to expose its inner structure.++* Change signature of the `loadEntry` function, its second argument is now+  just `EntrySelector` of the entry to add.++* The second argument of `packDirRecur` now receives paths that are relative+  to the root of the directory we pack.++## Zip 0.2.0++* Added `MonadBase` and `MonadBaseControl` instances for the `ZipArchive`+  monad. Also exported the `ZipState` type without revealing its data+  constructor and records.++* Dropped `MonadThrow` and `MonadCatch` constraints for `createArchive` and+  `withArchive`.+ ## Zip 0.1.11  * Minor refactoring.

@@ -1,6 +1,13 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+ -- | -- Module      :  Codec.Archive.Zip--- Copyright   :  © 2016–2017 Mark Karpov+-- Copyright   :  © 2016–present Mark Karpov -- License     :  BSD 3 clause -- -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>@@ -9,157 +16,170 @@ -- -- The module provides everything you may need to manipulate Zip archives. -- There are three things that should be clarified right away, to avoid--- confusion in the future.+-- confusion. ----- First, we use the 'EntrySelector' type that can be obtained from 'Path'--- 'Rel' 'File' paths. This method may seem awkward at first, but it will--- protect you from the problems with portability when your archive is--- unpacked on a different platform. Using well-typed paths is also--- something you should consider doing in your projects anyway. Even if you--- don't want to use the "Path" module in your project, it's easy to marshal--- 'FilePath' to 'Path' just before using functions from the library.+-- First, we use the 'EntrySelector' type that can be obtained from relative+-- 'FilePath's (paths to directories are not allowed). This method may seem+-- awkward at first, but it will protect you from the problems with+-- portability when your archive is unpacked on a different platform. ----- The second thing, that is rather a consequence of the first, is that--- there is no way to add directories, or to be precise, /empty directories/--- to your archive. This approach is used in Git, and I find it quite sane.+-- Second, there is no way to add directories, or to be precise, /empty+-- directories/ to your archive. This approach is used in Git, and I find it+-- sane. -- -- Finally, the third feature of the library is that it does not modify -- archive instantly, because doing so on every manipulation would often be--- inefficient. Instead we maintain a collection of pending actions that can--- be turned into an optimized procedure that efficiently modifies archive--- in one pass. Normally this should be of no concern to you, because all--- actions are performed automatically when you leave the realm of+-- inefficient. Instead, we maintain a collection of pending actions that+-- can be turned into an optimized procedure that efficiently modifies the+-- archive in one pass. Normally, this should be of no concern to you,+-- because all actions are performed automatically when you leave the -- 'ZipArchive' monad. If, however, you ever need to force an update, the--- 'commit' function is your friend. There are even “undo” functions, by the--- way.+-- 'commit' function is your friend. -- -- === Examples -- -- An example of a program that prints a list of archive entries: -- -- > import Codec.Archive.Zip--- > import Path.IO (resolveFile') -- > import System.Environment (getArgs) -- > import qualified Data.Map as M -- > -- > main :: IO () -- > main = do--- >   [fp]    <- getArgs--- >   path    <- resolveFile' fp+-- >   [path]  <- getArgs -- >   entries <- withArchive path (M.keys <$> getEntries) -- >   mapM_ print entries -- -- Create a Zip archive with a “Hello World” file: -- -- > import Codec.Archive.Zip--- > import Path (parseRelFile)--- > import Path.IO (resolveFile') -- > import System.Environment (getArgs) -- > -- > main :: IO () -- > main = do--- >   [fp]    <- getArgs--- >   path    <- resolveFile' fp--- >   s       <- parseRelFile "hello-world.txt" >>= mkEntrySelector+-- >   [path] <- getArgs+-- >   s      <- mkEntrySelector "hello-world.txt" -- >   createArchive path (addEntry Store "Hello, World!" s) ----- Extract contents of a specific file and print them:+-- Extract contents of a file and print them: -- -- > import Codec.Archive.Zip--- > import Path (parseRelFile)--- > import Path.IO (resolveFile') -- > import System.Environment (getArgs) -- > import qualified Data.ByteString.Char8 as B -- > -- > main :: IO () -- > main = do--- >   [fp,f]  <- getArgs--- >   path    <- resolveFile' fp--- >   s       <- parseRelFile f >>= mkEntrySelector--- >   bs      <- withArchive path (getEntry s)+-- >   [path,f] <- getArgs+-- >   s        <- mkEntrySelector f+-- >   bs       <- withArchive path (getEntry s) -- >   B.putStrLn bs--{-# LANGUAGE GeneralizedNewtypeDeriving #-}- 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-  , 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+    addEntry,+    sinkEntry,+    loadEntry,+    copyEntry,+    packDirRecur,+    packDirRecur',+     -- ** Modifying entries-  , renameEntry-  , deleteEntry-  , recompress-  , setEntryComment-  , deleteEntryComment-  , setModTime-  , addExtraField-  , deleteExtraField-  , 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 Codec.Archive.Zip.Type+import Codec.Archive.Zip.Internal qualified as I+import Codec.Archive.Zip.Internal.Type+import Conduit (PrimMonad) import Control.Monad+import Control.Monad.Base (MonadBase (..)) import Control.Monad.Catch import Control.Monad.State.Strict-import Control.Monad.Trans.Resource (ResourceT, runResourceT, MonadResource)+import Control.Monad.Trans.Control (MonadBaseControl (..))+import Control.Monad.Trans.Resource (MonadResource, ResourceT) import Data.ByteString (ByteString)-import Data.Conduit (Source, Sink, ($$), yield)+import Data.Conduit (ConduitT, (.|))+import Data.Conduit qualified as C+import Data.Conduit.Binary qualified as CB+import Data.Conduit.List qualified as CL+import Data.DList qualified as DList import Data.Map.Strict (Map, (!))+import Data.Map.Strict qualified as M import Data.Sequence (Seq, (|>))+import Data.Sequence qualified as S+import Data.Set qualified as E import Data.Text (Text) import Data.Time.Clock (UTCTime)-import Data.Word (Word16)-import Path-import Path.IO-import qualified Codec.Archive.Zip.Internal as I-import qualified Data.Conduit.Binary        as CB-import qualified Data.Conduit.List          as CL-import qualified Data.Map.Strict            as M-import qualified Data.Sequence              as S-import qualified Data.Set                   as E+import Data.Void+import Data.Word (Word16, Word32)+import System.Directory+import System.FilePath ((</>))+import System.FilePath qualified as FP+import System.IO.Error (isDoesNotExistError) +#ifndef mingw32_HOST_OS+import qualified Codec.Archive.Zip.Unix as Unix+import qualified System.Posix as Unix+#endif+ ---------------------------------------------------------------------------- -- Archive monad @@ -167,49 +187,70 @@ -- 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+    ) --- | Internal state record used by the 'ZipArchive' monad.+-- | @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)+  {-# INLINEABLE liftBaseWith #-}+  restoreM = ZipArchive . StateT . const . return+  {-# INLINEABLE restoreM #-}++-- | The 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  :: Path Abs File-    -- ^ Absolute path to zip archive-  , zsEntries   :: Map EntrySelector EntryDescription-    -- ^ Actual collection of entries-  , zsArchive   :: ArchiveDescription-    -- ^ Info about the whole archive-  , zsActions   :: Seq I.PendingAction-    -- ^ Pending actions+  { -- | 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, MonadCatch m)-  => Path b File       -- ^ Location of archive file to create-  -> ZipArchive a      -- ^ Actions that form archive's content-  -> m a-createArchive path m = do+createArchive ::+  (MonadIO m) =>+  -- | Location of the archive file to create+  FilePath ->+  -- | Actions that create the 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 }-      action = unZipArchive (liftM2 const m commit)-  liftIO (evalStateT action st)+  let st =+        ZipState+          { zsFilePath = apath,+            zsEntries = M.empty,+            zsArchive = ArchiveDescription Nothing 0 0,+            zsActions = S.empty+          }+      action = unZipArchive (m <* commit)+  evalStateT action st  -- | Work with an existing archive. See 'createArchive' if you want to -- create a new archive instead.@@ -235,34 +276,37 @@ -- '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, MonadThrow m)-  => Path b File       -- ^ Location of archive to work with-  -> ZipArchive a      -- ^ Actions on that archive-  -> m a-withArchive path m = do-  apath           <- canonicalizePath path+withArchive ::+  (MonadIO m) =>+  -- | Location of the archive to work with+  FilePath ->+  -- | Actions on that archive+  ZipArchive a ->+  m a+withArchive path m = liftIO $ do+  apath <- canonicalizePath path   (desc, entries) <- liftIO (I.scanArchive apath)-  let st = ZipState-        { zsFilePath = apath-        , zsEntries  = entries-        , zsArchive  = desc-        , zsActions  = S.empty }-      action = unZipArchive (liftM2 const m commit)+  let st =+        ZipState+          { zsFilePath = apath,+            zsEntries = entries,+            zsArchive = desc,+            zsActions = S.empty+          }+      action = unZipArchive (m <* commit)   liftIO (evalStateT action st)  ---------------------------------------------------------------------------- -- Retrieving information --- | Retrieve description of all archive entries. This is an efficient--- operation that can be used for example to list all entries in an archive.--- Do not hesitate to use the function frequently: scanning of archive--- happens only once anyway.+-- | Retrieve a description of all archive entries. This is an efficient+-- operation that can be used for example to list all entries in the+-- archive. Do not hesitate to use the function frequently: scanning of the+-- archive happens only once. ----- 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.-+-- Please note that the returned value only reflects the current contents of+-- the archive in file system, non-committed actions are not reflected, see+-- 'commit' for more information. getEntries :: ZipArchive (Map EntrySelector EntryDescription) getEntries = ZipArchive (gets zsEntries) @@ -270,15 +314,13 @@ -- simple shortcut defined as: -- -- > doesEntryExist s = M.member s <$> getEntries- doesEntryExist :: EntrySelector -> ZipArchive Bool doesEntryExist s = M.member s <$> getEntries --- | Get 'EntryDescription' for specified entry. This is a simple shortcut+-- | Get 'EntryDescription' for a specified entry. This is a simple shortcut -- defined as: -- -- > getEntryDesc s = M.lookup s <$> getEntries- getEntryDesc :: EntrySelector -> ZipArchive (Maybe EntryDescription) getEntryDesc s = M.lookup s <$> getEntries @@ -287,10 +329,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.@@ -298,80 +341,81 @@ -- Throws: 'EntryDoesNotExist'. -- -- @since 0.1.3--getEntrySource-  :: MonadResource m-  => EntrySelector-  -> ZipArchive (Source m ByteString)+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-  -> Sink ByteString (ResourceT IO) a-     -- ^ Sink where to stream entry contents-  -> ZipArchive a-     -- ^ Contents of the entry (if found)+sourceEntry ::+  -- | Selector that identifies the 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 . runResourceT) (src $$ sink)+  (liftIO . C.runConduitRes) (src .| sink)  -- | Save a specific archive entry as a file in the file system. -- -- Throws: 'EntryDoesNotExist'.--saveEntry-  :: EntrySelector     -- ^ Selector that identifies archive entry-  -> Path b File       -- ^ Where to save the file-  -> ZipArchive ()-saveEntry s path = sourceEntry s (CB.sinkFile (toFilePath path))+saveEntry ::+  -- | Selector that identifies the archive entry+  EntrySelector ->+  -- | Where to save the file+  FilePath ->+  ZipArchive ()+saveEntry s path = do+  sourceEntry s (CB.sinkFile path)+  med <- getEntryDesc s+  forM_ med (liftIO . setModificationTime path . edModTime)  -- | Calculate CRC32 check sum and compare it with the value read from the -- archive. The function returns 'True' when the check sums are the -- 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 the archive entry+  EntrySelector ->+  -- | Is the entry intact?+  ZipArchive Bool checkEntry s = do   calculated <- sourceEntry s I.crc32Sink-  given      <- edCRC32 . (! s) <$> getEntries-  -- ↑ NOTE We can assume that entry exists for sure because otherwise+  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 :: Path b Dir -> ZipArchive ()+-- | Unpack the 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   unless (null selectors) $ do     dir <- liftIO (makeAbsolute dir')-    liftIO (ensureDir dir)-    let dirs = E.map (parent . (dir </>) . unEntrySelector) selectors-    forM_ dirs (liftIO . ensureDir)+    liftIO (createDirectoryIfMissing True dir)+    let dirs = E.map (FP.takeDirectory . (dir </>) . unEntrySelector) selectors+    forM_ dirs (liftIO . createDirectoryIfMissing True)     forM_ selectors $ \s ->       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) @@ -379,215 +423,294 @@ -- 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 t b s = addPending (I.SinkEntry t (yield b) s)+addEntry ::+  -- | The compression method to use+  CompressionMethod ->+  -- | Entry contents+  ByteString ->+  -- | Name of the entry to add+  EntrySelector ->+  ZipArchive ()+addEntry t b s = addPending (I.StrictEntry t b s)  -- | Stream data from the specified source to an archive entry.--sinkEntry-  :: CompressionMethod -- ^ Compression method to use-  -> Source (ResourceT IO) ByteString -- ^ Source of entry contents-  -> EntrySelector     -- ^ Name of entry to add-  -> ZipArchive ()+sinkEntry ::+  -- | The compression method to use+  CompressionMethod ->+  -- | Source of entry contents+  ConduitT () ByteString (ResourceT IO) () ->+  -- | Name of the 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-  -> (Path Abs File -> ZipArchive EntrySelector) -- ^ How to get 'EntrySelector'-  -> Path b File       -- ^ Path to file to add-  -> ZipArchive ()-loadEntry t f path = do-  apath   <- liftIO (canonicalizePath path)-  s       <- f apath+loadEntry ::+  -- | The compression method to use+  CompressionMethod ->+  -- | Name of the entry to add+  EntrySelector ->+  -- | Path to the file to add+  FilePath ->+  ZipArchive ()+loadEntry t s path = do+  apath <- liftIO (canonicalizePath path)   modTime <- liftIO (getModificationTime path)-  let src = CB.sourceFile (toFilePath apath)+  let src = CB.sourceFile apath   addPending (I.SinkEntry t src s)   addPending (I.SetModTime modTime s) --- | Copy an entry “as is” from another zip archive. If the entry does not--- exist in that archive, 'EntryDoesNotExist' will be eventually thrown.+#ifndef mingw32_HOST_OS+  status <- liftIO $ Unix.getFileStatus path+  setExternalFileAttrs (Unix.fromFileMode (Unix.fileMode status)) s+#endif -copyEntry-  :: Path b File       -- ^ Path to archive to copy from-  -> EntrySelector     -- ^ Name of entry (in source archive) to copy-  -> EntrySelector     -- ^ Name of entry to insert (in actual archive)-  -> ZipArchive ()+-- | Copy an entry “as is” from another zip archive. If the entry does not+-- exist in that archive, 'EntryDoesNotExist' will be thrown.+copyEntry ::+  -- | Path to the archive to copy from+  FilePath ->+  -- | Name of the entry (in the source archive) to copy+  EntrySelector ->+  -- | Name of the entry to insert (in current archive)+  EntrySelector ->+  ZipArchive () copyEntry path s' s = do   apath <- liftIO (canonicalizePath path)   addPending (I.CopyEntry apath s' s) --- | Add an entire directory to the archive. Please note that due to the--- design of the library, empty sub-directories won't be added.+-- | Add an directory to the archive. Please note that due to the design of+-- the library, empty sub-directories will not be added. ----- The action can throw the same exceptions as 'listDirRecur' and--- 'InvalidEntrySelector'.+-- The action can throw 'InvalidEntrySelector'.+packDirRecur ::+  -- | The compression method to use+  CompressionMethod ->+  -- | How to get the 'EntrySelector' from a path relative to the root of+  -- the directory we pack+  (FilePath -> ZipArchive EntrySelector) ->+  -- | Path to the directory to add+  FilePath ->+  ZipArchive ()+packDirRecur t f = packDirRecur' t f (const $ return ()) -packDirRecur-  :: CompressionMethod -- ^ Compression method to use-  -> (Path Abs File -> ZipArchive EntrySelector) -- ^ How to get 'EntrySelector'-  -> Path b Dir        -- ^ Path to directory to add-  -> ZipArchive ()-packDirRecur t f path = do-  files <- snd <$> liftIO (listDirRecur path)-  mapM_ (loadEntry t f) files+-- | The same as 'packDirRecur' but allows us to perform modifying actions+-- on the created entities as we go.+--+-- @since 1.5.0+packDirRecur' ::+  -- | The compression method to use+  CompressionMethod ->+  -- | How to get the '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 the directory to add+  FilePath ->+  ZipArchive ()+packDirRecur' t f patch path = do+  files <- liftIO (listDirRecur path)+  forM_ files $ \x -> do+    s <- f x+    loadEntry t s (path </> x)+    patch s  -- | 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 ::+  -- | The original entry name+  EntrySelector ->+  -- | The 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 ::+  -- | The new compression method+  CompressionMethod ->+  -- | Name of the 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 the 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+-- | 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 the 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 the extra field to add+  Word16 ->+  -- | Body of the field+  ByteString ->+  -- | Name of the 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 the extra field to delete+  Word16 ->+  -- | Name of the entry to modify+  EntrySelector ->+  ZipArchive () deleteExtraField n s = addPending (I.DeleteExtraField n s) --- | Perform an action on every entry in the archive.+-- | Set external file attributes. This function can be used to set file+-- permissions.+--+-- See also: "Codec.Archive.Zip.Unix".+--+-- @since 1.2.0+setExternalFileAttrs ::+  -- | External file attributes+  Word32 ->+  -- | Name of the entry to modify+  EntrySelector ->+  ZipArchive ()+setExternalFileAttrs attrs s =+  addPending (I.SetExternalFileAttributes attrs s) -forEntries-  :: (EntrySelector -> ZipArchive ()) -- ^ Action to perform-  -> ZipArchive ()+-- | Perform an action on every entry in the archive.+forEntries ::+  -- | The action to perform+  (EntrySelector -> ZipArchive ()) ->+  ZipArchive () forEntries action = getEntries >>= mapM_ action . M.keysSet --- | Set comment of the entire archive.-+-- | Set the comment of the entire archive. setArchiveComment :: Text -> ZipArchive () setArchiveComment text = addPending (I.SetArchiveComment text) --- | Delete the archive comment if it's present.-+-- | Delete the archive's comment if it's present. deleteArchiveComment :: ZipArchive () deleteArchiveComment = addPending I.DeleteArchiveComment --- | Undo changes to a specific archive entry.-+-- | Undo the changes to a specific archive entry. undoEntryChanges :: EntrySelector -> ZipArchive () undoEntryChanges s = modifyActions f-  where f = S.filter ((/= Just s) . I.targetEntry)---- | Undo changes to the archive as a whole (archive's comment).+  where+    f = S.filter ((/= Just s) . I.targetEntry) +-- | Undo the 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)  -- | Archive contents are not modified instantly, but instead changes are -- collected as “pending actions” that should be committed, in order to -- efficiently modify the archive in one pass. The actions are committed--- automatically when the program leaves the realm of 'ZipArchive' monad--- (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.-+-- automatically when the program leaves the 'ZipArchive' monad (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   <- 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+    -- NOTE The most robust way to update the internal description of the     -- archive is to scan it again—manual manipulations with descriptions of     -- entries are too error-prone. We also want to erase all pending     -- actions because 'I.commit' executes them all by definition.     (ndesc, nentries) <- liftIO (I.scanArchive file)-    ZipArchive . modify $ \st -> st-      { zsEntries = nentries-      , zsArchive = ndesc-      , zsActions = S.empty }+    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 (Path Abs File)+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.-+-- | Modify the collection of pending actions. 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+    go adir = do+      let cdir = path </> adir+      raw <- listDirectory cdir+      fmap mconcat . forM raw $ \case+        "" -> return mempty+        "." -> return mempty+        ".." -> return mempty+        x -> do+          let fullx = cdir </> x+              adir' = adir </> x+          isFile <- doesFileExist fullx+          isDir <- doesDirectoryExist fullx+          if isFile+            then return (DList.singleton adir')+            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+    select e = if isDoesNotExistError e then Just e else Nothing+    handler = const (return ())

@@ -1,6 +1,6 @@ -- | -- Module      :  Codec.Archive.Zip.CP437--- Copyright   :  © 2016–2017 Mark Karpov+-- Copyright   :  © 2016–present Mark Karpov -- License     :  BSD 3 clause -- -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>@@ -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 Data.ByteString qualified as B import Data.Char import Data.Text (Text)+import Data.Text qualified 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,1018 +1,1256 @@--- |--- Module      :  Codec.Archive.Zip.Internal--- Copyright   :  © 2016–2017 Mark Karpov--- License     :  BSD 3 clause------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  portable------ Low-level, non-public concepts and operations.--{-# LANGUAGE ScopedTypeVariables #-}--module Codec.Archive.Zip.Internal-  ( PendingAction (..)-  , targetEntry-  , scanArchive-  , sourceEntry-  , crc32Sink-  , commit )-where--import Codec.Archive.Zip.CP437 (decodeCP437)-import Codec.Archive.Zip.Type-import Control.Applicative (many, (<|>))-import Control.Monad-import Control.Monad.Catch-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Resource (ResourceT, runResourceT, MonadResource)-import Data.Bits-import Data.Bool (bool)-import Data.ByteString (ByteString)-import Data.Char (ord)-import Data.Conduit (Conduit, Source, Sink, (=$=), ($$), awaitForever, yield)-import Data.Conduit.Internal (zipSinks)-import Data.Digest.CRC32 (crc32Update)-import Data.Fixed (Fixed (..))-import Data.Foldable (foldl')-import Data.Map.Strict (Map, (!))-import Data.Maybe (fromJust, catMaybes, isNothing)-import Data.Monoid ((<>))-import Data.Sequence (Seq, (><), (|>))-import Data.Serialize-import Data.Text (Text)-import Data.Time-import Data.Version-import Data.Word (Word16, Word32)-import Numeric.Natural (Natural)-import Path-import System.IO-import System.PlanB-import qualified Data.ByteString     as B-import qualified Data.Conduit.BZlib  as BZ-import qualified Data.Conduit.Binary as CB-import qualified Data.Conduit.List   as CL-import qualified Data.Conduit.Zlib   as Z-import qualified Data.Map.Strict     as M-import qualified Data.Sequence       as S-import qualified Data.Set            as E-import qualified Data.Text           as T-import qualified Data.Text.Encoding  as T--------------------------------------------------------------------------------- Data types---- | The sum type describes all possible actions that can be performed on--- archive.--data PendingAction-  = SinkEntry CompressionMethod (Source (ResourceT IO) ByteString) EntrySelector-    -- ^ Add entry given its 'Source'-  | CopyEntry (Path Abs File) EntrySelector EntrySelector-    -- ^ Copy an entry form another archive without re-compression-  | RenameEntry EntrySelector EntrySelector-    -- ^ Change name the entry inside archive-  | DeleteEntry EntrySelector-    -- ^ Delete entry from archive-  | Recompress CompressionMethod EntrySelector-    -- ^ Change compression method on an entry-  | SetEntryComment Text EntrySelector-    -- ^ Set comment for a particular entry-  | DeleteEntryComment EntrySelector-    -- ^ Delete comment of particular entry-  | SetModTime UTCTime EntrySelector-    -- ^ Set modification time of particular entry-  | AddExtraField Word16 ByteString EntrySelector-    -- ^ Add an extra field to specified entry-  | DeleteExtraField Word16 EntrySelector-    -- ^ Delete an extra filed of specified entry-  | SetArchiveComment Text-    -- ^ Set comment for entire archive-  | DeleteArchiveComment-    -- ^ Delete comment of entire archive---- | Collection of maps describing how to produce entries in resulting--- archive.--data ProducingActions = ProducingActions-  { paCopyEntry :: Map (Path Abs File) (Map EntrySelector EntrySelector)-  , paSinkEntry :: Map EntrySelector (Source (ResourceT IO) ByteString) }---- | Collection of editing actions, that is, actions that modify already--- existing entries.--data EditingActions = EditingActions-  { eaCompression   :: Map EntrySelector CompressionMethod-  , eaEntryComment  :: Map EntrySelector Text-  , eaDeleteComment :: Map EntrySelector ()-  , eaModTime       :: Map EntrySelector UTCTime-  , eaExtraField    :: Map EntrySelector (Map Word16 ByteString)-  , eaDeleteField   :: Map EntrySelector (Map Word16 ()) }---- | 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-  :: Path Abs File     -- ^ Path to archive to scan-  -> IO (ArchiveDescription, Map EntrySelector EntryDescription)-scanArchive path = withBinaryFile (toFilePath path) ReadMode $ \h -> do-  mecdOffset <- locateECD path h-  case mecdOffset of-    Just ecdOffset -> do-      hSeek h AbsoluteSeek ecdOffset-      ecdSize <- subtract ecdOffset <$> hFileSize h-      ecdRaw  <- B.hGet h (fromIntegral ecdSize)-      case runGet getECD ecdRaw of-        Left  msg -> throwM (ParsingFailed path msg)-        Right ecd -> do-          hSeek h AbsoluteSeek $ fromIntegral (adCDOffset ecd)-          cdRaw <- B.hGet h $ fromIntegral (adCDSize ecd)-          case runGet getCD cdRaw of-            Left  msg -> throwM (ParsingFailed path msg)-            Right cd  -> return (ecd, cd)-    Nothing ->-      throwM (ParsingFailed path "Cannot locate end of central directory")---- | Given location of archive and information about specific archive entry--- 'EntryDescription', return 'Source' of its data. Actual data can be--- compressed or uncompressed depending on the third argument.--sourceEntry-  :: MonadResource m-  => Path Abs File     -- ^ Path to archive that contains the entry-  -> EntryDescription  -- ^ Information needed to extract entry of interest-  -> Bool              -- ^ Should we stream uncompressed data?-  -> Source m ByteString -- ^ Source of uncompressed data-sourceEntry path EntryDescription {..} d =-  source =$= CB.isolate (fromIntegral edCompressedSize) =$= decompress-  where-    source = CB.sourceIOHandle $ do-      h <- openFile (toFilePath path) ReadMode-      hSeek h AbsoluteSeek (fromIntegral edOffset)-      localHeader <- B.hGet h 30-      case runGet getLocalHeaderGap localHeader of-        Left msg -> throwM (ParsingFailed path msg)-        Right gap -> do-          hSeek h RelativeSeek gap-          return h-    decompress = if d-      then decompressingPipe edCompression-      else awaitForever yield---- | Undertake /all/ actions specified as the fourth argument of the--- function. This transforms given pending actions so they can be performed--- in one pass, and then they are performed in the most efficient way.--commit-  :: Path Abs File     -- ^ Location of archive file to edit or create-  -> ArchiveDescription -- ^ Archive description-  -> Map EntrySelector EntryDescription -- ^ Current list of entires-  -> Seq PendingAction -- ^ Collection of pending actions-  -> IO ()-commit path ArchiveDescription {..} entries xs =-  withNewFile (overrideIfExists      <>-               nameTemplate ".zip"   <>-               tempDir (parent path) <>-               moveByRenaming) path $ \temp -> do-    let (ProducingActions coping sinking, editing) =-          optimize (toRecreatingActions path entries >< xs)-        comment = predictComment adComment xs-    withBinaryFile (toFilePath temp) WriteMode $ \h -> do-      copiedCD <- M.unions <$> forM (M.keys coping) (\srcPath ->-        copyEntries h srcPath (coping ! srcPath) editing)-      let sinkingKeys = M.keys $ sinking `M.difference` copiedCD-      sunkCD   <- M.fromList <$> forM sinkingKeys (\selector ->-        sinkEntry h selector GenericOrigin (sinking ! selector) editing)-      writeCD h comment (copiedCD `M.union` sunkCD)---- | Determine what comment in new archive will look like given its original--- value and 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-  :: Path Abs File     -- ^ 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 )-  where-    f (pa, ea) a = case a of-      SinkEntry m src s ->-        ( pa { paSinkEntry   = M.insert s src (paSinkEntry pa)-             , paCopyEntry   = M.map (M.filter (/= s)) (paCopyEntry pa) }-        , (clearEditingFor s ea)-             { eaCompression = M.insert s m (eaCompression ea) } )-      CopyEntry path os ns ->-        ( pa { paSinkEntry = M.delete ns (paSinkEntry pa)-             , paCopyEntry = M.alter (ef os ns) path (paCopyEntry pa) }-        , clearEditingFor ns ea )-      RenameEntry os ns ->-        ( pa { paCopyEntry = M.map (M.map $ re os ns) (paCopyEntry pa)-             , paSinkEntry = renameKey os ns (paSinkEntry pa) }-        , ea { eaCompression   = renameKey os ns (eaCompression ea)-             , eaEntryComment  = renameKey os ns (eaEntryComment ea)-             , eaDeleteComment = renameKey os ns (eaDeleteComment ea)-             , eaModTime       = renameKey os ns (eaModTime ea)-             , eaExtraField    = renameKey os ns (eaExtraField ea)-             , eaDeleteField   = renameKey os ns (eaDeleteField ea) } )-      DeleteEntry s ->-        ( pa { paSinkEntry = M.delete s (paSinkEntry pa)-             , paCopyEntry = M.map (M.delete s) (paCopyEntry pa) }-        , clearEditingFor s ea )-      Recompress m s ->-        (pa, ea { eaCompression = M.insert s m (eaCompression ea) })-      SetEntryComment txt s ->-        ( pa-        , ea { eaEntryComment  = M.insert s txt (eaEntryComment ea)-             , eaDeleteComment = M.delete s (eaDeleteComment ea) } )-      DeleteEntryComment s ->-        ( pa-        , ea { eaEntryComment  = M.delete s (eaEntryComment ea)-             , eaDeleteComment = M.insert s () (eaDeleteComment ea) } )-      SetModTime time s ->-        (pa, ea { eaModTime = M.insert s time (eaModTime ea) })-      AddExtraField n b s ->-        ( pa-        , ea { eaExtraField  = M.alter (ef n b) s (eaExtraField ea)-             , eaDeleteField = M.delete s (eaDeleteField ea) } )-      DeleteExtraField n s ->-        ( pa-        , ea { eaExtraField = M.alter (er n) s (eaExtraField ea)-             , eaDeleteField = M.alter (ef n ()) s (eaDeleteField ea) } )-      _ -> (pa, ea)-    clearEditingFor s ea = ea-      { eaCompression   = M.delete s (eaCompression ea)-      , eaEntryComment  = M.delete s (eaEntryComment ea)-      , eaDeleteComment = M.delete s (eaDeleteComment ea)-      , eaModTime       = M.delete s (eaModTime ea)-      , eaExtraField    = M.delete s (eaExtraField ea)-      , eaDeleteField   = M.delete s (eaDeleteField ea) }-    re o n x = if x == o then n else x-    ef k v (Just m) = Just (M.insert k v m)-    ef k v Nothing  = Just (M.singleton k v)-    er k (Just m)   = let n = M.delete k m in-      if M.null n then Nothing else Just n-    er _ Nothing    = Nothing---- | Copy entries from another archive and write them into 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-  -> Path Abs File     -- ^ Path to file from which to copy the entries-  -> Map EntrySelector EntrySelector-     -- ^ 'Map' from original name to name to use in new archive-  -> EditingActions    -- ^ Additional info that can influence result-  -> IO (Map EntrySelector EntryDescription)-     -- ^ Info to generate central directory file headers later-copyEntries h path m e = do-  entries <- snd <$> scanArchive path-  done    <- forM (M.keys m) $ \s ->-    case s `M.lookup` entries of-      Nothing -> throwM (EntryDoesNotExist path s)-      Just desc -> sinkEntry h (m ! s) (Borrowed desc)-        (sourceEntry path desc False) e-  return (M.fromList done)---- | Sink entry from given stream into 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)-  -> Source (ResourceT IO) ByteString -- ^ Source of entry contents-  -> EditingActions    -- ^ Additional info that can influence result-  -> IO (EntrySelector, EntryDescription)-     -- ^ Info to generate central directory file headers later-sinkEntry h s o src EditingActions {..} = do-  currentTime <- getCurrentTime-  offset  <- hTell h-  let compressed = case o of-        GenericOrigin -> Store-        Borrowed ed -> edCompression ed-      compression = M.findWithDefault compressed s eaCompression-      recompression = compression /= compressed-      modTime = case o of-        GenericOrigin -> currentTime-        Borrowed ed -> edModTime ed-      oldExtraFields = case o of-        GenericOrigin -> M.empty-        Borrowed ed -> edExtraField ed-      extraField  =-        (M.findWithDefault M.empty s eaExtraField `M.union` oldExtraFields)-        `M.difference` M.findWithDefault M.empty s eaDeleteField-      oldComment = case (o, M.lookup s eaDeleteComment) of-        (GenericOrigin, _)     -> Nothing-        (Borrowed ed, Nothing) -> edComment ed-        (Borrowed _,  Just ()) -> Nothing-      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 }-  B.hPut h (runPut (putHeader LocalHeader s desc0))-  DataDescriptor {..} <- runResourceT $-    if recompression-      then-        if compressed == Store-          then src $$ sinkData h compression-          else src =$= decompressingPipe compressed $$ sinkData h compression-      else src $$ sinkData h Store-  afterStreaming <- hTell h-  let 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-  -> Sink ByteString (ResourceT IO) DataDescriptor-     -- ^ 'Sink' where to stream data-sinkData h compression = do-  let sizeSink  = CL.fold (\acc input -> fromIntegral (B.length input) + acc) 0-      dataSink  = fst <$> zipSinks sizeSink (CB.sinkHandle h)-      withCompression = zipSinks (zipSinks sizeSink crc32Sink)-  ((uncompressedSize, crc32), compressedSize) <--    case compression of-      Store   -> withCompression-        dataSink-      Deflate -> withCompression $-        Z.compress 9 (Z.WindowBits (-15)) =$= dataSink-      BZip2   -> withCompression $-        BZ.bzip2 =$= dataSink-  return DataDescriptor-    { ddCRC32            = fromIntegral crc32-    , ddCompressedSize   = compressedSize-    , ddUncompressedSize = uncompressedSize }---- | Append central directory entries and end of central directory record to--- 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 8 -- disk number start, internal/external file attributes-  offset         <- fromIntegral <$> getWord32le -- offset of local header-  fileName       <- decodeText needUnicode <$>-    getBytes (fromIntegral fileNameSize) -- file name-  extraField     <- M.fromList <$>-    isolate (fromIntegral extraFieldSize) (many getExtraField)-  -- ↑ extra fields in their raw form-  comment <- decodeText needUnicode <$> getBytes (fromIntegral commentSize)-  -- ↑ file comment-  let dfltZip64 = Zip64ExtraField-        { z64efUncompressedSize = uncompressed-        , z64efCompressedSize   = compressed-        , z64efOffset           = offset }-      z64ef = case M.lookup 1 extraField of-        Nothing -> dfltZip64-        Just b  -> parseZip64ExtraField dfltZip64 b-  case mcompression of-    Nothing -> return Nothing-    Just compression ->-      let desc = EntryDescription-            { edVersionMadeBy    = versionMadeBy-            , edVersionNeeded    = versionNeeded-            , edCompression      = compression-            , edModTime          = fromMsDosTime (MsDosTime modDate modTime)-            , edCRC32            = crc32-            , edCompressedSize   = z64efCompressedSize   z64ef-            , edUncompressedSize = z64efUncompressedSize z64ef-            , edOffset           = z64efOffset           z64ef-            , edComment = if commentSize == 0 then Nothing else comment-            , edExtraField       = extraField }-      in return $ (,desc) <$>-         (fileName >>= parseRelFile . T.unpack >>= mkEntrySelector)---- | Parse an extra-field.--getExtraField :: Get (Word16, ByteString)-getExtraField = do-  header <- getWord16le -- header id-  size   <- getWord16le -- data size-  body   <- getBytes (fromIntegral size) -- content-  return (header, body)---- | Get signature. If 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 0 -- external file attributes-    putWord32le (withSaturation edOffset) -- relative offset of local header-  putByteString rawName -- file name (variable size)-  putByteString extraField -- extra field (variable size)-  when c (putByteString comment) -- file comment (variable size)---- | Create 'ByteString' representing Zip64 end of central directory record.--putZip64ECD-  :: 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 :: Path Abs File -> 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 (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 (major * 10 + minor)-  where (major:minor:_) = versionBranch v ++ repeat 0---- | Get compression method form its numeric representation.--toCompressionMethod :: Word16 -> Maybe CompressionMethod-toCompressionMethod 0  = Just Store-toCompressionMethod 8  = Just Deflate-toCompressionMethod 12 = Just BZip2-toCompressionMethod _  = Nothing---- | Convert 'CompressionMethod' to its numeric representation as per .ZIP--- specification.--fromCompressionMethod :: CompressionMethod -> Word16-fromCompressionMethod Store   = 0-fromCompressionMethod Deflate = 8-fromCompressionMethod BZip2   = 12---- | 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-  :: MonadResource m-  => CompressionMethod-  -> Conduit ByteString m ByteString-decompressingPipe Store   = awaitForever yield-decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)-decompressingPipe BZip2   = BZ.bunzip2---- | Sink that calculates CRC32 check sum for incoming stream.--crc32Sink :: Sink ByteString (ResourceT IO) Word32-crc32Sink = CL.fold crc32Update 0---- | Convert 'UTCTime' to MS-DOS time format.--toMsDosTime :: UTCTime -> MsDosTime-toMsDosTime UTCTime {..} = MsDosTime dosDate dosTime-  where-    dosTime = fromIntegral (seconds + shiftL minutes 5 + shiftL hours 11)-    dosDate = fromIntegral (day     + shiftL month   5 + shiftL year  9)--    seconds =-      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.--ffff, ffffffff :: Natural-ffff     = 0xffff-ffffffff = 0xffffffff+{-# 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 types and operations.+module Codec.Archive.Zip.Internal where++import Codec.Archive.Zip.CP437 (decodeCP437)+import Codec.Archive.Zip.Internal.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 Data.ByteString qualified as B+import Data.Char (ord)+import Data.Conduit (ConduitT, ZipSink (..), (.|))+import Data.Conduit qualified as C+import Data.Conduit.Binary qualified as CB+import Data.Conduit.List qualified as CL+import Data.Conduit.Zlib qualified as Z+import Data.Digest.CRC32 (crc32Update)+import Data.Fixed (Fixed (..))+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as M+import Data.Maybe (catMaybes, fromJust, isNothing)+import Data.Sequence (Seq, (><), (|>))+import Data.Sequence qualified as S+import Data.Serialize+import Data.Set qualified as E+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified 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)++#ifndef mingw32_HOST_OS+import qualified Codec.Archive.Zip.Unix as Unix+#endif++#ifdef ENABLE_BZIP2+import qualified Data.Conduit.BZlib as BZ+#endif++#ifdef ENABLE_ZSTD+import qualified Data.Conduit.Zstd as Zstandard+#endif++#if !MIN_VERSION_base(4,20,0)+import Data.Foldable (foldl')+#endif++----------------------------------------------------------------------------+-- Data types++-- | The sum type describes all possible actions that can be performed on an+-- archive.+data PendingAction+  = -- | Add an entry given its 'Source'+    SinkEntry+      CompressionMethod+      (ConduitT () ByteString (ResourceT IO) ())+      EntrySelector+  | -- | Add an entry given its content as a string ByteString.+    StrictEntry CompressionMethod ByteString EntrySelector+  | -- | Copy an entry from another archive without re-compression+    CopyEntry FilePath EntrySelector EntrySelector+  | -- | Change the name of the entry inside archive+    RenameEntry EntrySelector EntrySelector+  | -- | Delete an entry from archive+    DeleteEntry EntrySelector+  | -- | Change the compression method on an entry+    Recompress CompressionMethod EntrySelector+  | -- | Set the comment for a particular entry+    SetEntryComment Text EntrySelector+  | -- | Delete theh comment of a particular entry+    DeleteEntryComment EntrySelector+  | -- | Set the modification time of a particular entry+    SetModTime UTCTime EntrySelector+  | -- | Add an extra field to the specified entry+    AddExtraField Word16 ByteString EntrySelector+  | -- | Delete an extra filed of the specified entry+    DeleteExtraField Word16 EntrySelector+  | -- | Set the comment for the entire archive+    SetArchiveComment Text+  | -- | Delete the comment of the entire archive+    DeleteArchiveComment+  | -- | Set an external file attribute for the specified entry+    SetExternalFileAttributes Word32 EntrySelector++-- | A collection of maps describing how to produce entries in the resulting+-- archive.+data ProducingActions = ProducingActions+  { paCopyEntry :: Map FilePath (Map EntrySelector EntrySelector),+    paSinkEntry :: Map EntrySelector (EntryOrigin, ConduitT () ByteString (ResourceT IO) ())+  }++-- | A 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+  }++-- | The origin of entries that can be streamed into archive.+data EntryOrigin+  = GenericOrigin+  | StrictOrigin Natural -- uncompressed length+  | Borrowed EntryDescription+  deriving (Eq)++-- | The type of the file header: local or central directory.+data HeaderType+  = LocalHeader EntryOrigin+  | CentralDirHeader+  deriving (Eq)++-- | The 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 the archive and information about a specific archive+-- entry 'EntryDescription', return 'Source' of its data. The 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 =+  -- We cannot simply use CB.sourceIOHandle+  -- because that closes the archive only when its end is reached.+  -- See <https://github.com/mrkkrp/zip/issues/142>.+  -- The following implementation closes file handles promptly.+  C.bracketP+    ( do+        h <- openBinaryFile 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+    )+    hClose+    ( \h ->+        CB.sourceHandle h+          .| CB.isolate (fromIntegral edCompressedSize)+          .| decompress+    )+  where+    decompress =+      if d+        then decompressingPipe edCompression+        else C.awaitForever C.yield++-- | Undertake /all/ actions specified as the fourth argument of the+-- function. This transforms the given pending actions so they can be+-- performed in one pass, and then they are applied in the most efficient+-- way.+commit ::+  -- | Location of archive file to edit or create+  FilePath ->+  -- | Archive description+  ArchiveDescription ->+  -- | Current list of entries+  Map EntrySelector EntryDescription ->+  -- | Collection of pending actions+  Seq PendingAction ->+  IO ()+commit path ArchiveDescription {..} entries xs =+  withNewFile path $ \h -> do+    let (ProducingActions copying sinking, editing) =+          optimize (toRecreatingActions path entries >< xs)+        comment = predictComment adComment xs+    copiedCD <-+      M.unions+        <$> M.traverseWithKey+          ( \srcPath m ->+              copyEntries h srcPath m editing+          )+          copying+    sunkCD <-+      M.traverseWithKey+        ( \selector (origin, source) ->+            sinkEntry h selector origin source editing+        )+        (sinking `M.difference` copiedCD)+    writeCD h comment (copiedCD `M.union` sunkCD)++-- | Create a new file with the guarantee that in the case of an exception+-- the old file will be 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 (GenericOrigin, src) (paSinkEntry pa),+              paCopyEntry = M.map (M.filter (/= s)) (paCopyEntry pa)+            },+          (clearEditingFor s ea)+            { eaCompression = M.insert s m (eaCompression ea)+            }+        )+      StrictEntry m bs s ->+        ( pa+            { paSinkEntry = M.insert s (origin, C.yield bs) (paSinkEntry pa),+              paCopyEntry = M.map (M.filter (/= s)) (paCopyEntry pa)+            },+          (clearEditingFor s ea)+            { eaCompression = M.insert s m (eaCompression ea)+            }+        )+        where+          origin = StrictOrigin (fromIntegral $ B.length bs)+      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 the 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 names editing = do+  entries <- snd <$> scanArchive path+  M.foldlWithKey+    ( \acc oldName newName ->+        case M.lookup oldName entries of+          Nothing -> throwM (EntryDoesNotExist path oldName)+          Just oldDesc ->+            M.insert newName+              <$> sinkEntry h newName (Borrowed oldDesc) src editing+              <*> acc+            where+              src = sourceEntry path oldDesc False+    )+    mempty+    names++-- | Sink an entry from the given stream into the file associated with the+-- given 'Handle'.+sinkEntry ::+  -- | Opened 'Handle' of zip archive file+  Handle ->+  -- | Name of the entry to add+  EntrySelector ->+  -- | Origin of the entry (can contain additional info)+  EntryOrigin ->+  -- | Source of the entry contents+  ConduitT () ByteString (ResourceT IO) () ->+  -- | Additional info that can influence result+  EditingActions ->+  -- | Info to generate the central directory file headers later+  IO EntryDescription+sinkEntry h s o src EditingActions {..} = do+  currentTime <- getCurrentTime+  offset <- hTell h+  let compressed = case o of+        Borrowed ed -> edCompression ed+        _ -> Store+      compression = M.findWithDefault compressed s eaCompression+      recompression = compression /= compressed+      modTime = case o of+        Borrowed ed -> edModTime ed+        _ -> currentTime+      extFileAttr = M.findWithDefault defaultFileMode s eaExtFileAttr+      oldExtraFields = case o of+        Borrowed ed -> edExtraField ed+        _ -> M.empty+      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+        (Borrowed ed, Nothing) -> edComment ed+        _ -> 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 o) 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+        Borrowed ed ->+          desc0+            { edCRC32 =+                bool (edCRC32 ed) ddCRC32 recompression,+              edCompressedSize =+                bool (edCompressedSize ed) ddCompressedSize recompression,+              edUncompressedSize =+                bool (edUncompressedSize ed) ddUncompressedSize recompression+            }+        _ ->+          desc0+            { edCRC32 = ddCRC32,+              edCompressedSize = ddCompressedSize,+              edUncompressedSize = ddUncompressedSize+            }+      desc2 =+        desc1+          { edVersionNeeded =+              getZipVersion (needsZip64 desc1) (Just compression)+          }+  hSeek h AbsoluteSeek offset+  B.hPut h (runPut (putHeader (LocalHeader o) s desc2))+  hSeek h AbsoluteSeek afterStreaming+  return desc2++{- ORMOLU_DISABLE -}++-- | Create a 'Sink' to stream data there. Once streaming is finished,+-- return 'DataDescriptor' for the streamed data. The action /does not/+-- close the 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 (UnsupportedCompressionMethod BZip2)+#endif+#ifdef ENABLE_ZSTD+      Zstd ->+        withCompression $+          Zstandard.compress 1 .| dataSink+#else+      Zstd -> throwM (UnsupportedCompressionMethod Zstd)+#endif+  return+    DataDescriptor+      { ddCRC32 = fromIntegral crc32,+        ddCompressedSize = compressedSize,+        ddUncompressedSize = uncompressedSize+      }++{- ORMOLU_ENABLE -}++-- | Append central directory entries and the 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 the 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 the start of file name in local+-- header and the 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 a '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 the 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 headerType Zip64ExtraField {..} = runPut $ do+  case headerType of+    LocalHeader _ -> do+      putWord64le (fromIntegral z64efUncompressedSize) -- uncompressed size+      putWord64le (fromIntegral z64efCompressedSize) -- compressed size+    CentralDirHeader -> do+      when (z64efUncompressedSize >= ffffffff) $+        putWord64le (fromIntegral z64efUncompressedSize) -- uncompressed size+      when (z64efCompressedSize >= ffffffff) $+        putWord64le (fromIntegral z64efCompressedSize) -- compressed size+  when (z64efOffset >= ffffffff) $+    putWord64le (fromIntegral z64efOffset) -- offset of local file header++-- | Create 'ByteString' representing an extra field.+putExtraField :: Map Word16 ByteString -> Put+putExtraField = M.foldMapWithKey $ \headerId bs -> do+  let b = B.take 0xffff bs+  putWord16le headerId+  putWord16le (fromIntegral $ B.length b)+  putByteString b++-- | Create 'ByteString' representing the entire central directory.+putCD :: Map EntrySelector EntryDescription -> Put+putCD = M.foldMapWithKey (putHeader CentralDirHeader)++-- | Create 'ByteString' representing either a local file header or a+-- central directory file header.+putHeader ::+  -- | Type of header to generate+  HeaderType ->+  -- | Name of entry to write+  EntrySelector ->+  -- | Description of entry+  EntryDescription ->+  Put+putHeader headerType s entry@EntryDescription {..} = do+  let isCentralDirHeader = headerType == CentralDirHeader+  putWord32le (bool 0x04034b50 0x02014b50 isCentralDirHeader)+  -- ↑ local/central file header signature+  when isCentralDirHeader $+    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+          headerType+          Zip64ExtraField+            { z64efUncompressedSize = edUncompressedSize,+              z64efCompressedSize = edCompressedSize,+              z64efOffset = edOffset+            }+      appendZip64 =+        case headerType of+          LocalHeader (StrictOrigin size) -> size >= ffffffff+          LocalHeader (Borrowed ed) -> entryUsesZip64 ed+          LocalHeader GenericOrigin -> True+          CentralDirHeader -> needsZip64 entry+      extraField =+        B.take 0xffff . runPut . putExtraField $+          if appendZip64+            then M.insert 1 zip64ef edExtraField+            else edExtraField+  putWord16le (fromIntegral $ B.length extraField) -- extra field length+  when isCentralDirHeader $ 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 isCentralDirHeader (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 the 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 the central directory record or Zip64 end of the 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 a 'ByteString' representing the 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 the absolute offset of the 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 the target entry of an action.+targetEntry :: PendingAction -> Maybe EntrySelector+targetEntry (SinkEntry _ _ s) = Just s+targetEntry (StrictEntry _ _ 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 a '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 the archive.+needsUnicode :: Text -> Bool+needsUnicode = not . T.all validCP437+  where+    validCP437 x = ord x <= 127++-- | Convert numeric representation (as per the .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 the .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 the 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 the+-- .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 the Zip64 extension.+needsZip64 :: EntryDescription -> Bool+needsZip64 EntryDescription {..} =+  any+    (>= ffffffff)+    [edOffset, edCompressedSize, edUncompressedSize]++-- | Check if an entry has Zip64 extra fields.+entryUsesZip64 :: EntryDescription -> Bool+entryUsesZip64 EntryDescription {..} = M.member 1 edExtraField++-- | Determine “version needed to extract” that should be written to the+-- headers given the need of the Zip64 feature and the 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 a 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 (UnsupportedCompressionMethod BZip2)+#endif++#ifdef ENABLE_ZSTD+decompressingPipe Zstd = Zstandard.decompress+#else+decompressingPipe Zstd = throwM (UnsupportedCompressionMethod Zstd)+#endif++-- | A sink that calculates the CRC32 check sum for an incoming stream.+crc32Sink :: ConduitT ByteString Void (ResourceT IO) Word32+crc32Sink = CL.fold crc32Update 0++-- | Convert 'UTCTime' to the 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 the 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     = 25+ffffffff = 250+#else+ffff     = 0xffff+ffffffff = 0xffffffff+#endif++-- | The default permissions for the files, permissions not set on Windows,+-- and are set to rw on Unix. This mimics the behavior of the zip utility.+defaultFileMode :: Word32++#ifdef mingw32_HOST_OS+defaultFileMode = 0++#else+defaultFileMode = Unix.fromFileMode 0o600+#endif

@@ -0,0 +1,230 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- |+-- Module      :  Codec.Archive.Zip.Internal.Type+-- Copyright   :  © 2016–present Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Types used by the package.+module Codec.Archive.Zip.Internal.Type+  ( -- * Entry selector+    EntrySelector,+    mkEntrySelector,+    unEntrySelector,+    getEntryName,+    EntrySelectorException (..),++    -- * Entry description+    EntryDescription (..),+    CompressionMethod (..),++    -- * Archive description+    ArchiveDescription (..),++    -- * Exceptions+    ZipException (..),+  )+where++import Control.Exception (Exception)+import Control.Monad.Catch (MonadThrow (..))+import Data.ByteString (ByteString)+import Data.ByteString qualified as B+import Data.CaseInsensitive (CI)+import Data.CaseInsensitive qualified as CI+import Data.Data (Data)+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NE+import Data.Map (Map)+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Time.Clock (UTCTime)+import Data.Version (Version)+import Data.Word (Word16, Word32)+import Numeric.Natural+import System.FilePath qualified as FP+import System.FilePath.Posix qualified as Posix+import System.FilePath.Windows qualified as Windows++----------------------------------------------------------------------------+-- Entry selector++-- | This data type serves for naming and selection of archive entries. It+-- can be created only with the help of the smart constructor+-- 'mkEntrySelector', and it's the only “key” that can be used to refer to+-- files in the archive or to name new archive entries.+--+-- The abstraction is crucial for ensuring that created archives are+-- portable across operating systems, file systems, and platforms. Since on+-- some operating systems, file paths are case-insensitive, this selector is+-- also case-insensitive. It makes sure that only relative paths are used to+-- name files inside archive, as it's recommended in the specification. It+-- also guarantees that forward slashes are used when the path is stored+-- inside the archive for compatibility with Unix-like operating 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+  { -- | Path pieces of relative path inside archive+    unES :: NonEmpty (CI String)+  }+  deriving (Eq, Ord)++instance Show EntrySelector where+  show = show . unEntrySelector++-- | Create an 'EntrySelector' from a 'FilePath'. To avoid problems with+-- distribution of the archive, characters that some operating systems do+-- not expect in paths are not allowed.+--+-- Argument to 'mkEntrySelector' should pass these checks:+--+--     * 'System.FilePath.Posix.isValid'+--     * 'System.FilePath.Windows.isValid'+--     * it is a relative path without slash at the end+--     * binary representations of normalized path should be not longer than+--       65535 bytes+--+-- This function can throw an 'EntrySelectorException'.+mkEntrySelector :: (MonadThrow m) => FilePath -> m EntrySelector+mkEntrySelector path =+  let f x =+        case filter (not . FP.isPathSeparator) x of+          [] -> 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++-- | Restore a relative path from 'EntrySelector'. Every 'EntrySelector'+-- corresponds to a '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 problems you can have with an 'EntrySelector'.+newtype EntrySelectorException+  = -- | 'EntrySelector' cannot be created from this path+    InvalidEntrySelector FilePath+  deriving (Eq, Ord)++instance Show EntrySelectorException where+  show (InvalidEntrySelector path) = "Cannot build selector from " ++ show path++instance Exception EntrySelectorException++----------------------------------------------------------------------------+-- Entry description++-- | The information about archive entry that can be stored in a zip+-- archive. It does not mirror local file header or central directory file+-- header, but their binary representations can be built given this data+-- structure and the archive contents.+data EntryDescription = EntryDescription+  { -- | 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, Show)++-- | The supported compression methods.+data CompressionMethod+  = -- | 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)++----------------------------------------------------------------------------+-- Archive description++-- | The information about the archive as a whole.+data ArchiveDescription = ArchiveDescription+  { -- | The comment of the entire archive+    adComment :: Maybe Text,+    -- | Absolute offset of the start of central directory+    adCDOffset :: Natural,+    -- | The size of central directory record+    adCDSize :: Natural+  }+  deriving (Show, Read, Eq, Ord, Data)++----------------------------------------------------------------------------+-- Exceptions++-- | The bad things that can happen when you use the library.+data ZipException+  = -- | Thrown when you try to get contents of non-existing entry+    EntryDoesNotExist FilePath EntrySelector+  | -- | Thrown when attempting to decompress an entry compressed with an+    -- unsupported compression method or the library is compiled without+    -- support for it.+    --+    -- @since 2.0.0+    UnsupportedCompressionMethod CompressionMethod+  | -- | Thrown when archive structure cannot be parsed.+    ParsingFailed FilePath String+  deriving (Eq, Ord)++instance Show ZipException where+  show (EntryDoesNotExist file s) =+    "No such entry found: " ++ show s ++ " in " ++ show file+  show (ParsingFailed file msg) =+    "Parsing of archive structure failed: \n" ++ msg ++ "\nin " ++ show file+  show (UnsupportedCompressionMethod method) =+    "Encountered a zipfile entry with "+      ++ show method+      ++ " compression, but "+      ++ "zip library does not support it or has been built without support for it."++instance Exception ZipException

@@ -1,207 +0,0 @@--- |--- Module      :  Codec.Archive.Zip.Type--- Copyright   :  © 2016–2017 Mark Karpov--- License     :  BSD 3 clause------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  portable------ Types used by the package. You don't usually need to import this module,--- because "Codec.Archive.Zip" re-exports everything you may need, import--- that module instead.--{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}--module Codec.Archive.Zip.Type-  ( -- * Entry selector-    EntrySelector-  , mkEntrySelector-  , unEntrySelector-  , getEntryName-  , EntrySelectorException (..)-    -- * Entry description-  , EntryDescription (..)-  , CompressionMethod (..)-    -- * Archive desrciption-  , ArchiveDescription (..)-    -- * Exceptions-  , ZipException (..) )-where--import Control.Arrow ((>>>))-import Control.Exception (Exception)-import Control.Monad.Catch (MonadThrow (..))-import Data.ByteString (ByteString)-import Data.CaseInsensitive (CI)-import Data.Data (Data)-import Data.List.NonEmpty (NonEmpty)-import Data.Map (Map)-import Data.Maybe (mapMaybe, fromJust)-import Data.Text (Text)-import Data.Time.Clock (UTCTime)-import Data.Typeable (Typeable)-import Data.Version (Version)-import Data.Word (Word16, Word32)-import GHC.Generics (Generic)-import Numeric.Natural-import Path-import qualified Data.ByteString         as B-import qualified Data.CaseInsensitive    as CI-import qualified Data.List.NonEmpty      as NE-import qualified Data.Text               as T-import qualified Data.Text.Encoding      as T-import qualified System.FilePath         as FP-import qualified System.FilePath.Posix   as Posix-import qualified System.FilePath.Windows as Windows--------------------------------------------------------------------------------- Entry selector---- | This data type serves for naming and selection of archive entries. It--- can be created only with the help of the smart constructor--- 'mkEntrySelector', and it's the only “key” that can be used to select--- files in archive or to name new files.------ The abstraction is crucial for ensuring that created archives are--- portable across operating systems, file systems, and different platforms.--- Since on some operating systems, file paths are case-insensitive, this--- selector is also case-insensitive. It makes sure that only relative paths--- are used to name files inside archive, as it's recommended in the--- specification. It also guarantees that forward slashes are used when the--- path is stored inside archive for compatibility with Unix-like operating--- systems (as it is recommended in the specification). On the other hand,--- in can be rendered as ordinary relative file path in OS-specific format,--- when needed.--newtype EntrySelector = EntrySelector-  { unES :: NonEmpty (CI String)-    -- ^ Path pieces of relative path inside archive-  } deriving (Eq, Ord, Typeable, Data, Generic)--instance Show EntrySelector where-  show = show . unEntrySelector---- | Create an 'EntrySelector' from @'Path' 'Rel' 'File'@. To avoid problems--- with distribution of the archive, characters that some operating systems--- do not expect in paths are not allowed. Proper paths should pass these--- checks:------     * 'System.FilePath.Posix.isValid'---     * 'System.FilePath.Windows.isValid'---     * binary representation of normalized path should be not longer than---       65535 bytes------ This function can throw an 'EntrySelectorException'.--mkEntrySelector :: MonadThrow m => Path Rel File -> m EntrySelector-mkEntrySelector path =-  let fp           = toFilePath path-      g x          = if null x then Nothing else Just (CI.mk x)-      preparePiece = g . filter (not . FP.isPathSeparator)-      pieces       = mapMaybe preparePiece (FP.splitPath fp)-      selector     = EntrySelector (NE.fromList pieces)-      binLength    = B.length . T.encodeUtf8 . getEntryName-  in if Posix.isValid fp   &&-        Windows.isValid fp &&-        fp /= "."          && -- work around a bug in the path package-        not (null pieces)  &&-        binLength selector <= 0xffff-       then return selector-       else throwM (InvalidEntrySelector path)---- | Make a relative path from 'EntrySelector'. Every 'EntrySelector'--- produces a single @'Path' 'Rel' 'File'@ that corresponds to it.--unEntrySelector :: EntrySelector -> Path Rel File-unEntrySelector = unES-  >>> NE.toList-  >>> fmap CI.original-  >>> FP.joinPath-  >>> parseRelFile-  >>> fromJust---- | Get an entry name in the from that is suitable for writing to file--- header, given an 'EntrySelector'.--getEntryName :: EntrySelector -> Text-getEntryName = unES-  >>> fmap CI.original-  >>> NE.intersperse "/"-  >>> NE.toList-  >>> concat-  >>> T.pack---- | The exception describing various troubles you can have with--- 'EntrySelector'.--data EntrySelectorException-  = InvalidEntrySelector (Path Rel File)-    -- ^ Selector cannot be created from this path-  deriving (Eq, Ord, Typeable)--instance Show EntrySelectorException where-  show (InvalidEntrySelector path) = "Cannot build selector from " ++ show path--instance Exception EntrySelectorException--------------------------------------------------------------------------------- Entry description---- | This record represents all information about archive entry that can be--- stored in a zip archive. It does not mirror local file header or central--- directory file header, but their binary representation can be built given--- this 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-  } deriving (Eq, Typeable)---- | Supported compression methods.--data CompressionMethod-  = Store              -- ^ Store file uncompressed-  | Deflate            -- ^ Deflate-  | BZip2              -- ^ Compressed using BZip2 algorithm-  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)--------------------------------------------------------------------------------- Exceptions---- | The bad things that can happen when you use the library.--data ZipException-  = EntryDoesNotExist (Path Abs File) EntrySelector-    -- ^ Thrown when you try to get contents of non-existing entry-  | ParsingFailed     (Path Abs File) String-    -- ^ Thrown when archive structure cannot be parsed-  deriving (Eq, Ord, Typeable)--instance Show ZipException where-  show (EntryDoesNotExist file s) =-    "No such entry found: " ++ show s ++ " in " ++ show file-  show (ParsingFailed file msg) =-    "Parsing of archive structure failed: \n" ++ msg ++ "\nin " ++ show file--instance Exception ZipException

@@ -0,0 +1,40 @@+-- |+-- Module      :  Codec.Archive.Zip.Unix+-- Copyright   :  © 2016–present Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Unix-specific functionality of zip archives.+--+-- @since 1.4.0+module Codec.Archive.Zip.Unix+  ( toFileMode,+    fromFileMode,+  )+where++import Data.Bits+import Data.Word+import System.Posix.Types (CMode (..))++-- | Convert external attributes to the file info.+--+-- >>> toFileMode 2179792896+-- 0o0755+--+-- @since 1.4.0+toFileMode :: Word32 -> CMode+toFileMode attrs = fromIntegral $ (attrs `shiftR` 16) .&. 0x0fff++-- | Convert external attributes to the file info. The function assumes a+-- regular file and keeps DOS attributes untouched.+--+-- >>> fromFileMode 0o0755+-- 2179792896+--+-- @since 1.4.0+fromFileMode :: CMode -> Word32+fromFileMode cmode = (0o100000 .|. fromIntegral cmode) `shiftL` 16

@@ -1,4 +1,4 @@-Copyright © 2016–2017 Mark Karpov+Copyright © 2016–present Mark Karpov  All rights reserved. 

@@ -4,10 +4,9 @@ [![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)-[![Coverage Status](https://coveralls.io/repos/mrkkrp/zip/badge.svg?branch=master&service=github)](https://coveralls.io/github/mrkkrp/zip?branch=master)+[![CI](https://github.com/mrkkrp/zip/actions/workflows/ci.yaml/badge.svg)](https://github.com/mrkkrp/zip/actions/workflows/ci.yaml) -* [Why this library is written](#why-this-library-is-written)+* [Why this library was written](#why-this-library-was-written)     * [zip-archive](#zip-archive)     * [LibZip](#libzip)     * [zip-conduit](#zip-conduit)@@ -23,42 +22,35 @@ * [License](#license)  This is a feature-rich, memory-efficient, and type-safe library to-manipulate Zip archives in Haskell. The library is the most complete and-efficient implementation of .ZIP specification in pure Haskell (at least-from open-sourced ones). In particular, it's created with large multimedia-data in mind and provides all features users might expect, comparable in-terms of feature-set with libraries like `libzip` in C.+manipulate Zip archives. The library was created with large multimedia data+in mind and provides all features users might expect, comparable in terms of+feature-set with libraries like `libzip` in C. -## Why this library is written+## Why this library was written  There are a few libraries to work with Zip archives, yet every one of them-provides only a subset of all the functionality a user may need (obviously-the libraries provide functionality that their authors needed) and otherwise-is flawed in some way so it cannot be easily used in some situations. Let's-examine all the libraries available on Hackage to understand motivation for-this package.+provides only a subset of useful functionality or otherwise is flawed in+some way so it cannot be easily used in some situations. Let's examine all+libraries available on Hackage to understand the motivation for this+package.  ### zip-archive  `zip-archive` is a widely used library. It's quite old, well-known and-simple to use. However it creates Zip archives purely, as `ByteStrings`s in-memory that you can then write to the file system. This is not acceptable if-you work with more-or-less big data. For example, if you have collection of-files with total size of 500 MB and you want to pack them into an archive,-you can easily consume up to 1 GB of memory (the files plus resulting-archive). Not always you can afford to do this or do this at scale. Even if-you want just to look at list of archive entries it will read it into memory-in all its entirety. For my use-case it's not acceptable.+simple to use. However, it creates Zip archives purely, as `ByteStrings`s in+memory. This is not acceptable if you work with big data. For example, if+you have a collection of files with the total size 500 MB and you want to+pack them into an archive, you can easily consume up to 1 GB of memory (the+files plus the resulting archive). This is not always affordable. Even if+you want just to look at the list of archive entries it will read the entire+archive into memory.  ### LibZip -This is a binding to C-library [`libzip`](https://en.wikipedia.org/wiki/Libzip). There is always a-certain kind of trouble when you are using bindings. For example, you need-to take care that target library is installed and its version is compatible-with the version of your binding. Yes, this means additional headaches. It-should be just “plug and play”, but now you need to watch out for-compatibility.+This is a binding to the C library [`libzip`][libzip]. There is always a+certain kind of trouble with bindings. For example, you need to ensure that+the target library is installed and its version is compatible with the+version of your binding.  It's not that bad with libraries that do not break their API for years, but it's not the case with `libzip`. As the maintainer of `LibZip` puts it:@@ -67,40 +59,40 @@ > 0.11.x, then you should use LibZip 0.11. If your C library is 1.0, then > you should use LibZip master branch (not yet released to Hackage). -Now, on my machine I have version 1.0. To put the package on Stackage we had-to use version 0.10, because Stackage uses Ubuntu to build packages and-libraries on Ubuntu are always ancient. This means that I cannot use the+Now, on my machine I have the version 1.0. To put the package on Stackage we+had to use the version 0.10, because Stackage uses Ubuntu to build packages+and libraries on Ubuntu are always ancient. This means that I cannot use the version of the library from Stackage, and I don't yet know what will be on the server. -After much frustration with all these things I decided to avoid using of-`LibZip`, because after all, this is not that sort of a project that-shouldn't be done in pure Haskell. By rewriting this in Haskell, I also can-make it safer to use.+After much frustration, I decided to avoid using `LibZip`. After all, this+is not a project that shouldn't be done completely in Haskell. By rewriting+this in Haskell, I also can make it safer to use.  ### zip-conduit  This one uses the right approach: leverage a good streaming library-(`conduit`) for memory-efficient processing. This is however is not-feature-rich and has certain problems (including programming style, it uses-`error` if an entry is missing in archive, among other things), some of them-are reported on its issue tracker. It also does not appear to be maintained-(the last sign of activity was on December 23, 2014).+(`conduit`) for memory-efficient processing. The library is however not+feature-rich and has certain problems (including the programming style, it+uses `error` if an entry is missing in the archive, among other things),+some of them are reported on its issue tracker. It also does not appear to+be maintained (the last sign of activity was on December 23, 2014).  ## Features  The library supports all features specified in the modern .ZIP specification except for encryption and multi-disk archives. See more about this below. -For reference, here is a [copy of the specification](https://pkware.cachefly.net/webdocs/APPNOTE/APPNOTE-6.3.3.TXT).+For reference, here is a [copy of the specification][specification].  ### Compression methods  `zip` supports the following compression methods:  * Store (no compression, just store files “as is”)-* [DEFLATE](https://en.wikipedia.org/wiki/DEFLATE)-* [Bzip2](https://en.wikipedia.org/wiki/Bzip2)+* [DEFLATE]+* [Bzip2]+* [Zstandard]  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@@ -118,12 +110,11 @@  ### Sources of file data -The library gives you many options how to get file contents to compress and-how to get extracted data. The following methods are supported:+The following sources are supported:  * *File name.* This is an efficient method to perform compression or-  decompression. You just specify where to get data or where to save it and-  the rest is handled by the library.+  decompression. You specify where to get data or where to save it and the+  rest is handled by the library. * *Conduit source or sink.* * *ByteString.* Use it only with small data. * *Copy file from another archive.* An efficient operation, file is copied@@ -132,62 +123,60 @@ ### ZIP64  When necessary, the `ZIP64` extension is automatically used. It's necessary-when anything from this list takes place:+when: -* Total size of archive is greater than 4 GB.-* Size of compressed/uncompressed file in archive is greater than 4 GB.-* There are more than 65535 entries in archive.+* The total size of the archive is greater than 4 GB.+* The size of a single compressed/uncompressed file in the archive is+  greater than 4 GB.+* There are more than 65535 entries in the archive. -The library is particularly suited for processing of large files. For-example, I've been able to easily create 6.5 GB archive with reasonable-speed and without significant memory consumption.+The library is particularly well suited for processing large files. For+example, I've been able to create 6.5 GB archive with reasonable speed and+without significant memory consumption.  ### Filenames -The library has API that makes it impossible to create archive with+The library has an API that makes it impossible to create archive with non-portable or invalid file names in it.  As of .ZIP specification 6.3.2, files with Unicode symbols in their names-can be put into Zip archives. The library supports mechanisms for this and+can be stored in Zip archives. The library supports mechanisms for this and uses them automatically when needed. Besides UTF-8, CP437 is also supported-as it's required in the specification.+as per the specification.  ### Meta-information about files -The library allows to attach comments to entire archive or individual files,-and also gives its user full control over extra fields that are written to-file headers, so the user can store arbitrary information about file in the-archive.+The library allows us to attach comments to the entire archive or individual+files, and also gives its user full control over extra fields that are+written to file headers, so the user can store arbitrary information about+files in the archive.  ## Quick start  The module `Codec.Archive.Zip` provides everything you may need to manipulate Zip archives. There are three things that should be clarified-right away, to avoid confusion in the future.+right away to avoid confusion. -First, we use the `EntrySelector` type that can be obtained from `Path Rel-File` paths. This method may seem awkward at first, but it will protect you-from the problems with portability when your archive is unpacked on a-different platform. Using well-typed paths is also something you should-consider doing in your projects anyway. Even if you don't want to use the-`Path` module in your project, it's easy to marshal `FilePath` to `Path`-just before using functions from the library.+First, we use the `EntrySelector` type that can be obtained from relative+`FilePath`s (paths to directories are not allowed). This method may seem+awkward at first, but it will protect you from the problems with portability+when your archive is unpacked on a different platform. -The second thing, that is rather a consequence of the first, is that there-is no way to add directories, or to be precise, *empty directories* to your-archive. This approach is used in Git, and I find it quite sane.+Second, there is no way to add directories, or to be precise, *empty+directories* to your archive. This approach is used in Git and I find it+sane. -Finally, the third feature of the library is that it does not modify archive-instantly, because doing so on every manipulation would often be-inefficient. Instead we maintain a collection of pending actions that can be-turned into an optimized procedure that efficiently modifies archive in one-pass. Normally this should be of no concern to you, because all actions are-performed automatically when you leave the realm of `ZipArchive` monad. If,-however, you ever need to force an update, the `commit` function is your-friend. There are even “undo” functions, by the way.+Finally, the third feature of the library is that it does not modify the+archive instantly, because doing so on every manipulation would often be+inefficient. Instead, we maintain a collection of pending actions that can+be turned into an optimized procedure that efficiently modifies the archive+in one pass. Normally, this should be of no concern to you, because all+actions are performed automatically when you leave the `ZipArchive` monad.+If, however, you ever need to force an update, the `commit` function is your+friend. -Let's take a look at some examples that show how to accomplish most typical-tasks with help of the library.+Let's take a look at some examples that show how to accomplish most common+tasks.  To get full information about archive entries, use `getEntries`: @@ -214,7 +203,7 @@ λ> withArchive archivePath (saveEntry entrySelector pathToFile) ``` -…and finally just unpack the entire archive into some directory:+…and finally just unpack the entire archive into a directory:  ```haskell λ> withArchive archivePath (unpackInto destDir)@@ -222,9 +211,9 @@  See also `getArchiveComment` and `getArchiveDescription`. -Modifying is also easy, efficient, and powerful. When you want to create a-new archive use `createArchive`, otherwise `withArchive` will do. To add an-entry from `ByteString`:+Modifying is also easy. When you want to create a new archive use+`createArchive`, otherwise `withArchive` will do. To add an entry from+`ByteString`:  ```haskell λ> createArchive archivePath (addEntry Store "Hello, World!" entrySelector)@@ -239,7 +228,7 @@ To add contents from a file, use `loadEntry`:  ```haskell-λ> let toSelector = const $ parseRelFile "my-entry.txt" >>= mkEntrySelector+λ> let toSelector = const (mkEntrySelector "my-entry.txt") λ> createArchive archivePath (loadEntry BZip2 toSelector myFilePath) ``` @@ -253,8 +242,7 @@ It's often desirable to just pack a directory:  ```haskell-λ> let f = stripDir dir >=> mkEntrySelector-λ> createArchive archivePath (packDirRecur Deflate f dir)+λ> createArchive archivePath (packDirRecur Deflate mkEntrySelector dir) ```  It's also possible to:@@ -275,13 +263,19 @@  ## Contribution -You can contact the maintainer via-[the issue tracker](https://github.com/mrkkrp/zip/issues).+You can contact the maintainer via [the issue+tracker](https://github.com/mrkkrp/zip/issues). -Pull requests are also welcome and will be reviewed quickly.+Pull requests are welcome.  ## License -Copyright © 2016–2017 Mark Karpov+Copyright © 2016–present Mark Karpov  Distributed under BSD 3 clause license.++[libzip]: https://en.wikipedia.org/wiki/Libzip+[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+[Zstandard]: https://en.wikipedia.org/wiki/Zstandard

@@ -1,6 +0,0 @@-module Main (main) where--import Distribution.Simple--main :: IO ()-main = defaultMain

@@ -0,0 +1,19 @@+module Main (main) where++import Codec.Archive.Zip+import System.Environment (getArgs)+import System.Exit (exitFailure)+import System.FilePath++main :: IO ()+main = do+  [operation, input, output] <- getArgs+  case operation of+    "compress" -> do+      selector <- mkEntrySelector (takeFileName input)+      createArchive output (loadEntry Deflate selector input)+    "uncompress" ->+      withArchive input (unpackInto output)+    _ -> do+      putStrLn "Unknown command."+      exitFailure

@@ -1,706 +1,939 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# OPTIONS -fno-warn-orphans  #-}--module Main (main) where--import Codec.Archive.Zip-import Codec.Archive.Zip.CP437-import Control.Monad-import Control.Monad.Catch (catchIOError)-import Control.Monad.IO.Class-import Data.Bits (complement)-import Data.ByteString (ByteString)-import Data.Conduit (yield)-import Data.Foldable (foldl')-import Data.List (intercalate)-import Data.Map (Map, (!))-import Data.Maybe (fromJust)-import Data.Monoid-import Data.Text (Text)-import Data.Time-import Data.Version-import Path-import Path.IO-import System.IO-import System.IO.Error (isDoesNotExistError)-import Test.Hspec-import Test.QuickCheck-import qualified Data.ByteString         as B-import qualified Data.ByteString.Builder as LB-import qualified Data.ByteString.Lazy    as LB-import qualified Data.Conduit.List       as CL-import qualified Data.Map                as M-import qualified Data.Set                as E-import qualified Data.Text               as T-import qualified Data.Text.Encoding      as T-import qualified System.FilePath.Windows as Windows---- | Zip tests. Please note that Zip64 feature is not currently tested--- automatically because for it to expose itself we need > 4GB of--- data. Handling such quantities of data locally is problematic and even--- more problematic in the context of CI server.--main :: IO ()-main = hspec $ do-  describe "mkEntrySelector" mkEntrySelectorSpec-  describe "unEntrySelector" unEntrySelectorSpec-  describe "getEntryName"    getEntryNameSpec-  describe "decodeCP437"     decodeCP437Spec-  around withSandbox $ do-    describe "createArchive"      createArchiveSpec-    describe "withArchive"        withArchiveSpec-    describe "archive comment"    archiveCommentSpec-    describe "getEntryDesc"       getEntryDescSpec-    describe "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 "renameEntry"        renameEntrySpec-    describe "deleteEntry"        deleteEntrySpec-    describe "forEntries"         forEntriesSpec-    describe "undoEntryChanges"   undoEntryChangesSpec-    describe "undoArchiveChanges" undoArchiveChangesSpec-    describe "undoAll"            undoAllSpec-    describe "consistency"        consistencySpec-    describe "packDirRecur"       packDirRecurSpec-    describe "unpackInto"         unpackIntoSpec--------------------------------------------------------------------------------- Arbitrary instances and generators--instance Arbitrary Text where-  arbitrary = T.pack <$> listOf1 arbitrary--instance Arbitrary ByteString where-  arbitrary = B.pack <$> listOf arbitrary--instance Arbitrary CompressionMethod where-  arbitrary = elements [Store, Deflate, BZip2]--instance Arbitrary UTCTime where-  arbitrary = UTCTime-    <$> (ModifiedJulianDay <$> choose (44239, 90989))-    <*> (secondsToDiffTime <$> choose (0, 86399))--instance Arbitrary (Path Rel File) where-  arbitrary = do-    x <- intercalate "/" <$> listOf1 (listOf1 charGen)-    case parseRelFile x of-      Nothing -> arbitrary-      Just path -> return path--instance Arbitrary EntrySelector where-  arbitrary = do-    x <- arbitrary-    case mkEntrySelector x of-      Nothing -> arbitrary-      Just s  -> return s--data EM = EM EntrySelector EntryDescription (ZipArchive ()) deriving Show--instance Arbitrary EM where-  arbitrary = do-    s       <- arbitrary-    method  <- arbitrary-    content <- arbitrary-    modTime <- arbitrary-    comment <- arbitrary-    extraFieldTag <- arbitrary `suchThat` (/= 1)-    extraFieldContent <- arbitrary `suchThat` ((< 0xffff) . B.length)-    let action = do-          addEntry method content s-          setModTime modTime s-          setEntryComment comment s-          addExtraField extraFieldTag extraFieldContent s-    return $ EM s EntryDescription-      { edVersionMadeBy    = undefined-      , edVersionNeeded    = undefined-      , edCompression      = method-      , edModTime          = modTime-      , edCRC32            = undefined-      , edCompressedSize   = undefined-      , edUncompressedSize = fromIntegral (B.length content)-      , edOffset           = undefined-      , edComment          = Just comment-      , edExtraField       = M.singleton extraFieldTag extraFieldContent }-      action--data EC = EC (Map EntrySelector EntryDescription) (ZipArchive ()) deriving Show--instance Arbitrary EC where-  arbitrary = foldl' f (EC M.empty (return ())) <$> listOf1 arbitrary-    where f (EC m z') (EM s desc z) = EC (M.insert s desc m) (z' >> z)--charGen :: Gen Char-charGen = frequency-  [ (3, choose ('a', 'z'))-  , (3, choose ('A', 'Z'))-  , (3, choose ('0', '9'))-  , (1, arbitrary `suchThat` (>= ' ')) ]--binASCII :: Gen ByteString-binASCII = LB.toStrict . LB.toLazyByteString <$> go-  where go = frequency-          [ (10, (<>) <$> (LB.word8 <$> choose (0, 127)) <*> go)-          , (1,  return mempty) ]--instance Show EntryDescription where-  show ed = "{ edCompression = " ++ show (edCompression ed) ++-    "\n, edModTime = " ++ show (edModTime ed) ++-    "\n, edUncompressedSize = " ++ show (edUncompressedSize ed) ++-    "\n, edComment = " ++ show (edComment ed) ++-    "\n, edExtraField = " ++ show (edExtraField ed) ++-    " }"--instance Show (ZipArchive a) where-  show = const "<zip archive>"--------------------------------------------------------------------------------- Pure operations and periphery--mkEntrySelectorSpec :: Spec-mkEntrySelectorSpec = do-  context "when incorrect Windows paths are passed" $-    it "rejects them" . property $ \path ->-      (not . Windows.isValid . toFilePath $ path)-        ==> mkEntrySelector path === Nothing-  context "when too long paths are passed" $-    it "rejects them" $ do-      path <- parseRelFile (replicate 0x10000 'a')-      mkEntrySelector path `shouldThrow` isEntrySelectorException path-  context "when correct paths are passed" $-    it "adequately represents them" $ do-      let c str = do-            s <- parseRelFile str >>= mkEntrySelector-            getEntryName s `shouldBe` T.pack str-      c "one/two/three"-      c "something.txt"--unEntrySelectorSpec :: Spec-unEntrySelectorSpec =-  context "when entry selector exists" $-    it "has corresponding path" . property $ \s ->-      not . null . toFilePath . unEntrySelector $ s--getEntryNameSpec :: Spec-getEntryNameSpec =-  context "when entry selector exists" $-    it "has corresponding representation" . property $ \s ->-      not . T.null . getEntryName $ s--decodeCP437Spec :: Spec-decodeCP437Spec = do-  context "when ASCII-compatible subset is used" $-    it "has the same result as decoding UTF-8" . property $-      forAll binASCII $ \bin ->-        decodeCP437 bin `shouldBe` T.decodeUtf8 bin-  context "when non-ASCII subset is used" $-    it "is decoded correctly" $ do-      let c b t = decodeCP437 (B.pack b ) `shouldBe` t-      c [0x80..0x9f] "ÇüéâäàåçêëèïîìÄÅÉæÆôöòûùÿÖÜ¢£¥₧ƒ"-      c [0xa0..0xbf] "áíóúñѪº¿⌐¬½¼¡«»░▒▓│┤╡╢╖╕╣║╗╝╜╛┐"-      c [0xc0..0xdf] "└┴┬├─┼╞╟╚╔╩╦╠═╬╧╨╤╥╙╘╒╓╫╪┘┌█▄▌▐▀"-      c [0xe0..0xff] "αßΓπΣσµτΦΘΩδ∞φε∩≡±≥≤⌠⌡÷≈°∙·√ⁿ²■ "--------------------------------------------------------------------------------- Primitive editing/querying actions--createArchiveSpec :: SpecWith (Path Abs File)-createArchiveSpec = do-  context "when called with non-existent path and empty recipe" $-    it "creates correct representation of empty archive" $ \path -> do-      createArchive path (return ())-      B.readFile (toFilePath path) `shouldReturn` emptyArchive-  context "when called with occupied path" $-    it "overwrites it" $ \path -> do-      B.writeFile (toFilePath path) B.empty-      createArchive path (return ())-      B.readFile (toFilePath path) `shouldNotReturn` B.empty--withArchiveSpec :: SpecWith (Path Abs File)-withArchiveSpec = do-  context "when called with non-existent path" $-    it "throws 'isDoesNotExistError' exception" $ \path ->-      withArchive path (return ()) `shouldThrow` isDoesNotExistError-  context "when called with occupied path (empty file)" $-    it "throws 'ParsingFailed' exception" $ \path -> do-      B.writeFile (toFilePath path) B.empty-      withArchive path (return ()) `shouldThrow`-        isParsingFailed path "Cannot locate end of central directory"-  context "when called with occupied path (empty archive)" $-    it "does not overwrite the file unnecessarily" $ \path -> do-      let fp = toFilePath path-      B.writeFile fp emptyArchive-      withArchive path . liftIO $ B.writeFile fp B.empty-      B.readFile fp `shouldNotReturn` emptyArchive--archiveCommentSpec :: SpecWith (Path Abs File)-archiveCommentSpec = do-  context "when new archive is created" $-    it "returns no archive comment" $ \path ->-      createArchive path getArchiveComment `shouldReturn` Nothing-  context "when comment contains end of central directory signature" $-    it "reads it without problems" $ \path -> do-      entries <- createArchive path $ do-        setArchiveComment "I saw you want to have PK\ENQ\ACK here."-        commit-        getEntries-      entries `shouldBe` M.empty-  context "when comment is committed (delete/set)" $-    it "reads it and updates" $ \path -> property $ \txt -> do-      comment <- createArchive path $ do-        deleteArchiveComment-        setArchiveComment txt-        commit-        getArchiveComment-      comment `shouldBe` Just txt-  context "when comment is committed (set/delete)" $-    it "reads it and updates" $ \path -> property $ \txt -> do-      comment <- createArchive path $ do-        setArchiveComment txt-        deleteArchiveComment-        commit-        getArchiveComment-      comment `shouldBe` Nothing-  context "when pre-existing comment is overwritten" $-    it "returns the new comment" $ \path -> property $ \txt txt' -> do-      comment <- createArchive path $ do-        setArchiveComment txt-        commit-        setArchiveComment txt'-        commit-        getArchiveComment-      comment `shouldBe` Just txt'-  context "when pre-existing comment is deleted" $-    it "actually deletes it" $ \path -> property $ \txt -> do-      comment <- createArchive path $ do-        setArchiveComment txt-        commit-        deleteArchiveComment-        commit-        getArchiveComment-      comment `shouldBe` Nothing--getEntryDescSpec :: SpecWith (Path Abs File)-getEntryDescSpec =-  it "always returns correct description" $-    \path -> property $ \(EM s desc z) -> do-      desc' <- fromJust <$> createArchive path (z >> commit >> getEntryDesc s)-      desc' `shouldSatisfy` softEq desc--versionNeededSpec :: SpecWith (Path Abs File)-versionNeededSpec =-  it "writes correct version that is needed to extract archive" $-    -- 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-      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])--addEntrySpec :: SpecWith (Path Abs File)-addEntrySpec =-  context "when an entry is added" $-    it "is there" $ \path -> property $ \m b s -> do-      info <- createArchive path $ do-        addEntry m b s-        commit-        (,) <$> getEntry s <*> (edCompression . (! s) <$> getEntries)-      info `shouldBe` (b, m)--sinkEntrySpec :: SpecWith (Path Abs File)-sinkEntrySpec =-  context "when an entry is sunk" $-    it "is there" $ \path -> property $ \m b s -> do-      info <- createArchive path $ do-        sinkEntry m (yield b) s-        commit-        (,) <$> sourceEntry s (CL.foldMap id)-          <*> (edCompression . (! s) <$> getEntries)-      info `shouldBe` (b, m)--loadEntrySpec :: SpecWith (Path Abs File)-loadEntrySpec =-  context "when an entry is loaded" $-    it "is there" $ \path -> property $ \m b s -> do-      let vpath = deriveVacant path-      B.writeFile (toFilePath vpath) b-      createArchive path $ do-        loadEntry m (const $ return s) vpath-        commit-        liftIO (removeFile vpath)-        saveEntry s vpath-      B.readFile (toFilePath vpath) `shouldReturn` b--copyEntrySpec :: SpecWith (Path Abs File)-copyEntrySpec =-  context "when entry is copied form another archive" $-    it "is there" $ \path -> property $ \m b s -> do-      let vpath = deriveVacant path-      createArchive vpath (addEntry m b s)-      info <- createArchive path $ do-        copyEntry vpath s s-        commit-        (,) <$> getEntry s <*> (edCompression . (! s) <$> getEntries)-      info `shouldBe` (b, m)--checkEntrySpec :: SpecWith (Path Abs File)-checkEntrySpec = do-  context "when entry is intact" $-    it "passes the check" $ \path -> property $ \m b s -> do-      check <- createArchive path $ do-        addEntry m b s-        commit-        checkEntry s-      check `shouldBe` True-  context "when entry is corrupted" $-    it "does not pass the check" $ \path -> property $ \b s ->-      not (B.null b) ==> do-        let r = 50 + (B.length . T.encodeUtf8 . getEntryName $ s)-        offset <- createArchive path $ do-          addEntry Store b s-          commit-          fromIntegral . edOffset . (! s) <$> getEntries-        withFile (toFilePath path) ReadWriteMode $ \h -> do-          hSeek h AbsoluteSeek (offset + fromIntegral r)-          byte <- B.map complement <$> B.hGet h 1-          hSeek h RelativeSeek (-1)-          B.hPut h byte-        withArchive path (checkEntry s) `shouldReturn` False--recompressSpec :: SpecWith (Path Abs File)-recompressSpec =-  context "when recompression is used" $-    it "gets recompressed" $ \path -> property $ \m m' b s -> do-      info <- createArchive path $ do-        addEntry m b s-        commit-        recompress m' s-        commit-        (,) <$> getEntry s <*> (edCompression . (! s) <$> getEntries)-      info `shouldBe` (b, m')--entryCommentSpec :: SpecWith (Path Abs File)-entryCommentSpec = do-  context "when comment is committed (delete/set)" $-    it "reads it and updates" $ \path -> property $ \txt s -> do-      comment <- createArchive path $ do-        addEntry Store "foo" s-        deleteEntryComment s-        setEntryComment txt s-        commit-        edComment . (! s) <$> getEntries-      comment `shouldBe` Just txt-  context "when comment is committed (set/delete)" $-    it "reads it and updates" $ \path -> property $ \txt s -> do-      comment <- createArchive path $ do-        addEntry Store "foo" s-        setEntryComment txt s-        deleteEntryComment s-        commit-        edComment . (! s) <$> getEntries-      comment `shouldBe` Nothing-  context "when pre-existing comment is overwritten" $-    it "returns the new comment" $ \path -> property $ \txt txt' s -> do-      comment <- createArchive path $ do-        addEntry Store "foo" s-        setEntryComment txt s-        commit-        setEntryComment txt' s-        commit-        edComment . (! s) <$> getEntries-      comment `shouldBe` Just txt'-  context "when pre-existing comment is deleted" $-    it "actually deletes it" $ \path -> property $ \txt s -> do-      comment <- createArchive path $ do-        addEntry Store "foo" s-        setEntryComment txt s-        commit-        deleteEntryComment s-        commit-        edComment . (! s) <$> getEntries-      comment `shouldBe` Nothing--setModTimeSpec :: SpecWith (Path Abs File)-setModTimeSpec = do-  context "when mod time is set (after creation)" $-    it "reads it and updates" $ \path -> property $ \time s -> do-      modTime <- createArchive path $ do-        addEntry Store "foo" s-        setModTime time s-        commit-        edModTime . (! s) <$> getEntries-      modTime `shouldSatisfy` isCloseTo time-  context "when mod time is set (before creation)" $-    it "has no effect" $ \path -> property $ \time time' s ->-      not (isCloseTo time time') ==> do-        modTime <- createArchive path $ do-          setModTime time s-          addEntry Store "foo" s-          commit-          edModTime . (! s) <$> getEntries-        modTime `shouldNotSatisfy` isCloseTo time--extraFieldSpec :: SpecWith (Path Abs File)-extraFieldSpec = do-  context "when extra field is committed (delete/set)" $-    it "reads it and updates" $ \path -> property $ \n b s ->-      n /= 1 ==> do-        efield <- createArchive path $ do-          addEntry Store "foo" s-          deleteExtraField n s-          addExtraField n b s-          commit-          M.lookup n . edExtraField . (! s) <$> getEntries-        efield `shouldBe` Just b-  context "when extra field is committed (set/delete)" $-    it "reads it and updates" $ \path -> property $ \n b s ->-      n /= 1 ==> do-        efield <- createArchive path $ do-          addEntry Store "foo" s-          addExtraField n b s-          deleteExtraField n s-          commit-          M.lookup n . edExtraField . (! s) <$> getEntries-        efield `shouldBe` Nothing-  context "when pre-existing extra field is overwritten" $-    it "reads it and updates" $ \path -> property $ \n b b' s ->-      n /= 1 ==> do-        efield <- createArchive path $ do-          addEntry Store "foo" s-          addExtraField n b s-          commit-          addExtraField n b' s-          commit-          M.lookup n . edExtraField . (! s) <$> getEntries-        efield `shouldBe` Just b'-  context "when pre-existing extra field is deleted" $-    it "actually deletes it" $ \path -> property $ \n b s ->-      n /= 1 ==> do-        efield <- createArchive path $ do-          addEntry Store "foo" s-          addExtraField n b s-          commit-          deleteExtraField n s-          commit-          M.lookup n . edExtraField . (! s) <$> getEntries-        efield `shouldBe` Nothing--renameEntrySpec :: SpecWith (Path Abs File)-renameEntrySpec = do-  context "when renaming after editing of new entry" $-    it "produces correct result" $ \path -> property $ \(EM s desc z) s' -> do-      desc' <- createArchive path $ do-        z-        renameEntry s s'-        commit-        (! s') <$> getEntries-      desc' `shouldSatisfy` softEq desc-  context "when renaming existing entry" $-    it "gets renamed" $ \path -> property $ \(EM s desc z) s' -> do-      desc' <- createArchive path $ do-        z-        commit-        renameEntry s s'-        commit-        (! s') <$> getEntries-      desc' `shouldSatisfy` softEq desc--deleteEntrySpec :: SpecWith (Path Abs File)-deleteEntrySpec = do-  context "when deleting after editing of new entry" $-    it "produces correct result" $ \path -> property $ \(EM s _ z) -> do-      member <- createArchive path $ do-        z-        deleteEntry s-        commit-        doesEntryExist s-      member `shouldBe` False-  context "when deleting existing entry" $-    it "gets deleted" $ \path -> property $ \(EM s _ z) -> do-      member <- createArchive path $ do-        z-        commit-        deleteEntry s-        commit-        doesEntryExist s-      member `shouldBe` False--forEntriesSpec :: SpecWith (Path Abs File)-forEntriesSpec =-  it "affects all existing entries" $ \path -> property $ \(EC m z) txt -> do-    m' <- createArchive path $ do-      z-      commit-      forEntries (setEntryComment txt)-      commit-      getEntries-    let f ed = ed { edComment = Just txt }-    m' `shouldSatisfy` softEqMap (M.map f m)--undoEntryChangesSpec :: SpecWith (Path Abs File)-undoEntryChangesSpec =-  it "cancels all actions for specified entry" $-    \path -> property $ \(EM s _ z) -> do-      member <- createArchive path $ do-        z-        undoEntryChanges s-        commit-        doesEntryExist s-      member `shouldBe` False--undoArchiveChangesSpec :: SpecWith (Path Abs File)-undoArchiveChangesSpec = do-  it "cancels archive comment editing" $ \path -> property $ \txt -> do-    comment <- createArchive path $ do-      setArchiveComment txt-      undoArchiveChanges-      commit-      getArchiveComment-    comment `shouldBe` Nothing-  it "cancels archive comment deletion" $ \path -> property $ \txt -> do-    comment <- createArchive path $ do-      setArchiveComment txt-      commit-      deleteArchiveComment-      undoArchiveChanges-      commit-      getArchiveComment-    comment `shouldBe` Just txt--undoAllSpec :: SpecWith (Path Abs File)-undoAllSpec =-  it "cancels all editing at once" $ \path -> property $ \(EC _ z) txt -> do-    let fp = toFilePath path-    createArchive path (return ())-    withArchive path $ do-      z-      setArchiveComment txt-      undoAll-      liftIO (B.writeFile fp B.empty)-    B.readFile fp `shouldReturn` B.empty--------------------------------------------------------------------------------- Complex construction/restoration--consistencySpec :: SpecWith (Path Abs File)-consistencySpec =-  it "can save and restore arbitrary archive" $-    \path -> property $ \(EC m z) txt -> do-      (txt', m') <- createArchive path $ do-        z-        setArchiveComment txt-        commit-        (,) <$> getArchiveComment <*> getEntries-      txt' `shouldBe` Just txt-      m' `shouldSatisfy` softEqMap m--packDirRecurSpec :: SpecWith (Path Abs File)-packDirRecurSpec =-  it "packs arbitrary directory recursively" $-    \path -> property $ \contents -> do-      let dir = parent path-          f   = stripDir dir >=> mkEntrySelector-      blew <- catchIOError (do-        forM_ contents $ \s -> do-          let item = dir </> unEntrySelector s-          ensureDir (parent item)-          B.writeFile (toFilePath item) "foo"-        return False)-        (const $ return True)-      when blew discard -- TODO-      selectors <- M.keysSet <$>-        createArchive path (packDirRecur Store f dir >> commit >> getEntries)-      selectors `shouldBe` E.fromList contents--unpackIntoSpec :: SpecWith (Path Abs File)-unpackIntoSpec =-  it "unpacks archive contents into directory" $-    \path -> property $ \(EC m z) -> do-      let dir = parent path-      blew <- createArchive path $ do-        z-        commit-        catchIOError-          (unpackInto dir >> return False)-          (const $ return True)-      when blew discard -- TODO-      removeFile path-      selectors <- listDirRecur dir >>=-        mapM (stripDir dir >=> mkEntrySelector) . snd-      E.fromList selectors `shouldBe` M.keysSet m--------------------------------------------------------------------------------- Helpers---- | Check whether given exception is 'EntrySelectorException' with specific--- path inside.--isEntrySelectorException :: Path Rel File -> EntrySelectorException -> Bool-isEntrySelectorException path (InvalidEntrySelector p) = p == path---- | Check whether given exception is 'ParsingFailed' exception with--- specific path and error message inside.--isParsingFailed :: Path Abs File -> String -> ZipException -> Bool-isParsingFailed path msg (ParsingFailed path' msg') =-  path == path' && msg == msg'-isParsingFailed _ _ _ = False---- | Create sandbox directory to model some situation in it and run some--- tests. Note that we're using new unique sandbox directory for each test--- case to avoid contamination and it's unconditionally deleted after test--- case finishes. The function returns vacant file path in that directory.--withSandbox :: ActionWith (Path Abs File) -> IO ()-withSandbox action = withSystemTempDir "zip-sandbox" $ \dir ->-  action (dir </> $(mkRelFile "foo.zip"))---- | Given primary name (name of archive), generate a name that does not--- collide with it.--deriveVacant :: Path Abs File -> Path Abs File-deriveVacant = (</> $(mkRelFile "bar")) . parent---- | Compare times forgiving minor difference.--isCloseTo :: UTCTime -> UTCTime -> Bool-isCloseTo a b = abs (diffUTCTime a b) < 2---- | Compare only some fields of 'EntryDescription' record.--softEq :: EntryDescription -> EntryDescription -> Bool-softEq a b =-  edCompression a == edCompression b &&-  isCloseTo (edModTime a) (edModTime b) &&-  edUncompressedSize a == edUncompressedSize b &&-  edComment a == edComment b &&-  M.delete 1 (edExtraField a) == M.delete 1 (edExtraField b)---- | Compare two maps describing archive entries in such a way that only--- some fields in 'EntryDescription' record are tested.--softEqMap-  :: Map EntrySelector EntryDescription-  -> Map EntrySelector EntryDescription-  -> Bool-softEqMap n m = M.null (M.differenceWith f n m)-  where f a b = if softEq a b then Nothing else Just a---- | Canonical representation of empty Zip archive.--emptyArchive :: ByteString-emptyArchive = B.pack-  [ 0x50, 0x4b, 0x05, 0x06, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00-  , 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 ]+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main (main) where++import Codec.Archive.Zip+import Codec.Archive.Zip.CP437+import Codec.Archive.Zip.Unix+import Control.Monad+import Control.Monad.IO.Class+import Data.Bits+import Data.ByteString (ByteString)+import Data.ByteString qualified as B+import Data.ByteString.Builder qualified as LB+import Data.ByteString.Lazy qualified as LB+import Data.Conduit qualified as C+import Data.Conduit.List qualified as CL+import Data.DList qualified as DList+import Data.List (intercalate)+import Data.Map (Map, (!))+import Data.Map.Strict qualified as M+import Data.Maybe (fromJust)+import Data.Set qualified as E+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Time+import Data.Version+import Data.Word+import Numeric.Natural+import System.Directory+import System.FilePath ((</>))+import System.FilePath qualified as FP+import System.IO+import System.IO.Error (isDoesNotExistError)+import System.IO.Temp+import Test.Hspec+import Test.QuickCheck hiding ((.&.))++ffffffff :: Natural++#ifdef HASKELL_ZIP_DEV_MODE+ffffffff = 250+#else+ffffffff = 0xffffffff+#endif++-- | Zip tests. Please note that the Zip64 feature is not currently tested+-- automatically because we'd need > 4GB of data. Handling such quantities+-- of data locally is problematic and even more problematic on CI.+main :: IO ()+main = hspec $ do+  describe "mkEntrySelector" mkEntrySelectorSpec+  describe "unEntrySelector" unEntrySelectorSpec+  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 "setExternalFileAttrsSpec" setExternalFileAttrsSpec+    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++----------------------------------------------------------------------------+-- Arbitrary instances and generators++instance Arbitrary Text where+  arbitrary = T.pack <$> listOf1 arbitrary++instance Arbitrary ByteString where+  arbitrary = B.pack <$> scale (* 10) (listOf arbitrary)++{- ORMOLU_DISABLE -}++instance Arbitrary CompressionMethod where+  arbitrary =+    elements+      [ Store,+#ifdef ENABLE_BZIP2+        BZip2,+#endif+#ifdef ENABLE_ZSTD+        Zstd,+#endif+        Deflate+      ]++{- ORMOLU_ENABLE -}++instance Arbitrary UTCTime where+  arbitrary =+    UTCTime+      <$> (ModifiedJulianDay <$> choose (44239, 90989))+      <*> (secondsToDiffTime <$> choose (0, 86399))++newtype RelPath = RelPath FilePath++instance Show RelPath where+  show (RelPath path) = show path++instance Arbitrary RelPath where+  arbitrary = do+    p <-+      resize 10 $+        intercalate "/"+          <$> listOf1+            ( (++)+                <$> vectorOf 3 charGen+                <*> listOf1 charGen+            )+    case mkEntrySelector p of+      Nothing -> arbitrary+      Just _ -> return (RelPath p)++instance Arbitrary EntrySelector where+  arbitrary = do+    RelPath x <- arbitrary+    case mkEntrySelector x of+      Nothing -> arbitrary+      Just s -> return s++data EM = EM EntrySelector EntryDescription (ZipArchive ()) deriving (Show)++instance Arbitrary EM where+  arbitrary = do+    s <- arbitrary+    method <- arbitrary+    content <- arbitrary+    modTime <- arbitrary+    comment <- arbitrary+    externalFileAttrs <- arbitrary+    extraFieldTag <- arbitrary `suchThat` (/= 1)+    extraFieldContent <- arbitrary `suchThat` ((< 0xffff) . B.length)+    let action = do+          addEntry method content s+          setModTime modTime s+          setEntryComment comment s+          addExtraField extraFieldTag extraFieldContent s+          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++data EC = EC (Map EntrySelector EntryDescription) (ZipArchive ()) deriving (Show)++instance Arbitrary EC where+  arbitrary = do+    let f (EM s d z) = (s, (d, z))+    m <- M.fromList . fmap f <$> downScale (listOf arbitrary)+    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` (>= ' '))+    ]++binASCII :: Gen ByteString+binASCII = LB.toStrict . LB.toLazyByteString <$> go+  where+    go =+      frequency+        [ (10, (<>) <$> (LB.word8 <$> choose (0, 127)) <*> go),+          (1, return mempty)+        ]++instance Show (ZipArchive a) where+  show = const "<zip archive>"++----------------------------------------------------------------------------+-- Pure operations and periphery++mkEntrySelectorSpec :: Spec+mkEntrySelectorSpec = do+  let rejects x =+        mkEntrySelector x `shouldThrow` isEntrySelectorException x+      accepts x = do+        s <- mkEntrySelector x+        getEntryName s `shouldBe` T.pack x+  context "when absolute paths are passed" $+    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/"+      rejects "foo/bar/"+  context "when paths with dot as path segment are passed" $+    it "they are rejected" $ do+      rejects "./foo/bar"+      rejects "foo/./bar"+      rejects "foo/bar/."+  context "when paths with double dot as path segment are passed" $+    it "they are rejected" $ do+      rejects "../foo/bar"+      rejects "foo/../bar"+      rejects "foo/bar/.."+  context "when too long paths are passed" $+    it "rejects them" $ do+      let path = replicate 0x10000 'a'+      mkEntrySelector path `shouldThrow` isEntrySelectorException path+  context "when correct paths are passed" $+    it "adequately represents them" $ do+      accepts "foo"+      accepts "one/two/three"+      accepts "something.txt"++unEntrySelectorSpec :: Spec+unEntrySelectorSpec =+  context "when entry selector exists" $+    it "has corresponding path" . property $ \s ->+      not . null . unEntrySelector $ s++getEntryNameSpec :: Spec+getEntryNameSpec =+  context "when entry selector exists" $+    it "has corresponding representation" . property $ \s ->+      not . T.null . getEntryName $ s++decodeCP437Spec :: Spec+decodeCP437Spec = do+  context "when ASCII-compatible subset is used" $+    it "has the same result as decoding UTF-8" . property $+      forAll binASCII $ \bin ->+        decodeCP437 bin `shouldBe` T.decodeUtf8 bin+  context "when non-ASCII subset is used" $+    it "is decoded correctly" $ do+      let c b t = decodeCP437 (B.pack b) `shouldBe` t+      c [0x80 .. 0x9f] "ÇüéâäàåçêëèïîìÄÅÉæÆôöòûùÿÖÜ¢£¥₧ƒ"+      c [0xa0 .. 0xbf] "áíóúñѪº¿⌐¬½¼¡«»░▒▓│┤╡╢╖╕╣║╗╝╜╛┐"+      c [0xc0 .. 0xdf] "└┴┬├─┼╞╟╚╔╩╦╠═╬╧╨╤╥╙╘╒╓╫╪┘┌█▄▌▐▀"+      c [0xe0 .. 0xff] "αßΓπΣσµτΦΘΩδ∞φε∩≡±≥≤⌠⌡÷≈°∙·√ⁿ²■ "++fromFileModeSpec :: Spec+fromFileModeSpec =+  context "UNIX helpers" $ do+    it "toFileMode . fromFileMode == id .&. 0x0fffff" . property $ \mode ->+      (toFileMode . fromFileMode) (fromIntegral mode)+        == fromIntegral (mode .&. (0x0fff :: Word16))+    it "toFileMode == toFileMode . fromFileMode . toFileMode" . property $ \mode ->+      toFileMode mode == (toFileMode . fromFileMode . toFileMode) mode++----------------------------------------------------------------------------+-- Primitive editing/querying actions++createArchiveSpec :: SpecWith FilePath+createArchiveSpec = do+  context "when called with non-existent path and empty recipe" $+    it "creates correct representation of empty archive" $ \path -> do+      createArchive path (return ())+      B.readFile path `shouldReturn` emptyArchive+  context "when called with an occupied path" $+    it "overwrites it" $ \path -> do+      B.writeFile path B.empty+      createArchive path (return ())+      B.readFile path `shouldNotReturn` B.empty++withArchiveSpec :: SpecWith FilePath+withArchiveSpec = do+  context "when called with non-existent path" $+    it "throws 'isDoesNotExistError' exception" $ \path ->+      withArchive path (return ()) `shouldThrow` isDoesNotExistError+  context "when called with occupied path (empty file)" $+    it "throws 'ParsingFailed' exception" $ \path -> do+      B.writeFile path B.empty+      withArchive path (return ())+        `shouldThrow` isParsingFailed path "Cannot locate end of central directory"+  context "when called with occupied path (empty archive)" $+    it "does not overwrite the file unnecessarily" $ \path -> do+      B.writeFile path emptyArchive+      withArchive path $+        liftIO $+          B.writeFile path B.empty+      B.readFile path `shouldNotReturn` emptyArchive++archiveCommentSpec :: SpecWith FilePath+archiveCommentSpec = do+  context "when new archive is created" $+    it "returns no archive comment" $ \path ->+      createArchive path getArchiveComment `shouldReturn` Nothing+  context "when comment contains end of central directory signature" $+    it "reads it without problems" $ \path -> do+      entries <- createArchive path $ do+        setArchiveComment "I saw you want to have PK\ENQ\ACK here."+        commit+        getEntries+      entries `shouldBe` M.empty+  context "when comment is committed (delete/set)" $+    it "reads it and updates" $ \path ->+      property $ \txt -> do+        comment <- createArchive path $ do+          deleteArchiveComment+          setArchiveComment txt+          commit+          getArchiveComment+        comment `shouldBe` Just txt+  context "when comment is committed (set/delete)" $+    it "reads it and updates" $ \path ->+      property $ \txt -> do+        comment <- createArchive path $ do+          setArchiveComment txt+          deleteArchiveComment+          commit+          getArchiveComment+        comment `shouldBe` Nothing+  context "when pre-existing comment is overwritten" $+    it "returns the new comment" $ \path ->+      property $ \txt txt' -> do+        comment <- createArchive path $ do+          setArchiveComment txt+          commit+          setArchiveComment txt'+          commit+          getArchiveComment+        comment `shouldBe` Just txt'+  context "when pre-existing comment is deleted" $+    it "actually deletes it" $ \path ->+      property $ \txt -> do+        comment <- createArchive path $ do+          setArchiveComment txt+          commit+          deleteArchiveComment+          commit+          getArchiveComment+        comment `shouldBe` Nothing++getEntryDescSpec :: SpecWith FilePath+getEntryDescSpec =+  it "always returns correct description" $ \path ->+    property $ \(EM s desc z) -> do+      desc' <- fromJust <$> createArchive path (z >> commit >> getEntryDesc s)+      desc' `shouldSatisfy` softEq desc++versionNeededSpec :: SpecWith FilePath+versionNeededSpec =+  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+    property $ \(EM s desc z) -> do+      desc' <- fromJust <$> createArchive path (z >> commit >> getEntryDesc s)+      let minVersionZip64 =+            makeVersion $+              if edUncompressedSize desc' >= ffffffff+                || edCompressedSize desc' >= ffffffff+                then [4, 5]+                else [2, 0]+          minVersionCompression = makeVersion $ case edCompression desc of+            Store -> [2, 0]+            Deflate -> [2, 0]+            BZip2 -> [4, 6]+            Zstd -> [6, 3]+          versionNeeded = max minVersionZip64 minVersionCompression+      edVersionNeeded desc' `shouldBe` versionNeeded++addEntrySpec :: SpecWith FilePath+addEntrySpec =+  context "when an entry is added" $ do+    it "is there" $ \path ->+      property $ \m b s -> do+        info <- createArchive path $ do+          addEntry m b s+          commit+          checkEntry' s+          (,) <$> getEntry s <*> (edCompression . (! s) <$> getEntries)+        info `shouldBe` (b, m)+    it "does not add unnecessary zip64 extra fields" $ \path -> do+      property $ \b s ->+        fromIntegral (B.length b) < ffffffff ==> do+          createArchive path (addEntry Store b s)+          bytes <- B.drop (30 + rawSelectorLength s) <$> B.readFile path+          bytes `shouldSatisfy` B.isPrefixOf b++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+          checkEntry' s+          (,)+            <$> 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+          checkEntry' s+          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 from another archive" $ do+    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+          checkEntry' s+          (,) <$> getEntry s <*> (edCompression . (! s) <$> getEntries)+        info `shouldBe` (b, m)+    it "does not add unnecessary zip64 extra fields" $ \path -> do+      property $ \b s ->+        fromIntegral (B.length b) < ffffffff ==> do+          let vpath = deriveVacant path+          createArchive vpath $ addEntry Store b s+          createArchive path $ copyEntry vpath s s+          bytes <- B.drop (30 + rawSelectorLength s) <$> B.readFile path+          bytes `shouldSatisfy` B.isPrefixOf b++checkEntrySpec :: SpecWith FilePath+checkEntrySpec = do+  context "for entries added via addEntry" $ do+    context "when entry is intact" $+      it "passes the check" $ \path ->+        property $ \m b s ->+          asIO . createArchive path $ do+            addEntry m b s+            commit+            checkEntry' s+    context "when entry is corrupted" $+      it "does not pass the check" $ \path ->+        property $ \b s ->+          not (B.null b) ==> do+            let zip64Length =+                  if fromIntegral (B.length b) >= ffffffff+                    then 20+                    else 0+                headerLength = 30 + rawSelectorLength s + zip64Length+            localFileHeaderOffset <- createArchive path $ do+              addEntry Store b s+              commit+              fromIntegral . edOffset . (! s) <$> getEntries+            withFile path ReadWriteMode $ \h -> do+              hSeek+                h+                AbsoluteSeek+                (localFileHeaderOffset + fromIntegral headerLength)+              byte <- B.map complement <$> B.hGet h 1+              hSeek h RelativeSeek (-1)+              B.hPut h byte+            withArchive path (checkEntry s) `shouldReturn` False+  context "for entries added via sinkEntry" $ do+    context "when entry is intact" $+      it "passes the check" $ \path ->+        property $ \m b s ->+          asIO . createArchive path $ do+            sinkEntry m (C.yield b) s+            commit+            checkEntry' s+    context "when entry is corrupted" $+      it "does not pass the check" $ \path ->+        property $ \b s ->+          not (B.null b) ==> do+            let headerLength = 50 + rawSelectorLength s+            localFileHeaderOffset <- createArchive path $ do+              sinkEntry Store (C.yield b) s+              commit+              fromIntegral . edOffset . (! s) <$> getEntries+            withFile path ReadWriteMode $ \h -> do+              hSeek+                h+                AbsoluteSeek+                (localFileHeaderOffset + fromIntegral headerLength)+              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+          checkEntry' s+          recompress m' s+          commit+          checkEntry' s+          (,) <$> 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+  context "when comment is committed (set/delete)" $+    it "reads it and updates" $ \path ->+      property $ \txt s -> do+        comment <- createArchive path $ do+          addEntry Store "foo" s+          setEntryComment txt s+          deleteEntryComment s+          commit+          edComment . (! s) <$> getEntries+        comment `shouldBe` Nothing+  context "when pre-existing comment is overwritten" $+    it "returns the new comment" $ \path ->+      property $ \txt txt' s -> do+        comment <- createArchive path $ do+          addEntry Store "foo" s+          setEntryComment txt s+          commit+          setEntryComment txt' s+          commit+          edComment . (! s) <$> getEntries+        comment `shouldBe` Just txt'+  context "when pre-existing comment is deleted" $+    it "actually deletes it" $ \path ->+      property $ \txt s -> do+        comment <- createArchive path $ do+          addEntry Store "foo" s+          setEntryComment txt s+          commit+          deleteEntryComment s+          commit+          edComment . (! s) <$> getEntries+        comment `shouldBe` Nothing++setModTimeSpec :: SpecWith 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+          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+  context "when extra field is committed (set/delete)" $+    it "reads it and updates" $ \path ->+      property $ \n b s ->+        n /= 1 ==> do+          efield <- createArchive path $ do+            addEntry Store "foo" s+            addExtraField n b s+            deleteExtraField n s+            commit+            M.lookup n . edExtraField . (! s) <$> getEntries+          efield `shouldBe` Nothing+  context "when pre-existing extra field is overwritten" $+    it "reads it and updates" $ \path ->+      property $ \n b b' s ->+        n /= 1 ==> do+          efield <- createArchive path $ do+            addEntry Store "foo" s+            addExtraField n b s+            commit+            addExtraField n b' s+            commit+            M.lookup n . edExtraField . (! s) <$> getEntries+          efield `shouldBe` Just b'+  context "when pre-existing extra field is deleted" $+    it "actually deletes it" $ \path ->+      property $ \n b s ->+        n /= 1 ==> do+          efield <- createArchive path $ do+            addEntry Store "foo" s+            addExtraField n b s+            commit+            deleteExtraField n s+            commit+            M.lookup n . edExtraField . (! s) <$> getEntries+          efield `shouldBe` Nothing++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++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+  context "when renaming existing entry" $+    it "gets renamed" $ \path ->+      property $ \(EM s desc z) s' -> do+        desc' <- createArchive path $ do+          z+          commit+          renameEntry s s'+          commit+          (! s') <$> getEntries+        desc' `shouldSatisfy` softEq desc++deleteEntrySpec :: SpecWith 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+  context "when deleting existing entry" $+    it "gets deleted" $ \path ->+      property $ \(EM s _ z) -> do+        member <- createArchive path $ do+          z+          commit+          deleteEntry s+          commit+          doesEntryExist s+        member `shouldBe` False++forEntriesSpec :: SpecWith FilePath+forEntriesSpec =+  it "affects all existing entries" $ \path -> property $ \(EC m z) txt -> do+    m' <- createArchive path $ do+      z+      commit+      forEntries (setEntryComment txt)+      commit+      getEntries+    let f ed = ed {edComment = Just txt}+    m' `shouldSatisfy` softEqMap (M.map f m)++undoEntryChangesSpec :: SpecWith FilePath+undoEntryChangesSpec =+  it "cancels all actions for specified entry" $+    \path -> property $ \(EM s _ z) -> do+      member <- createArchive path $ do+        z+        undoEntryChanges s+        commit+        doesEntryExist s+      member `shouldBe` False++undoArchiveChangesSpec :: SpecWith FilePath+undoArchiveChangesSpec = do+  it "cancels archive comment editing" $ \path -> property $ \txt -> do+    comment <- createArchive path $ do+      setArchiveComment txt+      undoArchiveChanges+      commit+      getArchiveComment+    comment `shouldBe` Nothing+  it "cancels archive comment deletion" $ \path -> property $ \txt -> do+    comment <- createArchive path $ do+      setArchiveComment txt+      commit+      deleteArchiveComment+      undoArchiveChanges+      commit+      getArchiveComment+    comment `shouldBe` Just txt++undoAllSpec :: SpecWith FilePath+undoAllSpec =+  it "cancels all editing at once" $ \path -> property $ \(EC _ z) txt -> do+    createArchive path (return ())+    withArchive path $ do+      z+      setArchiveComment txt+      undoAll+      liftIO (B.writeFile path B.empty)+    B.readFile path `shouldReturn` B.empty++----------------------------------------------------------------------------+-- Complex construction/restoration++consistencySpec :: SpecWith FilePath+consistencySpec =+  it "can save and restore arbitrary archive" $ \path ->+    property $ \(EC m z) txt -> do+      (txt', m') <- createArchive path $ do+        z+        setArchiveComment txt+        commit+        (,) <$> getArchiveComment <*> getEntries+      txt' `shouldBe` Just txt+      m' `shouldSatisfy` softEqMap m++packDirRecur'Spec :: SpecWith FilePath+packDirRecur'Spec =+  it "packs arbitrary directory recursively" $ \path ->+    property $+      forAll (downScale arbitrary) $ \contents ->+        withSystemTempDirectory "zip-sandbox" $ \dir -> do+          forM_ contents $ \s -> do+            let item = dir </> unEntrySelector s+            createDirectoryIfMissing True (FP.takeDirectory item)+            B.writeFile item "foo"+          let magicFileAttrs = 123456789+          entries <-+            createArchive path $ do+              packDirRecur'+                Store+                mkEntrySelector+                (setExternalFileAttrs magicFileAttrs)+                dir+              commit+              getEntries+          M.keysSet entries `shouldBe` E.fromList contents+          forM_ (M.elems entries) $ \desc ->+            edExternalFileAttrs desc `shouldBe` magicFileAttrs++unpackIntoSpec :: SpecWith FilePath+unpackIntoSpec =+  it "unpacks archive contents into directory" $ \path ->+    property $ \(EC m z) ->+      withSystemTempDirectory "zip-sandbox" $ \dir -> do+        createArchive path $ do+          z+          commit+          unpackInto dir+        selectors <- listDirRecur dir >>= mapM mkEntrySelector+        let x = E.fromList selectors+            y = M.keysSet m+        E.difference x y `shouldBe` E.empty++----------------------------------------------------------------------------+-- Helpers++-- | Change the size parameter of a generator by dividing it by 2.+downScale :: Gen a -> Gen a+downScale = scale (`div` 2)++-- | Check whether a given exception is 'EntrySelectorException' with a+-- specific path inside.+isEntrySelectorException :: FilePath -> EntrySelectorException -> Bool+isEntrySelectorException path (InvalidEntrySelector p) = p == path++-- | Check whether a given exception is 'ParsingFailed' exception with a+-- specific path and error message inside.+isParsingFailed :: FilePath -> String -> ZipException -> Bool+isParsingFailed path msg (ParsingFailed path' msg') =+  path == path' && msg == msg'+isParsingFailed _ _ _ = False++-- | Create a sandbox directory to model some situation in it and run some+-- tests. Note that we're using a new unique sandbox directory for each test+-- case to avoid contamination and it's unconditionally deleted after the+-- test case finishes. The function returns a vacant file path in that+-- directory.+withSandbox :: ActionWith FilePath -> IO ()+withSandbox action = withSystemTempDirectory "zip-sandbox" $ \dir ->+  action (dir </> "foo.zip")++-- | Like 'checkEntry' but automatically aborts the test if the check fails.+checkEntry' :: EntrySelector -> ZipArchive ()+checkEntry' s = do+  r <- checkEntry s+  liftIO (if r then return () else fail "Entry integrity check failed!")++-- | Given a primary name (name of archive), generate a name that does not+-- collide with it.+deriveVacant :: FilePath -> FilePath+deriveVacant = (</> "bar") . FP.takeDirectory++-- | Compare times forgiving a minor difference.+isCloseTo :: UTCTime -> UTCTime -> Bool+isCloseTo a b = abs (diffUTCTime a b) < 2++-- | Compare for equality taking into account only some fields of the+-- 'EntryDescription' record.+softEq :: EntryDescription -> EntryDescription -> Bool+softEq a b =+  edCompression a == edCompression b+    && isCloseTo (edModTime a) (edModTime b)+    && edUncompressedSize a == edUncompressedSize b+    && edComment a == edComment b+    && M.delete 1 (edExtraField a) == M.delete 1 (edExtraField b)++-- | Compare two maps describing archive entries in such a way that only+-- some fields in 'EntryDescription' record are tested.+softEqMap ::+  Map EntrySelector EntryDescription ->+  Map EntrySelector EntryDescription ->+  Bool+softEqMap n m = M.null (M.differenceWith f n m)+  where+    f a b = if softEq a b then Nothing else Just a++-- | The canonical representation of an 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+    ]++-- | Recursively list a directory. Do not return paths to empty directories.+listDirRecur :: FilePath -> IO [FilePath]+listDirRecur path = DList.toList <$> go ""+  where+    go adir = do+      let cdir = path </> adir+      raw <- listDirectory cdir+      fmap mconcat . forM raw $ \case+        "" -> return mempty+        "." -> return mempty+        ".." -> return mempty+        x -> do+          let fullx = cdir </> x+              adir' = adir </> x+          isFile <- doesFileExist fullx+          isDir <- doesDirectoryExist fullx+          if isFile+            then return (DList.singleton adir')+            else+              if isDir+                then go adir'+                else return mempty++-- | Constrain the type of the argument monad to 'IO'.+asIO :: IO a -> IO a+asIO = id++-- | Get the length in bytes of an encoded 'EntrySelector'.+rawSelectorLength :: EntrySelector -> Int+rawSelectorLength = B.length . T.encodeUtf8 . getEntryName

@@ -1,83 +1,150 @@-name:                 zip-version:              0.1.11-cabal-version:        >= 1.10-tested-with:          GHC==7.10.3, GHC==8.0.2, GHC==8.2.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:   2.4+name:            zip+version:         2.2.2+license:         BSD-3-Clause+license-file:    LICENSE.md+maintainer:      Mark Karpov <markkarpov92@gmail.com>+author:          Mark Karpov <markkarpov92@gmail.com>+tested-with:     ghc ==9.10.3 ghc ==9.12.4 ghc ==9.14.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++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.8     && < 5.0-                    , bytestring       >= 0.9     && < 0.11-                    , bzlib-conduit    >= 0.2     && < 0.3-                    , case-insensitive >= 1.2.0.2 && < 1.3-                    , cereal           >= 0.3     && < 0.6-                    , conduit          >= 1.1     && < 2.0-                    , conduit-extra    >= 1.1     && < 2.0-                    , containers       >= 0.5.6.2 && < 0.6-                    , digest           < 0.1-                    , exceptions       >= 0.6     && < 0.9-                    , filepath         >= 1.2     && < 1.5-                    , mtl              >= 2.0     && < 3.0-                    , path             >= 0.5     && < 0.6-                    , path-io          >= 1.0.1   && < 2.0-                    , plan-b           >= 0.2     && < 0.3-                    , resourcet        >= 1.0     && < 2.0-                    , text             >= 0.2     && < 1.3-                    , time             >= 1.4     && < 1.9-                    , transformers     >= 0.4     && < 0.6-  if !impl(ghc >= 8.0)-    build-depends:    semigroups       >= 0.16-  default-extensions: RecordWildCards-                    , TupleSections-  exposed-modules:    Codec.Archive.Zip-                    , Codec.Archive.Zip.CP437-                    , Codec.Archive.Zip.Type-  other-modules:      Codec.Archive.Zip.Internal-  if flag(dev)-    ghc-options:      -Wall -Werror-  else-    ghc-options:      -O2 -Wall-  default-language:   Haskell2010+    exposed-modules:+        Codec.Archive.Zip+        Codec.Archive.Zip.CP437+        Codec.Archive.Zip.Unix+        Codec.Archive.Zip.Internal+        Codec.Archive.Zip.Internal.Type +    default-language: GHC2021+    build-depends:+        base >=4.15 && <5,+        bytestring >=0.9 && <0.13,+        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.9,+        digest <0.1,+        directory >=1.2.2 && <1.4,+        dlist >=0.8 && <2.0,+        exceptions >=0.6 && <0.11,+        filepath >=1.2 && <1.6,+        monad-control >=1.0 && <1.1,+        mtl >=2 && <3,+        resourcet >=1.2 && <1.4,+        text >=0.2 && <2.2,+        time >=1.4 && <1.16,+        transformers >=0.4 && <0.7,+        transformers-base++    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:+            -Wall -Werror -Wredundant-constraints -Wpartial-fields+            -Wunused-packages++    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+        build-depends: unix <2.9++executable haskell-zip-app+    main-is:          Main.hs+    hs-source-dirs:   bench-app+    default-language: GHC2021+    build-depends:+        base >=4.15 && <5,+        filepath >=1.2 && <1.6,+        zip++    if flag(dev)+        ghc-options:+            -Wall -Werror -Wredundant-constraints -Wpartial-fields+            -Wunused-packages++    else+        ghc-options: -O2 -Wall+ test-suite tests-  main-is:            Main.hs-  hs-source-dirs:     tests-  type:               exitcode-stdio-1.0-  if flag(dev)-    ghc-options:      -Wall -Werror-  else-    ghc-options:      -O2 -Wall-  build-depends:      base             >= 4.8     && < 5.0-                    , bytestring       >= 0.9     && < 0.11-                    , conduit          >= 1.1     && < 2.0-                    , containers       >= 0.5.6.2 && < 0.6-                    , exceptions       >= 0.6     && < 0.9-                    , filepath         >= 1.2     && < 1.5-                    , QuickCheck       >= 2.4     && < 3.0-                    , hspec            >= 2.0     && < 3.0-                    , path             >= 0.5     && < 6.0-                    , path-io          >= 1.0.1   && < 2.0-                    , text             >= 0.2     && < 1.3-                    , time             >= 1.4     && < 1.9-                    , transformers     >= 0.4     && < 0.6-                    , zip-  default-language:   Haskell2010+    type:             exitcode-stdio-1.0+    main-is:          Main.hs+    hs-source-dirs:   tests+    default-language: GHC2021+    build-depends:+        base >=4.15 && <5,+        QuickCheck >=2.4 && <3,+        bytestring >=0.9 && <0.13,+        conduit >=1.3 && <1.4,+        containers >=0.5 && <0.9,+        directory >=1.2.2 && <1.4,+        dlist >=0.8 && <2,+        filepath >=1.2 && <1.6,+        hspec >=2 && <3,+        temporary >=1.1 && <1.4,+        text >=0.2 && <2.2,+        time >=1.4 && <1.16,+        zip -source-repository head-  type:               git-  location:           https://github.com/mrkkrp/zip.git+    if flag(dev)+        cpp-options: -DHASKELL_ZIP_DEV_MODE+        ghc-options:+            -Wall -Werror -Wredundant-constraints -Wpartial-fields+            -Wunused-packages++    else+        ghc-options: -O2 -Wall++    if !flag(disable-bzip2)+        cpp-options: -DENABLE_BZIP2++    if !flag(disable-zstd)+        cpp-options: -DENABLE_ZSTD