zip-stream-0.1: cmd/zip.hs

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