diff --git a/Codec/Archive/Zip/Conduit/Internal.hs b/Codec/Archive/Zip/Conduit/Internal.hs new file mode 100644 --- /dev/null +++ b/Codec/Archive/Zip/Conduit/Internal.hs @@ -0,0 +1,62 @@ +module Codec.Archive.Zip.Conduit.Internal + ( zipVersion + , zipError + , idConduit + , sizeCRC + , outputSize + , inputSize + , maxBound32 + , deflateWindowBits + ) where + +import Codec.Compression.Zlib.Raw (WindowBits(..)) +import Control.Monad.Catch (MonadThrow, throwM) +import qualified Data.ByteString as BS +import qualified Data.Conduit as C +import qualified Data.Conduit.Internal as CI +import Data.Digest.CRC32 (crc32Update) +import Data.Word (Word16, Word32, Word64) + +import Codec.Archive.Zip.Conduit.Types + +-- |The version of this zip program, really just rough indicator of compatibility +zipVersion :: Word16 +zipVersion = 48 + +zipError :: MonadThrow m => String -> m a +zipError = throwM . ZipError + +idConduit :: Monad m => C.Conduit a m a +idConduit = C.awaitForever C.yield + +passthroughFold :: Monad m => (a -> b -> a) -> a -> C.ConduitM b b m a +passthroughFold f z = C.await >>= maybe + (return z) + (\x -> do + C.yield x + passthroughFold f (f z x)) + +sizeCRC :: Monad m => C.ConduitM BS.ByteString BS.ByteString m (Word64, Word32) +sizeCRC = passthroughFold (\(l, c) b -> (l + fromIntegral (BS.length b), crc32Update c b)) (0, 0) + +sizeC :: Monad m => C.ConduitM BS.ByteString BS.ByteString m Word64 +sizeC = passthroughFold (\l b -> l + fromIntegral (BS.length b)) 0 -- fst <$> sizeCRC + +outputSize :: Monad m => C.Conduit i m BS.ByteString -> C.ConduitM i BS.ByteString m Word64 +outputSize = (C..| sizeC) + +inputSize :: Monad m => C.Conduit BS.ByteString m o -> C.ConduitM BS.ByteString o m Word64 +-- inputSize = fuseUpstream sizeC -- won't work because we need to deal with leftovers properly +inputSize (CI.ConduitM src) = CI.ConduitM $ \rest -> let + go n (CI.Done ()) = rest n + go n (CI.PipeM m) = CI.PipeM $ go n <$> m + go n (CI.Leftover p b) = CI.Leftover (go (n - fromIntegral (BS.length b)) p) b + go n (CI.HaveOutput p f o) = CI.HaveOutput (go n p) f o + go n (CI.NeedInput p q) = CI.NeedInput (\b -> go (n + fromIntegral (BS.length b)) (p b)) (go n . q) + in go 0 (src CI.Done) + +maxBound32 :: Integral n => n +maxBound32 = fromIntegral (maxBound :: Word32) + +deflateWindowBits :: WindowBits +deflateWindowBits = WindowBits (-15) diff --git a/Codec/Archive/Zip/Conduit/Types.hs b/Codec/Archive/Zip/Conduit/Types.hs new file mode 100644 --- /dev/null +++ b/Codec/Archive/Zip/Conduit/Types.hs @@ -0,0 +1,54 @@ +module Codec.Archive.Zip.Conduit.Types where + +import Control.Exception (Exception(..)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Conduit as C +import Data.Conduit.Binary (sourceLbs) +import Data.String (IsString(..)) +import Data.Time.LocalTime (LocalTime) +import Data.Typeable (Typeable) +import Data.Word (Word64) + +-- |Errors thrown during zip file processing +newtype ZipError = ZipError String + deriving (Show, Typeable) + +instance IsString ZipError where + fromString = ZipError + +instance Exception ZipError where + displayException (ZipError e) = "ZipError: " ++ e + +-- |Summary information at the end of a zip stream. +data ZipInfo = ZipInfo + { zipComment :: ByteString + } deriving (Eq, Show) + +-- |(The beginning of) a single entry in a zip stream, which may be any file or directory. +-- As per zip file conventions, directory names should end with a slash and have no data, but this library does not ensure that. +data ZipEntry = ZipEntry + { zipEntryName :: ByteString -- ^File name (in posix format, no leading slashes), usually utf-8 encoded, with a trailing slash for directories + , zipEntryTime :: LocalTime -- ^Modification time + , zipEntrySize :: Maybe Word64 -- ^Size of file data (if known); checked on zipping and also used as hint to enable zip64 + } deriving (Eq, Show) + +-- |The data contents for a 'ZipEntry'. For empty entries (e.g., directories), use 'mempty'. +data ZipData m + = ZipDataByteString BSL.ByteString -- ^A known ByteString, which will be fully evaluated (not streamed) + | ZipDataSource (C.Source m ByteString) -- ^A byte stream producer, streamed (and compressed) directly into the zip + +instance Monad m => Monoid (ZipData m) where + mempty = ZipDataByteString BSL.empty + mappend (ZipDataByteString a) (ZipDataByteString b) = ZipDataByteString $ mappend a b + mappend a b = ZipDataSource $ mappend (sourceZipData a) (sourceZipData b) + +-- |Normalize any 'ZipData' to a simple source +sourceZipData :: Monad m => ZipData m -> C.Source m ByteString +sourceZipData (ZipDataByteString b) = sourceLbs b +sourceZipData (ZipDataSource s) = s + +-- |Convert between unpacked (as 'Codec.Archive.Zip.Conduit.UnZip.unZipStream' produces) and packed (as 'Codec.Archive.Zip.Conduit.Zip.zipStream' consumes) representations. +-- This is mainly for testing purposes, or if you really want to re-zip a stream on the fly for some reason. +-- Note that each 'ZipData' must be consumed completely before the next entry can be produced. +-- packZipEntries :: C.Conduit (Either ZipEntry BS.ByteString) m (ZipEntry, ZipData m) diff --git a/Codec/Archive/Zip/Conduit/UnZip.hs b/Codec/Archive/Zip/Conduit/UnZip.hs new file mode 100644 --- /dev/null +++ b/Codec/Archive/Zip/Conduit/UnZip.hs @@ -0,0 +1,233 @@ +-- |Stream the extraction of a zip file, e.g., as it's being downloaded. +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RankNTypes #-} +module Codec.Archive.Zip.Conduit.UnZip + ( unZipStream + , ZipEntry(..) + , ZipInfo(..) + ) where + +import Control.Applicative ((<|>), empty) +import Control.Monad (when, unless, guard) +import Control.Monad.Base (MonadBase) +import Control.Monad.Catch (MonadThrow) +import Control.Monad.Primitive (PrimMonad) +import qualified Data.Binary.Get as G +import Data.Bits ((.&.), testBit, clearBit, shiftL, shiftR) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.Conduit as C +import qualified Data.Conduit.List as CL +import Data.Conduit.Serialization.Binary (sinkGet) +import qualified Data.Conduit.Zlib as CZ +import Data.Time (LocalTime(..), TimeOfDay(..), fromGregorian) +import Data.Word (Word16, Word32, Word64) + +import Codec.Archive.Zip.Conduit.Types +import Codec.Archive.Zip.Conduit.Internal + +data Header m + = FileHeader + { fileDecompress :: C.Conduit BS.ByteString m BS.ByteString + , fileEntry :: !ZipEntry + , fileCRC :: !Word32 + , fileCSize :: !Word64 + , fileZip64 :: !Bool + } + | EndOfCentralDirectory + { endInfo :: ZipInfo + } + +data ExtField = ExtField + { extZip64 :: Bool + , extZip64USize + , extZip64CSize :: Word64 + } + +{- ExtUnix + { extUnixATime + , extUnixMTime :: UTCTime + , extUnixUID + , extUnixGID :: Word16 + , extUnixData :: BS.ByteString + } +-} + +pass :: (MonadThrow m, Integral n) => n -> C.Conduit BS.ByteString m BS.ByteString +pass 0 = return () +pass n = C.await >>= maybe + (zipError $ "EOF in file data, expecting " ++ show ni ++ " more bytes") + (\b -> + let n' = ni - toInteger (BS.length b) in + if n' < 0 + then do + let (b', r) = BS.splitAt (fromIntegral n) b + C.yield b' + C.leftover r + else do + C.yield b + pass n') + where ni = toInteger n + +foldGet :: (a -> G.Get a) -> a -> G.Get a +foldGet g z = do + e <- G.isEmpty + if e then return z else g z >>= foldGet g + +fromDOSTime :: Word16 -> Word16 -> LocalTime +fromDOSTime time date = LocalTime + (fromGregorian + (fromIntegral $ date `shiftR` 9 + 1980) + (fromIntegral $ date `shiftR` 5 .&. 0x0f) + (fromIntegral $ date .&. 0x1f)) + (TimeOfDay + (fromIntegral $ time `shiftR` 11) + (fromIntegral $ time `shiftR` 5 .&. 0x3f) + (fromIntegral $ time `shiftL` 1 .&. 0x3f)) + +-- |Stream process a zip file, producing a sequence of entry headers and data blocks. +-- For example, this might produce: @Left (ZipEntry "directory\/" ...), Left (ZipEntry "directory\/file.txt" ...), Right "hello w", Right "orld!\\n", Left ...@ +-- The final result is summary information taken from the end of the zip file. +-- No state is maintained during processing, and, in particular, any information in the central directory is discarded. +-- +-- This only supports a limited number of zip file features, including deflate compression and zip64. +-- It does not (ironically) support uncompressed zip files that have been created as streams, where file sizes are not known beforehand. +-- Since it does not use the offset information at the end of the file, it assumes all entries are packed sequentially, which is usually the case. +-- Any errors are thrown in the underlying monad (as 'ZipError's or 'Data.Conduit.Serialization.Binary.ParseError'). +unZipStream :: (MonadBase b m, PrimMonad b, MonadThrow m) => C.ConduitM BS.ByteString (Either ZipEntry BS.ByteString) m ZipInfo +unZipStream = next where + next = do -- local header, or start central directory + h <- sinkGet $ do + sig <- G.getWord32le + case sig of + 0x04034b50 -> fileHeader + _ -> centralBody sig + case h of + FileHeader{..} -> do + C.yield $ Left fileEntry + r <- C.mapOutput Right $ + case zipEntrySize fileEntry of + Nothing -> do -- unknown size + (csize, (size, crc)) <- inputSize fileDecompress `C.fuseBoth` sizeCRC + -- traceM $ "csize=" ++ show csize ++ " size=" ++ show size ++ " crc=" ++ show crc + -- required data description + sinkGet $ dataDesc h + { fileCSize = csize + , fileCRC = crc + , fileEntry = fileEntry + { zipEntrySize = Just size + } + } + Just usize -> do -- known size + (size, crc) <- pass fileCSize + C..| (fileDecompress >> CL.sinkNull) + C..| sizeCRC + -- traceM $ "size=" ++ show size ++ "," ++ show (zipEntrySize fileEntry) ++ " crc=" ++ show crc ++ "," ++ show fileCRC + -- optional data description (possibly ambiguous!) + sinkGet $ (guard =<< dataDesc h) <|> return () + return (size == usize && crc == fileCRC) + unless r $ zipError $ BSC.unpack (zipEntryName fileEntry) ++ ": data integrity check failed" + next + EndOfCentralDirectory{..} -> do + return endInfo + dataDesc h = -- this takes a bit of flexibility to account for the various cases + (do -- with signature + sig <- G.getWord32le + guard (sig == 0x08074b50) + dataDescBody h) + <|> dataDescBody h -- without signature + dataDescBody FileHeader{..} = do + crc <- G.getWord32le + let getSize = if fileZip64 then G.getWord64le else fromIntegral <$> G.getWord32le + csiz <- getSize + usiz <- getSize + -- traceM $ "crc=" ++ show crc ++ "," ++ show fileCRC ++ " csiz=" ++ show csiz ++ "," ++ show fileCSize ++ " usiz=" ++ show usiz ++ "," ++ show (zipEntrySize fileEntry) + return $ crc == fileCRC && csiz == fileCSize && (usiz ==) `all` zipEntrySize fileEntry + dataDescBody _ = empty + central = G.getWord32le >>= centralBody + centralBody 0x02014b50 = centralHeader >> central + centralBody 0x06064b50 = zip64EndDirectory >> central + centralBody 0x07064b50 = G.skip 16 >> central + centralBody 0x06054b50 = EndOfCentralDirectory <$> endDirectory + centralBody sig = fail $ "Unknown header signature: " ++ show sig + fileHeader = do + ver <- G.getWord16le + when (ver > zipVersion) $ fail $ "Unsupported version: " ++ show ver + gpf <- G.getWord16le + -- when (gpf .&. complement (bit 1 .|. bit 2 .|. bit 3) /= 0) $ fail $ "Unsupported flags: " ++ show gpf + when (gpf `clearBit` 1 `clearBit` 2 `clearBit` 3 /= 0) $ fail $ "Unsupported flags: " ++ show gpf + comp <- G.getWord16le + dcomp <- case comp of + 0 | testBit gpf 3 -> fail "Unsupported uncompressed streaming file data" + | otherwise -> return idConduit + 8 -> return $ CZ.decompress deflateWindowBits + _ -> fail $ "Unsupported compression method: " ++ show comp + time <- fromDOSTime <$> G.getWord16le <*> G.getWord16le + crc <- G.getWord32le + csiz <- G.getWord32le + usiz <- G.getWord32le + nlen <- fromIntegral <$> G.getWord16le + elen <- fromIntegral <$> G.getWord16le + name <- G.getByteString nlen + let getExt ext = do + t <- G.getWord16le + z <- fromIntegral <$> G.getWord16le + G.isolate z $ case t of + 0x0001 -> do + -- the zip specs claim "the Local header MUST include BOTH" but "only if the corresponding field is set to 0xFFFFFFFF" + usiz' <- if usiz == maxBound32 then G.getWord64le else return $ extZip64USize ext + csiz' <- if csiz == maxBound32 then G.getWord64le else return $ extZip64CSize ext + return ext + { extZip64 = True + , extZip64USize = usiz' + , extZip64CSize = csiz' + } + {- + 0x000d -> do + atim <- G.getWord32le + mtim <- G.getWord32le + uid <- G.getWord16le + gid <- G.getWord16le + dat <- G.getByteString $ z - 12 + return ExtUnix + { extUnixATime = posixSecondsToUTCTime atim + , extUnixMTime = posixSecondsToUTCTime mtim + , extUnixUID = uid + , extUnixGID = gid + , extUnixData = dat + } + -} + _ -> ext <$ G.skip z + ExtField{..} <- G.isolate elen $ foldGet getExt ExtField + { extZip64 = False + , extZip64USize = fromIntegral usiz + , extZip64CSize = fromIntegral csiz + } + return FileHeader + { fileEntry = ZipEntry + { zipEntryName = name + , zipEntryTime = time + , zipEntrySize = if testBit gpf 3 then Nothing else Just extZip64USize + } + , fileDecompress = dcomp + , fileCSize = extZip64CSize + , fileCRC = crc + , fileZip64 = extZip64 + } + centralHeader = do + -- ignore everything + G.skip 24 + nlen <- fromIntegral <$> G.getWord16le + elen <- fromIntegral <$> G.getWord16le + clen <- fromIntegral <$> G.getWord16le + G.skip $ 12 + nlen + elen + clen + zip64EndDirectory = do + len <- G.getWord64le + G.skip $ fromIntegral len -- would not expect to overflow... + endDirectory = do + G.skip 16 + clen <- fromIntegral <$> G.getWord16le + comm <- G.getByteString clen + return ZipInfo + { zipComment = comm + } diff --git a/Codec/Archive/Zip/Conduit/Zip.hs b/Codec/Archive/Zip/Conduit/Zip.hs new file mode 100644 --- /dev/null +++ b/Codec/Archive/Zip/Conduit/Zip.hs @@ -0,0 +1,220 @@ +-- |Stream the creation of a zip file, e.g., as it's being uploaded. +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +module Codec.Archive.Zip.Conduit.Zip + ( zipStream + , ZipOptions(..) + , ZipInfo(..) + , defaultZipOptions + , ZipEntry(..) + , ZipData(..) + , zipFileData + ) where + +import qualified Codec.Compression.Zlib.Raw as Z +import Control.Arrow ((&&&), (+++), left) +import Control.Monad (when) +import Control.Monad.Base (MonadBase) +import Control.Monad.Catch (MonadThrow) +import Control.Monad.Primitive (PrimMonad) +import Control.Monad.State.Strict (StateT, get) +import Control.Monad.Trans.Resource (MonadResource) +import qualified Data.Binary.Put as P +import Data.Bits (bit, shiftL, shiftR, (.|.)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Conduit as C +import qualified Data.Conduit.Binary as CB +import Data.Conduit.Lift (stateC, execStateC) +import Data.Conduit.Serialization.Binary (sourcePut) +import qualified Data.Conduit.Zlib as CZ +import Data.Digest.CRC32 (crc32) +import Data.Either (isLeft) +import Data.Maybe (fromMaybe, fromJust) +import Data.Monoid ((<>)) +import Data.Time (LocalTime(..), TimeOfDay(..), toGregorian) +import Data.Word (Word16, Word64) + +import Codec.Archive.Zip.Conduit.Types +import Codec.Archive.Zip.Conduit.Internal + +-- |Options controlling zip file parameters and features +data ZipOptions = ZipOptions + { zipOpt64 :: Bool -- ^Allow 'ZipDataSource's over 4GB (reduces compatibility in some cases); this is automatically enabled for any files of known size (e.g., 'zipEntrySize') + , zipOptCompressLevel :: Int -- ^Compress (0 = store only, 9 = best) zipped files (improves compatibility, since some unzip programs don't supported stored, streamed files, including the one in this package) + , zipOptInfo :: ZipInfo -- ^Other parameters to store in the zip file + } + +defaultZipOptions :: ZipOptions +defaultZipOptions = ZipOptions + { zipOpt64 = False + , zipOptCompressLevel = -1 + , zipOptInfo = ZipInfo + { zipComment = BS.empty + } + } + +infixr 7 ?* +(?*) :: Num a => Bool -> a -> a +True ?* x = x +False ?* _ = 0 + +-- |Use a file on disk as 'ZipData' (@'ZipDataSource' . 'CB.sourceFile'@). +zipFileData :: MonadResource m => FilePath -> ZipData m +zipFileData = ZipDataSource . CB.sourceFile + +zipData :: Monad m => ZipData m -> Either (C.Source m BS.ByteString) BSL.ByteString +zipData (ZipDataByteString b) = Right b +zipData (ZipDataSource s) = Left s + +dataSize :: Either a BSL.ByteString -> Maybe Word64 +dataSize (Left _) = Nothing +dataSize (Right b) = Just $ fromIntegral $ BSL.length b + +toDOSTime :: LocalTime -> (Word16, Word16) +toDOSTime (LocalTime (toGregorian -> (year, month, day)) (TimeOfDay hour mins secs)) = + ( fromIntegral hour `shiftL` 11 .|. fromIntegral mins `shiftL` 5 .|. truncate secs `shiftR` 1 + , fromIntegral (year - 1980) `shiftL` 9 .|. fromIntegral month `shiftL` 5 .|. fromIntegral day + ) + +countOutput :: Monad m => C.Conduit i m BS.ByteString -> C.Conduit i (StateT Word64 m) BS.ByteString +countOutput c = stateC $ \s -> (,) () . (s +) <$> outputSize c + +output :: MonadThrow m => P.Put -> C.ConduitM i BS.ByteString (StateT Word64 m) () +output = countOutput . sourcePut + +maxBound16 :: Integral n => n +maxBound16 = fromIntegral (maxBound :: Word16) + +-- |Stream produce a zip file, reading a sequence of entries with data. +-- Although file data is never kept in memory (beyond a single 'ZipDataByteString'), the format of zip files requires producing a final directory of entries at the end of the file, consuming an additional ~100 bytes of state per entry during streaming. +-- The final result is the total size of the zip file. +-- +-- Depending on options, the resulting zip file should be compatible with most unzipping applications. +-- Any errors are thrown in the underlying monad (as 'ZipError's). +zipStream :: (MonadBase b m, PrimMonad b, MonadThrow m) => ZipOptions -> C.ConduitM (ZipEntry, ZipData m) BS.ByteString m Word64 +zipStream ZipOptions{..} = execStateC 0 $ do + (cnt, cdir) <- next 0 (mempty :: P.Put) + cdoff <- get + output cdir + eoff <- get + endDirectory cdoff (eoff - cdoff) cnt + where + next cnt dir = C.await >>= maybe + (return (cnt, dir)) + (\e -> do + d <- entry e + next (succ cnt) $ dir <> d) + entry (ZipEntry{..}, zipData -> dat) = do + let usiz = dataSize dat + sdat = left ((C..| sizeCRC) . C.toProducer) dat + comp = zipOptCompressLevel /= 0 && all (0 /=) usiz + (cdat, csiz) + | comp = + ( ((`C.fuseBoth` (outputSize $ CZ.compress zipOptCompressLevel deflateWindowBits)) + +++ Z.compress) sdat -- level for Z.compress? + , dataSize cdat) + | otherwise = (left (fmap (id &&& fst)) sdat, usiz) + z64 = maybe (zipOpt64 || any (maxBound32 <) zipEntrySize) + (maxBound32 <) (max <$> usiz <*> csiz) + namelen = BS.length zipEntryName + (time, date) = toDOSTime zipEntryTime + mcrc = either (const Nothing) (Just . crc32) dat + when (namelen > maxBound16) $ zipError $ BSC.unpack zipEntryName ++ ": entry name too long" + let common = do + P.putWord16le $ isLeft dat ?* bit 3 + P.putWord16le $ comp ?* 8 + P.putWord16le $ time + P.putWord16le $ date + off <- get + output $ do + P.putWord32le 0x04034b50 + P.putWord16le $ if z64 then 45 else 20 + common + P.putWord32le $ fromMaybe 0 mcrc + P.putWord32le $ if z64 then maxBound32 else maybe 0 fromIntegral csiz + P.putWord32le $ if z64 then maxBound32 else maybe 0 fromIntegral usiz + P.putWord16le $ fromIntegral namelen + P.putWord16le $ z64 ?* 20 + P.putByteString zipEntryName + when z64 $ do + P.putWord16le 0x0001 + P.putWord16le 16 + P.putWord64le $ fromMaybe 0 usiz + P.putWord64le $ fromMaybe 0 csiz + let outsz c = stateC $ \o -> (id &&& (o +) . snd) <$> c + ((usz, crc), csz) <- either + (\cd -> do + r@((usz, crc), csz) <- outsz cd -- write compressed data + when (not z64 && (usz > maxBound32 || csz > maxBound32)) $ zipError $ BSC.unpack zipEntryName ++ ": file too large and zipOpt64 disabled" + output $ do + P.putWord32le 0x08074b50 + P.putWord32le crc + let putsz + | z64 = P.putWord64le + | otherwise = P.putWord32le . fromIntegral + putsz csz + putsz usz + return r) + (\b -> outsz $ ((fromJust usiz, fromJust mcrc), fromJust csiz) <$ CB.sourceLbs b) + cdat + when (any (usz /=) zipEntrySize) $ zipError $ BSC.unpack zipEntryName ++ ": incorrect zipEntrySize" + return $ do + -- central directory + let o64 = off >= maxBound32 + l64 = z64 ?* 16 + o64 ?* 8 + a64 = z64 || o64 + P.putWord32le 0x02014b50 + P.putWord16le zipVersion + P.putWord16le $ if a64 then 45 else 20 + common + P.putWord32le crc + P.putWord32le $ if z64 then maxBound32 else fromIntegral csz + P.putWord32le $ if z64 then maxBound32 else fromIntegral usz + P.putWord16le $ fromIntegral namelen + P.putWord16le $ a64 ?* (4 + l64) + P.putWord16le 0 -- comment length + P.putWord16le 0 -- disk number + P.putWord16le 0 -- internal file attributes + P.putWord32le 0 -- external file attributes + P.putWord32le $ if o64 then maxBound32 else fromIntegral off + P.putByteString zipEntryName + when a64 $ do + P.putWord16le 0x0001 + P.putWord16le l64 + when z64 $ do + P.putWord64le usz + P.putWord64le csz + when o64 $ + P.putWord64le off + endDirectory cdoff cdlen cnt = do + let z64 = zipOpt64 || cdoff > maxBound32 || cnt > maxBound16 + when z64 $ output $ do + P.putWord32le 0x06064b50 -- zip64 end + P.putWord64le 44 -- length of this record + P.putWord16le zipVersion + P.putWord16le 45 + P.putWord32le 0 -- disk + P.putWord32le 0 -- central disk + P.putWord64le cnt + P.putWord64le cnt + P.putWord64le cdlen + P.putWord64le cdoff + P.putWord32le 0x07064b50 -- locator: + P.putWord32le 0 -- central disk + P.putWord64le $ cdoff + cdlen + P.putWord32le 1 -- total disks + let comment = zipComment zipOptInfo + commlen = BS.length comment + when (commlen > maxBound16) $ zipError "comment too long" + output $ do + P.putWord32le 0x06054b50 -- end + P.putWord16le 0 -- disk + P.putWord16le 0 -- central disk + P.putWord16le $ fromIntegral $ min maxBound16 cnt + P.putWord16le $ fromIntegral $ min maxBound16 cnt + P.putWord32le $ fromIntegral $ min maxBound32 cdlen + P.putWord32le $ fromIntegral $ min maxBound32 cdoff + P.putWord16le $ fromIntegral commlen + P.putByteString comment diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Dylan Simon (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Dylan Simon nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cmd/unzip.hs b/cmd/unzip.hs new file mode 100644 --- /dev/null +++ b/cmd/unzip.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE RecordWildCards #-} +import Control.Monad (when, unless) +import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.Conduit as C +import qualified Data.Conduit.Binary as CB +import Data.Time.LocalTime (localTimeToUTC, utc) +import System.Directory (createDirectoryIfMissing, setModificationTime) +import System.Environment (getProgName, getArgs) +import System.Exit (exitFailure) +import System.FilePath.Posix (takeDirectory) -- zip files only use forward slashes +import System.IO (stdin, openFile, IOMode(WriteMode), hClose, hSetFileSize, hPutStrLn, stderr) + +import Codec.Archive.Zip.Conduit.UnZip + +extract :: C.Sink (Either ZipEntry BS.ByteString) IO () +extract = C.awaitForever start where + start (Left ZipEntry{..}) = do + liftIO $ BSC.putStrLn zipEntryName + liftIO $ createDirectoryIfMissing True (takeDirectory name) + if BSC.last zipEntryName == '/' + then when ((0 /=) `any` zipEntrySize) $ fail $ name ++ ": non-empty directory" + else do -- C.bracketP + h <- liftIO $ openFile name WriteMode + mapM_ (liftIO . hSetFileSize h . toInteger) zipEntrySize + write C..| CB.sinkHandle h + liftIO $ hClose h + liftIO $ setModificationTime name $ localTimeToUTC utc zipEntryTime -- FIXME: timezone + where name = BSC.unpack $ BSC.dropWhile ('/' ==) zipEntryName -- should we utf8 decode? + start (Right _) = fail "Unexpected leading or directory data contents" + write = C.await >>= maybe + (return ()) + block + block (Right b) = C.yield b >> write + block a = C.leftover a + +main :: IO () +main = do + prog <- getProgName + args <- getArgs + unless (null args) $ do + hPutStrLn stderr $ "Usage: " ++ prog ++ "\nRead a zip file from stdin and extract it in the current directory." + exitFailure + ZipInfo{..} <- C.runConduit + $ CB.sourceHandle stdin + C..| C.fuseUpstream unZipStream extract + BSC.putStrLn zipComment diff --git a/cmd/zip.hs b/cmd/zip.hs new file mode 100644 --- /dev/null +++ b/cmd/zip.hs @@ -0,0 +1,62 @@ +import Control.Monad (filterM, void) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Resource (MonadResource, runResourceT) +import qualified Data.ByteString.Char8 as BSC +import qualified Data.Conduit as C +import qualified Data.Conduit.Binary as CB +import Data.List (foldl') +import Data.Time.LocalTime (utcToLocalTime, utc) +import qualified System.Console.GetOpt as Opt +import System.Directory (doesDirectoryExist, getModificationTime, isSymbolicLink, listDirectory) +import System.Environment (getProgName, getArgs) +import System.Exit (exitFailure) +import System.FilePath.Posix (()) -- zip files only want forward slashes +import System.IO (stdout, hPutStrLn, stderr) + +import Codec.Archive.Zip.Conduit.Zip + +opts :: [Opt.OptDescr (ZipOptions -> ZipOptions)] +opts = + [ Opt.Option "z" ["compress"] (Opt.ReqArg (\l o -> o{ zipOptCompressLevel = read l }) "LEVEL") + "set compression level for files (0-9)" + , Opt.Option "0" ["store"] (Opt.NoArg (\o -> o{ zipOptCompressLevel = 0 })) + "don't compress files (-z0)" + , Opt.Option "e" ["zip64"] (Opt.NoArg (\o -> o{ zipOpt64 = True })) + "enable zip64 support for files over 4GB" + , Opt.Option "c" ["comment"] (Opt.ReqArg (\c o -> o{ zipOptInfo = (zipOptInfo o){ zipComment = BSC.pack c }}) "TEXT") + "set zip comment" + ] + +generate :: (MonadIO m, MonadResource m) => [FilePath] -> C.Source m (ZipEntry, ZipData m) +generate (p:paths) = do + t <- liftIO $ getModificationTime p + let e = ZipEntry + { zipEntryName = BSC.pack $ dropWhile ('/' ==) p + , zipEntryTime = utcToLocalTime utc t -- FIXME: timezone + , zipEntrySize = Nothing + } + isd <- liftIO $ doesDirectoryExist p + if isd + then do + dl <- liftIO $ filterM (fmap not . isSymbolicLink) . map (p ) =<< listDirectory p + C.yield (e{ zipEntryName = zipEntryName e `BSC.snoc` '/', zipEntrySize = Just 0 }, mempty) + generate $ dl ++ paths + else do + C.yield (e, zipFileData p) + generate paths +generate [] = return () + +main :: IO () +main = do + prog <- getProgName + args <- getArgs + (opt, paths) <- case Opt.getOpt Opt.Permute opts args of + (ol, paths@(_:_), []) -> return (foldl' (flip ($)) defaultZipOptions ol, paths) + (_, _, err) -> do + mapM_ (hPutStrLn stderr) err + hPutStrLn stderr $ Opt.usageInfo ("Usage: " ++ prog ++ " [OPTION...] PATH ...\nWrite a zip file to stdout containing the given files or directories (recursively).") opts + exitFailure + runResourceT $ C.runConduit + $ generate paths + C..| void (zipStream opt) + C..| CB.sinkHandle stdout diff --git a/zip-stream.cabal b/zip-stream.cabal new file mode 100644 --- /dev/null +++ b/zip-stream.cabal @@ -0,0 +1,72 @@ +name: zip-stream +version: 0.1 +synopsis: ZIP archive streaming using conduits +description: Process (extract and create) zip files as streams (e.g., over the network), accessing contained files without having to write the zip file to disk (unlike zip-conduit). +license: BSD3 +license-file: LICENSE +author: Dylan Simon +maintainer: dylan@dylex.net +copyright: 2017 +category: Codec +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/dylex/zip-stream + +library + exposed-modules: + Codec.Archive.Zip.Conduit.Types + Codec.Archive.Zip.Conduit.UnZip + Codec.Archive.Zip.Conduit.Zip + other-modules: + Codec.Archive.Zip.Conduit.Internal + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >= 4.8 && < 5, + binary >= 0.7.2, + binary-conduit, + bytestring, + conduit, + conduit-extra, + digest, + exceptions, + mtl, + primitive, + resourcet, + time, + transformers-base, + zlib + +executable unzip-stream + main-is: unzip.hs + hs-source-dirs: cmd + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.7 && <5, + bytestring, + conduit, + conduit-extra, + directory, + filepath, + time, + zip-stream + +executable zip-stream + main-is: zip.hs + hs-source-dirs: cmd + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.7 && <5, + bytestring, + conduit, + conduit-extra, + directory, + filepath, + resourcet, + time, + zip-stream