{-# 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
  ( PendingAction (..),
    targetEntry,
    scanArchive,
    sourceEntry,
    crc32Sink,
    commit,
  )
where

import Codec.Archive.Zip.CP437 (decodeCP437)
import Codec.Archive.Zip.Type
import Conduit (PrimMonad)
import Control.Applicative (many, (<|>))
import Control.Exception (bracketOnError, catchJust)
import Control.Monad
import Control.Monad.Catch (MonadThrow (..))
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Resource (MonadResource, ResourceT)
import Data.Bits
import Data.Bool (bool)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.Char (ord)
import Data.Conduit (ConduitT, ZipSink (..), (.|))
import qualified Data.Conduit as C
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Zlib as Z
import Data.Digest.CRC32 (crc32Update)
import Data.Fixed (Fixed (..))
import Data.Foldable (foldl')
import Data.Map.Strict (Map, (!))
import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes, fromJust, isNothing)
import Data.Sequence (Seq, (><), (|>))
import qualified Data.Sequence as S
import Data.Serialize
import qualified Data.Set as E
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time
import Data.Version
import Data.Void
import Data.Word (Word16, Word32)
import Numeric.Natural (Natural)
import System.Directory
import System.FilePath
import System.IO
import System.IO.Error (isDoesNotExistError)

#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

----------------------------------------------------------------------------
-- 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
  | -- | Copy an entry form 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
  { ProducingActions -> Map FilePath (Map EntrySelector EntrySelector)
paCopyEntry :: Map FilePath (Map EntrySelector EntrySelector),
    ProducingActions
-> Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
paSinkEntry :: Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
  }

-- | A collection of editing actions, that is, actions that modify already
-- existing entries.
data EditingActions = EditingActions
  { EditingActions -> Map EntrySelector CompressionMethod
eaCompression :: Map EntrySelector CompressionMethod,
    EditingActions -> Map EntrySelector Text
eaEntryComment :: Map EntrySelector Text,
    EditingActions -> Map EntrySelector ()
eaDeleteComment :: Map EntrySelector (),
    EditingActions -> Map EntrySelector UTCTime
eaModTime :: Map EntrySelector UTCTime,
    EditingActions -> Map EntrySelector (Map Word16 ByteString)
eaExtraField :: Map EntrySelector (Map Word16 ByteString),
    EditingActions -> Map EntrySelector (Map Word16 ())
eaDeleteField :: Map EntrySelector (Map Word16 ()),
    EditingActions -> Map EntrySelector Word32
eaExtFileAttr :: Map EntrySelector Word32
  }

-- | The origin of entries that can be streamed into archive.
data EntryOrigin
  = GenericOrigin
  | Borrowed EntryDescription

-- | The type of the file header: local or central directory.
data HeaderType
  = LocalHeader
  | CentralDirHeader
  deriving (HeaderType -> HeaderType -> Bool
(HeaderType -> HeaderType -> Bool)
-> (HeaderType -> HeaderType -> Bool) -> Eq HeaderType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HeaderType -> HeaderType -> Bool
$c/= :: HeaderType -> HeaderType -> Bool
== :: HeaderType -> HeaderType -> Bool
$c== :: HeaderType -> HeaderType -> Bool
Eq)

-- | The data descriptor representation.
data DataDescriptor = DataDescriptor
  { DataDescriptor -> Word32
ddCRC32 :: Word32,
    DataDescriptor -> Natural
ddCompressedSize :: Natural,
    DataDescriptor -> Natural
ddUncompressedSize :: Natural
  }

-- | A temporary data structure to hold Zip64 extra data field information.
data Zip64ExtraField = Zip64ExtraField
  { Zip64ExtraField -> Natural
z64efUncompressedSize :: Natural,
    Zip64ExtraField -> Natural
z64efCompressedSize :: Natural,
    Zip64ExtraField -> 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
  { MsDosTime -> Word16
msDosDate :: Word16,
    MsDosTime -> Word16
msDosTime :: Word16
  }

----------------------------------------------------------------------------
-- Constants

-- | “Version created by” to specify when writing archive data.
zipVersion :: Version
zipVersion :: Version
zipVersion = [Int] -> [FilePath] -> Version
Version [Int
6, Int
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 :: FilePath
-> IO (ArchiveDescription, Map EntrySelector EntryDescription)
scanArchive FilePath
path = FilePath
-> IOMode
-> (Handle
    -> IO (ArchiveDescription, Map EntrySelector EntryDescription))
-> IO (ArchiveDescription, Map EntrySelector EntryDescription)
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
path IOMode
ReadMode ((Handle
  -> IO (ArchiveDescription, Map EntrySelector EntryDescription))
 -> IO (ArchiveDescription, Map EntrySelector EntryDescription))
-> (Handle
    -> IO (ArchiveDescription, Map EntrySelector EntryDescription))
-> IO (ArchiveDescription, Map EntrySelector EntryDescription)
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
  Maybe Integer
mecdOffset <- FilePath -> Handle -> IO (Maybe Integer)
locateECD FilePath
path Handle
h
  case Maybe Integer
mecdOffset of
    Just Integer
ecdOffset -> do
      Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek Integer
ecdOffset
      Integer
ecdSize <- Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
subtract Integer
ecdOffset (Integer -> Integer) -> IO Integer -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Integer
hFileSize Handle
h
      ByteString
ecdRaw <- Handle -> Int -> IO ByteString
B.hGet Handle
h (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
ecdSize)
      case Get ArchiveDescription
-> ByteString -> Either FilePath ArchiveDescription
forall a. Get a -> ByteString -> Either FilePath a
runGet Get ArchiveDescription
getECD ByteString
ecdRaw of
        Left FilePath
msg -> ZipException
-> IO (ArchiveDescription, Map EntrySelector EntryDescription)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (FilePath -> FilePath -> ZipException
ParsingFailed FilePath
path FilePath
msg)
        Right ArchiveDescription
ecd -> do
          Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek (Integer -> IO ()) -> Integer -> IO ()
forall a b. (a -> b) -> a -> b
$ Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ArchiveDescription -> Natural
adCDOffset ArchiveDescription
ecd)
          ByteString
cdRaw <- Handle -> Int -> IO ByteString
B.hGet Handle
h (Int -> IO ByteString) -> Int -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ArchiveDescription -> Natural
adCDSize ArchiveDescription
ecd)
          case Get (Map EntrySelector EntryDescription)
-> ByteString
-> Either FilePath (Map EntrySelector EntryDescription)
forall a. Get a -> ByteString -> Either FilePath a
runGet Get (Map EntrySelector EntryDescription)
getCD ByteString
cdRaw of
            Left FilePath
msg -> ZipException
-> IO (ArchiveDescription, Map EntrySelector EntryDescription)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (FilePath -> FilePath -> ZipException
ParsingFailed FilePath
path FilePath
msg)
            Right Map EntrySelector EntryDescription
cd -> (ArchiveDescription, Map EntrySelector EntryDescription)
-> IO (ArchiveDescription, Map EntrySelector EntryDescription)
forall (m :: * -> *) a. Monad m => a -> m a
return (ArchiveDescription
ecd, Map EntrySelector EntryDescription
cd)
    Maybe Integer
Nothing ->
      ZipException
-> IO (ArchiveDescription, Map EntrySelector EntryDescription)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (FilePath -> FilePath -> ZipException
ParsingFailed FilePath
path FilePath
"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 :: FilePath -> EntryDescription -> Bool -> ConduitT () ByteString m ()
sourceEntry FilePath
path EntryDescription {Natural
Maybe Text
Word32
Version
Map Word16 ByteString
UTCTime
CompressionMethod
edExternalFileAttrs :: EntryDescription -> Word32
edExtraField :: EntryDescription -> Map Word16 ByteString
edComment :: EntryDescription -> Maybe Text
edOffset :: EntryDescription -> Natural
edUncompressedSize :: EntryDescription -> Natural
edCompressedSize :: EntryDescription -> Natural
edCRC32 :: EntryDescription -> Word32
edModTime :: EntryDescription -> UTCTime
edCompression :: EntryDescription -> CompressionMethod
edVersionNeeded :: EntryDescription -> Version
edVersionMadeBy :: EntryDescription -> Version
edExternalFileAttrs :: Word32
edExtraField :: Map Word16 ByteString
edComment :: Maybe Text
edOffset :: Natural
edUncompressedSize :: Natural
edCompressedSize :: Natural
edCRC32 :: Word32
edModTime :: UTCTime
edCompression :: CompressionMethod
edVersionNeeded :: Version
edVersionMadeBy :: Version
..} Bool
d =
  ConduitT () ByteString m ()
forall i. ConduitT i ByteString m ()
source ConduitT () ByteString m ()
-> ConduitM ByteString ByteString m ()
-> ConduitT () ByteString m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Int -> ConduitM ByteString ByteString m ()
forall (m :: * -> *).
Monad m =>
Int -> ConduitT ByteString ByteString m ()
CB.isolate (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
edCompressedSize) ConduitM ByteString ByteString m ()
-> ConduitM ByteString ByteString m ()
-> ConduitM ByteString ByteString m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ByteString ByteString m ()
decompress
  where
    source :: ConduitT i ByteString m ()
source = IO Handle -> ConduitT i ByteString m ()
forall (m :: * -> *) i.
MonadResource m =>
IO Handle -> ConduitT i ByteString m ()
CB.sourceIOHandle (IO Handle -> ConduitT i ByteString m ())
-> IO Handle -> ConduitT i ByteString m ()
forall a b. (a -> b) -> a -> b
$ do
      Handle
h <- FilePath -> IOMode -> IO Handle
openFile FilePath
path IOMode
ReadMode
      Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek (Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
edOffset)
      ByteString
localHeader <- Handle -> Int -> IO ByteString
B.hGet Handle
h Int
30
      case Get Integer -> ByteString -> Either FilePath Integer
forall a. Get a -> ByteString -> Either FilePath a
runGet Get Integer
getLocalHeaderGap ByteString
localHeader of
        Left FilePath
msg -> ZipException -> IO Handle
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (FilePath -> FilePath -> ZipException
ParsingFailed FilePath
path FilePath
msg)
        Right Integer
gap -> do
          Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
RelativeSeek Integer
gap
          Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
h
    decompress :: ConduitM ByteString ByteString m ()
decompress =
      if Bool
d
        then CompressionMethod -> ConduitM ByteString ByteString m ()
forall (m :: * -> *).
(PrimMonad m, MonadThrow m, MonadResource m) =>
CompressionMethod -> ConduitT ByteString ByteString m ()
decompressingPipe CompressionMethod
edCompression
        else (ByteString -> ConduitM ByteString ByteString m ())
-> ConduitM ByteString ByteString m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
C.awaitForever ByteString -> ConduitM ByteString ByteString m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
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 entires
  Map EntrySelector EntryDescription ->
  -- | Collection of pending actions
  Seq PendingAction ->
  IO ()
commit :: FilePath
-> ArchiveDescription
-> Map EntrySelector EntryDescription
-> Seq PendingAction
-> IO ()
commit FilePath
path ArchiveDescription {Natural
Maybe Text
adComment :: ArchiveDescription -> Maybe Text
adCDSize :: Natural
adCDOffset :: Natural
adComment :: Maybe Text
adCDSize :: ArchiveDescription -> Natural
adCDOffset :: ArchiveDescription -> Natural
..} Map EntrySelector EntryDescription
entries Seq PendingAction
xs =
  FilePath -> (Handle -> IO ()) -> IO ()
withNewFile FilePath
path ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    let (ProducingActions Map FilePath (Map EntrySelector EntrySelector)
coping Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
sinking, EditingActions
editing) =
          Seq PendingAction -> (ProducingActions, EditingActions)
optimize (FilePath -> Map EntrySelector EntryDescription -> Seq PendingAction
toRecreatingActions FilePath
path Map EntrySelector EntryDescription
entries Seq PendingAction -> Seq PendingAction -> Seq PendingAction
forall a. Seq a -> Seq a -> Seq a
>< Seq PendingAction
xs)
        comment :: Maybe Text
comment = Maybe Text -> Seq PendingAction -> Maybe Text
predictComment Maybe Text
adComment Seq PendingAction
xs
    Map EntrySelector EntryDescription
copiedCD <-
      [Map EntrySelector EntryDescription]
-> Map EntrySelector EntryDescription
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions
        ([Map EntrySelector EntryDescription]
 -> Map EntrySelector EntryDescription)
-> IO [Map EntrySelector EntryDescription]
-> IO (Map EntrySelector EntryDescription)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
-> (FilePath -> IO (Map EntrySelector EntryDescription))
-> IO [Map EntrySelector EntryDescription]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM
          (Map FilePath (Map EntrySelector EntrySelector) -> [FilePath]
forall k a. Map k a -> [k]
M.keys Map FilePath (Map EntrySelector EntrySelector)
coping)
          ( \FilePath
srcPath ->
              Handle
-> FilePath
-> Map EntrySelector EntrySelector
-> EditingActions
-> IO (Map EntrySelector EntryDescription)
copyEntries Handle
h FilePath
srcPath (Map FilePath (Map EntrySelector EntrySelector)
coping Map FilePath (Map EntrySelector EntrySelector)
-> FilePath -> Map EntrySelector EntrySelector
forall k a. Ord k => Map k a -> k -> a
! FilePath
srcPath) EditingActions
editing
          )
    let sinkingKeys :: [EntrySelector]
sinkingKeys = Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
-> [EntrySelector]
forall k a. Map k a -> [k]
M.keys (Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
 -> [EntrySelector])
-> Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
-> [EntrySelector]
forall a b. (a -> b) -> a -> b
$ Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
sinking Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
-> Map EntrySelector EntryDescription
-> Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`M.difference` Map EntrySelector EntryDescription
copiedCD
    Map EntrySelector EntryDescription
sunkCD <-
      [(EntrySelector, EntryDescription)]
-> Map EntrySelector EntryDescription
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
        ([(EntrySelector, EntryDescription)]
 -> Map EntrySelector EntryDescription)
-> IO [(EntrySelector, EntryDescription)]
-> IO (Map EntrySelector EntryDescription)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [EntrySelector]
-> (EntrySelector -> IO (EntrySelector, EntryDescription))
-> IO [(EntrySelector, EntryDescription)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM
          [EntrySelector]
sinkingKeys
          ( \EntrySelector
selector ->
              Handle
-> EntrySelector
-> EntryOrigin
-> ConduitT () ByteString (ResourceT IO) ()
-> EditingActions
-> IO (EntrySelector, EntryDescription)
sinkEntry Handle
h EntrySelector
selector EntryOrigin
GenericOrigin (Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
sinking Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
-> EntrySelector -> ConduitT () ByteString (ResourceT IO) ()
forall k a. Ord k => Map k a -> k -> a
! EntrySelector
selector) EditingActions
editing
          )
    Handle -> Maybe Text -> Map EntrySelector EntryDescription -> IO ()
writeCD Handle
h Maybe Text
comment (Map EntrySelector EntryDescription
copiedCD Map EntrySelector EntryDescription
-> Map EntrySelector EntryDescription
-> Map EntrySelector EntryDescription
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map EntrySelector EntryDescription
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 :: FilePath -> (Handle -> IO ()) -> IO ()
withNewFile FilePath
fpath Handle -> IO ()
action =
  IO (FilePath, Handle)
-> ((FilePath, Handle) -> IO ())
-> ((FilePath, Handle) -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError IO (FilePath, Handle)
allocate (FilePath, Handle) -> IO ()
release (((FilePath, Handle) -> IO ()) -> IO ())
-> ((FilePath, Handle) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(FilePath
path, Handle
h) -> do
    Handle -> IO ()
action Handle
h
    Handle -> IO ()
hClose Handle
h
    FilePath -> FilePath -> IO ()
renameFile FilePath
path FilePath
fpath
  where
    allocate :: IO (FilePath, Handle)
allocate = FilePath -> FilePath -> IO (FilePath, Handle)
openBinaryTempFile (FilePath -> FilePath
takeDirectory FilePath
fpath) FilePath
".zip"
    release :: (FilePath, Handle) -> IO ()
release (FilePath
path, Handle
h) = do
      Handle -> IO ()
hClose Handle
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`.
      (IOError -> Maybe ()) -> IO () -> (() -> IO ()) -> IO ()
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError) (FilePath -> IO ()
removeFile FilePath
path) (IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
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 :: Maybe Text -> Seq PendingAction -> Maybe Text
predictComment Maybe Text
original Seq PendingAction
xs =
  case Seq PendingAction -> Int -> PendingAction
forall a. Seq a -> Int -> a
S.index Seq PendingAction
xs (Int -> PendingAction) -> Maybe Int -> Maybe PendingAction
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PendingAction -> Bool) -> Seq PendingAction -> Maybe Int
forall a. (a -> Bool) -> Seq a -> Maybe Int
S.findIndexR (Maybe EntrySelector -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe EntrySelector -> Bool)
-> (PendingAction -> Maybe EntrySelector) -> PendingAction -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PendingAction -> Maybe EntrySelector
targetEntry) Seq PendingAction
xs of
    Maybe PendingAction
Nothing -> Maybe Text
original
    Just PendingAction
DeleteArchiveComment -> Maybe Text
forall a. Maybe a
Nothing
    Just (SetArchiveComment Text
txt) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
txt
    Just PendingAction
_ -> Maybe Text
forall a. Maybe a
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 :: FilePath -> Map EntrySelector EntryDescription -> Seq PendingAction
toRecreatingActions FilePath
path Map EntrySelector EntryDescription
entries = (Seq PendingAction -> EntrySelector -> Seq PendingAction)
-> Seq PendingAction -> Set EntrySelector -> Seq PendingAction
forall a b. (a -> b -> a) -> a -> Set b -> a
E.foldl' Seq PendingAction -> EntrySelector -> Seq PendingAction
f Seq PendingAction
forall a. Seq a
S.empty (Map EntrySelector EntryDescription -> Set EntrySelector
forall k a. Map k a -> Set k
M.keysSet Map EntrySelector EntryDescription
entries)
  where
    f :: Seq PendingAction -> EntrySelector -> Seq PendingAction
f Seq PendingAction
s EntrySelector
e = Seq PendingAction
s Seq PendingAction -> PendingAction -> Seq PendingAction
forall a. Seq a -> a -> Seq a
|> FilePath -> EntrySelector -> EntrySelector -> PendingAction
CopyEntry FilePath
path EntrySelector
e EntrySelector
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 :: Seq PendingAction -> (ProducingActions, EditingActions)
optimize =
  ((ProducingActions, EditingActions)
 -> PendingAction -> (ProducingActions, EditingActions))
-> (ProducingActions, EditingActions)
-> Seq PendingAction
-> (ProducingActions, EditingActions)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
    (ProducingActions, EditingActions)
-> PendingAction -> (ProducingActions, EditingActions)
f
    ( Map FilePath (Map EntrySelector EntrySelector)
-> Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
-> ProducingActions
ProducingActions Map FilePath (Map EntrySelector EntrySelector)
forall k a. Map k a
M.empty Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
forall k a. Map k a
M.empty,
      Map EntrySelector CompressionMethod
-> Map EntrySelector Text
-> Map EntrySelector ()
-> Map EntrySelector UTCTime
-> Map EntrySelector (Map Word16 ByteString)
-> Map EntrySelector (Map Word16 ())
-> Map EntrySelector Word32
-> EditingActions
EditingActions Map EntrySelector CompressionMethod
forall k a. Map k a
M.empty Map EntrySelector Text
forall k a. Map k a
M.empty Map EntrySelector ()
forall k a. Map k a
M.empty Map EntrySelector UTCTime
forall k a. Map k a
M.empty Map EntrySelector (Map Word16 ByteString)
forall k a. Map k a
M.empty Map EntrySelector (Map Word16 ())
forall k a. Map k a
M.empty Map EntrySelector Word32
forall k a. Map k a
M.empty
    )
  where
    f :: (ProducingActions, EditingActions)
-> PendingAction -> (ProducingActions, EditingActions)
f (ProducingActions
pa, EditingActions
ea) PendingAction
a = case PendingAction
a of
      SinkEntry CompressionMethod
m ConduitT () ByteString (ResourceT IO) ()
src EntrySelector
s ->
        ( ProducingActions
pa
            { paSinkEntry :: Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
paSinkEntry = EntrySelector
-> ConduitT () ByteString (ResourceT IO) ()
-> Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
-> Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert EntrySelector
s ConduitT () ByteString (ResourceT IO) ()
src (ProducingActions
-> Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
paSinkEntry ProducingActions
pa),
              paCopyEntry :: Map FilePath (Map EntrySelector EntrySelector)
paCopyEntry = (Map EntrySelector EntrySelector
 -> Map EntrySelector EntrySelector)
-> Map FilePath (Map EntrySelector EntrySelector)
-> Map FilePath (Map EntrySelector EntrySelector)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((EntrySelector -> Bool)
-> Map EntrySelector EntrySelector
-> Map EntrySelector EntrySelector
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (EntrySelector -> EntrySelector -> Bool
forall a. Eq a => a -> a -> Bool
/= EntrySelector
s)) (ProducingActions -> Map FilePath (Map EntrySelector EntrySelector)
paCopyEntry ProducingActions
pa)
            },
          (EntrySelector -> EditingActions -> EditingActions
clearEditingFor EntrySelector
s EditingActions
ea)
            { eaCompression :: Map EntrySelector CompressionMethod
eaCompression = EntrySelector
-> CompressionMethod
-> Map EntrySelector CompressionMethod
-> Map EntrySelector CompressionMethod
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert EntrySelector
s CompressionMethod
m (EditingActions -> Map EntrySelector CompressionMethod
eaCompression EditingActions
ea)
            }
        )
      CopyEntry FilePath
path EntrySelector
os EntrySelector
ns ->
        ( ProducingActions
pa
            { paSinkEntry :: Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
paSinkEntry = EntrySelector
-> Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
-> Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
forall k a. Ord k => k -> Map k a -> Map k a
M.delete EntrySelector
ns (ProducingActions
-> Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
paSinkEntry ProducingActions
pa),
              paCopyEntry :: Map FilePath (Map EntrySelector EntrySelector)
paCopyEntry = (Maybe (Map EntrySelector EntrySelector)
 -> Maybe (Map EntrySelector EntrySelector))
-> FilePath
-> Map FilePath (Map EntrySelector EntrySelector)
-> Map FilePath (Map EntrySelector EntrySelector)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (EntrySelector
-> EntrySelector
-> Maybe (Map EntrySelector EntrySelector)
-> Maybe (Map EntrySelector EntrySelector)
forall k a. Ord k => k -> a -> Maybe (Map k a) -> Maybe (Map k a)
ef EntrySelector
os EntrySelector
ns) FilePath
path (ProducingActions -> Map FilePath (Map EntrySelector EntrySelector)
paCopyEntry ProducingActions
pa)
            },
          EntrySelector -> EditingActions -> EditingActions
clearEditingFor EntrySelector
ns EditingActions
ea
        )
      RenameEntry EntrySelector
os EntrySelector
ns ->
        ( ProducingActions
pa
            { paCopyEntry :: Map FilePath (Map EntrySelector EntrySelector)
paCopyEntry = (Map EntrySelector EntrySelector
 -> Map EntrySelector EntrySelector)
-> Map FilePath (Map EntrySelector EntrySelector)
-> Map FilePath (Map EntrySelector EntrySelector)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((EntrySelector -> EntrySelector)
-> Map EntrySelector EntrySelector
-> Map EntrySelector EntrySelector
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((EntrySelector -> EntrySelector)
 -> Map EntrySelector EntrySelector
 -> Map EntrySelector EntrySelector)
-> (EntrySelector -> EntrySelector)
-> Map EntrySelector EntrySelector
-> Map EntrySelector EntrySelector
forall a b. (a -> b) -> a -> b
$ EntrySelector -> EntrySelector -> EntrySelector -> EntrySelector
forall p. Eq p => p -> p -> p -> p
re EntrySelector
os EntrySelector
ns) (ProducingActions -> Map FilePath (Map EntrySelector EntrySelector)
paCopyEntry ProducingActions
pa),
              paSinkEntry :: Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
paSinkEntry = EntrySelector
-> EntrySelector
-> Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
-> Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
forall k a. Ord k => k -> k -> Map k a -> Map k a
renameKey EntrySelector
os EntrySelector
ns (ProducingActions
-> Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
paSinkEntry ProducingActions
pa)
            },
          EditingActions
ea
            { eaCompression :: Map EntrySelector CompressionMethod
eaCompression = EntrySelector
-> EntrySelector
-> Map EntrySelector CompressionMethod
-> Map EntrySelector CompressionMethod
forall k a. Ord k => k -> k -> Map k a -> Map k a
renameKey EntrySelector
os EntrySelector
ns (EditingActions -> Map EntrySelector CompressionMethod
eaCompression EditingActions
ea),
              eaEntryComment :: Map EntrySelector Text
eaEntryComment = EntrySelector
-> EntrySelector
-> Map EntrySelector Text
-> Map EntrySelector Text
forall k a. Ord k => k -> k -> Map k a -> Map k a
renameKey EntrySelector
os EntrySelector
ns (EditingActions -> Map EntrySelector Text
eaEntryComment EditingActions
ea),
              eaDeleteComment :: Map EntrySelector ()
eaDeleteComment = EntrySelector
-> EntrySelector -> Map EntrySelector () -> Map EntrySelector ()
forall k a. Ord k => k -> k -> Map k a -> Map k a
renameKey EntrySelector
os EntrySelector
ns (EditingActions -> Map EntrySelector ()
eaDeleteComment EditingActions
ea),
              eaModTime :: Map EntrySelector UTCTime
eaModTime = EntrySelector
-> EntrySelector
-> Map EntrySelector UTCTime
-> Map EntrySelector UTCTime
forall k a. Ord k => k -> k -> Map k a -> Map k a
renameKey EntrySelector
os EntrySelector
ns (EditingActions -> Map EntrySelector UTCTime
eaModTime EditingActions
ea),
              eaExtraField :: Map EntrySelector (Map Word16 ByteString)
eaExtraField = EntrySelector
-> EntrySelector
-> Map EntrySelector (Map Word16 ByteString)
-> Map EntrySelector (Map Word16 ByteString)
forall k a. Ord k => k -> k -> Map k a -> Map k a
renameKey EntrySelector
os EntrySelector
ns (EditingActions -> Map EntrySelector (Map Word16 ByteString)
eaExtraField EditingActions
ea),
              eaDeleteField :: Map EntrySelector (Map Word16 ())
eaDeleteField = EntrySelector
-> EntrySelector
-> Map EntrySelector (Map Word16 ())
-> Map EntrySelector (Map Word16 ())
forall k a. Ord k => k -> k -> Map k a -> Map k a
renameKey EntrySelector
os EntrySelector
ns (EditingActions -> Map EntrySelector (Map Word16 ())
eaDeleteField EditingActions
ea)
            }
        )
      DeleteEntry EntrySelector
s ->
        ( ProducingActions
pa
            { paSinkEntry :: Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
paSinkEntry = EntrySelector
-> Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
-> Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
forall k a. Ord k => k -> Map k a -> Map k a
M.delete EntrySelector
s (ProducingActions
-> Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
paSinkEntry ProducingActions
pa),
              paCopyEntry :: Map FilePath (Map EntrySelector EntrySelector)
paCopyEntry = (Map EntrySelector EntrySelector
 -> Map EntrySelector EntrySelector)
-> Map FilePath (Map EntrySelector EntrySelector)
-> Map FilePath (Map EntrySelector EntrySelector)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (EntrySelector
-> Map EntrySelector EntrySelector
-> Map EntrySelector EntrySelector
forall k a. Ord k => k -> Map k a -> Map k a
M.delete EntrySelector
s) (ProducingActions -> Map FilePath (Map EntrySelector EntrySelector)
paCopyEntry ProducingActions
pa)
            },
          EntrySelector -> EditingActions -> EditingActions
clearEditingFor EntrySelector
s EditingActions
ea
        )
      Recompress CompressionMethod
m EntrySelector
s ->
        (ProducingActions
pa, EditingActions
ea {eaCompression :: Map EntrySelector CompressionMethod
eaCompression = EntrySelector
-> CompressionMethod
-> Map EntrySelector CompressionMethod
-> Map EntrySelector CompressionMethod
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert EntrySelector
s CompressionMethod
m (EditingActions -> Map EntrySelector CompressionMethod
eaCompression EditingActions
ea)})
      SetEntryComment Text
txt EntrySelector
s ->
        ( ProducingActions
pa,
          EditingActions
ea
            { eaEntryComment :: Map EntrySelector Text
eaEntryComment = EntrySelector
-> Text -> Map EntrySelector Text -> Map EntrySelector Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert EntrySelector
s Text
txt (EditingActions -> Map EntrySelector Text
eaEntryComment EditingActions
ea),
              eaDeleteComment :: Map EntrySelector ()
eaDeleteComment = EntrySelector -> Map EntrySelector () -> Map EntrySelector ()
forall k a. Ord k => k -> Map k a -> Map k a
M.delete EntrySelector
s (EditingActions -> Map EntrySelector ()
eaDeleteComment EditingActions
ea)
            }
        )
      DeleteEntryComment EntrySelector
s ->
        ( ProducingActions
pa,
          EditingActions
ea
            { eaEntryComment :: Map EntrySelector Text
eaEntryComment = EntrySelector -> Map EntrySelector Text -> Map EntrySelector Text
forall k a. Ord k => k -> Map k a -> Map k a
M.delete EntrySelector
s (EditingActions -> Map EntrySelector Text
eaEntryComment EditingActions
ea),
              eaDeleteComment :: Map EntrySelector ()
eaDeleteComment = EntrySelector -> () -> Map EntrySelector () -> Map EntrySelector ()
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert EntrySelector
s () (EditingActions -> Map EntrySelector ()
eaDeleteComment EditingActions
ea)
            }
        )
      SetModTime UTCTime
time EntrySelector
s ->
        (ProducingActions
pa, EditingActions
ea {eaModTime :: Map EntrySelector UTCTime
eaModTime = EntrySelector
-> UTCTime
-> Map EntrySelector UTCTime
-> Map EntrySelector UTCTime
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert EntrySelector
s UTCTime
time (EditingActions -> Map EntrySelector UTCTime
eaModTime EditingActions
ea)})
      AddExtraField Word16
n ByteString
b EntrySelector
s ->
        ( ProducingActions
pa,
          EditingActions
ea
            { eaExtraField :: Map EntrySelector (Map Word16 ByteString)
eaExtraField = (Maybe (Map Word16 ByteString) -> Maybe (Map Word16 ByteString))
-> EntrySelector
-> Map EntrySelector (Map Word16 ByteString)
-> Map EntrySelector (Map Word16 ByteString)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (Word16
-> ByteString
-> Maybe (Map Word16 ByteString)
-> Maybe (Map Word16 ByteString)
forall k a. Ord k => k -> a -> Maybe (Map k a) -> Maybe (Map k a)
ef Word16
n ByteString
b) EntrySelector
s (EditingActions -> Map EntrySelector (Map Word16 ByteString)
eaExtraField EditingActions
ea),
              eaDeleteField :: Map EntrySelector (Map Word16 ())
eaDeleteField = EntrySelector
-> Map EntrySelector (Map Word16 ())
-> Map EntrySelector (Map Word16 ())
forall k a. Ord k => k -> Map k a -> Map k a
M.delete EntrySelector
s (EditingActions -> Map EntrySelector (Map Word16 ())
eaDeleteField EditingActions
ea)
            }
        )
      DeleteExtraField Word16
n EntrySelector
s ->
        ( ProducingActions
pa,
          EditingActions
ea
            { eaExtraField :: Map EntrySelector (Map Word16 ByteString)
eaExtraField = (Maybe (Map Word16 ByteString) -> Maybe (Map Word16 ByteString))
-> EntrySelector
-> Map EntrySelector (Map Word16 ByteString)
-> Map EntrySelector (Map Word16 ByteString)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (Word16
-> Maybe (Map Word16 ByteString) -> Maybe (Map Word16 ByteString)
forall k a. Ord k => k -> Maybe (Map k a) -> Maybe (Map k a)
er Word16
n) EntrySelector
s (EditingActions -> Map EntrySelector (Map Word16 ByteString)
eaExtraField EditingActions
ea),
              eaDeleteField :: Map EntrySelector (Map Word16 ())
eaDeleteField = (Maybe (Map Word16 ()) -> Maybe (Map Word16 ()))
-> EntrySelector
-> Map EntrySelector (Map Word16 ())
-> Map EntrySelector (Map Word16 ())
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (Word16 -> () -> Maybe (Map Word16 ()) -> Maybe (Map Word16 ())
forall k a. Ord k => k -> a -> Maybe (Map k a) -> Maybe (Map k a)
ef Word16
n ()) EntrySelector
s (EditingActions -> Map EntrySelector (Map Word16 ())
eaDeleteField EditingActions
ea)
            }
        )
      SetExternalFileAttributes Word32
b EntrySelector
s ->
        ( ProducingActions
pa,
          EditingActions
ea {eaExtFileAttr :: Map EntrySelector Word32
eaExtFileAttr = EntrySelector
-> Word32 -> Map EntrySelector Word32 -> Map EntrySelector Word32
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert EntrySelector
s Word32
b (EditingActions -> Map EntrySelector Word32
eaExtFileAttr EditingActions
ea)}
        )
      PendingAction
_ -> (ProducingActions
pa, EditingActions
ea)
    clearEditingFor :: EntrySelector -> EditingActions -> EditingActions
clearEditingFor EntrySelector
s EditingActions
ea =
      EditingActions
ea
        { eaCompression :: Map EntrySelector CompressionMethod
eaCompression = EntrySelector
-> Map EntrySelector CompressionMethod
-> Map EntrySelector CompressionMethod
forall k a. Ord k => k -> Map k a -> Map k a
M.delete EntrySelector
s (EditingActions -> Map EntrySelector CompressionMethod
eaCompression EditingActions
ea),
          eaEntryComment :: Map EntrySelector Text
eaEntryComment = EntrySelector -> Map EntrySelector Text -> Map EntrySelector Text
forall k a. Ord k => k -> Map k a -> Map k a
M.delete EntrySelector
s (EditingActions -> Map EntrySelector Text
eaEntryComment EditingActions
ea),
          eaDeleteComment :: Map EntrySelector ()
eaDeleteComment = EntrySelector -> Map EntrySelector () -> Map EntrySelector ()
forall k a. Ord k => k -> Map k a -> Map k a
M.delete EntrySelector
s (EditingActions -> Map EntrySelector ()
eaDeleteComment EditingActions
ea),
          eaModTime :: Map EntrySelector UTCTime
eaModTime = EntrySelector
-> Map EntrySelector UTCTime -> Map EntrySelector UTCTime
forall k a. Ord k => k -> Map k a -> Map k a
M.delete EntrySelector
s (EditingActions -> Map EntrySelector UTCTime
eaModTime EditingActions
ea),
          eaExtraField :: Map EntrySelector (Map Word16 ByteString)
eaExtraField = EntrySelector
-> Map EntrySelector (Map Word16 ByteString)
-> Map EntrySelector (Map Word16 ByteString)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete EntrySelector
s (EditingActions -> Map EntrySelector (Map Word16 ByteString)
eaExtraField EditingActions
ea),
          eaDeleteField :: Map EntrySelector (Map Word16 ())
eaDeleteField = EntrySelector
-> Map EntrySelector (Map Word16 ())
-> Map EntrySelector (Map Word16 ())
forall k a. Ord k => k -> Map k a -> Map k a
M.delete EntrySelector
s (EditingActions -> Map EntrySelector (Map Word16 ())
eaDeleteField EditingActions
ea),
          eaExtFileAttr :: Map EntrySelector Word32
eaExtFileAttr = EntrySelector
-> Map EntrySelector Word32 -> Map EntrySelector Word32
forall k a. Ord k => k -> Map k a -> Map k a
M.delete EntrySelector
s (EditingActions -> Map EntrySelector Word32
eaExtFileAttr EditingActions
ea)
        }
    re :: p -> p -> p -> p
re p
o p
n p
x = if p
x p -> p -> Bool
forall a. Eq a => a -> a -> Bool
== p
o then p
n else p
x
    ef :: k -> a -> Maybe (Map k a) -> Maybe (Map k a)
ef k
k a
v (Just Map k a
m) = Map k a -> Maybe (Map k a)
forall a. a -> Maybe a
Just (k -> a -> Map k a -> Map k a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
k a
v Map k a
m)
    ef k
k a
v Maybe (Map k a)
Nothing = Map k a -> Maybe (Map k a)
forall a. a -> Maybe a
Just (k -> a -> Map k a
forall k a. k -> a -> Map k a
M.singleton k
k a
v)
    er :: k -> Maybe (Map k a) -> Maybe (Map k a)
er k
k (Just Map k a
m) =
      let n :: Map k a
n = k -> Map k a -> Map k a
forall k a. Ord k => k -> Map k a -> Map k a
M.delete k
k Map k a
m
       in if Map k a -> Bool
forall k a. Map k a -> Bool
M.null Map k a
n then Maybe (Map k a)
forall a. Maybe a
Nothing else Map k a -> Maybe (Map k a)
forall a. a -> Maybe a
Just Map k a
n
    er k
_ Maybe (Map k a)
Nothing = Maybe (Map k a)
forall a. Maybe a
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 :: Handle
-> FilePath
-> Map EntrySelector EntrySelector
-> EditingActions
-> IO (Map EntrySelector EntryDescription)
copyEntries Handle
h FilePath
path Map EntrySelector EntrySelector
m EditingActions
e = do
  Map EntrySelector EntryDescription
entries <- (ArchiveDescription, Map EntrySelector EntryDescription)
-> Map EntrySelector EntryDescription
forall a b. (a, b) -> b
snd ((ArchiveDescription, Map EntrySelector EntryDescription)
 -> Map EntrySelector EntryDescription)
-> IO (ArchiveDescription, Map EntrySelector EntryDescription)
-> IO (Map EntrySelector EntryDescription)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath
-> IO (ArchiveDescription, Map EntrySelector EntryDescription)
scanArchive FilePath
path
  [(EntrySelector, EntryDescription)]
done <- [EntrySelector]
-> (EntrySelector -> IO (EntrySelector, EntryDescription))
-> IO [(EntrySelector, EntryDescription)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map EntrySelector EntrySelector -> [EntrySelector]
forall k a. Map k a -> [k]
M.keys Map EntrySelector EntrySelector
m) ((EntrySelector -> IO (EntrySelector, EntryDescription))
 -> IO [(EntrySelector, EntryDescription)])
-> (EntrySelector -> IO (EntrySelector, EntryDescription))
-> IO [(EntrySelector, EntryDescription)]
forall a b. (a -> b) -> a -> b
$ \EntrySelector
s ->
    case EntrySelector
s EntrySelector
-> Map EntrySelector EntryDescription -> Maybe EntryDescription
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map EntrySelector EntryDescription
entries of
      Maybe EntryDescription
Nothing -> ZipException -> IO (EntrySelector, EntryDescription)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (FilePath -> EntrySelector -> ZipException
EntryDoesNotExist FilePath
path EntrySelector
s)
      Just EntryDescription
desc ->
        Handle
-> EntrySelector
-> EntryOrigin
-> ConduitT () ByteString (ResourceT IO) ()
-> EditingActions
-> IO (EntrySelector, EntryDescription)
sinkEntry
          Handle
h
          (Map EntrySelector EntrySelector
m Map EntrySelector EntrySelector -> EntrySelector -> EntrySelector
forall k a. Ord k => Map k a -> k -> a
! EntrySelector
s)
          (EntryDescription -> EntryOrigin
Borrowed EntryDescription
desc)
          (FilePath
-> EntryDescription
-> Bool
-> ConduitT () ByteString (ResourceT IO) ()
forall (m :: * -> *).
(PrimMonad m, MonadThrow m, MonadResource m) =>
FilePath -> EntryDescription -> Bool -> ConduitT () ByteString m ()
sourceEntry FilePath
path EntryDescription
desc Bool
False)
          EditingActions
e
  Map EntrySelector EntryDescription
-> IO (Map EntrySelector EntryDescription)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(EntrySelector, EntryDescription)]
-> Map EntrySelector EntryDescription
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(EntrySelector, EntryDescription)]
done)

-- | 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 (EntrySelector, EntryDescription)
sinkEntry :: Handle
-> EntrySelector
-> EntryOrigin
-> ConduitT () ByteString (ResourceT IO) ()
-> EditingActions
-> IO (EntrySelector, EntryDescription)
sinkEntry Handle
h EntrySelector
s EntryOrigin
o ConduitT () ByteString (ResourceT IO) ()
src EditingActions {Map EntrySelector Word32
Map EntrySelector ()
Map EntrySelector (Map Word16 ())
Map EntrySelector (Map Word16 ByteString)
Map EntrySelector Text
Map EntrySelector UTCTime
Map EntrySelector CompressionMethod
eaExtFileAttr :: Map EntrySelector Word32
eaDeleteField :: Map EntrySelector (Map Word16 ())
eaExtraField :: Map EntrySelector (Map Word16 ByteString)
eaModTime :: Map EntrySelector UTCTime
eaDeleteComment :: Map EntrySelector ()
eaEntryComment :: Map EntrySelector Text
eaCompression :: Map EntrySelector CompressionMethod
eaExtFileAttr :: EditingActions -> Map EntrySelector Word32
eaDeleteField :: EditingActions -> Map EntrySelector (Map Word16 ())
eaExtraField :: EditingActions -> Map EntrySelector (Map Word16 ByteString)
eaModTime :: EditingActions -> Map EntrySelector UTCTime
eaDeleteComment :: EditingActions -> Map EntrySelector ()
eaEntryComment :: EditingActions -> Map EntrySelector Text
eaCompression :: EditingActions -> Map EntrySelector CompressionMethod
..} = do
  UTCTime
currentTime <- IO UTCTime
getCurrentTime
  Integer
offset <- Handle -> IO Integer
hTell Handle
h
  let compressed :: CompressionMethod
compressed = case EntryOrigin
o of
        EntryOrigin
GenericOrigin -> CompressionMethod
Store
        Borrowed EntryDescription
ed -> EntryDescription -> CompressionMethod
edCompression EntryDescription
ed
      compression :: CompressionMethod
compression = CompressionMethod
-> EntrySelector
-> Map EntrySelector CompressionMethod
-> CompressionMethod
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault CompressionMethod
compressed EntrySelector
s Map EntrySelector CompressionMethod
eaCompression
      recompression :: Bool
recompression = CompressionMethod
compression CompressionMethod -> CompressionMethod -> Bool
forall a. Eq a => a -> a -> Bool
/= CompressionMethod
compressed
      modTime :: UTCTime
modTime = case EntryOrigin
o of
        EntryOrigin
GenericOrigin -> UTCTime
currentTime
        Borrowed EntryDescription
ed -> EntryDescription -> UTCTime
edModTime EntryDescription
ed
      extFileAttr :: Word32
extFileAttr = case EntryOrigin
o of
        EntryOrigin
GenericOrigin -> Word32 -> EntrySelector -> Map EntrySelector Word32 -> Word32
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Word32
defaultFileMode EntrySelector
s Map EntrySelector Word32
eaExtFileAttr
        Borrowed EntryDescription
_ -> Word32 -> EntrySelector -> Map EntrySelector Word32 -> Word32
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Word32
defaultFileMode EntrySelector
s Map EntrySelector Word32
eaExtFileAttr
      oldExtraFields :: Map Word16 ByteString
oldExtraFields = case EntryOrigin
o of
        EntryOrigin
GenericOrigin -> Map Word16 ByteString
forall k a. Map k a
M.empty
        Borrowed EntryDescription
ed -> EntryDescription -> Map Word16 ByteString
edExtraField EntryDescription
ed
      extraField :: Map Word16 ByteString
extraField =
        (Map Word16 ByteString
-> EntrySelector
-> Map EntrySelector (Map Word16 ByteString)
-> Map Word16 ByteString
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Map Word16 ByteString
forall k a. Map k a
M.empty EntrySelector
s Map EntrySelector (Map Word16 ByteString)
eaExtraField Map Word16 ByteString
-> Map Word16 ByteString -> Map Word16 ByteString
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map Word16 ByteString
oldExtraFields)
          Map Word16 ByteString -> Map Word16 () -> Map Word16 ByteString
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`M.difference` Map Word16 ()
-> EntrySelector
-> Map EntrySelector (Map Word16 ())
-> Map Word16 ()
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Map Word16 ()
forall k a. Map k a
M.empty EntrySelector
s Map EntrySelector (Map Word16 ())
eaDeleteField
      oldComment :: Maybe Text
oldComment = case (EntryOrigin
o, EntrySelector -> Map EntrySelector () -> Maybe ()
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup EntrySelector
s Map EntrySelector ()
eaDeleteComment) of
        (EntryOrigin
GenericOrigin, Maybe ()
_) -> Maybe Text
forall a. Maybe a
Nothing
        (Borrowed EntryDescription
ed, Maybe ()
Nothing) -> EntryDescription -> Maybe Text
edComment EntryDescription
ed
        (Borrowed EntryDescription
_, Just ()) -> Maybe Text
forall a. Maybe a
Nothing
      desc0 :: EntryDescription
desc0 =
        EntryDescription :: Version
-> Version
-> CompressionMethod
-> UTCTime
-> Word32
-> Natural
-> Natural
-> Natural
-> Maybe Text
-> Map Word16 ByteString
-> Word32
-> EntryDescription
EntryDescription -- to write in local header
          { edVersionMadeBy :: Version
edVersionMadeBy = Version
zipVersion,
            edVersionNeeded :: Version
edVersionNeeded = Version
zipVersion,
            edCompression :: CompressionMethod
edCompression = CompressionMethod
compression,
            edModTime :: UTCTime
edModTime = UTCTime -> EntrySelector -> Map EntrySelector UTCTime -> UTCTime
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault UTCTime
modTime EntrySelector
s Map EntrySelector UTCTime
eaModTime,
            edCRC32 :: Word32
edCRC32 = Word32
0, -- to be overwritten after streaming
            edCompressedSize :: Natural
edCompressedSize = Natural
0, -- ↑
            edUncompressedSize :: Natural
edUncompressedSize = Natural
0, -- ↑
            edOffset :: Natural
edOffset = Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
offset,
            edComment :: Maybe Text
edComment = EntrySelector -> Map EntrySelector Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup EntrySelector
s Map EntrySelector Text
eaEntryComment Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Text
oldComment,
            edExtraField :: Map Word16 ByteString
edExtraField = Map Word16 ByteString
extraField,
            edExternalFileAttrs :: Word32
edExternalFileAttrs = Word32
extFileAttr
          }
  Handle -> ByteString -> IO ()
B.hPut Handle
h (Put -> ByteString
runPut (HeaderType -> EntrySelector -> EntryDescription -> Put
putHeader HeaderType
LocalHeader EntrySelector
s EntryDescription
desc0))
  DataDescriptor {Natural
Word32
ddUncompressedSize :: Natural
ddCompressedSize :: Natural
ddCRC32 :: Word32
ddUncompressedSize :: DataDescriptor -> Natural
ddCompressedSize :: DataDescriptor -> Natural
ddCRC32 :: DataDescriptor -> Word32
..} <-
    ConduitT () Void (ResourceT IO) DataDescriptor -> IO DataDescriptor
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
C.runConduitRes (ConduitT () Void (ResourceT IO) DataDescriptor
 -> IO DataDescriptor)
-> ConduitT () Void (ResourceT IO) DataDescriptor
-> IO DataDescriptor
forall a b. (a -> b) -> a -> b
$
      if Bool
recompression
        then
          if CompressionMethod
compressed CompressionMethod -> CompressionMethod -> Bool
forall a. Eq a => a -> a -> Bool
== CompressionMethod
Store
            then ConduitT () ByteString (ResourceT IO) ()
src ConduitT () ByteString (ResourceT IO) ()
-> ConduitM ByteString Void (ResourceT IO) DataDescriptor
-> ConduitT () Void (ResourceT IO) DataDescriptor
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Handle
-> CompressionMethod
-> ConduitM ByteString Void (ResourceT IO) DataDescriptor
sinkData Handle
h CompressionMethod
compression
            else ConduitT () ByteString (ResourceT IO) ()
src ConduitT () ByteString (ResourceT IO) ()
-> ConduitM ByteString Void (ResourceT IO) DataDescriptor
-> ConduitT () Void (ResourceT IO) DataDescriptor
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| CompressionMethod
-> ConduitT ByteString ByteString (ResourceT IO) ()
forall (m :: * -> *).
(PrimMonad m, MonadThrow m, MonadResource m) =>
CompressionMethod -> ConduitT ByteString ByteString m ()
decompressingPipe CompressionMethod
compressed ConduitT ByteString ByteString (ResourceT IO) ()
-> ConduitM ByteString Void (ResourceT IO) DataDescriptor
-> ConduitM ByteString Void (ResourceT IO) DataDescriptor
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Handle
-> CompressionMethod
-> ConduitM ByteString Void (ResourceT IO) DataDescriptor
sinkData Handle
h CompressionMethod
compression
        else ConduitT () ByteString (ResourceT IO) ()
src ConduitT () ByteString (ResourceT IO) ()
-> ConduitM ByteString Void (ResourceT IO) DataDescriptor
-> ConduitT () Void (ResourceT IO) DataDescriptor
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Handle
-> CompressionMethod
-> ConduitM ByteString Void (ResourceT IO) DataDescriptor
sinkData Handle
h CompressionMethod
Store
  Integer
afterStreaming <- Handle -> IO Integer
hTell Handle
h
  let desc1 :: EntryDescription
desc1 = case EntryOrigin
o of
        EntryOrigin
GenericOrigin ->
          EntryDescription
desc0
            { edCRC32 :: Word32
edCRC32 = Word32
ddCRC32,
              edCompressedSize :: Natural
edCompressedSize = Natural
ddCompressedSize,
              edUncompressedSize :: Natural
edUncompressedSize = Natural
ddUncompressedSize
            }
        Borrowed EntryDescription
ed ->
          EntryDescription
desc0
            { edCRC32 :: Word32
edCRC32 =
                Word32 -> Word32 -> Bool -> Word32
forall a. a -> a -> Bool -> a
bool (EntryDescription -> Word32
edCRC32 EntryDescription
ed) Word32
ddCRC32 Bool
recompression,
              edCompressedSize :: Natural
edCompressedSize =
                Natural -> Natural -> Bool -> Natural
forall a. a -> a -> Bool -> a
bool (EntryDescription -> Natural
edCompressedSize EntryDescription
ed) Natural
ddCompressedSize Bool
recompression,
              edUncompressedSize :: Natural
edUncompressedSize =
                Natural -> Natural -> Bool -> Natural
forall a. a -> a -> Bool -> a
bool (EntryDescription -> Natural
edUncompressedSize EntryDescription
ed) Natural
ddUncompressedSize Bool
recompression
            }
      desc2 :: EntryDescription
desc2 =
        EntryDescription
desc1
          { edVersionNeeded :: Version
edVersionNeeded =
              Bool -> Maybe CompressionMethod -> Version
getZipVersion (EntryDescription -> Bool
needsZip64 EntryDescription
desc1) (CompressionMethod -> Maybe CompressionMethod
forall a. a -> Maybe a
Just CompressionMethod
compression)
          }
  Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek Integer
offset
  Handle -> ByteString -> IO ()
B.hPut Handle
h (Put -> ByteString
runPut (HeaderType -> EntrySelector -> EntryDescription -> Put
putHeader HeaderType
LocalHeader EntrySelector
s EntryDescription
desc2))
  Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek Integer
afterStreaming
  (EntrySelector, EntryDescription)
-> IO (EntrySelector, EntryDescription)
forall (m :: * -> *) a. Monad m => a -> m a
return (EntrySelector
s, EntryDescription
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 :: Handle
-> CompressionMethod
-> ConduitM ByteString Void (ResourceT IO) DataDescriptor
sinkData Handle
h CompressionMethod
compression = do
  let sizeSink :: ConduitT ByteString o (ResourceT IO) Natural
sizeSink = (Natural -> ByteString -> Natural)
-> Natural -> ConduitT ByteString o (ResourceT IO) Natural
forall (m :: * -> *) b a o.
Monad m =>
(b -> a -> b) -> b -> ConduitT a o m b
CL.fold (\Natural
acc ByteString
input -> Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
input) Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
acc) Natural
0
      dataSink :: Sink ByteString (ResourceT IO) Natural
dataSink =
        ZipSink ByteString (ResourceT IO) Natural
-> Sink ByteString (ResourceT IO) Natural
forall i (m :: * -> *) r. ZipSink i m r -> Sink i m r
getZipSink (ZipSink ByteString (ResourceT IO) Natural
 -> Sink ByteString (ResourceT IO) Natural)
-> ZipSink ByteString (ResourceT IO) Natural
-> Sink ByteString (ResourceT IO) Natural
forall a b. (a -> b) -> a -> b
$
          Sink ByteString (ResourceT IO) Natural
-> ZipSink ByteString (ResourceT IO) Natural
forall i (m :: * -> *) r. Sink i m r -> ZipSink i m r
ZipSink Sink ByteString (ResourceT IO) Natural
forall o. ConduitT ByteString o (ResourceT IO) Natural
sizeSink ZipSink ByteString (ResourceT IO) Natural
-> ZipSink ByteString (ResourceT IO) ()
-> ZipSink ByteString (ResourceT IO) Natural
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Sink ByteString (ResourceT IO) ()
-> ZipSink ByteString (ResourceT IO) ()
forall i (m :: * -> *) r. Sink i m r -> ZipSink i m r
ZipSink (Handle -> Sink ByteString (ResourceT IO) ()
forall (m :: * -> *) o.
MonadIO m =>
Handle -> ConduitT ByteString o m ()
CB.sinkHandle Handle
h)
      withCompression :: Sink ByteString (ResourceT IO) a
-> Sink ByteString (ResourceT IO) (Natural, Word32, a)
withCompression Sink ByteString (ResourceT IO) a
sink =
        ZipSink ByteString (ResourceT IO) (Natural, Word32, a)
-> Sink ByteString (ResourceT IO) (Natural, Word32, a)
forall i (m :: * -> *) r. ZipSink i m r -> Sink i m r
getZipSink (ZipSink ByteString (ResourceT IO) (Natural, Word32, a)
 -> Sink ByteString (ResourceT IO) (Natural, Word32, a))
-> ZipSink ByteString (ResourceT IO) (Natural, Word32, a)
-> Sink ByteString (ResourceT IO) (Natural, Word32, a)
forall a b. (a -> b) -> a -> b
$
          (,,) (Natural -> Word32 -> a -> (Natural, Word32, a))
-> ZipSink ByteString (ResourceT IO) Natural
-> ZipSink
     ByteString (ResourceT IO) (Word32 -> a -> (Natural, Word32, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sink ByteString (ResourceT IO) Natural
-> ZipSink ByteString (ResourceT IO) Natural
forall i (m :: * -> *) r. Sink i m r -> ZipSink i m r
ZipSink Sink ByteString (ResourceT IO) Natural
forall o. ConduitT ByteString o (ResourceT IO) Natural
sizeSink
            ZipSink
  ByteString (ResourceT IO) (Word32 -> a -> (Natural, Word32, a))
-> ZipSink ByteString (ResourceT IO) Word32
-> ZipSink ByteString (ResourceT IO) (a -> (Natural, Word32, a))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Sink ByteString (ResourceT IO) Word32
-> ZipSink ByteString (ResourceT IO) Word32
forall i (m :: * -> *) r. Sink i m r -> ZipSink i m r
ZipSink Sink ByteString (ResourceT IO) Word32
crc32Sink
            ZipSink ByteString (ResourceT IO) (a -> (Natural, Word32, a))
-> ZipSink ByteString (ResourceT IO) a
-> ZipSink ByteString (ResourceT IO) (Natural, Word32, a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Sink ByteString (ResourceT IO) a
-> ZipSink ByteString (ResourceT IO) a
forall i (m :: * -> *) r. Sink i m r -> ZipSink i m r
ZipSink Sink ByteString (ResourceT IO) a
sink
  (Natural
uncompressedSize, Word32
crc32, Natural
compressedSize) <-
    case CompressionMethod
compression of
      CompressionMethod
Store ->
        Sink ByteString (ResourceT IO) Natural
-> ConduitT
     ByteString Void (ResourceT IO) (Natural, Word32, Natural)
forall a.
Sink ByteString (ResourceT IO) a
-> Sink ByteString (ResourceT IO) (Natural, Word32, a)
withCompression
          Sink ByteString (ResourceT IO) Natural
dataSink
      CompressionMethod
Deflate ->
        Sink ByteString (ResourceT IO) Natural
-> ConduitT
     ByteString Void (ResourceT IO) (Natural, Word32, Natural)
forall a.
Sink ByteString (ResourceT IO) a
-> Sink ByteString (ResourceT IO) (Natural, Word32, a)
withCompression (Sink ByteString (ResourceT IO) Natural
 -> ConduitT
      ByteString Void (ResourceT IO) (Natural, Word32, Natural))
-> Sink ByteString (ResourceT IO) Natural
-> ConduitT
     ByteString Void (ResourceT IO) (Natural, Word32, Natural)
forall a b. (a -> b) -> a -> b
$
          Int
-> WindowBits -> ConduitT ByteString ByteString (ResourceT IO) ()
forall (m :: * -> *).
(PrimMonad m, MonadThrow m) =>
Int -> WindowBits -> ConduitT ByteString ByteString m ()
Z.compress Int
9 (Int -> WindowBits
Z.WindowBits (-Int
15)) ConduitT ByteString ByteString (ResourceT IO) ()
-> Sink ByteString (ResourceT IO) Natural
-> Sink ByteString (ResourceT IO) Natural
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Sink ByteString (ResourceT IO) Natural
dataSink
#ifdef ENABLE_BZIP2
      CompressionMethod
BZip2 ->
        Sink ByteString (ResourceT IO) Natural
-> ConduitT
     ByteString Void (ResourceT IO) (Natural, Word32, Natural)
forall a.
Sink ByteString (ResourceT IO) a
-> Sink ByteString (ResourceT IO) (Natural, Word32, a)
withCompression (Sink ByteString (ResourceT IO) Natural
 -> ConduitT
      ByteString Void (ResourceT IO) (Natural, Word32, Natural))
-> Sink ByteString (ResourceT IO) Natural
-> ConduitT
     ByteString Void (ResourceT IO) (Natural, Word32, Natural)
forall a b. (a -> b) -> a -> b
$
          ConduitT ByteString ByteString (ResourceT IO) ()
forall (m :: * -> *).
MonadResource m =>
ConduitT ByteString ByteString m ()
BZ.bzip2 ConduitT ByteString ByteString (ResourceT IO) ()
-> Sink ByteString (ResourceT IO) Natural
-> Sink ByteString (ResourceT IO) Natural
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Sink ByteString (ResourceT IO) Natural
dataSink
#else
      BZip2 -> throwM BZip2Unsupported
#endif
#ifdef ENABLE_ZSTD
      CompressionMethod
Zstd ->
        Sink ByteString (ResourceT IO) Natural
-> ConduitT
     ByteString Void (ResourceT IO) (Natural, Word32, Natural)
forall a.
Sink ByteString (ResourceT IO) a
-> Sink ByteString (ResourceT IO) (Natural, Word32, a)
withCompression (Sink ByteString (ResourceT IO) Natural
 -> ConduitT
      ByteString Void (ResourceT IO) (Natural, Word32, Natural))
-> Sink ByteString (ResourceT IO) Natural
-> ConduitT
     ByteString Void (ResourceT IO) (Natural, Word32, Natural)
forall a b. (a -> b) -> a -> b
$
          Int -> ConduitT ByteString ByteString (ResourceT IO) ()
forall (m :: * -> *).
MonadIO m =>
Int -> ConduitT ByteString ByteString m ()
Zstandard.compress Int
1 ConduitT ByteString ByteString (ResourceT IO) ()
-> Sink ByteString (ResourceT IO) Natural
-> Sink ByteString (ResourceT IO) Natural
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Sink ByteString (ResourceT IO) Natural
dataSink
#else
      Zstd -> throwM ZstdUnsupported
#endif
  DataDescriptor
-> ConduitM ByteString Void (ResourceT IO) DataDescriptor
forall (m :: * -> *) a. Monad m => a -> m a
return
    DataDescriptor :: Word32 -> Natural -> Natural -> DataDescriptor
DataDescriptor
      { ddCRC32 :: Word32
ddCRC32 = Word32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
crc32,
        ddCompressedSize :: Natural
ddCompressedSize = Natural
compressedSize,
        ddUncompressedSize :: Natural
ddUncompressedSize = Natural
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 :: Handle -> Maybe Text -> Map EntrySelector EntryDescription -> IO ()
writeCD Handle
h Maybe Text
comment Map EntrySelector EntryDescription
m = do
  let cd :: ByteString
cd = Put -> ByteString
runPut (Map EntrySelector EntryDescription -> Put
putCD Map EntrySelector EntryDescription
m)
  Natural
cdOffset <- Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Natural) -> IO Integer -> IO Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Integer
hTell Handle
h
  Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
cd -- write central directory
  let totalCount :: Natural
totalCount = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Map EntrySelector EntryDescription -> Int
forall k a. Map k a -> Int
M.size Map EntrySelector EntryDescription
m)
      cdSize :: Natural
cdSize = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
cd)
      needZip64 :: Bool
needZip64 =
        Natural
totalCount Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>= Natural
ffff
          Bool -> Bool -> Bool
|| Natural
cdSize Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>= Natural
ffffffff
          Bool -> Bool -> Bool
|| Natural
cdOffset Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>= Natural
ffffffff
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needZip64 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Natural
zip64ecdOffset <- Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Natural) -> IO Integer -> IO Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Integer
hTell Handle
h
    (Handle -> ByteString -> IO ()
B.hPut Handle
h (ByteString -> IO ()) -> (Put -> ByteString) -> Put -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut) (Natural -> Natural -> Natural -> Put
putZip64ECD Natural
totalCount Natural
cdSize Natural
cdOffset)
    (Handle -> ByteString -> IO ()
B.hPut Handle
h (ByteString -> IO ()) -> (Put -> ByteString) -> Put -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut) (Natural -> Put
putZip64ECDLocator Natural
zip64ecdOffset)
  (Handle -> ByteString -> IO ()
B.hPut Handle
h (ByteString -> IO ()) -> (Put -> ByteString) -> Put -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut) (Natural -> Natural -> Natural -> Maybe Text -> Put
putECD Natural
totalCount Natural
cdSize Natural
cdOffset Maybe Text
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 :: Get Integer
getLocalHeaderGap = do
  Word32 -> Get ()
getSignature Word32
0x04034b50
  Int -> Get ()
skip Int
2 -- version needed to extract
  Int -> Get ()
skip Int
2 -- general purpose bit flag
  Int -> Get ()
skip Int
2 -- compression method
  Int -> Get ()
skip Int
2 -- last mod file time
  Int -> Get ()
skip Int
2 -- last mod file date
  Int -> Get ()
skip Int
4 -- crc-32 check sum
  Int -> Get ()
skip Int
4 -- compressed size
  Int -> Get ()
skip Int
4 -- uncompressed size
  Integer
fileNameSize <- Word16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Integer) -> Get Word16 -> Get Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16le -- file name length
  Integer
extraFieldSize <- Word16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Integer) -> Get Word16 -> Get Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16le -- extra field length
  Integer -> Get Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
fileNameSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
extraFieldSize)

-- | Parse central directory file headers and put them into a 'Map'.
getCD :: Get (Map EntrySelector EntryDescription)
getCD :: Get (Map EntrySelector EntryDescription)
getCD = [(EntrySelector, EntryDescription)]
-> Map EntrySelector EntryDescription
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(EntrySelector, EntryDescription)]
 -> Map EntrySelector EntryDescription)
-> ([Maybe (EntrySelector, EntryDescription)]
    -> [(EntrySelector, EntryDescription)])
-> [Maybe (EntrySelector, EntryDescription)]
-> Map EntrySelector EntryDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (EntrySelector, EntryDescription)]
-> [(EntrySelector, EntryDescription)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (EntrySelector, EntryDescription)]
 -> Map EntrySelector EntryDescription)
-> Get [Maybe (EntrySelector, EntryDescription)]
-> Get (Map EntrySelector EntryDescription)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (Maybe (EntrySelector, EntryDescription))
-> Get [Maybe (EntrySelector, EntryDescription)]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Get (Maybe (EntrySelector, EntryDescription))
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 :: Get (Maybe (EntrySelector, EntryDescription))
getCDHeader = do
  Word32 -> Get ()
getSignature Word32
0x02014b50 -- central file header signature
  Version
versionMadeBy <- Word16 -> Version
toVersion (Word16 -> Version) -> Get Word16 -> Get Version
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16le -- version made by
  Version
versionNeeded <- Word16 -> Version
toVersion (Word16 -> Version) -> Get Word16 -> Get Version
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16le -- version needed to extract
  Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
versionNeeded Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
> Version
zipVersion) (Get () -> Get ()) -> (FilePath -> Get ()) -> FilePath -> Get ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Get ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Get ()) -> FilePath -> Get ()
forall a b. (a -> b) -> a -> b
$
    FilePath
"Version required to extract the archive is "
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
showVersion Version
versionNeeded
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" (can do "
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
showVersion Version
zipVersion
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")"
  Word16
bitFlag <- Get Word16
getWord16le -- general purpose bit flag
  Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Word16 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word16
bitFlag) [Int
0, Int
6, Int
13]) (Get () -> Get ()) -> (FilePath -> Get ()) -> FilePath -> Get ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Get ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Get ()) -> FilePath -> Get ()
forall a b. (a -> b) -> a -> b
$
    FilePath
"Encrypted archives are not supported"
  let needUnicode :: Bool
needUnicode = Word16 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word16
bitFlag Int
11
  Maybe CompressionMethod
mcompression <- Word16 -> Maybe CompressionMethod
toCompressionMethod (Word16 -> Maybe CompressionMethod)
-> Get Word16 -> Get (Maybe CompressionMethod)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16le -- compression method
  Word16
modTime <- Get Word16
getWord16le -- last mod file time
  Word16
modDate <- Get Word16
getWord16le -- last mod file date
  Word32
crc32 <- Get Word32
getWord32le -- CRC32 check sum
  Natural
compressed <- Word32 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Natural) -> Get Word32 -> Get Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32le -- compressed size
  Natural
uncompressed <- Word32 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Natural) -> Get Word32 -> Get Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32le -- uncompressed size
  Word16
fileNameSize <- Get Word16
getWord16le -- file name length
  Word16
extraFieldSize <- Get Word16
getWord16le -- extra field length
  Word16
commentSize <- Get Word16
getWord16le -- file comment size
  Int -> Get ()
skip Int
4 -- disk number start, internal file attributes
  Word32
externalFileAttrs <- Get Word32
getWord32le -- external file attributes
  Natural
offset <- Word32 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Natural) -> Get Word32 -> Get Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32le -- offset of local header
  Maybe Text
fileName <-
    Bool -> ByteString -> Maybe Text
decodeText Bool
needUnicode
      (ByteString -> Maybe Text) -> Get ByteString -> Get (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getBytes (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
fileNameSize) -- file name
  Map Word16 ByteString
extraField <-
    [(Word16, ByteString)] -> Map Word16 ByteString
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
      ([(Word16, ByteString)] -> Map Word16 ByteString)
-> Get [(Word16, ByteString)] -> Get (Map Word16 ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get [(Word16, ByteString)] -> Get [(Word16, ByteString)]
forall a. Int -> Get a -> Get a
isolate (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
extraFieldSize) (Get (Word16, ByteString) -> Get [(Word16, ByteString)]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Get (Word16, ByteString)
getExtraField)
  -- ↑ extra fields in their raw form
  Maybe Text
comment <- Bool -> ByteString -> Maybe Text
decodeText Bool
needUnicode (ByteString -> Maybe Text) -> Get ByteString -> Get (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getBytes (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
commentSize)
  -- ↑ file comment
  let dfltZip64 :: Zip64ExtraField
dfltZip64 =
        Zip64ExtraField :: Natural -> Natural -> Natural -> Zip64ExtraField
Zip64ExtraField
          { z64efUncompressedSize :: Natural
z64efUncompressedSize = Natural
uncompressed,
            z64efCompressedSize :: Natural
z64efCompressedSize = Natural
compressed,
            z64efOffset :: Natural
z64efOffset = Natural
offset
          }
      z64ef :: Zip64ExtraField
z64ef = case Word16 -> Map Word16 ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Word16
1 Map Word16 ByteString
extraField of
        Maybe ByteString
Nothing -> Zip64ExtraField
dfltZip64
        Just ByteString
b -> Zip64ExtraField -> ByteString -> Zip64ExtraField
parseZip64ExtraField Zip64ExtraField
dfltZip64 ByteString
b
  case Maybe CompressionMethod
mcompression of
    Maybe CompressionMethod
Nothing -> Maybe (EntrySelector, EntryDescription)
-> Get (Maybe (EntrySelector, EntryDescription))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (EntrySelector, EntryDescription)
forall a. Maybe a
Nothing
    Just CompressionMethod
compression ->
      let desc :: EntryDescription
desc =
            EntryDescription :: Version
-> Version
-> CompressionMethod
-> UTCTime
-> Word32
-> Natural
-> Natural
-> Natural
-> Maybe Text
-> Map Word16 ByteString
-> Word32
-> EntryDescription
EntryDescription
              { edVersionMadeBy :: Version
edVersionMadeBy = Version
versionMadeBy,
                edVersionNeeded :: Version
edVersionNeeded = Version
versionNeeded,
                edCompression :: CompressionMethod
edCompression = CompressionMethod
compression,
                edModTime :: UTCTime
edModTime = MsDosTime -> UTCTime
fromMsDosTime (Word16 -> Word16 -> MsDosTime
MsDosTime Word16
modDate Word16
modTime),
                edCRC32 :: Word32
edCRC32 = Word32
crc32,
                edCompressedSize :: Natural
edCompressedSize = Zip64ExtraField -> Natural
z64efCompressedSize Zip64ExtraField
z64ef,
                edUncompressedSize :: Natural
edUncompressedSize = Zip64ExtraField -> Natural
z64efUncompressedSize Zip64ExtraField
z64ef,
                edOffset :: Natural
edOffset = Zip64ExtraField -> Natural
z64efOffset Zip64ExtraField
z64ef,
                edComment :: Maybe Text
edComment = if Word16
commentSize Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
0 then Maybe Text
forall a. Maybe a
Nothing else Maybe Text
comment,
                edExtraField :: Map Word16 ByteString
edExtraField = Map Word16 ByteString
extraField,
                edExternalFileAttrs :: Word32
edExternalFileAttrs = Word32
externalFileAttrs
              }
       in Maybe (EntrySelector, EntryDescription)
-> Get (Maybe (EntrySelector, EntryDescription))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (EntrySelector, EntryDescription)
 -> Get (Maybe (EntrySelector, EntryDescription)))
-> Maybe (EntrySelector, EntryDescription)
-> Get (Maybe (EntrySelector, EntryDescription))
forall a b. (a -> b) -> a -> b
$ (,EntryDescription
desc) (EntrySelector -> (EntrySelector, EntryDescription))
-> Maybe EntrySelector -> Maybe (EntrySelector, EntryDescription)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe Text
fileName Maybe Text -> (Text -> Maybe EntrySelector) -> Maybe EntrySelector
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> Maybe EntrySelector
forall (m :: * -> *). MonadThrow m => FilePath -> m EntrySelector
mkEntrySelector (FilePath -> Maybe EntrySelector)
-> (Text -> FilePath) -> Text -> Maybe EntrySelector
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack)

-- | Parse an extra-field.
getExtraField :: Get (Word16, ByteString)
getExtraField :: Get (Word16, ByteString)
getExtraField = do
  Word16
header <- Get Word16
getWord16le -- header id
  Word16
size <- Get Word16
getWord16le -- data size
  ByteString
body <- Int -> Get ByteString
getBytes (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
size) -- content
  (Word16, ByteString) -> Get (Word16, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word16
header, ByteString
body)

-- | Get signature. If the extracted data is not equal to the provided
-- signature, fail.
getSignature :: Word32 -> Get ()
getSignature :: Word32 -> Get ()
getSignature Word32
sig = do
  Word32
x <- Get Word32
getWord32le -- grab 4-byte signature
  Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word32
x Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
sig) (Get () -> Get ()) -> (FilePath -> Get ()) -> FilePath -> Get ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Get ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Get ()) -> FilePath -> Get ()
forall a b. (a -> b) -> a -> b
$
    FilePath
"Expected signature " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Word32 -> FilePath
forall a. Show a => a -> FilePath
show Word32
sig FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
", but got: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Word32 -> FilePath
forall a. Show a => a -> FilePath
show Word32
x

-- | Parse 'Zip64ExtraField' from its binary representation.
parseZip64ExtraField ::
  -- | What is read from central directory file header
  Zip64ExtraField ->
  -- | Actual binary representation
  ByteString ->
  -- | Result
  Zip64ExtraField
parseZip64ExtraField :: Zip64ExtraField -> ByteString -> Zip64ExtraField
parseZip64ExtraField dflt :: Zip64ExtraField
dflt@Zip64ExtraField {Natural
z64efOffset :: Natural
z64efCompressedSize :: Natural
z64efUncompressedSize :: Natural
z64efOffset :: Zip64ExtraField -> Natural
z64efCompressedSize :: Zip64ExtraField -> Natural
z64efUncompressedSize :: Zip64ExtraField -> Natural
..} ByteString
b =
  (FilePath -> Zip64ExtraField)
-> (Zip64ExtraField -> Zip64ExtraField)
-> Either FilePath Zip64ExtraField
-> Zip64ExtraField
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Zip64ExtraField -> FilePath -> Zip64ExtraField
forall a b. a -> b -> a
const Zip64ExtraField
dflt) Zip64ExtraField -> Zip64ExtraField
forall a. a -> a
id (Either FilePath Zip64ExtraField -> Zip64ExtraField)
-> (Get Zip64ExtraField -> Either FilePath Zip64ExtraField)
-> Get Zip64ExtraField
-> Zip64ExtraField
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Get Zip64ExtraField
 -> ByteString -> Either FilePath Zip64ExtraField)
-> ByteString
-> Get Zip64ExtraField
-> Either FilePath Zip64ExtraField
forall a b c. (a -> b -> c) -> b -> a -> c
flip Get Zip64ExtraField
-> ByteString -> Either FilePath Zip64ExtraField
forall a. Get a -> ByteString -> Either FilePath a
runGet ByteString
b (Get Zip64ExtraField -> Zip64ExtraField)
-> Get Zip64ExtraField -> Zip64ExtraField
forall a b. (a -> b) -> a -> b
$ do
    let ifsat :: Natural -> Get Natural
ifsat Natural
v =
          if Natural
v Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>= Natural
ffffffff
            then Word64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Natural) -> Get Word64 -> Get Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord64le
            else Natural -> Get Natural
forall (m :: * -> *) a. Monad m => a -> m a
return Natural
v
    Natural
uncompressed <- Natural -> Get Natural
ifsat Natural
z64efUncompressedSize -- uncompressed size
    Natural
compressed <- Natural -> Get Natural
ifsat Natural
z64efCompressedSize -- compressed size
    Natural
offset <- Natural -> Get Natural
ifsat Natural
z64efOffset -- offset of local file header
    Zip64ExtraField -> Get Zip64ExtraField
forall (m :: * -> *) a. Monad m => a -> m a
return (Natural -> Natural -> Natural -> Zip64ExtraField
Zip64ExtraField Natural
uncompressed Natural
compressed Natural
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 -> ByteString
makeZip64ExtraField HeaderType
headerType Zip64ExtraField {Natural
z64efOffset :: Natural
z64efCompressedSize :: Natural
z64efUncompressedSize :: Natural
z64efOffset :: Zip64ExtraField -> Natural
z64efCompressedSize :: Zip64ExtraField -> Natural
z64efUncompressedSize :: Zip64ExtraField -> Natural
..} = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ do
  Bool -> Put -> Put
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HeaderType
headerType HeaderType -> HeaderType -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderType
LocalHeader Bool -> Bool -> Bool
|| Natural
z64efUncompressedSize Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>= Natural
ffffffff) (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$
    Putter Word64
putWord64le (Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
z64efUncompressedSize) -- uncompressed size
  Bool -> Put -> Put
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HeaderType
headerType HeaderType -> HeaderType -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderType
LocalHeader Bool -> Bool -> Bool
|| Natural
z64efCompressedSize Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>= Natural
ffffffff) (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$
    Putter Word64
putWord64le (Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
z64efCompressedSize) -- compressed size
  Bool -> Put -> Put
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HeaderType
headerType HeaderType -> HeaderType -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderType
CentralDirHeader Bool -> Bool -> Bool
&& Natural
z64efOffset Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>= Natural
ffffffff) (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$
    Putter Word64
putWord64le (Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
z64efOffset) -- offset of local file header

-- | Create 'ByteString' representing an extra field.
putExtraField :: Map Word16 ByteString -> Put
putExtraField :: Map Word16 ByteString -> Put
putExtraField Map Word16 ByteString
m = [Word16] -> (Word16 -> Put) -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map Word16 ByteString -> [Word16]
forall k a. Map k a -> [k]
M.keys Map Word16 ByteString
m) ((Word16 -> Put) -> Put) -> (Word16 -> Put) -> Put
forall a b. (a -> b) -> a -> b
$ \Word16
headerId -> do
  let b :: ByteString
b = Int -> ByteString -> ByteString
B.take Int
0xffff (Map Word16 ByteString
m Map Word16 ByteString -> Word16 -> ByteString
forall k a. Ord k => Map k a -> k -> a
! Word16
headerId)
  Word16 -> Put
putWord16le Word16
headerId
  Word16 -> Put
putWord16le (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
b)
  Putter ByteString
putByteString ByteString
b

-- | Create 'ByteString' representing the entire central directory.
putCD :: Map EntrySelector EntryDescription -> Put
putCD :: Map EntrySelector EntryDescription -> Put
putCD Map EntrySelector EntryDescription
m = [EntrySelector] -> (EntrySelector -> Put) -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map EntrySelector EntryDescription -> [EntrySelector]
forall k a. Map k a -> [k]
M.keys Map EntrySelector EntryDescription
m) ((EntrySelector -> Put) -> Put) -> (EntrySelector -> Put) -> Put
forall a b. (a -> b) -> a -> b
$ \EntrySelector
s ->
  HeaderType -> EntrySelector -> EntryDescription -> Put
putHeader HeaderType
CentralDirHeader EntrySelector
s (Map EntrySelector EntryDescription
m Map EntrySelector EntryDescription
-> EntrySelector -> EntryDescription
forall k a. Ord k => Map k a -> k -> a
! EntrySelector
s)

-- | 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 -> EntrySelector -> EntryDescription -> Put
putHeader HeaderType
headerType EntrySelector
s entry :: EntryDescription
entry@EntryDescription {Natural
Maybe Text
Word32
Version
Map Word16 ByteString
UTCTime
CompressionMethod
edExternalFileAttrs :: Word32
edExtraField :: Map Word16 ByteString
edComment :: Maybe Text
edOffset :: Natural
edUncompressedSize :: Natural
edCompressedSize :: Natural
edCRC32 :: Word32
edModTime :: UTCTime
edCompression :: CompressionMethod
edVersionNeeded :: Version
edVersionMadeBy :: Version
edExternalFileAttrs :: EntryDescription -> Word32
edExtraField :: EntryDescription -> Map Word16 ByteString
edComment :: EntryDescription -> Maybe Text
edOffset :: EntryDescription -> Natural
edUncompressedSize :: EntryDescription -> Natural
edCompressedSize :: EntryDescription -> Natural
edCRC32 :: EntryDescription -> Word32
edModTime :: EntryDescription -> UTCTime
edCompression :: EntryDescription -> CompressionMethod
edVersionNeeded :: EntryDescription -> Version
edVersionMadeBy :: EntryDescription -> Version
..} = do
  let isCentralDirHeader :: Bool
isCentralDirHeader = HeaderType
headerType HeaderType -> HeaderType -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderType
CentralDirHeader
  Putter Word32
putWord32le (Word32 -> Word32 -> Bool -> Word32
forall a. a -> a -> Bool -> a
bool Word32
0x04034b50 Word32
0x02014b50 Bool
isCentralDirHeader)
  -- ↑ local/central file header signature
  Bool -> Put -> Put
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isCentralDirHeader (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$
    Word16 -> Put
putWord16le (Version -> Word16
fromVersion Version
edVersionMadeBy) -- version made by
  Word16 -> Put
putWord16le (Version -> Word16
fromVersion Version
edVersionNeeded) -- version needed to extract
  let entryName :: Text
entryName = EntrySelector -> Text
getEntryName EntrySelector
s
      rawName :: ByteString
rawName = Text -> ByteString
T.encodeUtf8 Text
entryName
      comment :: ByteString
comment = Int -> ByteString -> ByteString
B.take Int
0xffff (ByteString -> (Text -> ByteString) -> Maybe Text -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
B.empty Text -> ByteString
T.encodeUtf8 Maybe Text
edComment)
      unicode :: Bool
unicode =
        Text -> Bool
needsUnicode Text
entryName
          Bool -> Bool -> Bool
|| Bool -> (Text -> Bool) -> Maybe Text -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Text -> Bool
needsUnicode Maybe Text
edComment
      modTime :: MsDosTime
modTime = UTCTime -> MsDosTime
toMsDosTime UTCTime
edModTime
  Word16 -> Put
putWord16le (if Bool
unicode then Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
setBit Word16
0 Int
11 else Word16
0)
  -- ↑ general purpose bit-flag
  Word16 -> Put
putWord16le (CompressionMethod -> Word16
fromCompressionMethod CompressionMethod
edCompression) -- compression method
  Word16 -> Put
putWord16le (MsDosTime -> Word16
msDosTime MsDosTime
modTime) -- last mod file time
  Word16 -> Put
putWord16le (MsDosTime -> Word16
msDosDate MsDosTime
modTime) -- last mod file date
  Putter Word32
putWord32le Word32
edCRC32 -- CRC-32 checksum
  Putter Word32
putWord32le (Natural -> Word32
forall a b. (Integral a, Integral b, Bounded b) => a -> b
withSaturation Natural
edCompressedSize) -- compressed size
  Putter Word32
putWord32le (Natural -> Word32
forall a b. (Integral a, Integral b, Bounded b) => a -> b
withSaturation Natural
edUncompressedSize) -- uncompressed size
  Word16 -> Put
putWord16le (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
rawName) -- file name length
  let zip64ef :: ByteString
zip64ef =
        HeaderType -> Zip64ExtraField -> ByteString
makeZip64ExtraField
          HeaderType
headerType
          Zip64ExtraField :: Natural -> Natural -> Natural -> Zip64ExtraField
Zip64ExtraField
            { z64efUncompressedSize :: Natural
z64efUncompressedSize = Natural
edUncompressedSize,
              z64efCompressedSize :: Natural
z64efCompressedSize = Natural
edCompressedSize,
              z64efOffset :: Natural
z64efOffset = Natural
edOffset
            }
      extraField :: ByteString
extraField =
        Int -> ByteString -> ByteString
B.take Int
0xffff (ByteString -> ByteString)
-> (Map Word16 ByteString -> ByteString)
-> Map Word16 ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut (Put -> ByteString)
-> (Map Word16 ByteString -> Put)
-> Map Word16 ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Word16 ByteString -> Put
putExtraField (Map Word16 ByteString -> ByteString)
-> Map Word16 ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
          if EntryDescription -> Bool
needsZip64 EntryDescription
entry
            then Word16
-> ByteString -> Map Word16 ByteString -> Map Word16 ByteString
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Word16
1 ByteString
zip64ef Map Word16 ByteString
edExtraField
            else Map Word16 ByteString
edExtraField
  Word16 -> Put
putWord16le (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
extraField) -- extra field length
  Bool -> Put -> Put
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isCentralDirHeader (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ do
    Word16 -> Put
putWord16le (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
comment) -- file comment length
    Word16 -> Put
putWord16le Word16
0 -- disk number start
    Word16 -> Put
putWord16le Word16
0 -- internal file attributes
    Putter Word32
putWord32le Word32
edExternalFileAttrs -- external file attributes
    Putter Word32
putWord32le (Natural -> Word32
forall a b. (Integral a, Integral b, Bounded b) => a -> b
withSaturation Natural
edOffset) -- relative offset of local header
  Putter ByteString
putByteString ByteString
rawName -- file name (variable size)
  Putter ByteString
putByteString ByteString
extraField -- extra field (variable size)
  Bool -> Put -> Put
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isCentralDirHeader (Putter ByteString
putByteString ByteString
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 :: Natural -> Natural -> Natural -> Put
putZip64ECD Natural
totalCount Natural
cdSize Natural
cdOffset = do
  Putter Word32
putWord32le Word32
0x06064b50 -- zip64 end of central dir signature
  Putter Word64
putWord64le Word64
44 -- size of zip64 end of central dir record
  Word16 -> Put
putWord16le (Version -> Word16
fromVersion Version
zipVersion) -- version made by
  Word16 -> Put
putWord16le (Version -> Word16
fromVersion (Version -> Word16) -> Version -> Word16
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe CompressionMethod -> Version
getZipVersion Bool
True Maybe CompressionMethod
forall a. Maybe a
Nothing)
  -- ↑ version needed to extract
  Putter Word32
putWord32le Word32
0 -- number of this disk
  Putter Word32
putWord32le Word32
0 -- number of the disk with the start of the central directory
  Putter Word64
putWord64le (Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
totalCount) -- total number of entries (this disk)
  Putter Word64
putWord64le (Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
totalCount) -- total number of entries
  Putter Word64
putWord64le (Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
cdSize) -- size of the central directory
  Putter Word64
putWord64le (Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
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 :: Natural -> Put
putZip64ECDLocator Natural
ecdOffset = do
  Putter Word32
putWord32le Word32
0x07064b50 -- zip64 end of central dir locator signature
  Putter Word32
putWord32le Word32
0 -- number of the disk with the start of the zip64 end of
  -- central directory
  Putter Word64
putWord64le (Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
ecdOffset) -- relative offset of the zip64 end
  -- of central directory record
  Putter Word32
putWord32le Word32
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 :: Get ArchiveDescription
getECD = do
  Word32
sig <- Get Word32
getWord32le -- end of central directory signature
  let zip64 :: Bool
zip64 = Word32
sig Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x06064b50
  Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word32
sig Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x06054b50 Bool -> Bool -> Bool
|| Word32
sig Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x06064b50) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
    FilePath -> Get ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"Cannot locate end of central directory"
  Maybe Word64
zip64size <-
    if Bool
zip64
      then do
        Word64
x <- Get Word64
getWord64le -- size of zip64 end of central directory record
        Int -> Get ()
skip Int
2 -- version made by
        Int -> Get ()
skip Int
2 -- version needed to extract
        Maybe Word64 -> Get (Maybe Word64)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
x)
      else Maybe Word64 -> Get (Maybe Word64)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Word64
forall a. Maybe a
Nothing
  Word32
thisDisk <- Get Word32 -> Get Word32 -> Bool -> Get Word32
forall a. a -> a -> Bool -> a
bool (Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Word32) -> Get Word16 -> Get Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16le) Get Word32
getWord32le Bool
zip64
  -- ↑ number of this disk
  Word32
cdDisk <- Get Word32 -> Get Word32 -> Bool -> Get Word32
forall a. a -> a -> Bool -> a
bool (Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Word32) -> Get Word16 -> Get Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16le) Get Word32
getWord32le Bool
zip64
  -- ↑ number of the disk with the start of the central directory
  Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word32
thisDisk Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 Bool -> Bool -> Bool
&& Word32
cdDisk Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
    FilePath -> Get ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"No support for multi-disk archives"
  Int -> Get ()
skip (Int -> Int -> Bool -> Int
forall a. a -> a -> Bool -> a
bool Int
2 Int
8 Bool
zip64)
  -- ↑ total number of entries in the central directory on this disk
  Int -> Get ()
skip (Int -> Int -> Bool -> Int
forall a. a -> a -> Bool -> a
bool Int
2 Int
8 Bool
zip64)
  -- ↑ total number of entries in the central directory
  Word64
cdSize <- Get Word64 -> Get Word64 -> Bool -> Get Word64
forall a. a -> a -> Bool -> a
bool (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word64) -> Get Word32 -> Get Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32le) Get Word64
getWord64le Bool
zip64
  -- ↑ size of the central directory
  Word64
cdOffset <- Get Word64 -> Get Word64 -> Bool -> Get Word64
forall a. a -> a -> Bool -> a
bool (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word64) -> Get Word32 -> Get Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32le) Get Word64
getWord64le Bool
zip64
  -- ↑ offset of start of central directory with respect to the starting
  -- disk number
  Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
zip64 (Get () -> Get ()) -> (Word64 -> Get ()) -> Word64 -> Get ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Get ()
skip (Int -> Get ()) -> (Word64 -> Int) -> Word64 -> Get ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Get ()) -> Word64 -> Get ()
forall a b. (a -> b) -> a -> b
$ Maybe Word64 -> Word64
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Word64
zip64size Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
4 -- obviously
  Word16
commentSize <- Get Word16
getWord16le -- .ZIP file comment length
  Maybe Text
comment <- Bool -> ByteString -> Maybe Text
decodeText Bool
True (ByteString -> Maybe Text) -> Get ByteString -> Get (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getBytes (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
commentSize)
  -- ↑ archive comment, it's uncertain how we should decide on encoding here
  ArchiveDescription -> Get ArchiveDescription
forall (m :: * -> *) a. Monad m => a -> m a
return
    ArchiveDescription :: Maybe Text -> Natural -> Natural -> ArchiveDescription
ArchiveDescription
      { adComment :: Maybe Text
adComment = if Word16
commentSize Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
0 then Maybe Text
forall a. Maybe a
Nothing else Maybe Text
comment,
        adCDOffset :: Natural
adCDOffset = Word64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
cdOffset,
        adCDSize :: Natural
adCDSize = Word64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
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 :: Natural -> Natural -> Natural -> Maybe Text -> Put
putECD Natural
totalCount Natural
cdSize Natural
cdOffset Maybe Text
mcomment = do
  Putter Word32
putWord32le Word32
0x06054b50 -- end of central dir signature
  Word16 -> Put
putWord16le Word16
0 -- number of this disk
  Word16 -> Put
putWord16le Word16
0 -- number of the disk with the start of the central directory
  Word16 -> Put
putWord16le (Natural -> Word16
forall a b. (Integral a, Integral b, Bounded b) => a -> b
withSaturation Natural
totalCount)
  -- ↑ total number of entries on this disk
  Word16 -> Put
putWord16le (Natural -> Word16
forall a b. (Integral a, Integral b, Bounded b) => a -> b
withSaturation Natural
totalCount) -- total number of entries
  Putter Word32
putWord32le (Natural -> Word32
forall a b. (Integral a, Integral b, Bounded b) => a -> b
withSaturation Natural
cdSize) -- size of central directory
  Putter Word32
putWord32le (Natural -> Word32
forall a b. (Integral a, Integral b, Bounded b) => a -> b
withSaturation Natural
cdOffset) -- offset of start of central directory
  let comment :: ByteString
comment = ByteString -> (Text -> ByteString) -> Maybe Text -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
B.empty Text -> ByteString
T.encodeUtf8 Maybe Text
mcomment
  Word16 -> Put
putWord16le (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
comment)
  Putter ByteString
putByteString ByteString
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 :: FilePath -> Handle -> IO (Maybe Integer)
locateECD FilePath
path Handle
h = IO (Maybe Integer)
sizeCheck
  where
    sizeCheck :: IO (Maybe Integer)
sizeCheck = do
      Integer
fsize <- Handle -> IO Integer
hFileSize Handle
h
      let limit :: Integer
limit = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
0 (Integer
fsize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
0xffff Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
22)
      if Integer
fsize Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
22
        then Maybe Integer -> IO (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing
        else Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
SeekFromEnd (-Integer
22) IO () -> IO (Maybe Integer) -> IO (Maybe Integer)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Integer -> IO (Maybe Integer)
loop Integer
limit
    loop :: Integer -> IO (Maybe Integer)
loop Integer
limit = do
      Word32
sig <- Get Word32 -> Int -> IO Word32
forall b. Get b -> Int -> IO b
getNum Get Word32
getWord32le Int
4
      Integer
pos <- Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
subtract Integer
4 (Integer -> Integer) -> IO Integer -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Integer
hTell Handle
h
      let again :: IO (Maybe Integer)
again = Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek (Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) IO () -> IO (Maybe Integer) -> IO (Maybe Integer)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Integer -> IO (Maybe Integer)
loop Integer
limit
          done :: Bool
done = Integer
pos Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
limit
      if Word32
sig Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x06054b50
        then do
          Maybe Integer
result <-
            MaybeT IO Integer -> IO (Maybe Integer)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO Integer -> IO (Maybe Integer))
-> MaybeT IO Integer -> IO (Maybe Integer)
forall a b. (a -> b) -> a -> b
$
              IO (Maybe Integer) -> MaybeT IO Integer
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Integer -> IO (Maybe Integer)
checkComment Integer
pos)
                MaybeT IO Integer
-> (Integer -> MaybeT IO Integer) -> MaybeT IO Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Maybe Integer) -> MaybeT IO Integer
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe Integer) -> MaybeT IO Integer)
-> (Integer -> IO (Maybe Integer)) -> Integer -> MaybeT IO Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> IO (Maybe Integer)
checkCDSig
                MaybeT IO Integer
-> (Integer -> MaybeT IO Integer) -> MaybeT IO Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Maybe Integer) -> MaybeT IO Integer
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe Integer) -> MaybeT IO Integer)
-> (Integer -> IO (Maybe Integer)) -> Integer -> MaybeT IO Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> IO (Maybe Integer)
checkZip64
          case Maybe Integer
result of
            Maybe Integer
Nothing -> IO (Maybe Integer)
-> IO (Maybe Integer) -> Bool -> IO (Maybe Integer)
forall a. a -> a -> Bool -> a
bool IO (Maybe Integer)
again (Maybe Integer -> IO (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing) Bool
done
            Just Integer
ecd -> Maybe Integer -> IO (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
ecd)
        else IO (Maybe Integer)
-> IO (Maybe Integer) -> Bool -> IO (Maybe Integer)
forall a. a -> a -> Bool -> a
bool IO (Maybe Integer)
again (Maybe Integer -> IO (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing) Bool
done
    checkComment :: Integer -> IO (Maybe Integer)
checkComment Integer
pos = do
      Integer
size <- Handle -> IO Integer
hFileSize Handle
h
      Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek (Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
20)
      Integer
l <- Word16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Integer) -> IO Word16 -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16 -> Int -> IO Word16
forall b. Get b -> Int -> IO b
getNum Get Word16
getWord16le Int
2
      Maybe Integer -> IO (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Integer -> IO (Maybe Integer))
-> Maybe Integer -> IO (Maybe Integer)
forall a b. (a -> b) -> a -> b
$
        if Integer
l Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
22 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
size Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
pos
          then Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
pos
          else Maybe Integer
forall a. Maybe a
Nothing
    checkCDSig :: Integer -> IO (Maybe Integer)
checkCDSig Integer
pos = do
      Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek (Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
16)
      Integer
sigPos <- Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Integer) -> IO Word32 -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32 -> Int -> IO Word32
forall b. Get b -> Int -> IO b
getNum Get Word32
getWord32le Int
4
      if Integer
sigPos Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0xffffffff -- Zip64 is probably used
        then Maybe Integer -> IO (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
pos)
        else do
          Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek Integer
sigPos
          Word32
cdSig <- Get Word32 -> Int -> IO Word32
forall b. Get b -> Int -> IO b
getNum Get Word32
getWord32le Int
4
          Maybe Integer -> IO (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Integer -> IO (Maybe Integer))
-> Maybe Integer -> IO (Maybe Integer)
forall a b. (a -> b) -> a -> b
$
            if Word32
cdSig Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x02014b50
              Bool -> Bool -> Bool
||
              -- ↑ normal case: central directory file header signature
              Word32
cdSig Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x06064b50
              Bool -> Bool -> Bool
||
              -- ↑ happens when zip 64 archive is empty
              Word32
cdSig Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x06054b50
              then -- ↑ happens when vanilla archive is empty
                Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
pos
              else Maybe Integer
forall a. Maybe a
Nothing
    checkZip64 :: Integer -> IO (Maybe Integer)
checkZip64 Integer
pos =
      if Integer
pos Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
20
        then Maybe Integer -> IO (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
pos)
        else do
          Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek (Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
20)
          Word32
zip64locatorSig <- Get Word32 -> Int -> IO Word32
forall b. Get b -> Int -> IO b
getNum Get Word32
getWord32le Int
4
          if Word32
zip64locatorSig Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x07064b50
            then do
              Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek (Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
12)
              Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer)
-> (Word64 -> Integer) -> Word64 -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Maybe Integer) -> IO Word64 -> IO (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64 -> Int -> IO Word64
forall b. Get b -> Int -> IO b
getNum Get Word64
getWord64le Int
8
            else Maybe Integer -> IO (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
pos)
    getNum :: Get b -> Int -> IO b
getNum Get b
f Int
n = do
      Either FilePath b
result <- Get b -> ByteString -> Either FilePath b
forall a. Get a -> ByteString -> Either FilePath a
runGet Get b
f (ByteString -> Either FilePath b)
-> IO ByteString -> IO (Either FilePath b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> Int -> IO ByteString
B.hGet Handle
h Int
n
      case Either FilePath b
result of
        Left FilePath
msg -> ZipException -> IO b
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (FilePath -> FilePath -> ZipException
ParsingFailed FilePath
path FilePath
msg)
        Right b
val -> b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
val

----------------------------------------------------------------------------
-- Helpers

-- | Rename an entry (key) in a 'Map'.
renameKey :: Ord k => k -> k -> Map k a -> Map k a
renameKey :: k -> k -> Map k a -> Map k a
renameKey k
ok k
nk Map k a
m = case k -> Map k a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
ok Map k a
m of
  Maybe a
Nothing -> Map k a
m
  Just a
e -> k -> a -> Map k a -> Map k a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
nk a
e (k -> Map k a -> Map k a
forall k a. Ord k => k -> Map k a -> Map k a
M.delete k
ok Map k a
m)

-- | Like 'fromIntegral', but with saturation when converting to bounded
-- types.
withSaturation :: forall a b. (Integral a, Integral b, Bounded b) => a -> b
withSaturation :: a -> b
withSaturation a
x =
  if (a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x :: Integer) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> (b -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
bound :: Integer)
    then b
bound
    else a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x
  where
    bound :: b
bound = b
forall a. Bounded a => a
maxBound :: b

-- | Determine the target entry of an action.
targetEntry :: PendingAction -> Maybe EntrySelector
targetEntry :: PendingAction -> Maybe EntrySelector
targetEntry (SinkEntry CompressionMethod
_ ConduitT () ByteString (ResourceT IO) ()
_ EntrySelector
s) = EntrySelector -> Maybe EntrySelector
forall a. a -> Maybe a
Just EntrySelector
s
targetEntry (CopyEntry FilePath
_ EntrySelector
_ EntrySelector
s) = EntrySelector -> Maybe EntrySelector
forall a. a -> Maybe a
Just EntrySelector
s
targetEntry (RenameEntry EntrySelector
s EntrySelector
_) = EntrySelector -> Maybe EntrySelector
forall a. a -> Maybe a
Just EntrySelector
s
targetEntry (DeleteEntry EntrySelector
s) = EntrySelector -> Maybe EntrySelector
forall a. a -> Maybe a
Just EntrySelector
s
targetEntry (Recompress CompressionMethod
_ EntrySelector
s) = EntrySelector -> Maybe EntrySelector
forall a. a -> Maybe a
Just EntrySelector
s
targetEntry (SetEntryComment Text
_ EntrySelector
s) = EntrySelector -> Maybe EntrySelector
forall a. a -> Maybe a
Just EntrySelector
s
targetEntry (DeleteEntryComment EntrySelector
s) = EntrySelector -> Maybe EntrySelector
forall a. a -> Maybe a
Just EntrySelector
s
targetEntry (SetModTime UTCTime
_ EntrySelector
s) = EntrySelector -> Maybe EntrySelector
forall a. a -> Maybe a
Just EntrySelector
s
targetEntry (AddExtraField Word16
_ ByteString
_ EntrySelector
s) = EntrySelector -> Maybe EntrySelector
forall a. a -> Maybe a
Just EntrySelector
s
targetEntry (DeleteExtraField Word16
_ EntrySelector
s) = EntrySelector -> Maybe EntrySelector
forall a. a -> Maybe a
Just EntrySelector
s
targetEntry (SetExternalFileAttributes Word32
_ EntrySelector
s) = EntrySelector -> Maybe EntrySelector
forall a. a -> Maybe a
Just EntrySelector
s
targetEntry (SetArchiveComment Text
_) = Maybe EntrySelector
forall a. Maybe a
Nothing
targetEntry PendingAction
DeleteArchiveComment = Maybe EntrySelector
forall a. Maybe a
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 :: Bool -> ByteString -> Maybe Text
decodeText Bool
False = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> (ByteString -> Text) -> ByteString -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeCP437
decodeText Bool
True = (UnicodeException -> Maybe Text)
-> (Text -> Maybe Text)
-> Either UnicodeException Text
-> Maybe Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Text -> UnicodeException -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing) Text -> Maybe Text
forall a. a -> Maybe a
Just (Either UnicodeException Text -> Maybe Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
T.decodeUtf8'

-- | Detect if the given text needs newer Unicode-aware features to be
-- properly encoded in the archive.
needsUnicode :: Text -> Bool
needsUnicode :: Text -> Bool
needsUnicode = Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
validCP437
  where
    validCP437 :: Char -> Bool
validCP437 Char
x = Char -> Int
ord Char
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
127

-- | Convert numeric representation (as per the .ZIP specification) of
-- version into 'Version'.
toVersion :: Word16 -> Version
toVersion :: Word16 -> Version
toVersion Word16
x = [Int] -> Version
makeVersion [Int
major, Int
minor]
  where
    (Int
major, Int
minor) = Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
quotRem (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int) -> Word16 -> Int
forall a b. (a -> b) -> a -> b
$ Word16
x Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0x00ff) Int
10

-- | Covert 'Version' to its numeric representation as per the .ZIP
-- specification.
fromVersion :: Version -> Word16
fromVersion :: Version -> Word16
fromVersion Version
v = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((ZIP_OS `shiftL` 8) .|. (major Int -> Int -> Int
forall a. Num a => a -> a -> a
* 10 + minor))
  where
    (Int
major, Int
minor) =
      case Version -> [Int]
versionBranch Version
v of
        Int
v0 : Int
v1 : [Int]
_ -> (Int
v0, Int
v1)
        Int
v0 : [Int]
_ -> (Int
v0, Int
0)
        [] -> (Int
0, Int
0)

-- | Get the compression method form its numeric representation.
toCompressionMethod :: Word16 -> Maybe CompressionMethod
toCompressionMethod :: Word16 -> Maybe CompressionMethod
toCompressionMethod Word16
0 = CompressionMethod -> Maybe CompressionMethod
forall a. a -> Maybe a
Just CompressionMethod
Store
toCompressionMethod Word16
8 = CompressionMethod -> Maybe CompressionMethod
forall a. a -> Maybe a
Just CompressionMethod
Deflate
toCompressionMethod Word16
12 = CompressionMethod -> Maybe CompressionMethod
forall a. a -> Maybe a
Just CompressionMethod
BZip2
toCompressionMethod Word16
93 = CompressionMethod -> Maybe CompressionMethod
forall a. a -> Maybe a
Just CompressionMethod
Zstd
toCompressionMethod Word16
_ = Maybe CompressionMethod
forall a. Maybe a
Nothing

-- | Convert 'CompressionMethod' to its numeric representation as per the
-- .ZIP specification.
fromCompressionMethod :: CompressionMethod -> Word16
fromCompressionMethod :: CompressionMethod -> Word16
fromCompressionMethod CompressionMethod
Store = Word16
0
fromCompressionMethod CompressionMethod
Deflate = Word16
8
fromCompressionMethod CompressionMethod
BZip2 = Word16
12
fromCompressionMethod CompressionMethod
Zstd = Word16
93

-- | Check if an entry with these parameters needs the Zip64 extension.
needsZip64 :: EntryDescription -> Bool
needsZip64 :: EntryDescription -> Bool
needsZip64 EntryDescription {Natural
Maybe Text
Word32
Version
Map Word16 ByteString
UTCTime
CompressionMethod
edExternalFileAttrs :: Word32
edExtraField :: Map Word16 ByteString
edComment :: Maybe Text
edOffset :: Natural
edUncompressedSize :: Natural
edCompressedSize :: Natural
edCRC32 :: Word32
edModTime :: UTCTime
edCompression :: CompressionMethod
edVersionNeeded :: Version
edVersionMadeBy :: Version
edExternalFileAttrs :: EntryDescription -> Word32
edExtraField :: EntryDescription -> Map Word16 ByteString
edComment :: EntryDescription -> Maybe Text
edOffset :: EntryDescription -> Natural
edUncompressedSize :: EntryDescription -> Natural
edCompressedSize :: EntryDescription -> Natural
edCRC32 :: EntryDescription -> Word32
edModTime :: EntryDescription -> UTCTime
edCompression :: EntryDescription -> CompressionMethod
edVersionNeeded :: EntryDescription -> Version
edVersionMadeBy :: EntryDescription -> Version
..} =
  (Natural -> Bool) -> [Natural] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
    (Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>= Natural
ffffffff)
    [Natural
edOffset, Natural
edCompressedSize, Natural
edUncompressedSize]

-- | 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 :: Bool -> Maybe CompressionMethod -> Version
getZipVersion Bool
zip64 Maybe CompressionMethod
m = Version -> Version -> Version
forall a. Ord a => a -> a -> a
max Version
zip64ver Version
mver
  where
    zip64ver :: Version
zip64ver = [Int] -> Version
makeVersion (if Bool
zip64 then [Int
4, Int
5] else [Int
2, Int
0])
    mver :: Version
mver = [Int] -> Version
makeVersion ([Int] -> Version) -> [Int] -> Version
forall a b. (a -> b) -> a -> b
$ case Maybe CompressionMethod
m of
      Maybe CompressionMethod
Nothing -> [Int
2, Int
0]
      Just CompressionMethod
Store -> [Int
2, Int
0]
      Just CompressionMethod
Deflate -> [Int
2, Int
0]
      Just CompressionMethod
BZip2 -> [Int
4, Int
6]
      Just CompressionMethod
Zstd -> [Int
6, Int
3]

-- | Return a decompressing 'Conduit' corresponding to the given compression
-- method.
decompressingPipe ::
  (PrimMonad m, MonadThrow m, MonadResource m) =>
  CompressionMethod ->
  ConduitT ByteString ByteString m ()
decompressingPipe :: CompressionMethod -> ConduitT ByteString ByteString m ()
decompressingPipe CompressionMethod
Store = (ByteString -> ConduitT ByteString ByteString m ())
-> ConduitT ByteString ByteString m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
C.awaitForever ByteString -> ConduitT ByteString ByteString m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
C.yield
decompressingPipe CompressionMethod
Deflate = WindowBits -> ConduitT ByteString ByteString m ()
forall (m :: * -> *).
(PrimMonad m, MonadThrow m) =>
WindowBits -> ConduitT ByteString ByteString m ()
Z.decompress (WindowBits -> ConduitT ByteString ByteString m ())
-> WindowBits -> ConduitT ByteString ByteString m ()
forall a b. (a -> b) -> a -> b
$ Int -> WindowBits
Z.WindowBits (-Int
15)

#ifdef ENABLE_BZIP2
decompressingPipe CompressionMethod
BZip2 = ConduitT ByteString ByteString m ()
forall (m :: * -> *).
MonadResource m =>
ConduitT ByteString ByteString m ()
BZ.bunzip2
#else
decompressingPipe BZip2 = throwM BZip2Unsupported
#endif

#ifdef ENABLE_ZSTD
decompressingPipe CompressionMethod
Zstd = ConduitT ByteString ByteString m ()
forall (m :: * -> *).
MonadIO m =>
ConduitT ByteString ByteString m ()
Zstandard.decompress
#else
decompressingPipe Zstd = throwM ZstdUnsupported
#endif

-- | A sink that calculates the CRC32 check sum for an incoming stream.
crc32Sink :: ConduitT ByteString Void (ResourceT IO) Word32
crc32Sink :: Sink ByteString (ResourceT IO) Word32
crc32Sink = (Word32 -> ByteString -> Word32)
-> Word32 -> Sink ByteString (ResourceT IO) Word32
forall (m :: * -> *) b a o.
Monad m =>
(b -> a -> b) -> b -> ConduitT a o m b
CL.fold Word32 -> ByteString -> Word32
forall a. CRC32 a => Word32 -> a -> Word32
crc32Update Word32
0

-- | Convert 'UTCTime' to the MS-DOS time format.
toMsDosTime :: UTCTime -> MsDosTime
toMsDosTime :: UTCTime -> MsDosTime
toMsDosTime UTCTime {DiffTime
Day
utctDay :: UTCTime -> Day
utctDayTime :: UTCTime -> DiffTime
utctDayTime :: DiffTime
utctDay :: Day
..} = Word16 -> Word16 -> MsDosTime
MsDosTime Word16
dosDate Word16
dosTime
  where
    dosTime :: Word16
dosTime = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
seconds Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftL Int
minutes Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftL Int
hours Int
11)
    dosDate :: Word16
dosDate = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
day Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftL Int
month Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftL Int
year Int
9)
    seconds :: Int
seconds =
      let (MkFixed Integer
x) = TimeOfDay -> Fixed E12
todSec TimeOfDay
tod
       in Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
x Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`quot` Integer
2000000000000)
    minutes :: Int
minutes = TimeOfDay -> Int
todMin TimeOfDay
tod
    hours :: Int
hours = TimeOfDay -> Int
todHour TimeOfDay
tod
    tod :: TimeOfDay
tod = DiffTime -> TimeOfDay
timeToTimeOfDay DiffTime
utctDayTime
    year :: Int
year = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
year' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1980
    (Integer
year', Int
month, Int
day) = Day -> (Integer, Int, Int)
toGregorian Day
utctDay

-- | Convert MS-DOS date-time to 'UTCTime'.
fromMsDosTime :: MsDosTime -> UTCTime
fromMsDosTime :: MsDosTime -> UTCTime
fromMsDosTime MsDosTime {Word16
msDosTime :: Word16
msDosDate :: Word16
msDosTime :: MsDosTime -> Word16
msDosDate :: MsDosTime -> Word16
..} =
  Day -> DiffTime -> UTCTime
UTCTime
    (Integer -> Int -> Int -> Day
fromGregorian Integer
year Int
month Int
day)
    (Integer -> DiffTime
secondsToDiffTime (Integer -> DiffTime) -> Integer -> DiffTime
forall a b. (a -> b) -> a -> b
$ Integer
hours Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
3600 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
minutes Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
60 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
seconds)
  where
    seconds :: Integer
seconds = Word16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Integer) -> Word16 -> Integer
forall a b. (a -> b) -> a -> b
$ Word16
2 Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
* (Word16
msDosTime Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0x1f)
    minutes :: Integer
minutes = Word16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
shiftR Word16
msDosTime Int
5 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0x3f)
    hours :: Integer
hours = Word16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
shiftR Word16
msDosTime Int
11 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0x1f)
    day :: Int
day = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
msDosDate Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0x1f)
    month :: Int
month = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int) -> Word16 -> Int
forall a b. (a -> b) -> a -> b
$ Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
shiftR Word16
msDosDate Int
5 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0x0f
    year :: Integer
year = Integer
1980 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Word16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
shiftR Word16
msDosDate Int
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     = 200
ffffffff = 5000
#else
ffff :: Natural
ffff     = Natural
0xffff
ffffffff :: Natural
ffffffff = Natural
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 :: Word32
defaultFileMode = CMode -> Word32
Unix.fromFileMode CMode
0o600
#endif