{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ViewPatterns #-}
------------------------------------------------------------------------
-- |
-- Module      : Codec.Archive.Zip
-- Copyright   : John MacFarlane
-- License     : BSD3
--
-- Maintainer  : John MacFarlane < jgm at berkeley dot edu >
-- Stability   : unstable
-- Portability : so far only tested on GHC
--
-- The zip-archive library provides functions for creating, modifying,
-- and extracting files from zip archives.
--
-- Certain simplifying assumptions are made about the zip archives: in
-- particular, there is no support for strong encryption, zip files that span
-- multiple disks, ZIP64, OS-specific file attributes, or compression
-- methods other than Deflate.  However, the library should be able to
-- read the most common zip archives, and the archives it produces should
-- be readable by all standard unzip programs.
--
-- One known limitation: when parsing an archive whose local file
-- headers defer sizes to a data descriptor (general purpose bit 3)
-- and whose entries are stored without compression, the end of the
-- entry data can only be found by scanning for the optional data
-- descriptor signature @0x08074b50@.  Parsing such an archive can
-- therefore fail (or truncate an entry) if that byte sequence occurs
-- within the stored data itself.  Archives of this kind are rare;
-- deflated entries with data descriptors are not affected.
--
-- As an example of the use of the library, a standalone zip archiver
-- and extractor, Zip.hs, is provided in the source distribution.
--
-- For more information on the format of zip archives, consult
-- <http://www.pkware.com/documents/casestudies/APPNOTE.TXT>
------------------------------------------------------------------------

module Codec.Archive.Zip
       (

       -- * Data structures
         Archive (..)
       , Entry (..)
       , CompressionMethod (..)
       , EncryptionMethod (..)
       , ZipOption (..)
       , ZipException (..)
       , emptyArchive

       -- * Pure functions for working with zip archives
       , toArchive
       , toArchiveOrFail
       , fromArchive
       , filesInArchive
       , addEntryToArchive
       , deleteEntryFromArchive
       , findEntryByPath
       , fromEntry
       , fromEncryptedEntry
       , isEncryptedEntry
       , toEntry
#ifndef _WINDOWS
       , isEntrySymbolicLink
       , symbolicLinkEntryTarget
       , entryCMode
#endif

       -- * IO functions for working with zip archives
       , readEntry
       , writeEntry
#ifndef _WINDOWS
       , writeSymbolicLinkEntry
#endif
       , addFilesToArchive
       , extractFilesFromArchive

       ) where

import Data.Time.Calendar ( toGregorian, fromGregorian )
import Data.Time.Clock ( UTCTime(..) )
import Data.Time.LocalTime ( TimeZone(..), TimeOfDay(..), timeToTimeOfDay,
                             getTimeZone )
import Data.Time.Clock.POSIX ( posixSecondsToUTCTime, utcTimeToPOSIXSeconds )
import Data.Bits ( shiftL, shiftR, (.&.), (.|.), xor, testBit, complement )
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
import Data.List (find, intercalate)
import Data.Int (Int64)
import Data.Data (Data)
import Data.Typeable (Typeable)
import Text.Printf
import System.FilePath
import System.Directory
       (doesDirectoryExist, getDirectoryContents,
        createDirectoryIfMissing, getModificationTime,
        renameFile, removeFile)
import Control.Monad ( when, unless, zipWithM_, foldM )
import Control.Monad.ST.Lazy ( runST )
import qualified Control.Exception as E
import System.IO ( stderr, hPutStrLn, hClose, openBinaryTempFile )
import qualified Data.Digest.CRC32 as CRC32
import Data.Array.Unboxed ( UArray, listArray, (!) )
import qualified Data.Map as M
import qualified Data.Set as Set
import Control.Applicative
#ifdef _WINDOWS
import Data.Char (isLetter)
#else
import System.Posix.Files ( setFileTimes, setFileMode, setFileCreationMask, fileMode, getSymbolicLinkStatus, symbolicLinkMode, readSymbolicLink, isSymbolicLink, unionFileModes, createSymbolicLink, removeLink, FileStatus )
import System.Posix.Types ( CMode(..) )
import Data.List (partition)
import Data.Maybe (fromJust)
#endif

-- from bytestring
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy.Char8 as C

-- text
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Text.Encoding.Error as TE

-- from zlib
import qualified Codec.Compression.Zlib.Raw as Zlib
import qualified Codec.Compression.Zlib.Internal as ZlibInt
import System.IO.Error (isAlreadyExistsError)

-- import Debug.Trace

manySig :: Word32 -> Get a -> Get [a]
manySig :: forall a. Word32 -> Get a -> Get [a]
manySig Word32
sig Get a
p = do
    sig' <- Get Word32 -> Get Word32
forall a. Get a -> Get a
lookAhead Get Word32
getWord32le
    if sig == sig'
        then do
            r <- p
            rs <- manySig sig p
            return $ r : rs
        else return []


------------------------------------------------------------------------

-- | Structured representation of a zip archive, including directory
-- information and contents (in lazy bytestrings).
data Archive = Archive
                { Archive -> [Entry]
zEntries                :: [Entry]              -- ^ Files in zip archive
                , Archive -> Maybe ByteString
zSignature              :: Maybe B.ByteString   -- ^ Digital signature
                , Archive -> ByteString
zComment                :: !B.ByteString        -- ^ Comment for whole zip archive
                } deriving (ReadPrec [Archive]
ReadPrec Archive
Int -> ReadS Archive
ReadS [Archive]
(Int -> ReadS Archive)
-> ReadS [Archive]
-> ReadPrec Archive
-> ReadPrec [Archive]
-> Read Archive
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Archive
readsPrec :: Int -> ReadS Archive
$creadList :: ReadS [Archive]
readList :: ReadS [Archive]
$creadPrec :: ReadPrec Archive
readPrec :: ReadPrec Archive
$creadListPrec :: ReadPrec [Archive]
readListPrec :: ReadPrec [Archive]
Read, Int -> Archive -> ShowS
[Archive] -> ShowS
Archive -> String
(Int -> Archive -> ShowS)
-> (Archive -> String) -> ([Archive] -> ShowS) -> Show Archive
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Archive -> ShowS
showsPrec :: Int -> Archive -> ShowS
$cshow :: Archive -> String
show :: Archive -> String
$cshowList :: [Archive] -> ShowS
showList :: [Archive] -> ShowS
Show)

instance Binary Archive where
  put :: Archive -> Put
put = Archive -> Put
putArchive
  get :: Get Archive
get = Get Archive
getArchive

-- | Representation of an archived file, including content and metadata.
data Entry = Entry
               { Entry -> String
eRelativePath            :: FilePath            -- ^ Relative path, using '/' as separator
               , Entry -> CompressionMethod
eCompressionMethod       :: !CompressionMethod   -- ^ Compression method
               , Entry -> EncryptionMethod
eEncryptionMethod        :: !EncryptionMethod    -- ^ Encryption method
               , Entry -> Integer
eLastModified            :: !Integer             -- ^ Modification time (seconds since unix epoch, shifted by the local time zone offset: MSDOS timestamps in zip archives are conventionally local time)
               , Entry -> Word32
eCRC32                   :: !Word32              -- ^ CRC32 checksum
               , Entry -> Word32
eCompressedSize          :: !Word32              -- ^ Compressed size in bytes
               , Entry -> Word32
eUncompressedSize        :: !Word32              -- ^ Uncompressed size in bytes
               , Entry -> ByteString
eExtraField              :: !B.ByteString        -- ^ Extra field - unused by this library
               , Entry -> ByteString
eFileComment             :: !B.ByteString        -- ^ File comment - unused by this library
               , Entry -> Word16
eVersionMadeBy           :: !Word16              -- ^ Version made by field
               , Entry -> Word16
eInternalFileAttributes  :: !Word16              -- ^ Internal file attributes - unused by this library
               , Entry -> Word32
eExternalFileAttributes  :: !Word32              -- ^ External file attributes (system-dependent)
               , Entry -> ByteString
eCompressedData          :: !B.ByteString        -- ^ Compressed contents of file
               } deriving (ReadPrec [Entry]
ReadPrec Entry
Int -> ReadS Entry
ReadS [Entry]
(Int -> ReadS Entry)
-> ReadS [Entry]
-> ReadPrec Entry
-> ReadPrec [Entry]
-> Read Entry
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Entry
readsPrec :: Int -> ReadS Entry
$creadList :: ReadS [Entry]
readList :: ReadS [Entry]
$creadPrec :: ReadPrec Entry
readPrec :: ReadPrec Entry
$creadListPrec :: ReadPrec [Entry]
readListPrec :: ReadPrec [Entry]
Read, Int -> Entry -> ShowS
[Entry] -> ShowS
Entry -> String
(Int -> Entry -> ShowS)
-> (Entry -> String) -> ([Entry] -> ShowS) -> Show Entry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Entry -> ShowS
showsPrec :: Int -> Entry -> ShowS
$cshow :: Entry -> String
show :: Entry -> String
$cshowList :: [Entry] -> ShowS
showList :: [Entry] -> ShowS
Show, Entry -> Entry -> Bool
(Entry -> Entry -> Bool) -> (Entry -> Entry -> Bool) -> Eq Entry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Entry -> Entry -> Bool
== :: Entry -> Entry -> Bool
$c/= :: Entry -> Entry -> Bool
/= :: Entry -> Entry -> Bool
Eq)

-- | Compression methods.
data CompressionMethod = Deflate
                       | NoCompression
                       deriving (ReadPrec [CompressionMethod]
ReadPrec CompressionMethod
Int -> ReadS CompressionMethod
ReadS [CompressionMethod]
(Int -> ReadS CompressionMethod)
-> ReadS [CompressionMethod]
-> ReadPrec CompressionMethod
-> ReadPrec [CompressionMethod]
-> Read CompressionMethod
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS CompressionMethod
readsPrec :: Int -> ReadS CompressionMethod
$creadList :: ReadS [CompressionMethod]
readList :: ReadS [CompressionMethod]
$creadPrec :: ReadPrec CompressionMethod
readPrec :: ReadPrec CompressionMethod
$creadListPrec :: ReadPrec [CompressionMethod]
readListPrec :: ReadPrec [CompressionMethod]
Read, Int -> CompressionMethod -> ShowS
[CompressionMethod] -> ShowS
CompressionMethod -> String
(Int -> CompressionMethod -> ShowS)
-> (CompressionMethod -> String)
-> ([CompressionMethod] -> ShowS)
-> Show CompressionMethod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CompressionMethod -> ShowS
showsPrec :: Int -> CompressionMethod -> ShowS
$cshow :: CompressionMethod -> String
show :: CompressionMethod -> String
$cshowList :: [CompressionMethod] -> ShowS
showList :: [CompressionMethod] -> ShowS
Show, CompressionMethod -> CompressionMethod -> Bool
(CompressionMethod -> CompressionMethod -> Bool)
-> (CompressionMethod -> CompressionMethod -> Bool)
-> Eq CompressionMethod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CompressionMethod -> CompressionMethod -> Bool
== :: CompressionMethod -> CompressionMethod -> Bool
$c/= :: CompressionMethod -> CompressionMethod -> Bool
/= :: CompressionMethod -> CompressionMethod -> Bool
Eq)

data EncryptionMethod = NoEncryption             -- ^ Entry is not encrypted
                      | PKWAREEncryption !Word8  -- ^ Entry is encrypted with the traditional PKWARE encryption
                      deriving (ReadPrec [EncryptionMethod]
ReadPrec EncryptionMethod
Int -> ReadS EncryptionMethod
ReadS [EncryptionMethod]
(Int -> ReadS EncryptionMethod)
-> ReadS [EncryptionMethod]
-> ReadPrec EncryptionMethod
-> ReadPrec [EncryptionMethod]
-> Read EncryptionMethod
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS EncryptionMethod
readsPrec :: Int -> ReadS EncryptionMethod
$creadList :: ReadS [EncryptionMethod]
readList :: ReadS [EncryptionMethod]
$creadPrec :: ReadPrec EncryptionMethod
readPrec :: ReadPrec EncryptionMethod
$creadListPrec :: ReadPrec [EncryptionMethod]
readListPrec :: ReadPrec [EncryptionMethod]
Read, Int -> EncryptionMethod -> ShowS
[EncryptionMethod] -> ShowS
EncryptionMethod -> String
(Int -> EncryptionMethod -> ShowS)
-> (EncryptionMethod -> String)
-> ([EncryptionMethod] -> ShowS)
-> Show EncryptionMethod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EncryptionMethod -> ShowS
showsPrec :: Int -> EncryptionMethod -> ShowS
$cshow :: EncryptionMethod -> String
show :: EncryptionMethod -> String
$cshowList :: [EncryptionMethod] -> ShowS
showList :: [EncryptionMethod] -> ShowS
Show, EncryptionMethod -> EncryptionMethod -> Bool
(EncryptionMethod -> EncryptionMethod -> Bool)
-> (EncryptionMethod -> EncryptionMethod -> Bool)
-> Eq EncryptionMethod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EncryptionMethod -> EncryptionMethod -> Bool
== :: EncryptionMethod -> EncryptionMethod -> Bool
$c/= :: EncryptionMethod -> EncryptionMethod -> Bool
/= :: EncryptionMethod -> EncryptionMethod -> Bool
Eq)

-- | The way the password should be verified during entry decryption
data PKWAREVerificationType = CheckTimeByte
                            | CheckCRCByte
                            deriving (ReadPrec [PKWAREVerificationType]
ReadPrec PKWAREVerificationType
Int -> ReadS PKWAREVerificationType
ReadS [PKWAREVerificationType]
(Int -> ReadS PKWAREVerificationType)
-> ReadS [PKWAREVerificationType]
-> ReadPrec PKWAREVerificationType
-> ReadPrec [PKWAREVerificationType]
-> Read PKWAREVerificationType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS PKWAREVerificationType
readsPrec :: Int -> ReadS PKWAREVerificationType
$creadList :: ReadS [PKWAREVerificationType]
readList :: ReadS [PKWAREVerificationType]
$creadPrec :: ReadPrec PKWAREVerificationType
readPrec :: ReadPrec PKWAREVerificationType
$creadListPrec :: ReadPrec [PKWAREVerificationType]
readListPrec :: ReadPrec [PKWAREVerificationType]
Read, Int -> PKWAREVerificationType -> ShowS
[PKWAREVerificationType] -> ShowS
PKWAREVerificationType -> String
(Int -> PKWAREVerificationType -> ShowS)
-> (PKWAREVerificationType -> String)
-> ([PKWAREVerificationType] -> ShowS)
-> Show PKWAREVerificationType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PKWAREVerificationType -> ShowS
showsPrec :: Int -> PKWAREVerificationType -> ShowS
$cshow :: PKWAREVerificationType -> String
show :: PKWAREVerificationType -> String
$cshowList :: [PKWAREVerificationType] -> ShowS
showList :: [PKWAREVerificationType] -> ShowS
Show, PKWAREVerificationType -> PKWAREVerificationType -> Bool
(PKWAREVerificationType -> PKWAREVerificationType -> Bool)
-> (PKWAREVerificationType -> PKWAREVerificationType -> Bool)
-> Eq PKWAREVerificationType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PKWAREVerificationType -> PKWAREVerificationType -> Bool
== :: PKWAREVerificationType -> PKWAREVerificationType -> Bool
$c/= :: PKWAREVerificationType -> PKWAREVerificationType -> Bool
/= :: PKWAREVerificationType -> PKWAREVerificationType -> Bool
Eq)

-- | Options for 'addFilesToArchive' and 'extractFilesFromArchive'.
data ZipOption = OptRecursive               -- ^ Recurse into directories when adding files
               | OptVerbose                 -- ^ Print information to stderr
               | OptDestination FilePath    -- ^ Directory in which to extract
               | OptLocation FilePath !Bool -- ^ Where to place file when adding files and whether to append current path
               | OptPreserveSymbolicLinks   -- ^ Preserve symbolic links as such. This option is ignored on Windows. WARNING: symbolic link targets are not validated on extraction, so they may be absolute or point outside of the destination directory; do not use this option when extracting untrusted archives.
               deriving (ReadPrec [ZipOption]
ReadPrec ZipOption
Int -> ReadS ZipOption
ReadS [ZipOption]
(Int -> ReadS ZipOption)
-> ReadS [ZipOption]
-> ReadPrec ZipOption
-> ReadPrec [ZipOption]
-> Read ZipOption
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS ZipOption
readsPrec :: Int -> ReadS ZipOption
$creadList :: ReadS [ZipOption]
readList :: ReadS [ZipOption]
$creadPrec :: ReadPrec ZipOption
readPrec :: ReadPrec ZipOption
$creadListPrec :: ReadPrec [ZipOption]
readListPrec :: ReadPrec [ZipOption]
Read, Int -> ZipOption -> ShowS
[ZipOption] -> ShowS
ZipOption -> String
(Int -> ZipOption -> ShowS)
-> (ZipOption -> String)
-> ([ZipOption] -> ShowS)
-> Show ZipOption
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ZipOption -> ShowS
showsPrec :: Int -> ZipOption -> ShowS
$cshow :: ZipOption -> String
show :: ZipOption -> String
$cshowList :: [ZipOption] -> ShowS
showList :: [ZipOption] -> ShowS
Show, ZipOption -> ZipOption -> Bool
(ZipOption -> ZipOption -> Bool)
-> (ZipOption -> ZipOption -> Bool) -> Eq ZipOption
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ZipOption -> ZipOption -> Bool
== :: ZipOption -> ZipOption -> Bool
$c/= :: ZipOption -> ZipOption -> Bool
/= :: ZipOption -> ZipOption -> Bool
Eq)

data ZipException =
    CRC32Mismatch FilePath
  | UnsafePath FilePath
  | CannotWriteEncryptedEntry FilePath
  | Zip64NotSupported String  -- ^ Data too large for the original zip format (which this library is limited to); the ZIP64 extension would be required
  deriving (Int -> ZipException -> ShowS
[ZipException] -> ShowS
ZipException -> String
(Int -> ZipException -> ShowS)
-> (ZipException -> String)
-> ([ZipException] -> ShowS)
-> Show ZipException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ZipException -> ShowS
showsPrec :: Int -> ZipException -> ShowS
$cshow :: ZipException -> String
show :: ZipException -> String
$cshowList :: [ZipException] -> ShowS
showList :: [ZipException] -> ShowS
Show, Typeable, Typeable ZipException
Typeable ZipException =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> ZipException -> c ZipException)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c ZipException)
-> (ZipException -> Constr)
-> (ZipException -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c ZipException))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c ZipException))
-> ((forall b. Data b => b -> b) -> ZipException -> ZipException)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> ZipException -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> ZipException -> r)
-> (forall u. (forall d. Data d => d -> u) -> ZipException -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> ZipException -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> ZipException -> m ZipException)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> ZipException -> m ZipException)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> ZipException -> m ZipException)
-> Data ZipException
ZipException -> Constr
ZipException -> DataType
(forall b. Data b => b -> b) -> ZipException -> ZipException
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> ZipException -> u
forall u. (forall d. Data d => d -> u) -> ZipException -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ZipException -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ZipException -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ZipException -> m ZipException
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ZipException -> m ZipException
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ZipException
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ZipException -> c ZipException
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ZipException)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ZipException)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ZipException -> c ZipException
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ZipException -> c ZipException
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ZipException
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ZipException
$ctoConstr :: ZipException -> Constr
toConstr :: ZipException -> Constr
$cdataTypeOf :: ZipException -> DataType
dataTypeOf :: ZipException -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ZipException)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ZipException)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ZipException)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ZipException)
$cgmapT :: (forall b. Data b => b -> b) -> ZipException -> ZipException
gmapT :: (forall b. Data b => b -> b) -> ZipException -> ZipException
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ZipException -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ZipException -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ZipException -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ZipException -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> ZipException -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> ZipException -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> ZipException -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> ZipException -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ZipException -> m ZipException
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ZipException -> m ZipException
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ZipException -> m ZipException
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ZipException -> m ZipException
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ZipException -> m ZipException
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ZipException -> m ZipException
Data, ZipException -> ZipException -> Bool
(ZipException -> ZipException -> Bool)
-> (ZipException -> ZipException -> Bool) -> Eq ZipException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ZipException -> ZipException -> Bool
== :: ZipException -> ZipException -> Bool
$c/= :: ZipException -> ZipException -> Bool
/= :: ZipException -> ZipException -> Bool
Eq)

