63 lines
2.6 KiB
Haskell
63 lines
2.6 KiB
Haskell
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
|