{-# LANGUAGE ScopedTypeVariables #-}
module Codec.Archive.Zip.Internal
( PendingAction (..)
, targetEntry
, scanArchive
, sourceEntry
, crc32Sink
, commit )
where
import Codec.Archive.Zip.CP437 (decodeCP437)
import Codec.Archive.Zip.Type
import Conduit (PrimMonad)
import Control.Applicative (many, (<|>))
import Control.Exception (bracketOnError)
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 qualified Data.ByteString as B
import qualified Data.Conduit as C
import qualified Data.Conduit.BZlib as BZ
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Zlib as Z
import qualified Data.Map.Strict as M
import qualified Data.Sequence as S
import qualified Data.Set as E
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
data 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
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 ()) }
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
removeFile path
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 )
where
f (pa, ea) a = case a of
SinkEntry m src s ->
( pa { paSinkEntry = M.insert s src (paSinkEntry pa)
, paCopyEntry = M.map (M.filter (/= s)) (paCopyEntry pa) }
, (clearEditingFor s ea)
{ eaCompression = M.insert s m (eaCompression ea) } )
CopyEntry path os ns ->
( pa { paSinkEntry = M.delete ns (paSinkEntry pa)
, paCopyEntry = M.alter (ef os ns) path (paCopyEntry pa) }
, clearEditingFor ns ea )
RenameEntry os ns ->
( pa { paCopyEntry = M.map (M.map $ re os ns) (paCopyEntry pa)
, paSinkEntry = renameKey os ns (paSinkEntry pa) }
, ea { eaCompression = renameKey os ns (eaCompression ea)
, eaEntryComment = renameKey os ns (eaEntryComment ea)
, eaDeleteComment = renameKey os ns (eaDeleteComment ea)
, eaModTime = renameKey os ns (eaModTime ea)
, eaExtraField = renameKey os ns (eaExtraField ea)
, eaDeleteField = renameKey os ns (eaDeleteField ea) } )
DeleteEntry s ->
( pa { paSinkEntry = M.delete s (paSinkEntry pa)
, paCopyEntry = M.map (M.delete s) (paCopyEntry pa) }
, clearEditingFor s ea )
Recompress m s ->
(pa, ea { eaCompression = M.insert s m (eaCompression ea) })
SetEntryComment txt s ->
( pa
, ea { eaEntryComment = M.insert s txt (eaEntryComment ea)
, eaDeleteComment = M.delete s (eaDeleteComment ea) } )
DeleteEntryComment s ->
( pa
, ea { eaEntryComment = M.delete s (eaEntryComment ea)
, eaDeleteComment = M.insert s () (eaDeleteComment ea) } )
SetModTime time s ->
(pa, ea { eaModTime = M.insert s time (eaModTime ea) })
AddExtraField n b s ->
( pa
, ea { eaExtraField = M.alter (ef n b) s (eaExtraField ea)
, eaDeleteField = M.delete s (eaDeleteField ea) } )
DeleteExtraField n s ->
( pa
, ea { eaExtraField = M.alter (er n) s (eaExtraField ea)
, eaDeleteField = M.alter (ef n ()) s (eaDeleteField ea) } )
_ -> (pa, ea)
clearEditingFor s ea = ea
{ eaCompression = M.delete s (eaCompression ea)
, eaEntryComment = M.delete s (eaEntryComment ea)
, eaDeleteComment = M.delete s (eaDeleteComment ea)
, eaModTime = M.delete s (eaModTime ea)
, eaExtraField = M.delete s (eaExtraField ea)
, eaDeleteField = M.delete s (eaDeleteField ea) }
re o n x = if x == o then n else x
ef k v (Just m) = Just (M.insert k v m)
ef k v Nothing = Just (M.singleton k v)
er k (Just m) = let n = M.delete k m in
if M.null n then Nothing else Just n
er _ Nothing = Nothing
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
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 }
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
BZip2 -> withCompression $
BZ.bzip2 .| dataSink
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 8
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 }
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 0
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 (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 (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)
decompressingPipe BZip2 = BZ.bunzip2
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
ffff = 0xffff
ffffffff = 0xffffffff