instance E.Exception ZipException

-- | A zip archive with no contents.
emptyArchive :: Archive
emptyArchive :: Archive
emptyArchive = Archive
                { zEntries :: [Entry]
zEntries                  = []
                , zSignature :: Maybe ByteString
zSignature              = Maybe ByteString
forall a. Maybe a
Nothing
                , zComment :: ByteString
zComment                = ByteString
B.empty }

-- | Reads an 'Archive' structure from a raw zip archive (in a lazy bytestring).
toArchive :: B.ByteString -> Archive
toArchive :: ByteString -> Archive
toArchive = ByteString -> Archive
forall a. Binary a => ByteString -> a
decode

-- | Like 'toArchive', but returns an 'Either' value instead of raising an
-- error if the archive cannot be decoded.  NOTE:  This function only
-- works properly when the library is compiled against binary >= 0.7.
-- With earlier versions, it will always return a Right value,
-- raising an error if parsing fails.
toArchiveOrFail :: B.ByteString -> Either String Archive
toArchiveOrFail :: ByteString -> Either String Archive
toArchiveOrFail ByteString
bs = case ByteString
-> Either (ByteString, Int64, String) (ByteString, Int64, Archive)
forall a.
Binary a =>
ByteString
-> Either (ByteString, Int64, String) (ByteString, Int64, a)
decodeOrFail ByteString
bs of
                           Left (ByteString
_,Int64
_,String
e)  -> String -> Either String Archive
forall a b. a -> Either a b
Left String
e
                           Right (ByteString
_,Int64
_,Archive
x) -> Archive -> Either String Archive
forall a b. b -> Either a b
Right Archive
x

-- | Writes an 'Archive' structure to a raw zip archive (in a lazy bytestring).
-- Throws a pure 'Zip64NotSupported' exception if the archive has 65535
-- or more entries or is 4GB or larger, since this would require the
-- (unsupported) ZIP64 extension.
fromArchive :: Archive -> B.ByteString
fromArchive :: Archive -> ByteString
fromArchive = Archive -> ByteString
forall a. Binary a => a -> ByteString
encode

-- | Returns a list of files in a zip archive.
filesInArchive :: Archive -> [FilePath]
filesInArchive :: Archive -> [String]
filesInArchive = (Entry -> String) -> [Entry] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Entry -> String
eRelativePath ([Entry] -> [String])
-> (Archive -> [Entry]) -> Archive -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Archive -> [Entry]
zEntries

-- | Adds an entry to a zip archive, or updates an existing entry.
addEntryToArchive :: Entry -> Archive -> Archive
addEntryToArchive :: Entry -> Archive -> Archive
addEntryToArchive Entry
entry Archive
archive =
  let archive' :: Archive
archive'   = String -> Archive -> Archive
deleteEntryFromArchive (Entry -> String
eRelativePath Entry
entry) Archive
archive
      oldEntries :: [Entry]
oldEntries = Archive -> [Entry]
zEntries Archive
archive'
  in  Archive
archive' { zEntries = entry : oldEntries }

-- | Deletes an entry from a zip archive.
deleteEntryFromArchive :: FilePath -> Archive -> Archive
deleteEntryFromArchive :: String -> Archive -> Archive
deleteEntryFromArchive String
path Archive
archive =
  let path' :: String
