LibZip-0.10: examples/hzip.hs

-- A utility to list, add or extract files in a zip archive.
--
-- This is an example of using LibZip library.
--
-- (c) Sergey Astanin 2010
-- License: BSD3
--
import Codec.Archive.LibZip

import Control.Monad (liftM, when)
import Data.List (intercalate)
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, getCurrentDirectory, getDirectoryContents, makeRelativeToCurrentDirectory)
import System.Environment (getArgs)
import System.FilePath (joinPath, splitDirectories, takeDirectory)
import System.IO (stderr, hPutStr, hPutStrLn)

usage :: String
usage =  unlines
  [ "Usage: hzip [l|a|x] archive.zip [files]"
  , "         l     list files in the archives"
  , "         a     add/update files or directories in the archive recursively"
  , "         x     extract files from the archive to the current direcotory"
  ]

main :: IO ()
main = do
  args <- getArgs
  case args of
    ("l":archive:_) -> list archive
    ("a":archive:files) -> mapM mkRel files >>= add archive
    ("x":archive:files) -> getCurrentDirectory >>= \d -> extract d archive files
    _ -> hPutStr stderr usage
  where
    mkRel = makeRelativeToCurrentDirectory

list :: FilePath -> IO ()
list archive = do
  stats <- withArchive [] archive $ do
             n <- numFiles []
             mapM (fileStatIx []) [0..(n-1)]
  mapM_ printEntry stats
  where
  printEntry e =
    let sz = padLeft 8 . show $ zs'size e
        mt = take 16 . show $ zs'mtime e
        nm = zs'name e
    in  putStrLn $ intercalate "  " [ sz, mt, nm ]
  padLeft n s = let m = max 0 (n - length s) in replicate m ' ' ++ s

add :: FilePath -> [FilePath] -> IO ()
add archive paths = mapM_ (addEntry archive) paths

-- not very effective: it opens the archive many times, but it should work
addEntry :: FilePath -> FilePath -> IO ()
addEntry a path = do
  isADir <- doesDirectoryExist path
  if isADir
     then printErrors a path $ do
       withArchive flags a $ mapM_ checkAddDirectory $ parents path
       paths <- filter (`notElem` [".",".."]) `liftM` getDirectoryContents path
       let rpaths = map (\e -> joinPath [path,e]) paths
       add a rpaths
     else do
       printErrors a path $
           withArchive flags a $ addOrUpdate path =<< sourceFile path 0 0
  where
    flags = [CreateFlag]
    parents = scanl1 (\p c -> joinPath [p,c]) . splitDirectories
    checkAddDirectory p = do
       e1 <- nameLocate [] p
       e2 <- nameLocate [] (p ++ "/")
       if e1 == Nothing && e2 == Nothing
          then addDirectory p
          else return (-1)
    addOrUpdate p src = do
       exists <- nameLocate [] p
       case exists of
          (Just i) -> replaceFileIx i src
          Nothing  -> addFile p src >> return ()
    printErrors a p action =
        catchZipError
        ( action >> return () )
        ( \ze -> hPutStrLn stderr $ intercalate ": " [a, p, show ze] )

extract :: FilePath -> FilePath -> [FilePath] -> IO ()
extract outdir archive onlyFiles =
  withArchive [] archive $ do
    n <- numFiles []
    mapM_ (extractEntry outdir onlyFiles) [0..(n-1)]

-- silently overwrites existing files
extractEntry :: FilePath -> [FilePath] -> Integer -> Archive ()
extractEntry outdir onlyFiles i = do
  name <- fileName [] i
  let fspath = joinPath [outdir, name]
  let fsdir = takeDirectory fspath
  when (null onlyFiles || name `elem` onlyFiles) $
      if isDir name
         then lift $ createDirectoryIfMissing True fsdir
         else do
           b <- fileContentsIx [] i
           lift $ do
                createDirectoryIfMissing True fsdir
                writeFile fspath b  -- FIXME: should be binary 
  where
    isDir "" = False
    isDir f  = last f == '/'