Add zip-stream command, fixes based on testing

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
 

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.

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

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

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

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

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