path' = ShowS
normalizePath String
path
  in  Archive
archive { zEntries = [e | e <- zEntries archive
                           , normalizePath (eRelativePath e) /= path'] }

-- | Returns Just the zip entry with the specified path, or Nothing.
findEntryByPath :: FilePath -> Archive -> Maybe Entry
findEntryByPath :: String -> Archive -> Maybe Entry
findEntryByPath String
path Archive
archive =
  let path' :: String
path' = ShowS
normalizePath String
path
  in  (Entry -> Bool) -> [Entry] -> Maybe Entry
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Entry
e -> String
path' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== ShowS
normalizePath (Entry -> String
eRelativePath Entry
e))
           (Archive -> [Entry]
zEntries Archive
archive)

-- | Returns uncompressed contents of zip entry.
fromEntry :: Entry -> B.ByteString
fromEntry :: Entry -> ByteString
fromEntry Entry
entry =
  CompressionMethod -> ByteString -> ByteString
decompressData (Entry -> CompressionMethod
eCompressionMethod Entry
entry) (Entry -> ByteString
eCompressedData Entry
entry)

-- | Returns decrypted and uncompressed contents of zip entry.
fromEncryptedEntry :: String -> Entry -> Maybe B.ByteString
fromEncryptedEntry :: String -> Entry -> Maybe ByteString
fromEncryptedEntry String
password Entry
entry =
  CompressionMethod -> ByteString -> ByteString
decompressData (Entry -> CompressionMethod
eCompressionMethod Entry
entry) (ByteString -> ByteString) -> Maybe ByteString -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> EncryptionMethod -> ByteString -> Maybe ByteString
decryptData String
password (Entry -> EncryptionMethod
eEncryptionMethod Entry
entry) (Entry -> ByteString
eCompressedData Entry
entry)

-- | Check if an 'Entry' is encrypted
isEncryptedEntry :: Entry -> Bool
isEncryptedEntry :: Entry -> Bool
isEncryptedEntry Entry
entry =
  case Entry -> EncryptionMethod
eEncryptionMethod Entry
entry of
    (PKWAREEncryption Word8
_) -> Bool
True
    EncryptionMethod
_ -> Bool
False

-- | Create an 'Entry' with specified file path, modification time, and contents.
-- Throws a pure 'Zip64NotSupported' exception if the contents are too
-- large to be represented without the (unsupported) ZIP64 extension.
toEntry :: FilePath         -- ^ File path for entry
        -> Integer          -- ^ Modification time for entry (seconds since unix epoch)
        -> B.ByteString     -- ^ Contents of entry
        -> Entry
toEntry :: String -> Integer -> ByteString -> Entry
toEntry String
path Integer
modtime ByteString
contents =
  let uncompressedSize :: Int64
uncompressedSize = ByteString -> Int64
B.length ByteString
contents
      compressedData :: ByteString
compressedData = CompressionMethod -> ByteString -> ByteString
compressData CompressionMethod
Deflate ByteString
contents
      compressedSize :: Int64
compressedSize = ByteString -> Int64
B.length ByteString
compressedData
      -- only use compression if it helps!
      (CompressionMethod
compressionMethod, ByteString
finalData, Int64
finalSize) =
        if Int64
uncompressedSize Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
compressedSize
           then (CompressionMethod
NoCompression, ByteString
contents, Int64
uncompressedSize)
           else (CompressionMethod
Deflate, ByteString
compressedData, Int64
compressedSize)
      crc32 :: Word32
crc32 = ByteString -> Word32
forall a. CRC32 a => a -> Word32
CRC32.crc32 ByteString
contents
  in  if Int64
uncompressedSize Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
0xFFFFFFFF
         then ZipException -> Entry
forall a e. (HasCallStack, Exception e) => e -> a
E.throw (ZipException -> Entry) -> ZipException -> Entry
forall a b. (a -> b) -> a -> b
$ String -> ZipException
Zip64NotSupported (String -> ZipException) -> String -> ZipException
forall a b. (a -> b) -> a -> b
$
                String
path String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": entry of 4GB or more requires ZIP64"
         else
      Entry { eRelativePath :: String
eRelativePath            = ShowS
normalizePath String
path
            , eCompressionMethod :: CompressionMethod
eCompressionMethod       = CompressionMethod
compressionMethod
            , eEncryptionMethod :: EncryptionMethod
eEncryptionMethod        = EncryptionMethod
NoEncryption
            , eLastModified :: Integer
eLastModified            = Integer
modtime
            , eCRC32 :: Word32
eCRC32                   = Word32
crc32
            , eCompressedSize :: Word32
eCompressedSize          = Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
finalSize
            , eUncompressedSize :: Word32
eUncompressedSize        = Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
uncompressedSize
            , eExtraField :: ByteString
eExtraField              = ByteString
B.empty
            , eFileComment :: ByteString
eFileComment             = ByteString
B.empty
            , eVersionMadeBy :: Word16
eVersionMadeBy           = Word16
0  -- FAT
            , eInternalFileAttributes :: Word16
eInternalFileAttributes  = Word16
0  -- potentially non-text
            , eExternalFileAttributes :: Word32
eExternalFileAttributes  = Word32
0  -- appropriate if from stdin
            , eCompressedData :: ByteString
eCompressedData          = ByteString
finalData
            }

-- | Generates a 'Entry' from a file or directory.
readEntry :: [ZipOption] -> FilePath -> IO Entry
readEntry :: [ZipOption] -> String -> IO Entry
readEntry [ZipOption]
opts String
path = do
  isDir <- String -> IO Bool
doesDirectoryExist String
path
#ifdef _WINDOWS
  let isSymLink = False
#else
  fs <- getSymbolicLinkStatus path
  let isSymLink = FileStatus -> Bool
isSymbolicLink FileStatus
fs
#endif
 -- make sure directories end in / and deal with the OptLocation option
  let path' = let p :: String
p = String
path String -> ShowS
forall a. [a] -> [a] -> [a]
++ (case ShowS
forall a. [a] -> [a]
reverse String
path of
                                    (Char
'/':String
_) -> String
""
                                    String
_ | Bool
isDir Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isSymLink -> String
"/"
                                    String
_ | Bool
isDir Bool -> Bool -> Bool
&& Bool
isSymLink -> String
""
                                      | Bool
otherwise -> String
"") in
              (case [(String
l,Bool
a) | OptLocation String
l Bool
a <- [ZipOption]
opts] of
                    ((String
l,Bool
a):[(String, Bool)]
_) -> if Bool
a then String
l String -> ShowS
</> String
p else String
l String -> ShowS
</> ShowS
takeFileName String
p
                    [(String, Bool)]
_         -> String
p)
  contents <-
#ifndef _WINDOWS
              if isSymLink
                 then do
                   linkTarget <- readSymbolicLink path
                   return $ C.pack linkTarget
                 else
#endif
                   if isDir
                      then
                        return B.empty
                      else
                        B.fromStrict <$> S.readFile path
  modTime <- getModificationTime path
  tzone <- getTimeZone modTime
  let modEpochTime = -- UNIX time computed relative to LOCAL time zone! (#67)
        POSIXTime -> Integer
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (UTCTime -> POSIXTime
utcTimeToPOSIXSeconds UTCTime
modTime) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+
          Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TimeZone -> Int
timeZoneMinutes TimeZone
tzone Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60)
  let entry = String -> Integer -> ByteString -> Entry
toEntry String
path' Integer
modEpochTime ByteString
contents

  entryE <-
#ifdef _WINDOWS
        return $ entry { eVersionMadeBy = 0x0000 } -- FAT/VFAT/VFAT32 file attributes
#else
        do
           let fm = if Bool
isSymLink
                      then CMode -> CMode -> CMode
unionFileModes CMode
symbolicLinkMode (FileStatus -> CMode
fileMode FileStatus
fs)
                      else FileStatus -> CMode
fileMode FileStatus
fs

           let modes = Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word32) -> Integer -> Word32
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftL (CMode -> Integer
forall a. Integral a => a -> Integer
toInteger CMode
fm) Int
16
           return $ entry { eExternalFileAttributes = modes,
                            eVersionMadeBy = 0x0300 } -- UNIX file attributes
#endif

  when (OptVerbose `elem` opts) $ do
    let compmethod = case Entry -> CompressionMethod
eCompressionMethod Entry
entryE of
                     CompressionMethod
Deflate       -> (String
"deflated" :: String)
                     CompressionMethod
NoCompression -> String
"stored"
    hPutStrLn stderr $
      printf "  adding: %s (%s %.f%%)" (eRelativePath entryE)
      compmethod (100 - (100 * compressionRatio entryE))
  return entryE

-- check path: reject absolute paths and drive-qualified paths, and
-- resolve .. and . components, raising UnsafePath exception if this
-- takes you outside of the root.
checkPath :: FilePath -> IO ()
checkPath :: String -> IO ()
checkPath String
fp
  | String -> Bool
isAbsolute' String
fp Bool -> Bool -> Bool
|| String -> Bool
hasDrive String
fp = ZipException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (String -> ZipException
UnsafePath String
fp)
  | Bool
otherwise =
      IO () -> ([String] -> IO ()) -> Maybe [String] -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ZipException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (String -> ZipException
UnsafePath String
fp)) (\[String]
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
        ([String] -> Maybe [String]
resolve ([String] -> Maybe [String])
-> (String -> [String]) -> String -> Maybe [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitDirectories (String -> Maybe [String]) -> String -> Maybe [String]
forall a b. (a -> b) -> a -> b
$ String
fp)
  where
    resolve :: [String] -> Maybe [String]
resolve =
      ([String] -> [String]) -> Maybe [String] -> Maybe [String]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [String] -> [String]
forall a. [a] -> [a]
reverse (Maybe [String] -> Maybe [String])
-> ([String] -> Maybe [String]) -> [String] -> Maybe [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe [String] -> String -> Maybe [String])
-> Maybe [String] -> [String] -> Maybe [String]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Maybe [String] -> String -> Maybe [String]
forall {m :: * -> *} {a}.
(Eq a, IsString a, MonadFail m) =>
m [a] -> a -> m [a]
go ([String] -> Maybe [String]
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return [])
      where
      go :: m [a] -> a -> m [a]
go m [a]
acc a
x = do
        xs <- m [a]
acc
        case x of
          a
"."  -> [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
xs
          a
".." -> case [a]
xs of
                    []     -> String -> m [a]
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"outside of root path"
                    (a
_:[a]
ys) -> [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
ys
          a
_    -> [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)
    -- ensure that /foo is absolute even on Windows:
    isAbsolute' :: String -> Bool
isAbsolute' (Char
'/':String
_) = Bool
True
    isAbsolute' String
f = String -> Bool
isAbsolute String
f

-- | Writes contents of an 'Entry' to a file.  Throws a
-- 'CRC32Mismatch' exception if the CRC32 checksum for the entry
-- does not match the uncompressed data.
writeEntry :: [ZipOption] -> Entry -> IO ()
writeEntry :: [ZipOption] -> Entry -> IO ()
writeEntry [ZipOption]
opts Entry
entry = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Entry -> Bool
isEncryptedEntry Entry
entry) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    ZipException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (ZipException -> IO ()) -> ZipException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ZipException
CannotWriteEncryptedEntry (Entry -> String
eRelativePath Entry
entry)
  let relpath :: String
relpath = Entry -> String
eRelativePath Entry
entry
  String -> IO ()
checkPath String
relpath
  path <- case [String
d | OptDestination String
d <- [ZipOption]
opts] of
             (String
x:[String]
_) -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
x String -> ShowS
</> String
relpath)
             []    -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
relpath
  -- create directories if needed
  let dir = ShowS
takeDirectory String
path
  exists <- doesDirectoryExist dir
  unless exists $ do
    createDirectoryIfMissing True dir
    when (OptVerbose `elem` opts) $
      hPutStrLn stderr $ "  creating: " ++ dir
  if not (null path) && last path == '/' -- path is a directory
     then return ()
     else do
       when (OptVerbose `elem` opts) $
         hPutStrLn stderr $ case eCompressionMethod entry of
                                 CompressionMethod
Deflate       -> String
" inflating: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
path
                                 CompressionMethod
NoCompression -> String
"extracting: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
path
       -- Write the entry chunk by chunk while updating the CRC
       -- incrementally, so the uncompressed data need not be held in
       -- memory in full.  Write to a temporary file first and rename
       -- it into place only if the CRC matches, so a pre-existing
       -- file at the target path is left intact on a CRC mismatch.
       (tmpPath, tmpHandle) <- openBinaryTempFile dir
                                 (takeFileName path ++ ".tmp")
       crc <- foldM (\Word32
k ByteString
chunk -> do
                        Handle -> ByteString -> IO ()
S.hPut Handle
tmpHandle ByteString
chunk
                        Word32 -> IO Word32
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> ByteString -> Word32
forall a. CRC32 a => Word32 -> a -> Word32
CRC32.crc32Update Word32
k ByteString
chunk))
                0 (B.toChunks (fromEntry entry))
              `E.onException` (hClose tmpHandle >> removeFile tmpPath)
       hClose tmpHandle
       if crc == eCRC32 entry
          then renameFile tmpPath path
          else do
            removeFile tmpPath
            E.throwIO $ CRC32Mismatch path
