From a7acdf1a16d40aafd60e2895b800e92a523467ac Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 13 May 2017 11:54:56 -0400 Subject: [PATCH] Add zip-stream command, fixes based on testing --- Codec/Archive/Zip/Conduit/Internal.hs | 9 +++- Codec/Archive/Zip/Conduit/Types.hs | 2 +- Codec/Archive/Zip/Conduit/UnZip.hs | 2 +- Codec/Archive/Zip/Conduit/Zip.hs | 16 +++---- cmd/unzip.hs | 7 +-- cmd/zip.hs | 62 +++++++++++++++++++++++++++ zip-stream.cabal | 16 +++++++ 7 files changed, 99 insertions(+), 15 deletions(-) create mode 100644 cmd/zip.hs diff --git a/Codec/Archive/Zip/Conduit/Internal.hs b/Codec/Archive/Zip/Conduit/Internal.hs index 4257a8b..1ee8387 100644 --- a/Codec/Archive/Zip/Conduit/Internal.hs +++ b/Codec/Archive/Zip/Conduit/Internal.hs @@ -1,5 +1,6 @@ module Codec.Archive.Zip.Conduit.Internal - ( zipError + ( zipVersion + , zipError , idConduit , sizeCRC , sizeC @@ -12,10 +13,14 @@ import Control.Monad.Catch (MonadThrow, throwM) import qualified Data.ByteString as BS import qualified Data.Conduit as C import Data.Digest.CRC32 (crc32Update) -import Data.Word (Word32, Word64) +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 diff --git a/Codec/Archive/Zip/Conduit/Types.hs b/Codec/Archive/Zip/Conduit/Types.hs index e96771f..3582b81 100644 --- a/Codec/Archive/Zip/Conduit/Types.hs +++ b/Codec/Archive/Zip/Conduit/Types.hs @@ -22,7 +22,7 @@ instance Exception ZipError where data ZipEntry = ZipEntry { zipEntryName :: ByteString -- ^File name, usually utf-8 encoded, with a trailing slash for directories , zipEntryTime :: LocalTime -- ^Modification time - , zipEntrySize :: Maybe Word64 -- ^Size of file data (if known) + , zipEntrySize :: Maybe Word64 -- ^Size of file data (if known, ignored on zip) } -- |Summary information at the end of a zip stream. diff --git a/Codec/Archive/Zip/Conduit/UnZip.hs b/Codec/Archive/Zip/Conduit/UnZip.hs index 649bb7e..fa5e1ef 100644 --- a/Codec/Archive/Zip/Conduit/UnZip.hs +++ b/Codec/Archive/Zip/Conduit/UnZip.hs @@ -154,7 +154,7 @@ unZipStream = next where centralBody sig = fail $ "Unknown header signature: " ++ show sig fileHeader = do ver <- G.getWord16le - when (ver > 45) $ fail $ "Unsupported version: " ++ show ver + when (ver > zipVersion) $ fail $ "Unsupported version: " ++ show ver gpf <- G.getWord16le when (gpf .&. complement 0o06 /= 0) $ fail $ "Unsupported flags: " ++ show gpf comp <- G.getWord16le diff --git a/Codec/Archive/Zip/Conduit/Zip.hs b/Codec/Archive/Zip/Conduit/Zip.hs index fea19a2..b17fa4b 100644 --- a/Codec/Archive/Zip/Conduit/Zip.hs +++ b/Codec/Archive/Zip/Conduit/Zip.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ViewPatterns #-} module Codec.Archive.Zip.Conduit.Zip ( ZipOptions(..) + , ZipInfo(..) , defaultZipOptions , ZipEntry(..) , ZipData(..) @@ -93,10 +94,6 @@ countBytes c = stateC $ \s -> c `C.fuseBoth` ((s +) <$> sizeC) output :: MonadThrow m => P.Put -> C.ConduitM i BS.ByteString (StateT Word64 m) () output = countBytes . sourcePut --- |The version of this zip program, really just rough indicator of compatibility -zipVersion :: Word16 -zipVersion = 48 - maxBound16 :: Integral n => n maxBound16 = fromIntegral (maxBound :: Word16) @@ -129,7 +126,6 @@ zipStream ZipOptions{..} = execStateC 0 $ do mcrc = either (const Nothing) (Just . crc32) cdat when (namelen > maxBound16) $ zipError $ BSC.unpack zipEntryName ++ ": entry name too long" let common = do - P.putWord16le $ if z64 then 45 else 20 P.putWord16le $ isLeft dat ?* bit 3 P.putWord16le $ comp ?* 8 P.putWord16le $ time @@ -137,6 +133,7 @@ zipStream ZipOptions{..} = execStateC 0 $ do 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 @@ -166,23 +163,26 @@ zipStream ZipOptions{..} = execStateC 0 $ do (\b -> outsz $ ((fromJust usiz, fromJust mcrc), fromJust csiz) <$ CB.sourceLbs b) cdat 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 $ 4 + l64 + 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 (z64 || o64) $ do + when a64 $ do P.putWord16le 0x0001 P.putWord16le l64 when z64 $ do @@ -217,6 +217,6 @@ zipStream ZipOptions{..} = execStateC 0 $ do P.putWord16le $ fromIntegral $ min maxBound16 cnt P.putWord16le $ fromIntegral $ min maxBound16 cnt P.putWord32le $ fromIntegral $ min maxBound32 cdlen - P.putWord32le $ fromIntegral $ max maxBound32 cdoff + P.putWord32le $ fromIntegral $ min maxBound32 cdoff P.putWord16le $ fromIntegral commlen P.putByteString comment diff --git a/cmd/unzip.hs b/cmd/unzip.hs index 1daa5fc..a226f54 100644 --- a/cmd/unzip.hs +++ b/cmd/unzip.hs @@ -7,9 +7,9 @@ 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 (getArgs) +import System.Environment (getProgName, getArgs) import System.Exit (exitFailure) -import System.FilePath.Posix (takeDirectory) +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 @@ -37,9 +37,10 @@ extract = C.awaitForever start where main :: IO () main = do + prog <- getProgName args <- getArgs unless (null args) $ do - hPutStrLn stderr "Usage: unzip\nRead a zip file from stdin and extract it in the current directory." + hPutStrLn stderr $ "Usage: " ++ prog ++ "\nRead a zip file from stdin and extract it in the current directory." exitFailure ZipInfo{..} <- C.runConduit $ CB.sourceHandle stdin diff --git a/cmd/zip.hs b/cmd/zip.hs new file mode 100644 index 0000000..3934c31 --- /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 index 41e856b..d4df5b8 100644 --- a/zip-stream.cabal +++ b/zip-stream.cabal @@ -54,3 +54,19 @@ executable unzip-stream 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