zip-stream-0.1.0.1: cmd/zip.hs

{-# LANGUAGE CPP #-}
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
#if MIN_VERSION_directory(1,2,6)
  , isSymbolicLink, listDirectory
#else
  , getDirectoryContents
#endif
  )
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
#if MIN_VERSION_directory(1,2,6)
      dl <- liftIO $ filterM (fmap not . isSymbolicLink) . map (p </>) =<< listDirectory p
#else
      dl <- liftIO $ filter (`notElem` [".",".."]) . map (p </>) <$> getDirectoryContents p
#endif
      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