#ifndef _WINDOWS
       -- openBinaryTempFile creates the file with mode 0600; restore
       -- the default permissions the file would have had if written
       -- directly, unless the entry carries its own mode bits.
       let modes = Word32 -> CMode
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> CMode) -> Word32 -> CMode
forall a b. (a -> b) -> a -> b
$ Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR (Entry -> Word32
eExternalFileAttributes Entry
entry) Int
16
       if eVersionMadeBy entry .&. 0xFF00 == 0x0300 && modes /= 0
          then setFileMode path modes
          else do
            umask <- setFileCreationMask 0o022
            _ <- setFileCreationMask umask
            setFileMode path (0o666 .&. complement umask)
#endif
  -- Note that last modified times are supported only for POSIX, not for
  -- Windows.
  setFileTimeStamp path (eLastModified entry)

#ifndef _WINDOWS
-- | Write an 'Entry' representing a symbolic link to a file.
-- If the 'Entry' does not represent a symbolic link or
-- the options do not contain 'OptPreserveSymbolicLinks`, this
-- function behaves like `writeEntry`.
--
-- Note that the symbolic link target is written as is; it may be
-- absolute or point outside of the extraction directory.  Do not
-- extract untrusted archives with 'OptPreserveSymbolicLinks'.
writeSymbolicLinkEntry :: [ZipOption] -> Entry -> IO ()
writeSymbolicLinkEntry :: [ZipOption] -> Entry -> IO ()
writeSymbolicLinkEntry [ZipOption]
opts Entry
entry =
  if ZipOption
OptPreserveSymbolicLinks ZipOption -> [ZipOption] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ZipOption]
opts
     then [ZipOption] -> Entry -> IO ()
writeEntry [ZipOption]
opts Entry
entry
     else do
        if Entry -> Bool
isEntrySymbolicLink Entry
entry
           then do
             let relpath :: String
relpath = Entry -> String
eRelativePath Entry
entry
             String -> IO ()
checkPath String
relpath
             let prefixPath :: String
prefixPath = case [String
d | OptDestination String
d <- [ZipOption]
opts] of
                                   (String
x:[String]
_) -> String
x
                                   [String]
_     -> String
""
             String -> String -> IO ()
checkSymbolicLinkAncestry String
prefixPath String
relpath
             let targetPath :: String
targetPath = Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String)
-> (Entry -> Maybe String) -> Entry -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> Maybe String
symbolicLinkEntryTarget (Entry -> String) -> Entry -> String
forall a b. (a -> b) -> a -> b
$ Entry
entry
             let symlinkPath :: String
symlinkPath = String
prefixPath String -> ShowS
</> String
relpath
             Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ZipOption
OptVerbose ZipOption -> [ZipOption] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ZipOption]
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
               Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"linking " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
symlinkPath String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
targetPath
             String -> String -> IO ()
forceSymLink String
targetPath String
symlinkPath
           else [ZipOption] -> Entry -> IO ()
writeEntry [ZipOption]
opts Entry
entry

-- Guard against symlink chaining on extraction: raise 'UnsafePath' if
-- any directory component of relpath (relative to prefix) is itself a
-- symbolic link.  Otherwise a crafted archive containing a symbolic
-- link entry @a -> /somewhere@ followed by an entry @a/b@ could create
-- a symbolic link outside of the destination directory.
checkSymbolicLinkAncestry :: FilePath -> FilePath -> IO ()
checkSymbolicLinkAncestry :: String -> String -> IO ()
checkSymbolicLinkAncestry String
prefix String
relpath =
  (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
check ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ (String -> ShowS) -> [String] -> [String]
forall a. (a -> a -> a) -> [a] -> [a]
scanl1 String -> ShowS
(</>) [String]
ancestors
  where
    ancestors :: [String]
ancestors = case String -> [String]
splitDirectories String
relpath of
                     [] -> []
                     [String]
cs -> [String] -> [String]
forall a. HasCallStack => [a] -> [a]
init [String]
cs
    check :: String -> IO ()
check String
dir = do
      res <- IO FileStatus -> IO (Either IOError FileStatus)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (String -> IO FileStatus
getSymbolicLinkStatus (String
prefix String -> ShowS
</> String
dir))
                :: IO (Either E.IOException FileStatus)
      case res of
        Right FileStatus
st | FileStatus -> Bool
isSymbolicLink FileStatus
st -> ZipException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (String -> ZipException
UnsafePath String
relpath)
        Either IOError FileStatus
_                            -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- | Writes a symbolic link, but removes any conflicting files and retries if necessary.
forceSymLink :: FilePath -> FilePath -> IO ()
forceSymLink :: String -> String -> IO ()
forceSymLink String
target String
linkName =
    String -> String -> IO ()
createSymbolicLink String
target String
linkName IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch`
      (\IOError
e -> if IOError -> Bool
isAlreadyExistsError IOError
e
             then String -> IO ()
removeLink String
linkName IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> String -> IO ()
createSymbolicLink String
target String
linkName
             else IOError -> IO ()
forall a. HasCallStack => IOError -> IO a
ioError IOError
e)

-- | Get the target of a 'Entry' representing a symbolic link. This might fail
-- if the 'Entry' does not represent a symbolic link
symbolicLinkEntryTarget :: Entry -> Maybe FilePath
symbolicLinkEntryTarget :: Entry -> Maybe String
symbolicLinkEntryTarget Entry
entry | Entry -> Bool
isEntrySymbolicLink Entry
entry = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (ByteString -> String) -> ByteString -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
C.unpack (ByteString -> Maybe String) -> ByteString -> Maybe String
forall a b. (a -> b) -> a -> b
$ Entry -> ByteString
fromEntry Entry
entry
                              | Bool
otherwise = Maybe String
forall a. Maybe a
Nothing

-- | Check if an 'Entry' represents a symbolic link
isEntrySymbolicLink :: Entry -> Bool
isEntrySymbolicLink :: Entry -> Bool
isEntrySymbolicLink Entry
entry = Entry -> CMode
entryCMode Entry
entry CMode -> CMode -> CMode
forall a. Bits a => a -> a -> a
.&. CMode
symbolicLinkMode CMode -> CMode -> Bool
forall a. Eq a => a -> a -> Bool
== CMode
symbolicLinkMode

-- | Get the 'eExternalFileAttributes' of an 'Entry' as a 'CMode' a.k.a. 'FileMode'
entryCMode :: Entry -> CMode
entryCMode :: Entry -> CMode
entryCMode Entry
entry = Word32 -> CMode
CMode (Word32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$ Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR (Entry -> Word32
eExternalFileAttributes Entry
entry) Int
16)
#endif

-- | Add the specified files to an 'Archive'.  If 'OptRecursive' is specified,
-- recursively add files contained in directories. if 'OptPreserveSymbolicLinks'
-- is specified, don't recurse into it. If 'OptVerbose' is specified,
-- print messages to stderr.
addFilesToArchive :: [ZipOption] -> Archive -> [FilePath] -> IO Archive
addFilesToArchive :: [ZipOption] -> Archive -> [String] -> IO Archive
addFilesToArchive [ZipOption]
opts Archive
archive [String]
files = do
  filesAndChildren <- if ZipOption
OptRecursive ZipOption -> [ZipOption] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ZipOption]
opts
#ifdef _WINDOWS
                         then ordNub . concat <$> mapM getDirectoryContentsRecursive files
#else
                         then [String] -> [String]
forall a. Ord a => [a] -> [a]
ordNub ([String] -> [String])
-> ([[String]] -> [String]) -> [[String]] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([ZipOption] -> String -> IO [String]
getDirectoryContentsRecursive' [ZipOption]
opts) [String]
files
#endif
                         else [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
files
  entries <- mapM (readEntry opts) filesAndChildren
  -- Equivalent to foldr addEntryToArchive archive entries (the first
  -- entry for a given path wins, new entries precede old ones), but
  -- without quadratic cost in the number of entries.
  let newPaths = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ([String] -> Set String) -> [String] -> Set String
forall a b. (a -> b) -> a -> b
$ (Entry -> String) -> [Entry] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ShowS
normalizePath ShowS -> (Entry -> String) -> Entry -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> String
eRelativePath) [Entry]
entries
  return archive
    { zEntries = ordNubOn (normalizePath . eRelativePath) entries ++
        [e | e <- zEntries archive
           , normalizePath (eRelativePath e) `Set.notMember` newPaths] }

-- Remove duplicates from a list, keeping the first occurrence of each
-- element and preserving order.
ordNub :: Ord a => [a] -> [a]
ordNub :: forall a. Ord a => [a] -> [a]
ordNub = (a -> a) -> [a] -> [a]
forall b a. Ord b => (a -> b) -> [a] -> [a]
ordNubOn a -> a
forall a. a -> a
id

ordNubOn :: Ord b => (a -> b) -> [a] -> [a]
ordNubOn :: forall b a. Ord b => (a -> b) -> [a] -> [a]
ordNubOn a -> b
f = Set b -> [a] -> [a]
go Set b
forall a. Set a
Set.empty
  where go :: Set b -> [a] -> [a]
go Set b
_ [] = []
        go Set b
seen (a
x:[a]
xs)
          | b
fx b -> Set b -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set b
seen = Set b -> [a] -> [a]
go Set b
seen [a]
xs
          | Bool
otherwise            = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Set b -> [a] -> [a]
go (b -> Set b -> Set b
forall a. Ord a => a -> Set a -> Set a
Set.insert b
fx Set b
seen) [a]
xs
          where fx :: b
fx = a -> b
f a
x

-- | Extract all files from an 'Archive', creating directories
-- as needed.  If 'OptVerbose' is specified, print messages to stderr.
-- Note that the last-modified time is set correctly only in POSIX,
-- not in Windows.
-- This function fails if encrypted entries are present.
-- See the warning on 'OptPreserveSymbolicLinks' before using it
-- with untrusted archives.
extractFilesFromArchive :: [ZipOption] -> Archive -> IO ()
extractFilesFromArchive :: [ZipOption] -> Archive -> IO ()
extractFilesFromArchive [ZipOption]
opts Archive
archive = do
  let entries :: [Entry]
entries = Archive -> [Entry]
zEntries Archive
archive
  if ZipOption
OptPreserveSymbolicLinks ZipOption -> [ZipOption] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ZipOption]
opts
    then do
#ifdef _WINDOWS
      mapM_ (writeEntry opts) entries
#else
      let ([Entry]
symbolicLinkEntries, [Entry]
nonSymbolicLinkEntries) = (Entry -> Bool) -> [Entry] -> ([Entry], [Entry])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Entry -> Bool
isEntrySymbolicLink [Entry]
entries
      (Entry -> IO ()) -> [Entry] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([ZipOption] -> Entry -> IO ()
writeEntry [ZipOption]
opts) [Entry]
nonSymbolicLinkEntries
      (Entry -> IO ()) -> [Entry] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([ZipOption] -> Entry -> IO ()
writeSymbolicLinkEntry [ZipOption]
opts) [Entry]
symbolicLinkEntries
#endif
    else (Entry -> IO ()) -> [Entry] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([ZipOption] -> Entry -> IO ()
writeEntry [ZipOption]
opts) [Entry]
entries

--------------------------------------------------------------------------------
-- Internal functions for reading and writing zip binary format.

-- Note that even on Windows, zip files use "/" internally as path separator.
normalizePath :: FilePath -> String
normalizePath :: ShowS
normalizePath String
path =
  let dir :: String
dir   = ShowS
takeDirectory String
path
      fn :: String
fn    = ShowS
takeFileName String
path
      dir' :: String
dir' = case String
dir of
#ifdef _WINDOWS
               (c:':':d:xs) | isLetter c
                            , d == '/' || d == '\\'
                            -> xs  -- remove drive
#endif
               String
_ -> String
dir
      -- note: some versions of filepath return ["."] if no dir
      dirParts :: [String]
dirParts = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=String
".") ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
splitDirectories String
dir'
  in  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/" ([String]
dirParts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
fn])

-- | Uncompress a lazy bytestring.
compressData :: CompressionMethod -> B.ByteString -> B.ByteString
compressData :: CompressionMethod -> ByteString -> ByteString
compressData CompressionMethod
Deflate       = ByteString -> ByteString
Zlib.compress
compressData CompressionMethod
NoCompression = ByteString -> ByteString
forall a. a -> a
id

-- | Compress a lazy bytestring.
decompressData :: CompressionMethod -> B.ByteString -> B.ByteString
decompressData :: CompressionMethod -> ByteString -> ByteString
decompressData CompressionMethod
Deflate       = ByteString -> ByteString
Zlib.decompress
decompressData CompressionMethod
NoCompression = ByteString -> ByteString
forall a. a -> a
id

-- | Decrypt a lazy bytestring
-- Returns Nothing if password is incorrect or the data is too short
-- to contain the 12-byte encryption header
decryptData :: String -> EncryptionMethod -> B.ByteString -> Maybe B.ByteString
decryptData :: String -> EncryptionMethod -> ByteString -> Maybe ByteString
decryptData String
_ EncryptionMethod
NoEncryption ByteString
s = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
s
decryptData String
password (PKWAREEncryption Word8
controlByte) ByteString
s
  | ByteString -> Int64
B.length ByteString
s Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
headerlen = Maybe ByteString
forall a. Maybe a
Nothing
  | Bool
otherwise =
      let initKeys :: (Word32, Word32, Word32)
initKeys = (Word32
305419896, Word32
591751049, Word32
878082192)
          startKeys :: (Word32, Word32, Word32)
startKeys = ((Word32, Word32, Word32) -> Word8 -> (Word32, Word32, Word32))
-> (Word32, Word32, Word32)
-> ByteString
-> (Word32, Word32, Word32)
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
B.foldl (Word32, Word32, Word32) -> Word8 -> (Word32, Word32, Word32)
pkwareUpdateKeys (Word32, Word32, Word32)
initKeys (String -> ByteString
C.pack String
password)
          (ByteString
header, ByteString
content) = Int64 -> ByteString -> (ByteString, ByteString)
B.splitAt Int64
headerlen (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ((Word32, Word32, Word32), ByteString) -> ByteString
forall a b. (a, b) -> b
snd (((Word32, Word32, Word32), ByteString) -> ByteString)
-> ((Word32, Word32, Word32), ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ ((Word32, Word32, Word32)
 -> Word8 -> ((Word32, Word32, Word32), Word8))
-> (Word32, Word32, Word32)
-> ByteString
-> ((Word32, Word32, Word32), ByteString)
forall acc.
(acc -> Word8 -> (acc, Word8))
-> acc -> ByteString -> (acc, ByteString)
B.mapAccumL (Word32, Word32, Word32)
-> Word8 -> ((Word32, Word32, Word32), Word8)
pkwareDecryptByte (Word32, Word32, Word32)
startKeys ByteString
s
      in if HasCallStack => ByteString -> Word8
ByteString -> Word8
B.last ByteString
header Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
controlByte
            then ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
content
            else Maybe ByteString
forall a. Maybe a
Nothing
  where headerlen :: Int64
headerlen = Int64
12

-- | PKWARE decryption context
type DecryptionCtx = (Word32, Word32, Word32)

-- | An implementation of the PKWARE decryption algorithm
pkwareDecryptByte :: DecryptionCtx -> Word8 -> (DecryptionCtx, Word8)
pkwareDecryptByte :: (Word32, Word32, Word32)
-> Word8 -> ((Word32, Word32, Word32), Word8)
pkwareDecryptByte keys :: (Word32, Word32, Word32)
keys@(Word32
_, Word32
_, Word32
key2) Word8
inB =
  let tmp :: Word32
tmp = Word32
key2 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
2
      tmp' :: Word8
tmp' = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word32
tmp Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* (Word32
tmp Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` Word32
1)) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
8) :: Word8
      outB :: Word8
