diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/htar.cabal b/htar.cabal new file mode 100644 --- /dev/null +++ b/htar.cabal @@ -0,0 +1,16 @@ +Name: htar +Version: 0.1 +License: BSD4 +License-File: ../LICENSE +Author: Bjorn Bringert +Maintainer: Bjorn Bringert +Copyright: 2007 Bjorn Bringert +Stability: Experimental +Build-depends: base >= 2.0, tar == 0.1, compression >= 0.1 +Synopsis: Command-line TAR utility. +Description: + Command-line TAR utility which uses the tar package. + +Executable: htar +Main-Is: htar.hs +GHC-options: -O -Wall diff --git a/htar.hs b/htar.hs new file mode 100644 --- /dev/null +++ b/htar.hs @@ -0,0 +1,188 @@ +module Main where + +import Codec.Archive.Tar + +import Codec.Compression.GZip.GUnZip (gunzip) + +import qualified Data.ByteString.Lazy as BS +import Data.ByteString.Lazy (ByteString) +import Control.Monad +import Data.Bits +import Data.Char (toUpper) +import qualified Data.Set as Set +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.Locale (defaultTimeLocale) +import System.IO +import System.Posix.Types (EpochTime) +import System.Time (ClockTime(..), toUTCTime, formatCalendarTime) + +main :: IO () +main = do args <- getArgs + (opts, files) <- parseOptions args + mainOpts opts files + +parseOptions :: [String] -> IO (Options, [FilePath]) +parseOptions args = + do let (fs, files, nonopts, errs) = getOpt' RequireOrder optDescr args + when (not (null errs)) $ die errs + case nonopts of + [] -> return $ (foldl (flip ($)) defaultOptions fs, files) + ["--help"] -> usage + _ -> die (map (("unrecognized option "++).show) nonopts) + +mainOpts :: Options -> [FilePath] -> IO () +mainOpts (Options { optAction = Nothing }) _ + = die ["No action given. Specify one of -c, -t or -x."] +mainOpts (Options { optFile = file, + optAction = Just action, + optCompression = compression, + optVerbose = verbose }) files = + -- FIXME: catch errors and print out nicely + case action of + Create -> recurseDirectories files + >>= mapM (createEntry verbose) + >>= output . compress compression + . writeTarArchive . TarArchive + Extract -> inputEntries >>= mapM_ (extractEntry verbose) + List -> inputEntries >>= mapM_ (putStrLn . entryInfo verbose) + where input = if file == "-" then BS.getContents else BS.readFile file + output = if file == "-" then BS.putStr else BS.writeFile file + inputEntries = input >>= return . readEntries files . decompress compression + +compress :: Maybe Compression -> ByteString -> ByteString +compress Nothing = id +compress (Just GZip) = error "gzip compression is not supported yet" +compress (Just BZip2) = error "bzip2 compression is not supported yet" + +decompress :: Maybe Compression -> ByteString -> ByteString +decompress Nothing = id +decompress (Just GZip) = gunzip +decompress (Just BZip2) = error "bzip2 decompression is not supported yet" + +readEntries :: [FilePath] -> ByteString -> [TarEntry] +readEntries files = (if null files then id else keepFiles files) + . archiveEntries . readTarArchive + +-- FIXME: allow files names to differ in trailing slashes +keepFiles :: [FilePath] -> [TarEntry] -> [TarEntry] +keepFiles files = filter (p . entryHeader) + where p = ((`Set.member` Set.fromList files) . tarFileName) + +createEntry :: Bool -> FilePath -> IO TarEntry +createEntry verbose file = + do when verbose $ putStrLn file + createTarEntry file + +extractEntry :: Bool -> TarEntry -> IO () +extractEntry verbose e = + do when verbose $ putStrLn $ tarFileName $ entryHeader e + extractTarEntry e + +die :: [String] -> IO a +die errs = do mapM_ (\e -> hPutStrLn stderr $ "htar: " ++ e) $ errs + hPutStrLn stderr "Try `htar --help' for more information." + exitFailure + +usage :: IO a +usage = do putStrLn (usageInfo hdr optDescr) + exitWith ExitSuccess + where hdr = unlines ["htar creates and extracts TAR archives.", + "", + "Usage: htar [OPTION ...] [FILE ...]"] + +-- * Options + +data Options = Options + { + optFile :: FilePath, -- "-" means stdin/stdout + optAction :: Maybe Action, + optCompression :: Maybe Compression, + optVerbose :: Bool + } + deriving Show + +data Action = Create + | Extract + | List + deriving Show + +data Compression = GZip | BZip2 + deriving Show + +defaultOptions :: Options +defaultOptions = Options { + optFile = "-", + optAction = Nothing, + optCompression = Nothing, + optVerbose = False + } + +optDescr :: [OptDescr (Options -> Options)] +optDescr = + [ + Option ['c'] ["create"] (action Create) "Create a new archive.", + Option ['x'] ["extract","get"] (action Extract) "Extract files.", + Option ['t'] ["list"] (action List) "List archive contents.", + Option ['z'] ["gzip","ungzip"] (compression GZip) "Use gzip compression.", + Option ['j'] ["bzip2"] (compression BZip2) "Use bzip2 compression.", + Option ['f'] ["file"] (ReqArg (\f o -> o { optFile = f}) "ARCHIVE") + "Use archive file ARCHIVE.", + Option ['v'] ["verbose"] (NoArg (\o -> o { optVerbose = True })) + "Increase output verbosity." + ] + where action a = NoArg (\o -> o { optAction = Just a }) + compression c = NoArg (\o -> o { optCompression = Just c }) + +-- * Formatted information about archives + +entryInfo :: Bool -- ^ Verbosity + -> TarEntry -> String +entryInfo True = detailedInfo . entryHeader +entryInfo False = tarFileName . entryHeader + +detailedInfo :: TarHeader -> String +detailedInfo hdr = unwords [typ:mode, owner, group, size, time, name++link] + where typ = case tarFileType hdr of + TarHardLink -> 'h' + TarSymbolicLink -> 'l' + TarCharacterDevice -> 'c' + TarBlockDevice -> 'b' + TarDirectory -> 'd' + TarFIFO -> 'p' + _ -> '-' + mode = concat [u,g,o] + where m = tarFileMode hdr + f r w x s c = [if testBit m r then 'r' else '-', + if testBit m w then 'w' else '-', + if testBit m s + then if testBit m x then c else toUpper c + else if testBit m x then 'x' else '-'] + u = f 8 7 6 11 's' + g = f 5 4 3 10 's' + o = f 2 1 0 9 't' + owner = rpad 7 ' ' $ nameOrID (tarOwnerName hdr) (tarOwnerID hdr) + group = rpad 7 ' ' $ nameOrID (tarGroupName hdr) (tarGroupID hdr) + nameOrID n i = if null n then show i else n + size = lpad 11 ' ' $ show (tarFileSize hdr) + time = formatEpochTime "%Y-%m-%d %H:%M:%S" (tarModTime hdr) + name = tarFileName hdr + link = case tarFileType hdr of + TarHardLink -> " link to " ++ tarLinkTarget hdr + TarSymbolicLink -> " -> " ++ tarLinkTarget hdr + _ -> "" + +lpad :: Int -> a -> [a] -> [a] +lpad n x xs = replicate (n - length xs) x ++ xs + +rpad :: Int -> a -> [a] -> [a] +rpad n x xs = xs ++ replicate (n - length xs) x + +formatEpochTime :: String -> EpochTime -> String +formatEpochTime f = + formatCalendarTime defaultTimeLocale f . toUTCTime . epochTimeToClockTime + +epochTimeToClockTime :: EpochTime -> ClockTime +epochTimeToClockTime e = TOD s (truncate (1000000000 * f)) + where (s,f) = properFraction (toRational e)