content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE TupleSections #-}
  
  -- |
  -- Module      :  Codec.Archive.Zip.Internal
  -- Copyright   :  © 2016–present Mark Karpov
  -- License     :  BSD 3 clause
  --
  -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
  -- Stability   :  experimental
  -- Portability :  portable
  --
  -- Low-level, non-public types and operations.
  module Codec.Archive.Zip.Internal where
  
  import Codec.Archive.Zip.CP437 (decodeCP437)
  import Codec.Archive.Zip.Internal.Type
  import Conduit (PrimMonad)
  import Control.Applicative (many, (<|>))
  import Control.Exception (bracketOnError, catchJust)
  import Control.Monad
  import Control.Monad.Catch (MonadThrow (..))
  import Control.Monad.Trans.Maybe
  import Control.Monad.Trans.Resource (MonadResource, ResourceT)
  import Data.Bits
  import Data.Bool (bool)
  import Data.ByteString (ByteString)
  import Data.ByteString qualified as B
  import Data.Char (ord)
  import Data.Conduit (ConduitT, ZipSink (..), (.|))
  import Data.Conduit qualified as C
  import Data.Conduit.Binary qualified as CB
  import Data.Conduit.List qualified as CL
  import Data.Conduit.Zlib qualified as Z
  import Data.Digest.CRC32 (crc32Update)
  import Data.Fixed (Fixed (..))
  import Data.Map.Strict (Map)
  import Data.Map.Strict qualified as M
  import Data.Maybe (catMaybes, fromJust, isNothing)
  import Data.Sequence (Seq, (><), (|>))
  import Data.Sequence qualified as S
  import Data.Serialize
  import Data.Set qualified as E
  import Data.Text (Text)
  import Data.Text qualified as T
  import Data.Text.Encoding qualified as T
  import Data.Time
  import Data.Version
  import Data.Void
  import Data.Word (Word16, Word32)
  import Numeric.Natural (Natural)
  import System.Directory
  import System.FilePath
  import System.IO
  import System.IO.Error (isDoesNotExistError)
  
  #ifndef mingw32_HOST_OS
  import qualified Codec.Archive.Zip.Unix as Unix
  #endif
  
  #ifdef ENABLE_BZIP2
  import qualified Data.Conduit.BZlib as BZ
  #endif
  
  #ifdef ENABLE_ZSTD
  import qualified Data.Conduit.Zstd as Zstandard
  #endif
  
  #if !MIN_VERSION_base(4,20,0)
  import Data.Foldable (foldl')
  #endif
  
  ----------------------------------------------------------------------------
  -- Data types
  
  -- | The sum type describes all possible actions that can be performed on an
  -- archive.
  data PendingAction
    = -- | Add an entry given its 'Source'
      SinkEntry
        CompressionMethod
        (ConduitT () ByteString (ResourceT IO) ())
        EntrySelector
    | -- | Add an entry given its content as a string ByteString.
      StrictEntry CompressionMethod ByteString EntrySelector
    | -- | Copy an entry from another archive without re-compression
      CopyEntry FilePath EntrySelector EntrySelector
    | -- | Change the name of the entry inside archive
      RenameEntry EntrySelector EntrySelector
    | -- | Delete an entry from archive
      DeleteEntry EntrySelector
    | -- | Change the compression method on an entry
      Recompress CompressionMethod EntrySelector
    | -- | Set the comment for a particular entry
      SetEntryComment Text EntrySelector
    | -- | Delete theh comment of a particular entry
      DeleteEntryComment EntrySelector
    | -- | Set the modification time of a particular entry
      SetModTime UTCTime EntrySelector
    | -- | Add an extra field to the specified entry
      AddExtraField Word16 ByteString EntrySelector
    | -- | Delete an extra filed of the specified entry
      DeleteExtraField Word16 EntrySelector
    | -- | Set the comment for the entire archive
      SetArchiveComment Text
    | -- | Delete the comment of the entire archive
      DeleteArchiveComment
    | -- | Set an external file attribute for the specified entry
      SetExternalFileAttributes Word32 EntrySelector
  
  -- | A collection of maps describing how to produce entries in the resulting
  -- archive.
  data ProducingActions = ProducingActions
    { paCopyEntry :: Map FilePath (Map EntrySelector EntrySelector),
      paSinkEntry :: Map EntrySelector (EntryOrigin, ConduitT () ByteString (ResourceT IO) ())
    }
  
  -- | A collection of editing actions, that is, actions that modify already
  -- existing entries.
  data EditingActions = EditingActions
    { eaCompression :: Map EntrySelector CompressionMethod,
      eaEntryComment :: Map EntrySelector Text,
      eaDeleteComment :: Map EntrySelector (),
      eaModTime :: Map EntrySelector UTCTime,
      eaExtraField :: Map EntrySelector (Map Word16 ByteString),
      eaDeleteField :: Map EntrySelector (Map Word16 ()),
      eaExtFileAttr :: Map EntrySelector Word32
    }
  
  -- | The origin of entries that can be streamed into archive.
  data EntryOrigin
    = GenericOrigin
    | StrictOrigin Natural -- uncompressed length
    | Borrowed EntryDescription
    deriving (Eq)
  
  -- | The type of the file header: local or central directory.
  data HeaderType
    = LocalHeader EntryOrigin
    | CentralDirHeader
    deriving (Eq)
  
  -- | The data descriptor representation.
  data DataDescriptor = DataDescriptor
    { ddCRC32 :: Word32,
      ddCompressedSize :: Natural,
      ddUncompressedSize :: Natural
    }
  
  -- | A temporary data structure to hold Zip64 extra data field information.
  data Zip64ExtraField = Zip64ExtraField
    { z64efUncompressedSize :: Natural,
      z64efCompressedSize :: Natural,
      z64efOffset :: Natural
    }
  
  -- | MS-DOS date-time: a pair of 'Word16' (date, time) with the following
  -- structure:
  --
  -- > DATE bit     0 - 4           5 - 8           9 - 15
  -- >      value   day (1 - 31)    month (1 - 12)  years from 1980
  -- > TIME bit     0 - 4           5 - 10          11 - 15
  -- >      value   seconds*        minute          hour
  -- >              *stored in two-second increments
  data MsDosTime = MsDosTime
    { msDosDate :: Word16,
      msDosTime :: Word16
    }
  
  ----------------------------------------------------------------------------
  -- Constants
  
  -- | “Version created by” to specify when writing archive data.
  zipVersion :: Version
  zipVersion = Version [6, 3] []
  
  ----------------------------------------------------------------------------
  -- Higher-level operations
  
  -- | Scan the central directory of an archive and return its description
  -- 'ArchiveDescription' as well as a collection of its entries.
  --
  -- This operation may fail with:
  --
  --     * @isAlreadyInUseError@ if the file is already open and cannot be
  --     reopened;
  --
  --     * @isDoesNotExistError@ if the file does not exist;
  --
  --     * @isPermissionError@ if the user does not have permission to open
  --     the file;
  --
  --     * 'ParsingFailed' when specified archive is something this library
  --     cannot parse (this includes multi-disk archives, for example).
  --
  -- Please note that entries with invalid (non-portable) file names may be
  -- missing in the list of entries. Files that are compressed with
  -- unsupported compression methods are skipped as well. Also, if several
  -- entries would collide on some operating systems (such as Windows, because
  -- of its case-insensitivity), only one of them will be available, because
  -- 'EntrySelector' is case-insensitive. These are the consequences of the
  -- design decision to make it impossible to create non-portable archives
  -- with this library.
  scanArchive ::
    -- | Path to archive to scan
    FilePath ->
    IO (ArchiveDescription, Map EntrySelector EntryDescription)
  scanArchive path = withBinaryFile path ReadMode $ \h -> do
    mecdOffset <- locateECD path h
    case mecdOffset of
      Just ecdOffset -> do
        hSeek h AbsoluteSeek ecdOffset
        ecdSize <- subtract ecdOffset <$> hFileSize h
        ecdRaw <- B.hGet h (fromIntegral ecdSize)
        case runGet getECD ecdRaw of
          Left msg -> throwM (ParsingFailed path msg)
          Right ecd -> do
            hSeek h AbsoluteSeek $ fromIntegral (adCDOffset ecd)
            cdRaw <- B.hGet h $ fromIntegral (adCDSize ecd)
            case runGet getCD cdRaw of
              Left msg -> throwM (ParsingFailed path msg)
              Right cd -> return (ecd, cd)
      Nothing ->
        throwM (ParsingFailed path "Cannot locate end of central directory")
  
  -- | Given location of the archive and information about a specific archive
  -- entry 'EntryDescription', return 'Source' of its data. The actual data
  -- can be compressed or uncompressed depending on the third argument.
  sourceEntry ::
    (PrimMonad m, MonadThrow m, MonadResource m) =>
    -- | Path to archive that contains the entry
    FilePath ->
    -- | Information needed to extract entry of interest
    EntryDescription ->
    -- | Should we stream uncompressed data?
    Bool ->
    -- | Source of uncompressed data
    ConduitT () ByteString m ()
  sourceEntry path EntryDescription {..} d =
    source .| CB.isolate (fromIntegral edCompressedSize) .| decompress
    where
      source = CB.sourceIOHandle $ do
        h <- openFile path ReadMode
        hSeek h AbsoluteSeek (fromIntegral edOffset)
        localHeader <- B.hGet h 30
        case runGet getLocalHeaderGap localHeader of
          Left msg -> throwM (ParsingFailed path msg)
          Right gap -> do
            hSeek h RelativeSeek gap
            return h
      decompress =
        if d
          then decompressingPipe edCompression
          else C.awaitForever C.yield
  
  -- | Undertake /all/ actions specified as the fourth argument of the
  -- function. This transforms the given pending actions so they can be
  -- performed in one pass, and then they are applied in the most efficient
  -- way.
  commit ::
    -- | Location of archive file to edit or create
    FilePath ->
    -- | Archive description
    ArchiveDescription ->
    -- | Current list of entries
    Map EntrySelector EntryDescription ->
    -- | Collection of pending actions
    Seq PendingAction ->
    IO ()
  commit path ArchiveDescription {..} entries xs =
    withNewFile path $ \h -> do
      let (ProducingActions copying sinking, editing) =
            optimize (toRecreatingActions path entries >< xs)
          comment = predictComment adComment xs
      copiedCD <-
        M.unions
          <$> M.traverseWithKey
            ( \srcPath m ->
                copyEntries h srcPath m editing
            )
            copying
      sunkCD <-
        M.traverseWithKey
          ( \selector (origin, source) ->
              sinkEntry h selector origin source editing
          )
          (sinking `M.difference` copiedCD)
      writeCD h comment (copiedCD `M.union` sunkCD)
  
  -- | Create a new file with the guarantee that in the case of an exception
  -- the old file will be intact. The file is only updated\/replaced if the
  -- second argument finishes without exceptions.
  withNewFile ::
    -- | Name of file to create
    FilePath ->
    -- | Action that writes to given 'Handle'
    (Handle -> IO ()) ->
    IO ()
  withNewFile fpath action =
    bracketOnError allocate release $ \(path, h) -> do
      action h
      hClose h
      renameFile path fpath
    where
      allocate = openBinaryTempFile (takeDirectory fpath) ".zip"
      release (path, h) = do
        hClose h
        -- Despite using `bracketOnError` the file is not guaranteed to exist
        -- here since we could be interrupted with an async exception after
        -- the file has been renamed. Therefore, we silentely ignore
        -- `DoesNotExistError`.
        catchJust (guard . isDoesNotExistError) (removeFile path) (const $ pure ())
  
  -- | Determine what comment in new archive will look like given its original
  -- value and a collection of pending actions.
  predictComment :: Maybe Text -> Seq PendingAction -> Maybe Text
  predictComment original xs =
    case S.index xs <$> S.findIndexR (isNothing . targetEntry) xs of
      Nothing -> original
      Just DeleteArchiveComment -> Nothing
      Just (SetArchiveComment txt) -> Just txt
      Just _ -> Nothing
  
  -- | Transform a map representing existing entries into a collection of
  -- actions that re-create those entires.
  toRecreatingActions ::
    -- | Name of the archive file where entires are found
    FilePath ->
    -- | Actual list of entires
    Map EntrySelector EntryDescription ->
    -- | Actions that recreate the archive entries
    Seq PendingAction
  toRecreatingActions path entries = E.foldl' f S.empty (M.keysSet entries)
    where
      f s e = s |> CopyEntry path e e
  
  -- | Transform a collection of 'PendingAction's into 'ProducingActions' and
  -- 'EditingActions'—data that describes how to create resulting archive.
  optimize ::
    -- | Collection of pending actions
    Seq PendingAction ->
    -- | Optimized data
    (ProducingActions, EditingActions)
  optimize =
    foldl'
      f
      ( ProducingActions M.empty M.empty,
        EditingActions M.empty M.empty M.empty M.empty M.empty M.empty M.empty
      )
    where
      f (pa, ea) a = case a of
        SinkEntry m src s ->
          ( pa
              { paSinkEntry = M.insert s (GenericOrigin, src) (paSinkEntry pa),
                paCopyEntry = M.map (M.filter (/= s)) (paCopyEntry pa)
              },
            (clearEditingFor s ea)
              { eaCompression = M.insert s m (eaCompression ea)
              }
          )
        StrictEntry m bs s ->
          ( pa
              { paSinkEntry = M.insert s (origin, C.yield bs) (paSinkEntry pa),
                paCopyEntry = M.map (M.filter (/= s)) (paCopyEntry pa)
              },
            (clearEditingFor s ea)
              { eaCompression = M.insert s m (eaCompression ea)
              }
          )
          where
            origin = StrictOrigin (fromIntegral $ B.length bs)
        CopyEntry path os ns ->
          ( pa
              { paSinkEntry = M.delete ns (paSinkEntry pa),
                paCopyEntry = M.alter (ef os ns) path (paCopyEntry pa)
              },
            clearEditingFor ns ea
          )
        RenameEntry os ns ->
          ( pa
              { paCopyEntry = M.map (M.map $ re os ns) (paCopyEntry pa),
                paSinkEntry = renameKey os ns (paSinkEntry pa)
              },
            ea
              { eaCompression = renameKey os ns (eaCompression ea),
                eaEntryComment = renameKey os ns (eaEntryComment ea),
                eaDeleteComment = renameKey os ns (eaDeleteComment ea),
                eaModTime = renameKey os ns (eaModTime ea),
                eaExtraField = renameKey os ns (eaExtraField ea),
                eaDeleteField = renameKey os ns (eaDeleteField ea)
              }
          )
        DeleteEntry s ->
          ( pa
              { paSinkEntry = M.delete s (paSinkEntry pa),
                paCopyEntry = M.map (M.delete s) (paCopyEntry pa)
              },
            clearEditingFor s ea
          )
        Recompress m s ->
          (pa, ea {eaCompression = M.insert s m (eaCompression ea)})
        SetEntryComment txt s ->
          ( pa,
            ea
              { eaEntryComment = M.insert s txt (eaEntryComment ea),
                eaDeleteComment = M.delete s (eaDeleteComment ea)
              }
          )
        DeleteEntryComment s ->
          ( pa,
            ea
              { eaEntryComment = M.delete s (eaEntryComment ea),
                eaDeleteComment = M.insert s () (eaDeleteComment ea)
              }
          )
        SetModTime time s ->
          (pa, ea {eaModTime = M.insert s time (eaModTime ea)})
        AddExtraField n b s ->
          ( pa,
            ea
              { eaExtraField = M.alter (ef n b) s (eaExtraField ea),
                eaDeleteField = M.delete s (eaDeleteField ea)
              }
          )
        DeleteExtraField n s ->
          ( pa,
            ea
              { eaExtraField = M.alter (er n) s (eaExtraField ea),
                eaDeleteField = M.alter (ef n ()) s (eaDeleteField ea)
              }
          )
        SetExternalFileAttributes b s ->
          ( pa,
            ea {eaExtFileAttr = M.insert s b (eaExtFileAttr ea)}
          )
        _ -> (pa, ea)
      clearEditingFor s ea =
        ea
          { eaCompression = M.delete s (eaCompression ea),
            eaEntryComment = M.delete s (eaEntryComment ea),
            eaDeleteComment = M.delete s (eaDeleteComment ea),
            eaModTime = M.delete s (eaModTime ea),
            eaExtraField = M.delete s (eaExtraField ea),
            eaDeleteField = M.delete s (eaDeleteField ea),
            eaExtFileAttr = M.delete s (eaExtFileAttr ea)
          }
      re o n x = if x == o then n else x
      ef k v (Just m) = Just (M.insert k v m)
      ef k v Nothing = Just (M.singleton k v)
      er k (Just m) =
        let n = M.delete k m
         in if M.null n then Nothing else Just n
      er _ Nothing = Nothing
  
  -- | Copy entries from another archive and write them into the file
  -- associated with the given handle. This can throw 'EntryDoesNotExist' if
  -- there is no such entry in that archive.
  copyEntries ::
    -- | Opened 'Handle' of zip archive file
    Handle ->
    -- | Path to the file to copy the entries from
    FilePath ->
    -- | 'Map' from original name to name to use in new archive
    Map EntrySelector EntrySelector ->
    -- | Additional info that can influence result
    EditingActions ->
    -- | Info to generate central directory file headers later
    IO (Map EntrySelector EntryDescription)
  copyEntries h path names editing = do
    entries <- snd <$> scanArchive path
    M.foldlWithKey
      ( \acc oldName newName ->
          case M.lookup oldName entries of
            Nothing -> throwM (EntryDoesNotExist path oldName)
            Just oldDesc ->
              M.insert newName
                <$> sinkEntry h newName (Borrowed oldDesc) src editing
                <*> acc
              where
                src = sourceEntry path oldDesc False
      )
      mempty
      names
  
  -- | Sink an entry from the given stream into the file associated with the
  -- given 'Handle'.
  sinkEntry ::
    -- | Opened 'Handle' of zip archive file
    Handle ->
    -- | Name of the entry to add
    EntrySelector ->
    -- | Origin of the entry (can contain additional info)
    EntryOrigin ->
    -- | Source of the entry contents
    ConduitT () ByteString (ResourceT IO) () ->
    -- | Additional info that can influence result
    EditingActions ->
    -- | Info to generate the central directory file headers later
    IO EntryDescription
  sinkEntry h s o src EditingActions {..} = do
    currentTime <- getCurrentTime
    offset <- hTell h
    let compressed = case o of
          Borrowed ed -> edCompression ed
          _ -> Store
        compression = M.findWithDefault compressed s eaCompression
        recompression = compression /= compressed
        modTime = case o of
          Borrowed ed -> edModTime ed
          _ -> currentTime
        extFileAttr = M.findWithDefault defaultFileMode s eaExtFileAttr
        oldExtraFields = case o of
          Borrowed ed -> edExtraField ed
          _ -> M.empty
        extraField =
          (M.findWithDefault M.empty s eaExtraField `M.union` oldExtraFields)
            `M.difference` M.findWithDefault M.empty s eaDeleteField
        oldComment = case (o, M.lookup s eaDeleteComment) of
          (Borrowed ed, Nothing) -> edComment ed
          _ -> Nothing
        desc0 =
          EntryDescription -- to write in local header
            { edVersionMadeBy = zipVersion,
              edVersionNeeded = zipVersion,
              edCompression = compression,
              edModTime = M.findWithDefault modTime s eaModTime,
              edCRC32 = 0, -- to be overwritten after streaming
              edCompressedSize = 0, -- ↑
              edUncompressedSize = 0, -- ↑
              edOffset = fromIntegral offset,
              edComment = M.lookup s eaEntryComment <|> oldComment,
              edExtraField = extraField,
              edExternalFileAttrs = extFileAttr
            }
    B.hPut h (runPut (putHeader (LocalHeader o) s desc0))
    DataDescriptor {..} <-
      C.runConduitRes $
        if recompression
          then
            if compressed == Store
              then src .| sinkData h compression
              else src .| decompressingPipe compressed .| sinkData h compression
          else src .| sinkData h Store
    afterStreaming <- hTell h
    let desc1 = case o of
          Borrowed ed ->
            desc0
              { edCRC32 =
                  bool (edCRC32 ed) ddCRC32 recompression,
                edCompressedSize =
                  bool (edCompressedSize ed) ddCompressedSize recompression,
                edUncompressedSize =
                  bool (edUncompressedSize ed) ddUncompressedSize recompression
              }
          _ ->
            desc0
              { edCRC32 = ddCRC32,
                edCompressedSize = ddCompressedSize,
                edUncompressedSize = ddUncompressedSize
              }
        desc2 =
          desc1
            { edVersionNeeded =
                getZipVersion (needsZip64 desc1) (Just compression)
            }
    hSeek h AbsoluteSeek offset
    B.hPut h (runPut (putHeader (LocalHeader o) s desc2))
    hSeek h AbsoluteSeek afterStreaming
    return desc2
  
  {- ORMOLU_DISABLE -}
  
  -- | Create a 'Sink' to stream data there. Once streaming is finished,
  -- return 'DataDescriptor' for the streamed data. The action /does not/
  -- close the given 'Handle'.
  sinkData ::
    -- | Opened 'Handle' of zip archive file
    Handle ->
    -- | Compression method to apply
    CompressionMethod ->
    -- | 'Sink' where to stream data
    ConduitT ByteString Void (ResourceT IO) DataDescriptor
  sinkData h compression = do
    let sizeSink = CL.fold (\acc input -> fromIntegral (B.length input) + acc) 0
        dataSink =
          getZipSink $
            ZipSink sizeSink <* ZipSink (CB.sinkHandle h)
        withCompression sink =
          getZipSink $
            (,,) <$> ZipSink sizeSink
              <*> ZipSink crc32Sink
              <*> ZipSink sink
    (uncompressedSize, crc32, compressedSize) <-
      case compression of
        Store ->
          withCompression
            dataSink
        Deflate ->
          withCompression $
            Z.compress 9 (Z.WindowBits (-15)) .| dataSink
  #ifdef ENABLE_BZIP2
        BZip2 ->
          withCompression $
            BZ.bzip2 .| dataSink
  #else
        BZip2 -> throwM (UnsupportedCompressionMethod BZip2)
  #endif
  #ifdef ENABLE_ZSTD
        Zstd ->
          withCompression $
            Zstandard.compress 1 .| dataSink
  #else
        Zstd -> throwM (UnsupportedCompressionMethod Zstd)
  #endif
    return
      DataDescriptor
        { ddCRC32 = fromIntegral crc32,
          ddCompressedSize = compressedSize,
          ddUncompressedSize = uncompressedSize
        }
  
  {- ORMOLU_ENABLE -}
  
  -- | Append central directory entries and the end of central directory
  -- record to the file that given 'Handle' is associated with. Note that this
  -- automatically writes Zip64 end of central directory record and Zip64 end
  -- of central directory locator when necessary.
  writeCD ::
    -- | Opened handle of zip archive file
    Handle ->
    -- | Commentary to the entire archive
    Maybe Text ->
    -- | Info about already written local headers and entry data
    Map EntrySelector EntryDescription ->
    IO ()
  writeCD h comment m = do
    let cd = runPut (putCD m)
    cdOffset <- fromIntegral <$> hTell h
    B.hPut h cd -- write central directory
    let totalCount = fromIntegral (M.size m)
        cdSize = fromIntegral (B.length cd)
        needZip64 =
          totalCount >= ffff
            || cdSize >= ffffffff
            || cdOffset >= ffffffff
    when needZip64 $ do
      zip64ecdOffset <- fromIntegral <$> hTell h
      (B.hPut h . runPut) (putZip64ECD totalCount cdSize cdOffset)
      (B.hPut h . runPut) (putZip64ECDLocator zip64ecdOffset)
    (B.hPut h . runPut) (putECD totalCount cdSize cdOffset comment)
  
  ----------------------------------------------------------------------------
  -- Binary serialization
  
  -- | Extract the number of bytes between the start of file name in local
  -- header and the start of actual data.
  getLocalHeaderGap :: Get Integer
  getLocalHeaderGap = do
    getSignature 0x04034b50
    skip 2 -- version needed to extract
    skip 2 -- general purpose bit flag
    skip 2 -- compression method
    skip 2 -- last mod file time
    skip 2 -- last mod file date
    skip 4 -- crc-32 check sum
    skip 4 -- compressed size
    skip 4 -- uncompressed size
    fileNameSize <- fromIntegral <$> getWord16le -- file name length
    extraFieldSize <- fromIntegral <$> getWord16le -- extra field length
    return (fileNameSize + extraFieldSize)
  
  -- | Parse central directory file headers and put them into a 'Map'.
  getCD :: Get (Map EntrySelector EntryDescription)
  getCD = M.fromList . catMaybes <$> many getCDHeader
  
  -- | Parse a single central directory file header. If it's a directory or
  -- file compressed with unsupported compression method, 'Nothing' is
  -- returned.
  getCDHeader :: Get (Maybe (EntrySelector, EntryDescription))
  getCDHeader = do
    getSignature 0x02014b50 -- central file header signature
    versionMadeBy <- toVersion <$> getWord16le -- version made by
    versionNeeded <- toVersion <$> getWord16le -- version needed to extract
    when (versionNeeded > zipVersion) . fail $
      "Version required to extract the archive is "
        ++ showVersion versionNeeded
        ++ " (can do "
        ++ showVersion zipVersion
        ++ ")"
    bitFlag <- getWord16le -- general purpose bit flag
    when (any (testBit bitFlag) [0, 6, 13]) . fail $
      "Encrypted archives are not supported"
    let needUnicode = testBit bitFlag 11
    mcompression <- toCompressionMethod <$> getWord16le -- compression method
    modTime <- getWord16le -- last mod file time
    modDate <- getWord16le -- last mod file date
    crc32 <- getWord32le -- CRC32 check sum
    compressed <- fromIntegral <$> getWord32le -- compressed size
    uncompressed <- fromIntegral <$> getWord32le -- uncompressed size
    fileNameSize <- getWord16le -- file name length
    extraFieldSize <- getWord16le -- extra field length
    commentSize <- getWord16le -- file comment size
    skip 4 -- disk number start, internal file attributes
    externalFileAttrs <- getWord32le -- external file attributes
    offset <- fromIntegral <$> getWord32le -- offset of local header
    fileName <-
      decodeText needUnicode
        <$> getBytes (fromIntegral fileNameSize) -- file name
    extraField <-
      M.fromList
        <$> isolate (fromIntegral extraFieldSize) (many getExtraField)
    -- ↑ extra fields in their raw form
    comment <- decodeText needUnicode <$> getBytes (fromIntegral commentSize)
    -- ↑ file comment
    let dfltZip64 =
          Zip64ExtraField
            { z64efUncompressedSize = uncompressed,
              z64efCompressedSize = compressed,
              z64efOffset = offset
            }
        z64ef = case M.lookup 1 extraField of
          Nothing -> dfltZip64
          Just b -> parseZip64ExtraField dfltZip64 b
    case mcompression of
      Nothing -> return Nothing
      Just compression ->
        let desc =
              EntryDescription
                { edVersionMadeBy = versionMadeBy,
                  edVersionNeeded = versionNeeded,
                  edCompression = compression,
                  edModTime = fromMsDosTime (MsDosTime modDate modTime),
                  edCRC32 = crc32,
                  edCompressedSize = z64efCompressedSize z64ef,
                  edUncompressedSize = z64efUncompressedSize z64ef,
                  edOffset = z64efOffset z64ef,
                  edComment = if commentSize == 0 then Nothing else comment,
                  edExtraField = extraField,
                  edExternalFileAttrs = externalFileAttrs
                }
         in return $ (,desc) <$> (fileName >>= mkEntrySelector . T.unpack)
  
  -- | Parse an extra-field.
  getExtraField :: Get (Word16, ByteString)
  getExtraField = do
    header <- getWord16le -- header id
    size <- getWord16le -- data size
    body <- getBytes (fromIntegral size) -- content
    return (header, body)
  
  -- | Get signature. If the extracted data is not equal to the provided
  -- signature, fail.
  getSignature :: Word32 -> Get ()
  getSignature sig = do
    x <- getWord32le -- grab 4-byte signature
    unless (x == sig) . fail $
      "Expected signature " ++ show sig ++ ", but got: " ++ show x
  
  -- | Parse 'Zip64ExtraField' from its binary representation.
  parseZip64ExtraField ::
    -- | What is read from central directory file header
    Zip64ExtraField ->
    -- | Actual binary representation
    ByteString ->
    -- | Result
    Zip64ExtraField
  parseZip64ExtraField dflt@Zip64ExtraField {..} b =
    either (const dflt) id . flip runGet b $ do
      let ifsat v =
            if v >= ffffffff
              then fromIntegral <$> getWord64le
              else return v
      uncompressed <- ifsat z64efUncompressedSize -- uncompressed size
      compressed <- ifsat z64efCompressedSize -- compressed size
      offset <- ifsat z64efOffset -- offset of local file header
      return (Zip64ExtraField uncompressed compressed offset)
  
  -- | Produce binary representation of 'Zip64ExtraField'.
  makeZip64ExtraField ::
    -- | Is this for local or central directory header?
    HeaderType ->
    -- | Zip64 extra field's data
    Zip64ExtraField ->
    -- | Resulting representation
    ByteString
  makeZip64ExtraField headerType Zip64ExtraField {..} = runPut $ do
    case headerType of
      LocalHeader _ -> do
        putWord64le (fromIntegral z64efUncompressedSize) -- uncompressed size
        putWord64le (fromIntegral z64efCompressedSize) -- compressed size
      CentralDirHeader -> do
        when (z64efUncompressedSize >= ffffffff) $
          putWord64le (fromIntegral z64efUncompressedSize) -- uncompressed size
        when (z64efCompressedSize >= ffffffff) $
          putWord64le (fromIntegral z64efCompressedSize) -- compressed size
    when (z64efOffset >= ffffffff) $
      putWord64le (fromIntegral z64efOffset) -- offset of local file header
  
  -- | Create 'ByteString' representing an extra field.
  putExtraField :: Map Word16 ByteString -> Put
  putExtraField = M.foldMapWithKey $ \headerId bs -> do
    let b = B.take 0xffff bs
    putWord16le headerId
    putWord16le (fromIntegral $ B.length b)
    putByteString b
  
  -- | Create 'ByteString' representing the entire central directory.
  putCD :: Map EntrySelector EntryDescription -> Put
  putCD = M.foldMapWithKey (putHeader CentralDirHeader)
  
  -- | Create 'ByteString' representing either a local file header or a
  -- central directory file header.
  putHeader ::
    -- | Type of header to generate
    HeaderType ->
    -- | Name of entry to write
    EntrySelector ->
    -- | Description of entry
    EntryDescription ->
    Put
  putHeader headerType s entry@EntryDescription {..} = do
    let isCentralDirHeader = headerType == CentralDirHeader
    putWord32le (bool 0x04034b50 0x02014b50 isCentralDirHeader)
    -- ↑ local/central file header signature
    when isCentralDirHeader $
      putWord16le (fromVersion edVersionMadeBy) -- version made by
    putWord16le (fromVersion edVersionNeeded) -- version needed to extract
    let entryName = getEntryName s
        rawName = T.encodeUtf8 entryName
        comment = B.take 0xffff (maybe B.empty T.encodeUtf8 edComment)
        unicode =
          needsUnicode entryName
            || maybe False needsUnicode edComment
        modTime = toMsDosTime edModTime
    putWord16le (if unicode then setBit 0 11 else 0)
    -- ↑ general purpose bit-flag
    putWord16le (fromCompressionMethod edCompression) -- compression method
    putWord16le (msDosTime modTime) -- last mod file time
    putWord16le (msDosDate modTime) -- last mod file date
    putWord32le edCRC32 -- CRC-32 checksum
    putWord32le (withSaturation edCompressedSize) -- compressed size
    putWord32le (withSaturation edUncompressedSize) -- uncompressed size
    putWord16le (fromIntegral $ B.length rawName) -- file name length
    let zip64ef =
          makeZip64ExtraField
            headerType
            Zip64ExtraField
              { z64efUncompressedSize = edUncompressedSize,
                z64efCompressedSize = edCompressedSize,
                z64efOffset = edOffset
              }
        appendZip64 =
          case headerType of
            LocalHeader (StrictOrigin size) -> size >= ffffffff
            LocalHeader (Borrowed ed) -> entryUsesZip64 ed
            LocalHeader GenericOrigin -> True
            CentralDirHeader -> needsZip64 entry
        extraField =
          B.take 0xffff . runPut . putExtraField $
            if appendZip64
              then M.insert 1 zip64ef edExtraField
              else edExtraField
    putWord16le (fromIntegral $ B.length extraField) -- extra field length
    when isCentralDirHeader $ do
      putWord16le (fromIntegral $ B.length comment) -- file comment length
      putWord16le 0 -- disk number start
      putWord16le 0 -- internal file attributes
      putWord32le edExternalFileAttrs -- external file attributes
      putWord32le (withSaturation edOffset) -- relative offset of local header
    putByteString rawName -- file name (variable size)
    putByteString extraField -- extra field (variable size)
    when isCentralDirHeader (putByteString comment) -- file comment (variable size)
  
  -- | Create 'ByteString' representing Zip64 end of central directory record.
  putZip64ECD ::
    -- | Total number of entries
    Natural ->
    -- | Size of the central directory
    Natural ->
    -- | Offset of central directory record
    Natural ->
    Put
  putZip64ECD totalCount cdSize cdOffset = do
    putWord32le 0x06064b50 -- zip64 end of central dir signature
    putWord64le 44 -- size of zip64 end of central dir record
    putWord16le (fromVersion zipVersion) -- version made by
    putWord16le (fromVersion $ getZipVersion True Nothing)
    -- ↑ version needed to extract
    putWord32le 0 -- number of this disk
    putWord32le 0 -- number of the disk with the start of the central directory
    putWord64le (fromIntegral totalCount) -- total number of entries (this disk)
    putWord64le (fromIntegral totalCount) -- total number of entries
    putWord64le (fromIntegral cdSize) -- size of the central directory
    putWord64le (fromIntegral cdOffset) -- offset of central directory
  
  -- | Create 'ByteString' representing Zip64 end of the central directory
  -- locator.
  putZip64ECDLocator ::
    -- | Offset of Zip64 end of central directory
    Natural ->
    Put
  putZip64ECDLocator ecdOffset = do
    putWord32le 0x07064b50 -- zip64 end of central dir locator signature
    putWord32le 0 -- number of the disk with the start of the zip64 end of
    -- central directory
    putWord64le (fromIntegral ecdOffset) -- relative offset of the zip64 end
    -- of central directory record
    putWord32le 1 -- total number of disks
  
  -- | Parse end of the central directory record or Zip64 end of the central
  -- directory record depending on signature binary data begins with.
  getECD :: Get ArchiveDescription
  getECD = do
    sig <- getWord32le -- end of central directory signature
    let zip64 = sig == 0x06064b50
    unless (sig == 0x06054b50 || sig == 0x06064b50) $
      fail "Cannot locate end of central directory"
    zip64size <-
      if zip64
        then do
          x <- getWord64le -- size of zip64 end of central directory record
          skip 2 -- version made by
          skip 2 -- version needed to extract
          return (Just x)
        else return Nothing
    thisDisk <- bool (fromIntegral <$> getWord16le) getWord32le zip64
    -- ↑ number of this disk
    cdDisk <- bool (fromIntegral <$> getWord16le) getWord32le zip64
    -- ↑ number of the disk with the start of the central directory
    unless (thisDisk == 0 && cdDisk == 0) $
      fail "No support for multi-disk archives"
    skip (bool 2 8 zip64)
    -- ↑ total number of entries in the central directory on this disk
    skip (bool 2 8 zip64)
    -- ↑ total number of entries in the central directory
    cdSize <- bool (fromIntegral <$> getWord32le) getWord64le zip64
    -- ↑ size of the central directory
    cdOffset <- bool (fromIntegral <$> getWord32le) getWord64le zip64
    -- ↑ offset of start of central directory with respect to the starting
    -- disk number
    when zip64 . skip . fromIntegral $ fromJust zip64size - 4 -- obviously
    commentSize <- getWord16le -- .ZIP file comment length
    comment <- decodeText True <$> getBytes (fromIntegral commentSize)
    -- ↑ archive comment, it's uncertain how we should decide on encoding here
    return
      ArchiveDescription
        { adComment = if commentSize == 0 then Nothing else comment,
          adCDOffset = fromIntegral cdOffset,
          adCDSize = fromIntegral cdSize
        }
  
  -- | Create a 'ByteString' representing the end of central directory record.
  putECD ::
    -- | Total number of entries
    Natural ->
    -- | Size of the central directory
    Natural ->
    -- | Offset of central directory record
    Natural ->
    -- | Zip file comment
    Maybe Text ->
    Put
  putECD totalCount cdSize cdOffset mcomment = do
    putWord32le 0x06054b50 -- end of central dir signature
    putWord16le 0 -- number of this disk
    putWord16le 0 -- number of the disk with the start of the central directory
    putWord16le (withSaturation totalCount)
    -- ↑ total number of entries on this disk
    putWord16le (withSaturation totalCount) -- total number of entries
    putWord32le (withSaturation cdSize) -- size of central directory
    putWord32le (withSaturation cdOffset) -- offset of start of central directory
    let comment = maybe B.empty T.encodeUtf8 mcomment
    putWord16le (fromIntegral $ B.length comment)
    putByteString comment
  
  -- | Find the absolute offset of the end of central directory record or, if
  -- present, Zip64 end of central directory record.
  locateECD :: FilePath -> Handle -> IO (Maybe Integer)
  locateECD path h = sizeCheck
    where
      sizeCheck = do
        fsize <- hFileSize h
        let limit = max 0 (fsize - 0xffff - 22)
        if fsize < 22
          then return Nothing
          else hSeek h SeekFromEnd (-22) >> loop limit
      loop limit = do
        sig <- getNum getWord32le 4
        pos <- subtract 4 <$> hTell h
        let again = hSeek h AbsoluteSeek (pos - 1) >> loop limit
            done = pos <= limit
        if sig == 0x06054b50
          then do
            result <-
              runMaybeT $
                MaybeT (checkComment pos)
                  >>= MaybeT . checkCDSig
                  >>= MaybeT . checkZip64
            case result of
              Nothing -> bool again (return Nothing) done
              Just ecd -> return (Just ecd)
          else bool again (return Nothing) done
      checkComment pos = do
        size <- hFileSize h
        hSeek h AbsoluteSeek (pos + 20)
        l <- fromIntegral <$> getNum getWord16le 2
        return $
          if l + 22 == size - pos
            then Just pos
            else Nothing
      checkCDSig pos = do
        hSeek h AbsoluteSeek (pos + 16)
        sigPos <- fromIntegral <$> getNum getWord32le 4
        if sigPos == 0xffffffff -- Zip64 is probably used
          then return (Just pos)
          else do
            hSeek h AbsoluteSeek sigPos
            cdSig <- getNum getWord32le 4
            return $
              if cdSig == 0x02014b50
                ||
                -- ↑ normal case: central directory file header signature
                cdSig == 0x06064b50
                ||
                -- ↑ happens when zip 64 archive is empty
                cdSig == 0x06054b50
                then -- ↑ happens when vanilla archive is empty
                  Just pos
                else Nothing
      checkZip64 pos =
        if pos < 20
          then return (Just pos)
          else do
            hSeek h AbsoluteSeek (pos - 20)
            zip64locatorSig <- getNum getWord32le 4
            if zip64locatorSig == 0x07064b50
              then do
                hSeek h AbsoluteSeek (pos - 12)
                Just . fromIntegral <$> getNum getWord64le 8
              else return (Just pos)
      getNum f n = do
        result <- runGet f <$> B.hGet h n
        case result of
          Left msg -> throwM (ParsingFailed path msg)
          Right val -> return val
  
  ----------------------------------------------------------------------------
  -- Helpers
  
  -- | Rename an entry (key) in a 'Map'.
  renameKey :: (Ord k) => k -> k -> Map k a -> Map k a
  renameKey ok nk m = case M.lookup ok m of
    Nothing -> m
    Just e -> M.insert nk e (M.delete ok m)
  
  -- | Like 'fromIntegral', but with saturation when converting to bounded
  -- types.
  withSaturation :: forall a b. (Integral a, Integral b, Bounded b) => a -> b
  withSaturation x =
    if (fromIntegral x :: Integer) > (fromIntegral bound :: Integer)
      then bound
      else fromIntegral x
    where
      bound = maxBound :: b
  
  -- | Determine the target entry of an action.
  targetEntry :: PendingAction -> Maybe EntrySelector
  targetEntry (SinkEntry _ _ s) = Just s
  targetEntry (StrictEntry _ _ s) = Just s
  targetEntry (CopyEntry _ _ s) = Just s
  targetEntry (RenameEntry s _) = Just s
  targetEntry (DeleteEntry s) = Just s
  targetEntry (Recompress _ s) = Just s
  targetEntry (SetEntryComment _ s) = Just s
  targetEntry (DeleteEntryComment s) = Just s
  targetEntry (SetModTime _ s) = Just s
  targetEntry (AddExtraField _ _ s) = Just s
  targetEntry (DeleteExtraField _ s) = Just s
  targetEntry (SetExternalFileAttributes _ s) = Just s
  targetEntry (SetArchiveComment _) = Nothing
  targetEntry DeleteArchiveComment = Nothing
  
  -- | Decode a 'ByteString'. The first argument indicates whether we should
  -- treat it as UTF-8 (in case bit 11 of general-purpose bit flag is set),
  -- otherwise the function assumes CP437. Note that since not every stream of
  -- bytes constitutes valid UTF-8 text, this function can fail. In that case
  -- 'Nothing' is returned.
  decodeText ::
    -- | Whether bit 11 of general-purpose bit flag is set
    Bool ->
    -- | Binary data to decode
    ByteString ->
    -- | Decoded 'Text' in case of success
    Maybe Text
  decodeText False = Just . decodeCP437
  decodeText True = either (const Nothing) Just . T.decodeUtf8'
  
  -- | Detect if the given text needs newer Unicode-aware features to be
  -- properly encoded in the archive.
  needsUnicode :: Text -> Bool
  needsUnicode = not . T.all validCP437
    where
      validCP437 x = ord x <= 127
  
  -- | Convert numeric representation (as per the .ZIP specification) of
  -- version into 'Version'.
  toVersion :: Word16 -> Version
  toVersion x = makeVersion [major, minor]
    where
      (major, minor) = quotRem (fromIntegral $ x .&. 0x00ff) 10
  
  -- | Covert 'Version' to its numeric representation as per the .ZIP
  -- specification.
  fromVersion :: Version -> Word16
  fromVersion v = fromIntegral ((ZIP_OS `shiftL` 8) .|. (major * 10 + minor))
    where
      (major, minor) =
        case versionBranch v of
          v0 : v1 : _ -> (v0, v1)
          v0 : _ -> (v0, 0)
          [] -> (0, 0)
  
  -- | Get the compression method form its numeric representation.
  toCompressionMethod :: Word16 -> Maybe CompressionMethod
  toCompressionMethod 0 = Just Store
  toCompressionMethod 8 = Just Deflate
  toCompressionMethod 12 = Just BZip2
  toCompressionMethod 93 = Just Zstd
  toCompressionMethod _ = Nothing
  
  -- | Convert 'CompressionMethod' to its numeric representation as per the
  -- .ZIP specification.
  fromCompressionMethod :: CompressionMethod -> Word16
  fromCompressionMethod Store = 0
  fromCompressionMethod Deflate = 8
  fromCompressionMethod BZip2 = 12
  fromCompressionMethod Zstd = 93
  
  -- | Check if an entry with these parameters needs the Zip64 extension.
  needsZip64 :: EntryDescription -> Bool
  needsZip64 EntryDescription {..} =
    any
      (>= ffffffff)
      [edOffset, edCompressedSize, edUncompressedSize]
  
  -- | Check if an entry has Zip64 extra fields.
  entryUsesZip64 :: EntryDescription -> Bool
  entryUsesZip64 EntryDescription {..} = M.member 1 edExtraField
  
  -- | Determine “version needed to extract” that should be written to the
  -- headers given the need of the Zip64 feature and the compression method.
  getZipVersion :: Bool -> Maybe CompressionMethod -> Version
  getZipVersion zip64 m = max zip64ver mver
    where
      zip64ver = makeVersion (if zip64 then [4, 5] else [2, 0])
      mver = makeVersion $ case m of
        Nothing -> [2, 0]
        Just Store -> [2, 0]
        Just Deflate -> [2, 0]
        Just BZip2 -> [4, 6]
        Just Zstd -> [6, 3]
  
  -- | Return a decompressing 'Conduit' corresponding to the given compression
  -- method.
  decompressingPipe ::
    (PrimMonad m, MonadThrow m, MonadResource m) =>
    CompressionMethod ->
    ConduitT ByteString ByteString m ()
  decompressingPipe Store = C.awaitForever C.yield
  decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)
  
  #ifdef ENABLE_BZIP2
  decompressingPipe BZip2 = BZ.bunzip2
  #else
  decompressingPipe BZip2 = throwM (UnsupportedCompressionMethod BZip2)
  #endif
  
  #ifdef ENABLE_ZSTD
  decompressingPipe Zstd = Zstandard.decompress
  #else
  decompressingPipe Zstd = throwM (UnsupportedCompressionMethod Zstd)
  #endif
  
  -- | A sink that calculates the CRC32 check sum for an incoming stream.
  crc32Sink :: ConduitT ByteString Void (ResourceT IO) Word32
  crc32Sink = CL.fold crc32Update 0
  
  -- | Convert 'UTCTime' to the MS-DOS time format.
  toMsDosTime :: UTCTime -> MsDosTime
  toMsDosTime UTCTime {..} = MsDosTime dosDate dosTime
    where
      dosTime = fromIntegral (seconds + shiftL minutes 5 + shiftL hours 11)
      dosDate = fromIntegral (day + shiftL month 5 + shiftL year 9)
      seconds =
        let (MkFixed x) = todSec tod
         in fromIntegral (x `quot` 2000000000000)
      minutes = todMin tod
      hours = todHour tod
      tod = timeToTimeOfDay utctDayTime
      year = fromIntegral year' - 1980
      (year', month, day) = toGregorian utctDay
  
  -- | Convert MS-DOS date-time to 'UTCTime'.
  fromMsDosTime :: MsDosTime -> UTCTime
  fromMsDosTime MsDosTime {..} =
    UTCTime
      (fromGregorian year month day)
      (secondsToDiffTime $ hours * 3600 + minutes * 60 + seconds)
    where
      seconds = fromIntegral $ 2 * (msDosTime .&. 0x1f)
      minutes = fromIntegral (shiftR msDosTime 5 .&. 0x3f)
      hours = fromIntegral (shiftR msDosTime 11 .&. 0x1f)
      day = fromIntegral (msDosDate .&. 0x1f)
      month = fromIntegral $ shiftR msDosDate 5 .&. 0x0f
      year = 1980 + fromIntegral (shiftR msDosDate 9)
  
  -- We use the constants of the type 'Natural' instead of literals to protect
  -- ourselves from overflows on 32 bit systems.
  --
  -- If we're in the development mode, use lower values so the tests get a
  -- chance to check all cases (otherwise we would need to generate way too
  -- big archives on CI).
  
  ffff, ffffffff :: Natural
  
  #ifdef HASKELL_ZIP_DEV_MODE
  ffff     = 25
  ffffffff = 250
  #else
  ffff     = 0xffff
  ffffffff = 0xffffffff
  #endif
  
  -- | The default permissions for the files, permissions not set on Windows,
  -- and are set to rw on Unix. This mimics the behavior of the zip utility.
  defaultFileMode :: Word32
  
  #ifdef mingw32_HOST_OS
  defaultFileMode = 0
  
  #else
  defaultFileMode = Unix.fromFileMode 0o600
  #endif
  