outB = Word8
inB Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
`xor` Word8
tmp'
  in ((Word32, Word32, Word32) -> Word8 -> (Word32, Word32, Word32)
pkwareUpdateKeys (Word32, Word32, Word32)
keys Word8
outB, Word8
outB)

-- | Update decryption keys after a decrypted byte
pkwareUpdateKeys :: DecryptionCtx -> Word8 -> DecryptionCtx
pkwareUpdateKeys :: (Word32, Word32, Word32) -> Word8 -> (Word32, Word32, Word32)
pkwareUpdateKeys (Word32
key0, Word32
key1, Word32
key2) Word8
inB =
  let key0' :: Word32
key0' = Word32 -> Word8 -> Word32
pkwareCrc32Byte Word32
key0 Word8
inB
      key1' :: Word32
key1' = (Word32
key1 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ (Word32
key0' Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xff)) Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
134775813 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1
      key1Byte :: Word8
key1Byte = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
key1' Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
24) :: Word8
      key2' :: Word32
key2' = Word32 -> Word8 -> Word32
pkwareCrc32Byte Word32
key2 Word8
key1Byte
  in (Word32
key0', Word32
key1', Word32
key2')

-- | One step of the raw (unconditioned) CRC32 used by the PKWARE
-- key schedule, computed with a lookup table.
pkwareCrc32Byte :: Word32 -> Word8 -> Word32
pkwareCrc32Byte :: Word32 -> Word8 -> Word32
pkwareCrc32Byte Word32
key Word8
b =
  (Word32
key Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
8) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor`
    (UArray Word32 Word32
pkwareCrcTable UArray Word32 Word32 -> Word32 -> Word32
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! ((Word32
key Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xff))

-- | Standard CRC32 table (reflected, polynomial 0xedb88320).
pkwareCrcTable :: UArray Word32 Word32
pkwareCrcTable :: UArray Word32 Word32
pkwareCrcTable = (Word32, Word32) -> [Word32] -> UArray Word32 Word32
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Word32
0, Word32
255) ([Word32] -> UArray Word32 Word32)
-> [Word32] -> UArray Word32 Word32
forall a b. (a -> b) -> a -> b
$ (Word32 -> Word32) -> [Word32] -> [Word32]
forall a b. (a -> b) -> [a] -> [b]
map Word32 -> Word32
forall {a}. (Integral a, Bits a) => a -> a
crcEntry [Word32
0..Word32
255]
  where
    crcEntry :: a -> a
crcEntry a
n = (a -> a) -> a -> [a]
forall a. (a -> a) -> a -> [a]
iterate a -> a
forall {a}. (Integral a, Bits a) => a -> a
step a
n [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
!! (Int
8 :: Int)
    step :: a -> a
step a
x = if a -> Bool
forall a. Integral a => a -> Bool
odd a
x
                then (a
x a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
1) a -> a -> a
forall a. Bits a => a -> a -> a
`xor` a
0xedb88320
                else a
x a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
1

-- | Calculate compression ratio for an entry (for verbose output).
compressionRatio :: Entry -> Float
compressionRatio :: Entry -> Float
compressionRatio Entry
entry =
  if Entry -> Word32
eUncompressedSize Entry
entry Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0
     then Float
1
     else Word32 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Entry -> Word32
eCompressedSize Entry
entry) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Word32 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Entry -> Word32
eUncompressedSize Entry
entry)

-- | MSDOS datetime: a pair of Word16s (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 MSDOSDateTime = MSDOSDateTime { MSDOSDateTime -> Word16
msDOSDate :: Word16
                                   , MSDOSDateTime -> Word16
msDOSTime :: Word16
                                   } deriving (ReadPrec [MSDOSDateTime]
ReadPrec MSDOSDateTime
Int -> ReadS MSDOSDateTime
ReadS [MSDOSDateTime]
(Int -> ReadS MSDOSDateTime)
-> ReadS [MSDOSDateTime]
-> ReadPrec MSDOSDateTime
-> ReadPrec [MSDOSDateTime]
-> Read MSDOSDateTime
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS MSDOSDateTime
readsPrec :: Int -> ReadS MSDOSDateTime
$creadList :: ReadS [MSDOSDateTime]
readList :: ReadS [MSDOSDateTime]
$creadPrec :: ReadPrec MSDOSDateTime
readPrec :: ReadPrec MSDOSDateTime
$creadListPrec :: ReadPrec [MSDOSDateTime]
readListPrec :: ReadPrec [MSDOSDateTime]
Read, Int -> MSDOSDateTime -> ShowS
[MSDOSDateTime] -> ShowS
MSDOSDateTime -> String
(Int -> MSDOSDateTime -> ShowS)
-> (MSDOSDateTime -> String)
-> ([MSDOSDateTime] -> ShowS)
-> Show MSDOSDateTime
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MSDOSDateTime -> ShowS
showsPrec :: Int -> MSDOSDateTime -> ShowS
$cshow :: MSDOSDateTime -> String
show :: MSDOSDateTime -> String
$cshowList :: [MSDOSDateTime] -> ShowS
showList :: [MSDOSDateTime] -> ShowS
Show, MSDOSDateTime -> MSDOSDateTime -> Bool
(MSDOSDateTime -> MSDOSDateTime -> Bool)
-> (MSDOSDateTime -> MSDOSDateTime -> Bool) -> Eq MSDOSDateTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MSDOSDateTime -> MSDOSDateTime -> Bool
== :: MSDOSDateTime -> MSDOSDateTime -> Bool
$c/= :: MSDOSDateTime -> MSDOSDateTime -> Bool
/= :: MSDOSDateTime -> MSDOSDateTime -> Bool
Eq)

-- | Epoch time corresponding to the minimum DOS DateTime (Jan 1 1980 00:00:00).
minMSDOSDateTime :: Integer
minMSDOSDateTime :: Integer
minMSDOSDateTime = Integer
315532800

-- | Epoch time corresponding to the maximum DOS DateTime (Dec 31 2107 23:59:58).
maxMSDOSDateTime :: Integer
maxMSDOSDateTime :: Integer
maxMSDOSDateTime = POSIXTime -> Integer
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime -> Integer) -> POSIXTime -> Integer
forall a b. (a -> b) -> a -> b
$ UTCTime -> POSIXTime
utcTimeToPOSIXSeconds (UTCTime -> POSIXTime) -> UTCTime -> POSIXTime
forall a b. (a -> b) -> a -> b
$
  Day -> DiffTime -> UTCTime
UTCTime (Integer -> Int -> Int -> Day
fromGregorian Integer
2107 Int
12 Int
31) (DiffTime
23 DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
3600 DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
59 DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
60 DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
58)

-- | Convert an epoch time to a MSDOS datetime.  Note that no time zone
-- adjustment happens here: the epoch time is rendered as is, so callers
-- are expected to pass times already shifted to the local time zone
-- (see 'readEntry' and 'setFileTimeStamp').
epochTimeToMSDOSDateTime :: Integer -> MSDOSDateTime
epochTimeToMSDOSDateTime :: Integer -> MSDOSDateTime
epochTimeToMSDOSDateTime Integer
epochtime | Integer
epochtime Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
minMSDOSDateTime =
  Integer -> MSDOSDateTime
epochTimeToMSDOSDateTime Integer
minMSDOSDateTime
  -- if time is earlier than minimum DOS datetime, return minimum
epochTimeToMSDOSDateTime Integer
epochtime | Integer
epochtime Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
maxMSDOSDateTime =
  Integer -> MSDOSDateTime
epochTimeToMSDOSDateTime Integer
maxMSDOSDateTime
  -- if time is later than maximum DOS datetime, return maximum;
  -- the year field of a DOS datetime cannot represent years past 2107,
  -- and larger values would make toEnum fail below
epochTimeToMSDOSDateTime Integer
epochtime =
  let
    UTCTime
      (Day -> (Integer, Int, Int)
toGregorian -> (Integer -> Int
forall a. Num a => Integer -> a
fromInteger -> Int
year, Int
month, Int
day))
      (DiffTime -> TimeOfDay
timeToTimeOfDay -> (TimeOfDay Int
hour Int
minutes (Pico -> Int
forall b. Integral b => Pico -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor -> Int
sec)))
      = POSIXTime -> UTCTime
posixSecondsToUTCTime (Integer -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
epochtime)

    dosTime :: Word16
dosTime = Int -> Word16
forall a. Enum a => Int -> a
toEnum (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ (Int
sec Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) 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
hour Int
11
    dosDate :: Word16
dosDate = Int -> Word16
forall a. Enum a => Int -> a
toEnum (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ 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 -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1980) Int
9
  in  MSDOSDateTime { msDOSDate :: Word16
msDOSDate = Word16
dosDate, msDOSTime :: Word16
msDOSTime = Word16
dosTime }

-- | Convert a MSDOS datetime to a 'ClockTime'.
msDOSDateTimeToEpochTime :: MSDOSDateTime -> Integer
msDOSDateTimeToEpochTime :: MSDOSDateTime -> Integer
msDOSDateTimeToEpochTime MSDOSDateTime {msDOSDate :: MSDOSDateTime -> Word16
msDOSDate = Word16
dosDate, msDOSTime :: MSDOSDateTime -> Word16
msDOSTime = Word16
dosTime} =
  let seconds :: DiffTime
seconds = Word16 -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> DiffTime) -> Word16 -> DiffTime
forall a b. (a -> b) -> a -> b
$ Word16
2 Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
* (Word16
dosTime Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0O37)
      minutes :: DiffTime
minutes = Word16 -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> DiffTime) -> Word16 -> DiffTime
forall a b. (a -> b) -> a -> b
$ Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
shiftR Word16
dosTime Int
5 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0O77
      hour :: DiffTime
hour    = Word16 -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> DiffTime) -> Word16 -> DiffTime
forall a b. (a -> b) -> a -> b
$ Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
shiftR Word16
dosTime Int
11
      day :: Int
day     = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int) -> Word16 -> Int
forall a b. (a -> b) -> a -> b
$ Word16
dosDate Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0O37
      month :: Int
month   = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
shiftR Word16
dosDate Int
5) Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0O17)
      year :: Integer
year    = Word16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Integer) -> Word16 -> Integer
forall a b. (a -> b) -> a -> b
$ Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
shiftR Word16
dosDate Int
9
      utc :: UTCTime
utc = Day -> DiffTime -> UTCTime
UTCTime (Integer -> Int -> Int -> Day
fromGregorian (Integer
1980 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
year) Int
month Int
day) (DiffTime
3600 DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
hour DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
60 DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
minutes DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
seconds)
  in POSIXTime -> Integer
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (UTCTime -> POSIXTime
utcTimeToPOSIXSeconds UTCTime
utc)

#ifndef _WINDOWS
getDirectoryContentsRecursive' :: [ZipOption] -> FilePath -> IO [FilePath]
getDirectoryContentsRecursive' :: [ZipOption] -> String -> IO [String]
getDirectoryContentsRecursive' [ZipOption]
opts String
path =
  if ZipOption
OptPreserveSymbolicLinks ZipOption -> [ZipOption] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ZipOption]
opts
     then do
       isDir <- String -> IO Bool
doesDirectoryExist String
path
       if isDir
          then do
            isSymLink <- fmap isSymbolicLink $ getSymbolicLinkStatus path
            if isSymLink
               then return [path]
               else getDirectoryContentsRecursivelyBy (getDirectoryContentsRecursive' opts) path
          else return [path]
     else String -> IO [String]
getDirectoryContentsRecursive String
path
#endif

getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive :: String -> IO [String]
getDirectoryContentsRecursive String
path = do
  isDir <- String -> IO Bool
doesDirectoryExist String
path
  if isDir
     then getDirectoryContentsRecursivelyBy getDirectoryContentsRecursive path
     else return [path]

getDirectoryContentsRecursivelyBy :: (FilePath -> IO [FilePath]) -> FilePath -> IO [FilePath]
getDirectoryContentsRecursivelyBy :: (String -> IO [String]) -> String -> IO [String]
getDirectoryContentsRecursivelyBy String -> IO [String]
exploreMethod String
path = do
       contents <- String -> IO [String]
getDirectoryContents String
path
       let contents' = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
path String -> ShowS
</>) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
"..",String
"."]) [String]
contents
       children <- mapM exploreMethod contents'
       if path == "."
          then return (concat children)
          else return (path : concat children)


setFileTimeStamp :: FilePath -> Integer -> IO ()
#ifdef _WINDOWS
setFileTimeStamp _ _ = return () -- TODO: figure out how to set the timestamp on Windows
#else
setFileTimeStamp :: String -> Integer -> IO ()
setFileTimeStamp String
file Integer
epochtime = do
  -- eLastModified is relative to the LOCAL time zone (see readEntry
  -- and #67), because MSDOS timestamps are conventionally local time.
  -- Reverse that shift here, so that reading and extracting an entry
  -- preserves the file's modification time.
  tzone <- UTCTime -> IO TimeZone
getTimeZone (POSIXTime -> UTCTime
posixSecondsToUTCTime (Integer -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
epochtime))
  let epochtime' = Integer -> EpochTime
forall a. Num a => Integer -> a
fromInteger (Integer -> EpochTime) -> Integer -> EpochTime
forall a b. (a -> b) -> a -> b
$
        Integer
epochtime Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TimeZone -> Int
timeZoneMinutes TimeZone
tzone Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60)
  setFileTimes file epochtime' epochtime'
#endif

-- A zip file has the following format (*'d items are not supported in this implementation):
--
-- >   [local file header 1]
-- >   [file data 1]
-- >   [data descriptor 1*]
-- >   .
-- >   .
-- >   .
-- >   [local file header n]
-- >   [file data n]
-- >   [data descriptor n*]
-- >   [archive decryption header*]
-- >   [archive extra data record*]
-- >   [central directory]
-- >   [zip64 end of central directory record*]
-- >   [zip64 end of central directory locator*]
-- >   [end of central directory record]
--
-- Files stored in arbitrary order.  All values are stored in
-- little-endian byte order unless otherwise specified.
--
--  Central directory structure:
--
-- >   [file header 1]
-- >   .
-- >   .
-- >   .
-- >   [file header n]
-- >   [digital signature]
--
--  End of central directory record:
--
-- >   end of central dir signature    4 bytes  (0x06054b50)
-- >   number of this disk             2 bytes
-- >   number of the disk with the
-- >   start of the central directory  2 bytes
-- >   total number of entries in the
-- >   central directory on this disk  2 bytes
-- >   total number of entries in
-- >   the central directory           2 bytes
-- >   size of the central directory   4 bytes
-- >   offset of start of central
-- >   directory with respect to
-- >   the starting disk number        4 bytes
-- >   .ZIP file comment length        2 bytes
-- >   .ZIP file comment       (variable size)

getArchive :: Get Archive
getArchive :: Get Archive
getArchive = do
  locals <- Word32 -> Get (Word32, ByteString) -> Get [(Word32, ByteString)]
forall a. Word32 -> Get a -> Get [a]
manySig Word32
0x04034b50 Get (Word32, ByteString)
getLocalFile
  files <- manySig 0x02014b50 (getFileHeader (M.fromList locals))
  digSig <- Just `fmap` getDigitalSignature <|> return Nothing
  endSig <- getWord32le
  unless (endSig == 0x06054b50)
    $ fail "Did not find end of central directory signature"
  skip 2 -- disk number
  skip 2 -- disk number of central directory
  skip 2 -- num entries on this disk
  skip 2 -- num entries in central directory
  skip 4 -- central directory size
  skip 4 -- offset of central directory
  commentLength <- getWord16le
  zipComment <- getLazyByteString (toEnum $ fromEnum commentLength)
  return Archive
           { zEntries                = files
           , zSignature              = digSig
           , zComment                = zipComment
           }

putArchive :: Archive -> Put
putArchive :: Archive -> Put
putArchive Archive
archive = do
  let numEntries :: Int
numEntries = [Entry] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Entry] -> Int) -> [Entry] -> Int
forall a b. (a -> b) -> a -> b
$ Archive -> [Entry]
zEntries Archive
archive
  Bool -> Put -> Put
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
numEntries Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0xFFFF) (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$
    ZipException -> Put
forall a e. (HasCallStack, Exception e) => e -> a
E.throw (ZipException -> Put) -> ZipException -> Put
forall a b. (a -> b) -> a -> b
$ String -> ZipException
Zip64NotSupported String
"65535 or more entries require ZIP64"
  (Entry -> Put) -> [Entry] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Entry -> Put
putLocalFile ([Entry] -> Put) -> [Entry] -> Put
forall a b. (a -> b) -> a -> b
$ Archive -> [Entry]
zEntries Archive
archive
  let localFileSizes :: [Int64]
localFileSizes = (Entry -> Int64) -> [Entry] -> [Int64]
forall a b. (a -> b) -> [a] -> [b]
map Entry -> Int64
localFileSize ([Entry] -> [Int64]) -> [Entry] -> [Int64]
forall a b. (a -> b) -> a -> b
$ Archive -> [Entry]
zEntries Archive
archive
  let offsets :: [Int64]
offsets = (Int64 -> Int64 -> Int64) -> Int64 -> [Int64] -> [Int64]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
(+) Int64
0 [Int64]
localFileSizes
  let cdOffset :: Int64
cdOffset = [Int64] -> Int64
forall a. HasCallStack => [a] -> a
last [Int64]
offsets
  Bool -> Put -> Put
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64
cdOffset Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
0xFFFFFFFF) (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$
    ZipException -> Put
forall a e. (HasCallStack, Exception e) => e -> a
E.throw (ZipException -> Put) -> ZipException -> Put
forall a b. (a -> b) -> a -> b
$ String -> ZipException
Zip64NotSupported String
"archive of 4GB or more requires ZIP64"
  _ <- (Word32 -> Entry -> Put) -> [Word32] -> [Entry] -> Put
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ Word32 -> Entry -> Put
putFileHeader ((Int64 -> Word32) -> [Int64] -> [Word32]
forall a b. (a -> b) -> [a] -> [b]
map Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Int64]
offsets) (Archive -> [Entry]
zEntries Archive
archive)
  putDigitalSignature $ zSignature archive
  putWord32le 0x06054b50
  putWord16le 0 -- disk number
  putWord16le 0 -- disk number of central directory
  putWord16le $ fromIntegral $ length $ zEntries archive -- number of entries this disk
  putWord16le $ fromIntegral $ length $ zEntries archive -- number of entries
  putWord32le $ sum $ map fileHeaderSize $ zEntries archive  -- size of central directory
  putWord32le $ fromIntegral cdOffset                    -- offset of central dir
  putWord16le $ fromIntegral $ B.length $ zComment archive
  putLazyByteString $ zComment archive


fileHeaderSize :: Entry -> Word32
fileHeaderSize :: Entry -> Word32
fileHeaderSize Entry
f =
  Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word32) -> Int64 -> Word32
forall a b. (a -> b) -> a -> b
$ Int64
4 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
4 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
4 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
4 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
4 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
4 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+
    Int64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int64
B.length (ByteString -> Int64) -> ByteString -> Int64
forall a b. (a -> b) -> a -> b
$ String -> ByteString
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ ShowS
normalizePath ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Entry -> String
eRelativePath Entry
f) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+
    ByteString -> Int64
B.length (Entry -> ByteString
eExtraField Entry
f) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ ByteString -> Int64
B.length (Entry -> ByteString
eFileComment Entry
f)

-- Note: computed as Int64 (not Word32) so that putArchive can detect
-- offsets that would overflow the 32-bit fields of the zip format.
localFileSize :: Entry -> Int64
localFileSize :: Entry -> Int64
localFileSize Entry
f =
  Int64
4 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
4 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
4 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
4 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+
    ByteString -> Int64
B.length (String -> ByteString
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ ShowS
normalizePath ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Entry -> String
eRelativePath Entry
f) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+
    ByteString -> Int64
B.length (Entry -> ByteString
eExtraField Entry
f) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ ByteString -> Int64
B.length (Entry -> ByteString
eCompressedData Entry
f)

-- Local file header:
--
-- >    local file header signature     4 bytes  (0x04034b50)
-- >    version needed to extract       2 bytes
-- >    general purpose bit flag        2 bytes
-- >    compression method              2 bytes
-- >    last mod file time              2 bytes
-- >    last mod file date              2 bytes
-- >    crc-32                          4 bytes
-- >    compressed size                 4 bytes
-- >    uncompressed size               4 bytes
-- >    file name length                2 bytes
-- >    extra field length              2 bytes
--
-- >    file name (variable size)
-- >    extra field (variable size)
--
-- Note that if bit 3 of the general purpose bit flag is set, then the
-- compressed size will be 0 and the size will be stored instead in a
-- data descriptor record AFTER the file contents. The record normally
-- begins with the signature 0x08074b50, then 4 bytes crc-32, 4 bytes
-- compressed size, 4 bytes uncompressed size.

getLocalFile :: Get (Word32, B.ByteString)
getLocalFile :: Get (Word32, ByteString)
getLocalFile = do
  offset <- Get Int64
bytesRead
  getWord32le >>= ensure (== 0x04034b50)
  skip 2  -- version
  bitflag <- getWord16le
  rawCompressionMethod <- getWord16le
  compressionMethod <- case rawCompressionMethod of
                        Word16
0 -> CompressionMethod -> Get CompressionMethod
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return CompressionMethod
NoCompression
                        Word16
8 -> CompressionMethod -> Get CompressionMethod
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return CompressionMethod
Deflate
                        Word16
_ -> String -> Get CompressionMethod
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get CompressionMethod)
-> String -> Get CompressionMethod
forall a b. (a -> b) -> a -> b
$ String
"Unknown compression method " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word16 -> String
forall a. Show a => a -> String
show Word16
rawCompressionMethod
  skip 2  -- last mod file time
  skip 2  -- last mod file date
  skip 4  -- crc32
  compressedSize <- getWord32le
  when (compressedSize == 0xFFFFFFFF) $
    fail "Can't read ZIP64 archive."
  skip 4  -- uncompressedsize
  fileNameLength <- getWord16le
  extraFieldLength <- getWord16le
  skip (fromIntegral fileNameLength)  -- filename
  skip (fromIntegral extraFieldLength) -- extra field
  compressedData <-
    if bitflag .&. 0O10 == 0
      then getLazyByteString (fromIntegral compressedSize)
      else -- If bit 3 of general purpose bit flag is set,
           -- then we need to read until we get to the
           -- data descriptor record.
           do raw <- getCompressedData compressionMethod
              sig <- lookAhead getWord32le
              when (sig == 0x08074b50) $ skip 4
              skip 4 -- crc32
              cs <- getWord32le  -- compressed size
              skip 4 -- uncompressed size
              if fromIntegral cs == B.length raw
                 then return raw
                 else fail $ printf
                       ("Content size mismatch in data descriptor record: "
                         ++ "expected %d, got %d bytes")
                       cs (B.length raw)
  return (fromIntegral offset, compressedData)

putLocalFile :: Entry -> Put
putLocalFile :: Entry -> Put
putLocalFile Entry
f = do
  Word32 -> Put
putWord32le Word32
0x04034b50
  Word16 -> Put
putWord16le Word16
20 -- version needed to extract (>=2.0)
  Word16 -> Put
putWord16le Word16
0x800  -- general purpose bit flag (bit 11 = UTF-8)
  Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ case Entry -> CompressionMethod
eCompressionMethod Entry
f of
                     CompressionMethod
NoCompression -> Word16
0
                     CompressionMethod
Deflate       -> Word16
8
  let modTime :: MSDOSDateTime
modTime = Integer -> MSDOSDateTime
epochTimeToMSDOSDateTime (Integer -> MSDOSDateTime) -> Integer -> MSDOSDateTime
forall a b. (a -> b) -> a -> b
$ Entry -> Integer
eLastModified Entry
f
  Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ MSDOSDateTime -> Word16
msDOSTime MSDOSDateTime
modTime
  Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ MSDOSDateTime -> Word16
msDOSDate MSDOSDateTime
modTime
  Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Entry -> Word32
eCRC32 Entry
f
  Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Entry -> Word32
eCompressedSize Entry
f
  Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Entry -> Word32
eUncompressedSize Entry
f
  let encodedPath :: ByteString
encodedPath = String -> ByteString
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ ShowS
normalizePath ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Entry -> String
eRelativePath Entry
f
  Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ Int64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word16) -> Int64 -> Word16
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
B.length ByteString
encodedPath
  Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ Int64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word16) -> Int64 -> Word16
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
B.length (ByteString -> Int64) -> ByteString -> Int64
forall a b. (a -> b) -> a -> b
$ Entry -> ByteString
eExtraField Entry
f
  ByteString -> Put
putLazyByteString ByteString
encodedPath
  ByteString -> Put
putLazyByteString (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ Entry -> ByteString
eExtraField Entry
f
  ByteString -> Put
putLazyByteString (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ Entry -> ByteString
eCompressedData Entry
f

-- File header structure:
--
-- >    central file header signature   4 bytes  (0x02014b50)
-- >    version made by                 2 bytes
-- >    version needed to extract       2 bytes
-- >    general purpose bit flag        2 bytes
-- >    compression method              2 bytes
-- >    last mod file time              2 bytes
-- >    last mod file date              2 bytes
-- >    crc-32                          4 bytes
-- >    compressed size                 4 bytes
-- >    uncompressed size               4 bytes
-- >    file name length                2 bytes
-- >    extra field length              2 bytes
-- >    file comment length             2 bytes
-- >    disk number start               2 bytes
-- >    internal file attributes        2 bytes
-- >    external file attributes        4 bytes
-- >    relative offset of local header 4 bytes
--
-- >    file name (variable size)
-- >    extra field (variable size)
-- >    file comment (variable size)

getFileHeader :: M.Map Word32 B.ByteString -- ^ map of (offset, content) pairs returned by getLocalFile
              -> Get Entry
getFileHeader :: Map Word32 ByteString -> Get Entry
getFileHeader Map Word32 ByteString
locals = do
  Get Word32
getWord32le Get Word32 -> (Word32 -> Get ()) -> Get ()
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Word32 -> Bool) -> Word32 -> Get ()
forall a. (a -> Bool) -> a -> Get ()
ensure (Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x02014b50)
  vmb <- Get Word16
getWord16le  -- version made by
  versionNeededToExtract <- getWord8
  skip 1 -- upper byte indicates OS part of "version needed to extract"
  unless (versionNeededToExtract <= 20) $
    fail "This archive requires zip >= 2.0 to extract."
  bitflag <- getWord16le
  rawCompressionMethod <- getWord16le
  compressionMethod <- case rawCompressionMethod of
                        Word16
0 -> CompressionMethod -> Get CompressionMethod
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return CompressionMethod
NoCompression
                        Word16
8 -> CompressionMethod -> Get CompressionMethod
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return CompressionMethod
Deflate
                        Word16
_ -> String -> Get CompressionMethod
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get CompressionMethod)
-> String -> Get CompressionMethod
forall a b. (a -> b) -> a -> b
$ String
"Unknown compression method " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word16 -> String
forall a. Show a => a -> String
show Word16
rawCompressionMethod
  lastModFileTime <- getWord16le
  lastModFileDate <- getWord16le
  crc32 <- getWord32le
  encryptionMethod <- case (testBit bitflag 0, testBit bitflag 3, testBit bitflag 6) of
                        (Bool
False, Bool
_, Bool
_) -> EncryptionMethod -> Get EncryptionMethod
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return EncryptionMethod
NoEncryption
                        (Bool
True, Bool
False, Bool
False) -> EncryptionMethod -> Get EncryptionMethod
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (EncryptionMethod -> Get EncryptionMethod)
-> EncryptionMethod -> Get EncryptionMethod
forall a b. (a -> b) -> a -> b
$ Word8 -> EncryptionMethod
PKWAREEncryption (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
crc32 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
24))
                        (Bool
True, Bool
True, Bool
False) -> EncryptionMethod -> Get EncryptionMethod
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (EncryptionMethod -> Get EncryptionMethod)
-> EncryptionMethod -> Get EncryptionMethod
forall a b. (a -> b) -> a -> b
$ Word8 -> EncryptionMethod
PKWAREEncryption (Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
lastModFileTime Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftR` Int
8))
                        (Bool
True, Bool
_, Bool
True) -> String -> Get EncryptionMethod
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Strong encryption is not supported"

  compressedSize <- getWord32le
  uncompressedSize <- getWord32le
  fileNameLength <- getWord16le
  extraFieldLength <- getWord16le
  fileCommentLength <- getWord16le
  skip 2 -- disk number start
  internalFileAttributes <- getWord16le
  externalFileAttributes <- getWord32le
  relativeOffset <- getWord32le
  fileName <- getLazyByteString (toEnum $ fromEnum fileNameLength)
  extraField <- getLazyByteString (toEnum $ fromEnum extraFieldLength)
  fileComment <- getLazyByteString (toEnum $ fromEnum fileCommentLength)
  compressedData <- case M.lookup relativeOffset locals of
                    Just ByteString
