{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Codec.Archive.Zip.Internal
( PendingAction (..)
, targetEntry
, scanArchive
, sourceEntry
, crc32Sink
, commit )
where
import Codec.Archive.Zip.CP437 (decodeCP437)
import Codec.Archive.Zip.Type
import Conduit (PrimMonad)
import Control.Applicative (many, (<|>))
import Control.Exception (bracketOnError, catchJust)
import Control.Monad
import Control.Monad.Catch (MonadThrow (..))
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Resource (ResourceT, MonadResource)
import Data.Bits
import Data.Bool (bool)
import Data.ByteString (ByteString)
import Data.Char (ord)
import Data.Conduit (ConduitT, (.|), ZipSink (..))
import Data.Digest.CRC32 (crc32Update)
import Data.Fixed (Fixed (..))
import Data.Foldable (foldl')
import Data.Map.Strict (Map, (!))
import Data.Maybe (fromJust, catMaybes, isNothing)
import Data.Sequence (Seq, (><), (|>))
import Data.Serialize
import Data.Text (Text)
import Data.Time
import Data.Version
import Data.Void
import Data.Word (Word16, Word32)
import Numeric.Natural (Natural)
import System.Directory
import System.FilePath
import System.IO
import System.IO.Error (isDoesNotExistError)
import qualified Data.ByteString as B
import qualified Data.Conduit as C
#ifdef ENABLE_BZIP2
import qualified Data.Conduit.BZlib as BZ
#endif
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Zlib as Z
import qualified Data.Map.Strict as M
import qualified Data.Sequence as S
import qualified Data.Set as E
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
data PendingAction
= SinkEntry CompressionMethod
(ConduitT () ByteString (ResourceT IO) ())
EntrySelector
| CopyEntry FilePath EntrySelector EntrySelector
| RenameEntry EntrySelector EntrySelector
| DeleteEntry EntrySelector
| Recompress CompressionMethod EntrySelector
| SetEntryComment Text EntrySelector
| DeleteEntryComment EntrySelector
| SetModTime UTCTime EntrySelector
| AddExtraField Word16 ByteString EntrySelector
| DeleteExtraField Word16 EntrySelector
| SetArchiveComment Text
| DeleteArchiveComment
| SetExternalFileAttributes Word32 EntrySelector
data ProducingActions = ProducingActions
{ paCopyEntry :: Map FilePath (Map EntrySelector EntrySelector)
, paSinkEntry :: Map EntrySelector (ConduitT () ByteString (ResourceT IO) ())
}
data EditingActions = EditingActions
{ eaCompression :: Map EntrySelector CompressionMethod
, eaEntryComment :: Map EntrySelector Text
, eaDeleteComment :: Map EntrySelector ()
, eaModTime :: Map EntrySelector UTCTime
, eaExtraField :: Map EntrySelector (Map Word16 ByteString)
, eaDeleteField :: Map EntrySelector (Map Word16 ())
, eaExtFileAttr :: Map EntrySelector Word32 }
data EntryOrigin
= GenericOrigin
| Borrowed EntryDescription
data HeaderType
= LocalHeader
| CentralDirHeader
deriving Eq
data DataDescriptor = DataDescriptor
{ ddCRC32 :: Word32
, ddCompressedSize :: Natural
, ddUncompressedSize :: Natural }
data Zip64ExtraField = Zip64ExtraField
{ z64efUncompressedSize :: Natural
, z64efCompressedSize :: Natural
, z64efOffset :: Natural }
data MsDosTime = MsDosTime
{ msDosDate :: Word16
, msDosTime :: Word16 }
zipVersion :: Version
zipVersion = Version [4,6] []
scanArchive
:: FilePath
-> IO (ArchiveDescription, Map EntrySelector EntryDescription)
scanArchive path = withBinaryFile path ReadMode $ \h -> do
mecdOffset <- locateECD path h
case mecdOffset of
Just ecdOffset -> do
hSeek h AbsoluteSeek ecdOffset
ecdSize <- subtract ecdOffset <$> hFileSize h
ecdRaw <- B.hGet h (fromIntegral ecdSize)
case runGet getECD ecdRaw of
Left msg -> throwM (ParsingFailed path msg)
Right ecd -> do
hSeek h AbsoluteSeek $ fromIntegral (adCDOffset ecd)
cdRaw <- B.hGet h $ fromIntegral (adCDSize ecd)
case runGet getCD cdRaw of
Left msg -> throwM (ParsingFailed path msg)
Right cd -> return (ecd, cd)
Nothing ->
throwM (ParsingFailed path "Cannot locate end of central directory")
sourceEntry
:: (PrimMonad m, MonadThrow m, MonadResource m)
=> FilePath
-> EntryDescription
-> Bool
-> ConduitT () ByteString m ()
sourceEntry path EntryDescription {..} d =
source .| CB.isolate (fromIntegral edCompressedSize) .| decompress
where
source = CB.sourceIOHandle $ do
h <- openFile path ReadMode
hSeek h AbsoluteSeek (fromIntegral edOffset)
localHeader <- B.hGet h 30
case runGet getLocalHeaderGap localHeader of
Left msg -> throwM (ParsingFailed path msg)
Right gap -> do
hSeek h RelativeSeek gap
return h
decompress = if d
then decompressingPipe edCompression
else C.awaitForever C.yield
commit
:: FilePath
-> ArchiveDescription
-> Map EntrySelector EntryDescription
-> Seq PendingAction
-> IO ()
commit path ArchiveDescription {..} entries xs =
withNewFile path $ \h -> do
let (ProducingActions coping sinking, editing) =
optimize (toRecreatingActions path entries >< xs)
comment = predictComment adComment xs
copiedCD <- M.unions <$> forM (M.keys coping) (\srcPath ->
copyEntries h srcPath (coping ! srcPath) editing)
let sinkingKeys = M.keys $ sinking `M.difference` copiedCD
sunkCD <- M.fromList <$> forM sinkingKeys (\selector ->
sinkEntry h selector GenericOrigin (sinking ! selector) editing)
writeCD h comment (copiedCD `M.union` sunkCD)
withNewFile
:: FilePath
-> (Handle -> IO ())
-> IO ()
withNewFile fpath action =
bracketOnError allocate release $ \(path, h) -> do
action h
hClose h
renameFile path fpath
where
allocate = openBinaryTempFile (takeDirectory fpath) ".zip"
release (path, h) = do
hClose h
catchJust (guard . isDoesNotExistError) (removeFile path) (const $ pure ())
predictComment :: Maybe Text -> Seq PendingAction -> Maybe Text
predictComment original xs =
case S.index xs <$> S.findIndexR (isNothing . targetEntry) xs of
Nothing -> original
Just DeleteArchiveComment -> Nothing
Just (SetArchiveComment txt) -> Just txt
Just _ -> Nothing
toRecreatingActions
:: FilePath
-> Map EntrySelector EntryDescription
-> Seq PendingAction
toRecreatingActions path entries = E.foldl' f S.empty (M.keysSet entries)
where
f s e = s |> CopyEntry path e e
optimize
:: Seq PendingAction
-> (ProducingActions, EditingActions)
optimize = foldl' f
( ProducingActions M.empty M.empty
, EditingActions M.empty M.empty M.empty M.empty M.empty M.empty M.empty)
where
f (pa, ea) a = case a of
SinkEntry m src s ->
( pa { paSinkEntry = M.insert s src (paSinkEntry pa)
, paCopyEntry = M.map (M.filter (/= s)) (paCopyEntry pa) }
, (clearEditingFor s ea)
{ eaCompression = M.insert s m (eaCompression ea) } )
CopyEntry path os ns ->
( pa { paSinkEntry = M.delete ns (paSinkEntry pa)
, paCopyEntry = M.alter (ef os ns) path (paCopyEntry pa) }
, clearEditingFor ns ea )
RenameEntry os ns ->
( pa { paCopyEntry = M.map (M.map $ re os ns) (paCopyEntry pa)
, paSinkEntry = renameKey os ns (paSinkEntry pa) }
, ea { eaCompression = renameKey os ns (eaCompression ea)
, eaEntryComment = renameKey os ns (eaEntryComment ea)
, eaDeleteComment = renameKey os ns (eaDeleteComment ea)
, eaModTime = renameKey os ns (eaModTime ea)
, eaExtraField = renameKey os ns (eaExtraField ea)
, eaDeleteField = renameKey os ns (eaDeleteField ea) } )
DeleteEntry s ->
( pa { paSinkEntry = M.delete s (paSinkEntry pa)
, paCopyEntry = M.map (M.delete s) (paCopyEntry pa) }
, clearEditingFor s ea )
Recompress m s ->
(pa, ea { eaCompression = M.insert s m (eaCompression ea) })
SetEntryComment txt s ->
( pa
, ea { eaEntryComment = M.insert s txt (eaEntryComment ea)
, eaDeleteComment = M.delete s (eaDeleteComment ea) } )
DeleteEntryComment s ->
( pa
, ea { eaEntryComment = M.delete s (eaEntryComment ea)
, eaDeleteComment = M.insert s () (eaDeleteComment ea) } )
SetModTime time s ->
(pa, ea { eaModTime = M.insert s time (eaModTime ea) })
AddExtraField n b s ->
( pa
, ea { eaExtraField = M.alter (ef n b) s (eaExtraField ea)
, eaDeleteField = M.delete s (eaDeleteField ea) } )
DeleteExtraField n s ->
( pa
, ea { eaExtraField = M.alter (er n) s (eaExtraField ea)
, eaDeleteField = M.alter (ef n ()) s (eaDeleteField ea) } )
SetExternalFileAttributes b s ->
( pa
, ea { eaExtFileAttr = M.insert s b (eaExtFileAttr ea) })
_ -> (pa, ea)
clearEditingFor s ea = ea
{ eaCompression = M.delete s (eaCompression ea)
, eaEntryComment = M.delete s (eaEntryComment ea)
, eaDeleteComment = M.delete s (eaDeleteComment ea)
, eaModTime = M.delete s (eaModTime ea)
, eaExtraField = M.delete s (eaExtraField ea)
, eaDeleteField = M.delete s (eaDeleteField ea)
, eaExtFileAttr = M.delete s (eaExtFileAttr ea) }
re o n x = if x == o then n else x
ef k v (Just m) = Just (M.insert k v m)
ef k v Nothing = Just (M.singleton k v)
er k (Just m) = let n = M.delete k m in
if M.null n then Nothing else Just n
er _ Nothing = Nothing
copyEntries
:: Handle
-> FilePath
-> Map EntrySelector EntrySelector
-> EditingActions
-> IO (Map EntrySelector EntryDescription)
copyEntries h path m e = do
entries <- snd <$> scanArchive path
done <- forM (M.keys m) $ \s ->
case s `M.lookup` entries of
Nothing -> throwM (EntryDoesNotExist path s)
Just desc -> sinkEntry h (m ! s) (Borrowed desc)
(sourceEntry path desc False) e
return (M.fromList done)
sinkEntry
:: Handle
-> EntrySelector
-> EntryOrigin
-> ConduitT () ByteString (ResourceT IO) ()
-> EditingActions
-> IO (EntrySelector, EntryDescription)
sinkEntry h s o src EditingActions {..} = do
currentTime <- getCurrentTime
offset <- hTell h
let compressed = case o of
GenericOrigin -> Store
Borrowed ed -> edCompression ed
compression = M.findWithDefault compressed s eaCompression
recompression = compression /= compressed
modTime = case o of
GenericOrigin -> currentTime
Borrowed ed -> edModTime ed
extFileAttr = case o of
GenericOrigin -> M.findWithDefault 0 s eaExtFileAttr
Borrowed _ -> M.findWithDefault 0 s eaExtFileAttr
oldExtraFields = case o of
GenericOrigin -> M.empty
Borrowed ed -> edExtraField ed
extraField =
(M.findWithDefault M.empty s eaExtraField `M.union` oldExtraFields)
`M.difference` M.findWithDefault M.empty s eaDeleteField
oldComment = case (o, M.lookup s eaDeleteComment) of
(GenericOrigin, _) -> Nothing
(Borrowed ed, Nothing) -> edComment ed
(Borrowed _, Just ()) -> Nothing
desc0 = EntryDescription
{ edVersionMadeBy = zipVersion
, edVersionNeeded = zipVersion
, edCompression = compression
, edModTime = M.findWithDefault modTime s eaModTime
, edCRC32 = 0
, edCompressedSize = 0
, edUncompressedSize = 0
, edOffset = fromIntegral offset
, edComment = M.lookup s eaEntryComment <|> oldComment
, edExtraField = extraField
, edExternalFileAttrs = extFileAttr }
B.hPut h (runPut (putHeader LocalHeader s desc0))
DataDescriptor {..} <- C.runConduitRes $
if recompression
then
if compressed == Store
then src .| sinkData h compression
else src .| decompressingPipe compressed .| sinkData h compression
else src .| sinkData h Store
afterStreaming <- hTell h
let desc1 = case o of
GenericOrigin -> desc0
{ edCRC32 = ddCRC32
, edCompressedSize = ddCompressedSize
, edUncompressedSize = ddUncompressedSize }
Borrowed ed -> desc0
{ edCRC32 =
bool (edCRC32 ed) ddCRC32 recompression
, edCompressedSize =
bool (edCompressedSize ed) ddCompressedSize recompression
, edUncompressedSize =
bool (edUncompressedSize ed) ddUncompressedSize recompression }
desc2 = desc1
{ edVersionNeeded =
getZipVersion (needsZip64 desc1) (Just compression) }
hSeek h AbsoluteSeek offset
B.hPut h (runPut (putHeader LocalHeader s desc2))
hSeek h AbsoluteSeek afterStreaming
return (s, desc2)
sinkData
:: Handle
-> CompressionMethod
-> ConduitT ByteString Void (ResourceT IO) DataDescriptor
sinkData h compression = do
let sizeSink = CL.fold (\acc input -> fromIntegral (B.length input) + acc) 0
dataSink = getZipSink $
ZipSink sizeSink <* ZipSink (CB.sinkHandle h)
withCompression sink = getZipSink $
(,,) <$> ZipSink sizeSink
<*> ZipSink crc32Sink
<*> ZipSink sink
(uncompressedSize, crc32, compressedSize) <-
case compression of
Store -> withCompression
dataSink
Deflate -> withCompression $
Z.compress 9 (Z.WindowBits (-15)) .| dataSink
#ifdef ENABLE_BZIP2
BZip2 -> withCompression $
BZ.bzip2 .| dataSink
#else
BZip2 -> throwM BZip2Unsupported
#endif
return DataDescriptor
{ ddCRC32 = fromIntegral crc32
, ddCompressedSize = compressedSize
, ddUncompressedSize = uncompressedSize }
writeCD
:: Handle
-> Maybe Text
-> Map EntrySelector EntryDescription
-> IO ()
writeCD h comment m = do
let cd = runPut (putCD m)
cdOffset <- fromIntegral <$> hTell h
B.hPut h cd
let totalCount = fromIntegral (M.size m)
cdSize = fromIntegral (B.length cd)
needZip64 =
totalCount >= ffff
|| cdSize >= ffffffff
|| cdOffset >= ffffffff
when needZip64 $ do
zip64ecdOffset <- fromIntegral <$> hTell h
(B.hPut h . runPut) (putZip64ECD totalCount cdSize cdOffset)
(B.hPut h . runPut) (putZip64ECDLocator zip64ecdOffset)
(B.hPut h . runPut) (putECD totalCount cdSize cdOffset comment)
getLocalHeaderGap :: Get Integer
getLocalHeaderGap = do
getSignature 0x04034b50
skip 2
skip 2
skip 2
skip 2
skip 2
skip 4
skip 4
skip 4
fileNameSize <- fromIntegral <$> getWord16le
extraFieldSize <- fromIntegral <$> getWord16le
return (fileNameSize + extraFieldSize)
getCD :: Get (Map EntrySelector EntryDescription)
getCD = M.fromList . catMaybes <$> many getCDHeader
getCDHeader :: Get (Maybe (EntrySelector, EntryDescription))
getCDHeader = do
getSignature 0x02014b50
versionMadeBy <- toVersion <$> getWord16le
versionNeeded <- toVersion <$> getWord16le
when (versionNeeded > zipVersion) . fail $
"Version required to extract the archive is "
++ showVersion versionNeeded ++ " (can do "
++ showVersion zipVersion ++ ")"
bitFlag <- getWord16le
when (any (testBit bitFlag) [0,6,13]) . fail $
"Encrypted archives are not supported"
let needUnicode = testBit bitFlag 11
mcompression <- toCompressionMethod <$> getWord16le
modTime <- getWord16le
modDate <- getWord16le
crc32 <- getWord32le
compressed <- fromIntegral <$> getWord32le
uncompressed <- fromIntegral <$> getWord32le
fileNameSize <- getWord16le
extraFieldSize <- getWord16le
commentSize <- getWord16le
skip 4
externalFileAttrs <- getWord32le
offset <- fromIntegral <$> getWord32le
fileName <- decodeText needUnicode <$>
getBytes (fromIntegral fileNameSize)
extraField <- M.fromList <$>
isolate (fromIntegral extraFieldSize) (many getExtraField)
comment <- decodeText needUnicode <$> getBytes (fromIntegral commentSize)
let dfltZip64 = Zip64ExtraField
{ z64efUncompressedSize = uncompressed
, z64efCompressedSize = compressed
, z64efOffset = offset }
z64ef = case M.lookup 1 extraField of
Nothing -> dfltZip64
Just b -> parseZip64ExtraField dfltZip64 b
case mcompression of
Nothing -> return Nothing
Just compression ->
let desc = EntryDescription
{ edVersionMadeBy = versionMadeBy
, edVersionNeeded = versionNeeded
, edCompression = compression
, edModTime = fromMsDosTime (MsDosTime modDate modTime)
, edCRC32 = crc32
, edCompressedSize = z64efCompressedSize z64ef
, edUncompressedSize = z64efUncompressedSize z64ef
, edOffset = z64efOffset z64ef
, edComment = if commentSize == 0 then Nothing else comment
, edExtraField = extraField
, edExternalFileAttrs = externalFileAttrs }
in return $ (,desc) <$> (fileName >>= mkEntrySelector . T.unpack)
getExtraField :: Get (Word16, ByteString)
getExtraField = do
header <- getWord16le
size <- getWord16le
body <- getBytes (fromIntegral size)
return (header, body)
getSignature :: Word32 -> Get ()
getSignature sig = do
x <- getWord32le
unless (x == sig) . fail $
"Expected signature " ++ show sig ++ ", but got: " ++ show x
parseZip64ExtraField
:: Zip64ExtraField
-> ByteString
-> Zip64ExtraField
parseZip64ExtraField dflt@Zip64ExtraField {..} b =
either (const dflt) id . flip runGet b $ do
let ifsat v = if v >= ffffffff
then fromIntegral <$> getWord64le
else return v
uncompressed <- ifsat z64efUncompressedSize
compressed <- ifsat z64efCompressedSize
offset <- ifsat z64efOffset
return (Zip64ExtraField uncompressed compressed offset)
makeZip64ExtraField
:: HeaderType
-> Zip64ExtraField
-> ByteString
makeZip64ExtraField c Zip64ExtraField {..} = runPut $ do
when (c == LocalHeader || z64efUncompressedSize >= ffffffff) $
putWord64le (fromIntegral z64efUncompressedSize)
when (c == LocalHeader || z64efCompressedSize >= ffffffff) $
putWord64le (fromIntegral z64efCompressedSize)
when (c == CentralDirHeader && z64efOffset >= ffffffff) $
putWord64le (fromIntegral z64efOffset)
putExtraField :: Map Word16 ByteString -> Put
putExtraField m = forM_ (M.keys m) $ \headerId -> do
let b = B.take 0xffff (m ! headerId)
putWord16le headerId
putWord16le (fromIntegral $ B.length b)
putByteString b
putCD :: Map EntrySelector EntryDescription -> Put
putCD m = forM_ (M.keys m) $ \s ->
putHeader CentralDirHeader s (m ! s)
putHeader
:: HeaderType
-> EntrySelector
-> EntryDescription
-> Put
putHeader c' s EntryDescription {..} = do
let c = c' == CentralDirHeader
putWord32le (bool 0x04034b50 0x02014b50 c)
when c $
putWord16le (fromVersion edVersionMadeBy)
putWord16le (fromVersion edVersionNeeded)
let entryName = getEntryName s
rawName = T.encodeUtf8 entryName
comment = B.take 0xffff (maybe B.empty T.encodeUtf8 edComment)
unicode = needsUnicode entryName
|| maybe False needsUnicode edComment
modTime = toMsDosTime edModTime
putWord16le (if unicode then setBit 0 11 else 0)
putWord16le (fromCompressionMethod edCompression)
putWord16le (msDosTime modTime)
putWord16le (msDosDate modTime)
putWord32le edCRC32
putWord32le (withSaturation edCompressedSize)
putWord32le (withSaturation edUncompressedSize)
putWord16le (fromIntegral $ B.length rawName)
let zip64ef = makeZip64ExtraField c' Zip64ExtraField
{ z64efUncompressedSize = edUncompressedSize
, z64efCompressedSize = edCompressedSize
, z64efOffset = edOffset }
extraField = B.take 0xffff . runPut . putExtraField $
M.insert 1 zip64ef edExtraField
putWord16le (fromIntegral $ B.length extraField)
when c $ do
putWord16le (fromIntegral $ B.length comment)
putWord16le 0
putWord16le 0
putWord32le edExternalFileAttrs
putWord32le (withSaturation edOffset)
putByteString rawName
putByteString extraField
when c (putByteString comment)
putZip64ECD
:: Natural
-> Natural
-> Natural
-> Put
putZip64ECD totalCount cdSize cdOffset = do
putWord32le 0x06064b50
putWord64le 44
putWord16le (fromVersion zipVersion)
putWord16le (fromVersion $ getZipVersion True Nothing)
putWord32le 0
putWord32le 0
putWord64le (fromIntegral totalCount)
putWord64le (fromIntegral totalCount)
putWord64le (fromIntegral cdSize)
putWord64le (fromIntegral cdOffset)
putZip64ECDLocator
:: Natural
-> Put
putZip64ECDLocator ecdOffset = do
putWord32le 0x07064b50
putWord32le 0
putWord64le (fromIntegral ecdOffset)
putWord32le 1
getECD :: Get ArchiveDescription
getECD = do
sig <- getWord32le
let zip64 = sig == 0x06064b50
unless (sig == 0x06054b50 || sig == 0x06064b50) $
fail "Cannot locate end of central directory"
zip64size <- if zip64 then do
x <- getWord64le
skip 2
skip 2
return (Just x)
else return Nothing
thisDisk <- bool (fromIntegral <$> getWord16le) getWord32le zip64
cdDisk <- bool (fromIntegral <$> getWord16le) getWord32le zip64
unless (thisDisk == 0 && cdDisk == 0) $
fail "No support for multi-disk archives"
skip (bool 2 8 zip64)
skip (bool 2 8 zip64)
cdSize <- bool (fromIntegral <$> getWord32le) getWord64le zip64
cdOffset <- bool (fromIntegral <$> getWord32le) getWord64le zip64
when zip64 . skip . fromIntegral $ fromJust zip64size - 4
commentSize <- getWord16le
comment <- decodeText True <$> getBytes (fromIntegral commentSize)
return ArchiveDescription
{ adComment = if commentSize == 0 then Nothing else comment
, adCDOffset = fromIntegral cdOffset
, adCDSize = fromIntegral cdSize }
putECD
:: Natural
-> Natural
-> Natural
-> Maybe Text
-> Put
putECD totalCount cdSize cdOffset mcomment = do
putWord32le 0x06054b50
putWord16le 0
putWord16le 0
putWord16le (withSaturation totalCount)
putWord16le (withSaturation totalCount)
putWord32le (withSaturation cdSize)
putWord32le (withSaturation cdOffset)
let comment = maybe B.empty T.encodeUtf8 mcomment
putWord16le (fromIntegral $ B.length comment)
putByteString comment
locateECD :: FilePath -> Handle -> IO (Maybe Integer)
locateECD path h = sizeCheck
where
sizeCheck = do
fsize <- hFileSize h
let limit = max 0 (fsize - 0xffff - 22)
if fsize < 22
then return Nothing
else hSeek h SeekFromEnd (-22) >> loop limit
loop limit = do
sig <- getNum getWord32le 4
pos <- subtract 4 <$> hTell h
let again = hSeek h AbsoluteSeek (pos - 1) >> loop limit
done = pos <= limit
if sig == 0x06054b50
then do
result <- runMaybeT $
MaybeT (checkComment pos) >>=
MaybeT . checkCDSig >>=
MaybeT . checkZip64
case result of
Nothing -> bool again (return Nothing) done
Just ecd -> return (Just ecd)
else bool again (return Nothing) done
checkComment pos = do
size <- hFileSize h
hSeek h AbsoluteSeek (pos + 20)
l <- fromIntegral <$> getNum getWord16le 2
return $ if l + 22 == size - pos
then Just pos
else Nothing
checkCDSig pos = do
hSeek h AbsoluteSeek (pos + 16)
sigPos <- fromIntegral <$> getNum getWord32le 4
if sigPos == 0xffffffff
then return (Just pos)
else do
hSeek h AbsoluteSeek sigPos
cdSig <- getNum getWord32le 4
return $ if cdSig == 0x02014b50 ||
cdSig == 0x06064b50 ||
cdSig == 0x06054b50
then Just pos
else Nothing
checkZip64 pos =
if pos < 20
then return (Just pos)
else do
hSeek h AbsoluteSeek (pos - 20)
zip64locatorSig <- getNum getWord32le 4
if zip64locatorSig == 0x07064b50
then do
hSeek h AbsoluteSeek (pos - 12)
Just . fromIntegral <$> getNum getWord64le 8
else return (Just pos)
getNum f n = do
result <- runGet f <$> B.hGet h n
case result of
Left msg -> throwM (ParsingFailed path msg)
Right val -> return val
renameKey :: Ord k => k -> k -> Map k a -> Map k a
renameKey ok nk m = case M.lookup ok m of
Nothing -> m
Just e -> M.insert nk e (M.delete ok m)
withSaturation :: forall a b. (Integral a, Integral b, Bounded b) => a -> b
withSaturation x =
if (fromIntegral x :: Integer) > (fromIntegral bound :: Integer)
then bound
else fromIntegral x
where bound = maxBound :: b
targetEntry :: PendingAction -> Maybe EntrySelector
targetEntry (SinkEntry _ _ s) = Just s
targetEntry (CopyEntry _ _ s) = Just s
targetEntry (RenameEntry s _) = Just s
targetEntry (DeleteEntry s) = Just s
targetEntry (Recompress _ s) = Just s
targetEntry (SetEntryComment _ s) = Just s
targetEntry (DeleteEntryComment s) = Just s
targetEntry (SetModTime _ s) = Just s
targetEntry (AddExtraField _ _ s) = Just s
targetEntry (DeleteExtraField _ s) = Just s
targetEntry (SetExternalFileAttributes _ s) = Just s
targetEntry (SetArchiveComment _) = Nothing
targetEntry DeleteArchiveComment = Nothing
decodeText
:: Bool
-> ByteString
-> Maybe Text
decodeText False = Just . decodeCP437
decodeText True = either (const Nothing) Just . T.decodeUtf8'
needsUnicode :: Text -> Bool
needsUnicode = not . T.all validCP437
where validCP437 x = ord x <= 127
toVersion :: Word16 -> Version
toVersion x = makeVersion [major, minor]
where (major, minor) = quotRem (fromIntegral $ x .&. 0x00ff) 10
fromVersion :: Version -> Word16
fromVersion v = fromIntegral ((ZIP_OS `shiftL` 8) .|. (major * 10 + minor))
where (major,minor) =
case versionBranch v of
v0:v1:_ -> (v0, v1)
v0:_ -> (v0, 0)
[] -> (0, 0)
toCompressionMethod :: Word16 -> Maybe CompressionMethod
toCompressionMethod 0 = Just Store
toCompressionMethod 8 = Just Deflate
toCompressionMethod 12 = Just BZip2
toCompressionMethod _ = Nothing
fromCompressionMethod :: CompressionMethod -> Word16
fromCompressionMethod Store = 0
fromCompressionMethod Deflate = 8
fromCompressionMethod BZip2 = 12
needsZip64 :: EntryDescription -> Bool
needsZip64 EntryDescription {..} = any (>= ffffffff)
[edOffset, edCompressedSize, edUncompressedSize]
getZipVersion :: Bool -> Maybe CompressionMethod -> Version
getZipVersion zip64 m = max zip64ver mver
where zip64ver = makeVersion (if zip64 then [4,5] else [2,0])
mver = makeVersion $ case m of
Nothing -> [2,0]
Just Store -> [2,0]
Just Deflate -> [2,0]
Just BZip2 -> [4,6]
decompressingPipe
:: (PrimMonad m, MonadThrow m, MonadResource m)
=> CompressionMethod
-> ConduitT ByteString ByteString m ()
decompressingPipe Store = C.awaitForever C.yield
decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)
#ifdef ENABLE_BZIP2
decompressingPipe BZip2 = BZ.bunzip2
#else
decompressingPipe BZip2 = throwM BZip2Unsupported
#endif
crc32Sink :: ConduitT ByteString Void (ResourceT IO) Word32
crc32Sink = CL.fold crc32Update 0
toMsDosTime :: UTCTime -> MsDosTime
toMsDosTime UTCTime {..} = MsDosTime dosDate dosTime
where
dosTime = fromIntegral (seconds + shiftL minutes 5 + shiftL hours 11)
dosDate = fromIntegral (day + shiftL month 5 + shiftL year 9)
seconds =
let (MkFixed x) = todSec tod
in fromIntegral (x `quot` 2000000000000)
minutes = todMin tod
hours = todHour tod
tod = timeToTimeOfDay utctDayTime
year = fromIntegral year' - 1980
(year', month, day) = toGregorian utctDay
fromMsDosTime :: MsDosTime -> UTCTime
fromMsDosTime MsDosTime {..} = UTCTime
(fromGregorian year month day)
(secondsToDiffTime $ hours * 3600 + minutes * 60 + seconds)
where
seconds = fromIntegral $ 2 * (msDosTime .&. 0x1f)
minutes = fromIntegral (shiftR msDosTime 5 .&. 0x3f)
hours = fromIntegral (shiftR msDosTime 11 .&. 0x1f)
day = fromIntegral (msDosDate .&. 0x1f)
month = fromIntegral $ shiftR msDosDate 5 .&. 0x0f
year = 1980 + fromIntegral (shiftR msDosDate 9)
ffff, ffffffff :: Natural
#ifdef HASKELL_ZIP_DEV_MODE
ffff = 200
ffffffff = 5000
#else
ffff = 0xffff
ffffffff = 0xffffffff
#endif