x  -> ByteString -> Get ByteString
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
                    Maybe ByteString
Nothing -> String -> Get ByteString
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get ByteString) -> String -> Get ByteString
forall a b. (a -> b) -> a -> b
$ String
"Unable to find data at offset " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                        Word32 -> String
forall a. Show a => a -> String
show Word32
relativeOffset
  return Entry
            { eRelativePath            = decodeFileName bitflag fileName
            , eCompressionMethod       = compressionMethod
            , eEncryptionMethod        = encryptionMethod
            , eLastModified            = msDOSDateTimeToEpochTime $
                                         MSDOSDateTime { msDOSDate = lastModFileDate,
                                                         msDOSTime = lastModFileTime }
            , eCRC32                   = crc32
            , eCompressedSize          = compressedSize
            , eUncompressedSize        = uncompressedSize
            , eExtraField              = extraField
            , eFileComment             = fileComment
            , eVersionMadeBy           = vmb
            , eInternalFileAttributes  = internalFileAttributes
            , eExternalFileAttributes  = externalFileAttributes
            , eCompressedData          = compressedData
            }

putFileHeader :: Word32        -- ^ offset
              -> Entry
              -> Put
putFileHeader :: Word32 -> Entry -> Put
putFileHeader Word32
offset Entry
local = do
  Word32 -> Put
putWord32le Word32
0x02014b50
  Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ Entry -> Word16
eVersionMadeBy Entry
local
  Word16 -> Put
putWord16le Word16
20 -- version needed to extract (>= 2.0)
  Word16 -> Put
putWord16le Word16
0x800  -- general purpose bit flag (bit 11 = UTF-8)
  Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ case Entry -> CompressionMethod
eCompressionMethod Entry
local of
                     CompressionMethod
NoCompression -> Word16
0
                     CompressionMethod
Deflate       -> Word16
8
  let modTime :: MSDOSDateTime
modTime = Integer -> MSDOSDateTime
epochTimeToMSDOSDateTime (Integer -> MSDOSDateTime) -> Integer -> MSDOSDateTime
forall a b. (a -> b) -> a -> b
$ Entry -> Integer
eLastModified Entry
local
  Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ MSDOSDateTime -> Word16
msDOSTime MSDOSDateTime
modTime
  Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ MSDOSDateTime -> Word16
msDOSDate MSDOSDateTime
modTime
  Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Entry -> Word32
eCRC32 Entry
local
  Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Entry -> Word32
eCompressedSize Entry
local
  Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Entry -> Word32
eUncompressedSize Entry
local
  let encodedPath :: ByteString
encodedPath = String -> ByteString
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ ShowS
normalizePath ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Entry -> String
eRelativePath Entry
local
  Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ Int64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word16) -> Int64 -> Word16
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
B.length ByteString
encodedPath
  Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ Int64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word16) -> Int64 -> Word16
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
B.length (ByteString -> Int64) -> ByteString -> Int64
forall a b. (a -> b) -> a -> b
$ Entry -> ByteString
eExtraField Entry
local
  Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ Int64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word16) -> Int64 -> Word16
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
B.length (ByteString -> Int64) -> ByteString -> Int64
forall a b. (a -> b) -> a -> b
$ Entry -> ByteString
eFileComment Entry
local
  Word16 -> Put
putWord16le Word16
0  -- disk number start
  Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ Entry -> Word16
eInternalFileAttributes Entry
local
  Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Entry -> Word32
eExternalFileAttributes Entry
local
  Word32 -> Put
putWord32le Word32
offset
  ByteString -> Put
putLazyByteString ByteString
encodedPath
  ByteString -> Put
putLazyByteString (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ Entry -> ByteString
eExtraField Entry
local
  ByteString -> Put
putLazyByteString (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ Entry -> ByteString
eFileComment Entry
local

--  Digital signature:
--
-- >     header signature                4 bytes  (0x05054b50)
-- >     size of data                    2 bytes
-- >     signature data (variable size)

getDigitalSignature :: Get B.ByteString
getDigitalSignature :: Get ByteString
getDigitalSignature = do
  Get Word32
getWord32le Get Word32 -> (Word32 -> Get ()) -> Get ()
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Word32 -> Bool) -> Word32 -> Get ()
forall a. (a -> Bool) -> a -> Get ()
ensure (Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x05054b50)
  sigSize <- Get Word16
getWord16le
  getLazyByteString (toEnum $ fromEnum sigSize)

putDigitalSignature :: Maybe B.ByteString -> Put
putDigitalSignature :: Maybe ByteString -> Put
putDigitalSignature Maybe ByteString
Nothing = () -> Put
forall a. a -> PutM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
putDigitalSignature (Just ByteString
sig) = do
  Word32 -> Put
putWord32le Word32
0x05054b50
  Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ Int64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word16) -> Int64 -> Word16
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
B.length ByteString
sig
  ByteString -> Put
putLazyByteString ByteString
sig

ensure :: (a -> Bool) -> a -> Get ()
ensure :: forall a. (a -> Bool) -> a -> Get ()
ensure a -> Bool
p a
val =
  if a -> Bool
p a
val
     then () -> Get ()
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     else String -> Get ()
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"ensure not satisfied"

-- | Decode a file name from a zip archive according to the general
-- purpose bit flag: if bit 11 is set, the name is UTF-8 encoded;
-- otherwise the zip spec says it is encoded in IBM code page 437.
-- Invalid UTF-8 is decoded leniently (invalid bytes are replaced by
-- U+FFFD) rather than raising an exception, so that 'toArchiveOrFail'
-- remains total.
decodeFileName :: Word16 -> B.ByteString -> String
decodeFileName :: Word16 -> ByteString -> String
decodeFileName Word16
bitflag ByteString
fn
  | Word16 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word16
bitflag Int
11 = Text -> String
TL.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
TL.decodeUtf8With OnDecodeError
TE.lenientDecode ByteString
fn
  | Bool
otherwise          = (Word8 -> Char) -> [Word8] -> String
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Char
cp437ToChar ([Word8] -> String) -> [Word8] -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
B.unpack ByteString
fn

cp437ToChar :: Word8 -> Char
cp437ToChar :: Word8 -> Char
cp437ToChar Word8
w
  | Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
128   = Int -> Char
forall a. Enum a => Int -> a
toEnum (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w)
  | Bool
otherwise = String
cp437table String -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
!! Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
w Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
128)

-- IBM code page 437, upper half (0x80 - 0xFF).
cp437table :: String
cp437table :: String
cp437table =
  "\199\252\233\226\228\224\229\231\234\235\232\239\238\236\196\197\
  \\201\230\198\244\246\242\251\249\255\214\220\162\163\165\8359\402\
  \\225\237\243\250\241\209\170\186\191\8976\172\189\188\161\171\187\
  \\9617\9618\9619\9474\9508\9569\9570\9558\9557\9571\9553\9559\9565\9564\9563\9488\
  \\9492\9524\9516\9500\9472\9532\9566\9567\9562\9556\9577\9574\9568\9552\9580\9575\
  \\9576\9572\9573\9561\9560\9554\9555\9579\9578\9496\9484\9608\9604\9612\9616\9600\
  \\945\223\915\960\931\963\181\964\934\920\937\948\8734\966\949\8745\
  \\8801\177\8805\8804\8992\8993\247\8776\176\8729\183\8730\8319\178\9632\160"

fromString :: String -> B.ByteString
fromString :: String -> ByteString
fromString = Text -> ByteString
TL.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
TL.pack

getCompressedData :: CompressionMethod -> Get B.ByteString
getCompressedData :: CompressionMethod -> Get ByteString
getCompressedData CompressionMethod
NoCompression = do
  -- we assume there will be a signature on the data descriptor,
  -- otherwise we have no way of identifying where the data ends!
  -- The signature 0x08074b50 is commonly used but not required by spec.
  let findSigPos :: Get Int64
findSigPos = do
        w1 <- Get Word8
getWord8
        if w1 == 0x50
           then do
             w2 <- getWord8
             if w2 == 0x4b
                then do
                  w3 <- getWord8
                  if w3 == 0x07
                     then do
                       w4 <- getWord8
                       if w4 == 0x08
                          then (\Int64
x -> Int64
x Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
4) <$> bytesRead
                          else findSigPos
                     else findSigPos
                else findSigPos
           else findSigPos
  pos <- Get Int64
bytesRead
  sigpos <- lookAhead findSigPos <|>
              fail "getCompressedData can't find data descriptor signature"
  let compressedBytes = Int64
sigpos Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
pos
  getLazyByteString compressedBytes
getCompressedData CompressionMethod
Deflate = do
  remainingBytes <- Get ByteString -> Get ByteString
forall a. Get a -> Get a
lookAhead Get ByteString
getRemainingLazyByteString
  -- We decompress (discarding the output) only as a way of finding
  -- where the compressed data ends.
  case countCompressedBytes remainingBytes of
    Left DecompressError
err       -> String -> Get ByteString
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (DecompressError -> String
forall a. Show a => a -> String
show DecompressError
err)
    Right Int64
consumed -> Int64 -> Get ByteString
getLazyByteString Int64
consumed

-- Decompress the input chunk by chunk, discarding the decompressed
-- output, and return the number of compressed bytes consumed (i.e.,
-- where the deflate stream ends).  Feeding the decompressor chunk by
-- chunk means we only ever force the compressed data itself, rather
-- than computing the length of everything that follows it (which
-- would force the entire rest of the archive).
countCompressedBytes :: B.ByteString -> Either ZlibInt.DecompressError Int64
countCompressedBytes :: ByteString -> Either DecompressError Int64
countCompressedBytes ByteString
input =
    (forall s. ST s (Either DecompressError Int64))
-> Either DecompressError Int64
forall a. (forall s. ST s a) -> a
runST ([ByteString]
-> Int64
-> DecompressStream (ST s)
-> ST s (Either DecompressError Int64)
forall {m :: * -> *} {a}.
(Monad m, Num a) =>
[ByteString]
-> a -> DecompressStream m -> m (Either DecompressError a)
go (ByteString -> [ByteString]
B.toChunks ByteString
input) Int64
0
              (Format -> DecompressParams -> DecompressStream (ST s)
forall s. Format -> DecompressParams -> DecompressStream (ST s)
ZlibInt.decompressST Format
ZlibInt.rawFormat
                DecompressParams
ZlibInt.defaultDecompressParams{
                    ZlibInt.decompressAllMembers = False }))
  where
    go :: [ByteString]
-> a -> DecompressStream m -> m (Either DecompressError a)
go [ByteString]
chunks a
supplied DecompressStream m
stream =
      case DecompressStream m
stream of
        ZlibInt.DecompressInputRequired ByteString -> m (DecompressStream m)
next ->
          case [ByteString]
chunks of
            (ByteString
c:[ByteString]
cs) -> let supplied' :: a
supplied' = a
supplied a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
S.length ByteString
c)
                      in  a
supplied' a -> m (Either DecompressError a) -> m (Either DecompressError a)
forall a b. a -> b -> b
`seq` (ByteString -> m (DecompressStream m)
next ByteString
c m (DecompressStream m)
-> (DecompressStream m -> m (Either DecompressError a))
-> m (Either DecompressError a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [ByteString]
-> a -> DecompressStream m -> m (Either DecompressError a)
go [ByteString]
cs a
supplied')
            []     -> ByteString -> m (DecompressStream m)
next ByteString
S.empty m (DecompressStream m)
-> (DecompressStream m -> m (Either DecompressError a))
-> m (Either DecompressError a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [ByteString]
-> a -> DecompressStream m -> m (Either DecompressError a)
go [] a
supplied
                        -- S.empty signals end of input; the
                        -- decompressor then either ends cleanly or
                        -- reports a truncated stream
        ZlibInt.DecompressOutputAvailable ByteString
_out m (DecompressStream m)
next ->
          m (DecompressStream m)
next m (DecompressStream m)
-> (DecompressStream m -> m (Either DecompressError a))
-> m (Either DecompressError a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [ByteString]
-> a -> DecompressStream m -> m (Either DecompressError a)
go [ByteString]
chunks a
supplied
        ZlibInt.DecompressStreamEnd ByteString
leftover ->
          Either DecompressError a -> m (Either DecompressError a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either DecompressError a -> m (Either DecompressError a))
-> Either DecompressError a -> m (Either DecompressError a)
forall a b. (a -> b) -> a -> b
$ a -> Either DecompressError a
forall a b. b -> Either a b
Right (a -> Either DecompressError a) -> a -> Either DecompressError a
forall a b. (a -> b) -> a -> b
$ a
supplied a -> a -> a
forall a. Num a => a -> a -> a
- Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
S.length ByteString
leftover)
        ZlibInt.DecompressStreamError DecompressError
err ->
          Either DecompressError a -> m (Either DecompressError a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either DecompressError a -> m (Either DecompressError a))
-> Either DecompressError a -> m (Either DecompressError a)
forall a b. (a -> b) -> a -> b
$ DecompressError -> Either DecompressError a
forall a b. a -> Either a b
Left DecompressError
err