diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2007, Björn Bringert + 2008-2009 Duncan Coutts +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +- Neither the names of the copyright owners nor the names of the + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain diff --git a/htar.cabal b/htar.cabal --- a/htar.cabal +++ b/htar.cabal @@ -1,16 +1,39 @@ -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. +name: htar +version: 0.3 +license: BSD3 +license-File: LICENSE +author: Bjorn Bringert + Duncan Coutts +maintainer: Duncan Coutts +copyright: 2007 Bjorn Bringert + 2008-2009 Duncan Coutts +category: Codec +synopsis: Command-line tar archive utility. +description: A Command-line utility to create, extract and list the + contents of tar archives. It can work with compressed + archives using gzip or bzip2 compression. +build-type: Simple +cabal-version: >= 1.2 -Executable: htar -Main-Is: htar.hs -GHC-options: -O -Wall +flag base3 + +executable htar + main-is: htar.hs + ghc-options: -Wall + build-depends: + base >= 2, + tar >= 0.3 && < 0.4, + zlib >= 0.4 && < 0.6, + bzlib >= 0.4 && < 0.6, + filepath >= 1 + + if flag(base3) + build-depends: + base >= 3, + old-time >= 1.0, + old-locale >= 1.0, + directory >= 1.0, + bytestring >= 0.9 + else + build-depends: + base < 3 diff --git a/htar.hs b/htar.hs --- a/htar.hs +++ b/htar.hs @@ -1,188 +1,200 @@ module Main where -import Codec.Archive.Tar +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar -import Codec.Compression.GZip.GUnZip (gunzip) +import qualified Codec.Compression.GZip as GZip (compress, decompress) +import qualified Codec.Compression.BZip as BZip (compress, decompress) 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) +import Data.ByteString.Lazy (ByteString) +import Data.Bits (testBit) +import Data.Char (toUpper) +import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..), + getOpt', usageInfo) +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) +import System.Locale (defaultTimeLocale) +import System.Time (ClockTime(..), toUTCTime, formatCalendarTime) main :: IO () -main = do args <- getArgs - (opts, files) <- parseOptions args - mainOpts opts files +main = do + (opts, files) <- parseOptions =<< getArgs + main' 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) +main' :: Options -> [FilePath] -> IO () +main' (Options { optFile = file, + optAction = action, + optCompression = compression, + optVerbosity = verbosity }) files = + case action of + NoAction -> die ["No action given. Specify one of -c, -t or -x."] + Help -> printUsage + Create -> output . compress compression + . Tar.write =<< Tar.pack "" files + Extract -> Tar.unpack "." . Tar.read . decompress compression =<< input + List -> printEntries . Tar.read . decompress compression =<< input + where + input = if file == "-" then BS.getContents else BS.readFile file + output = if file == "-" then BS.putStr else BS.writeFile file -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 + printEntries = Tar.foldEntries (\entry rest -> printEntry entry >> rest) + (return ()) fail + printEntry = putStrLn . entryInfo verbosity -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" +data Compression = None | GZip | BZip + deriving Show -decompress :: Maybe Compression -> ByteString -> ByteString -decompress Nothing = id -decompress (Just GZip) = gunzip -decompress (Just BZip2) = error "bzip2 decompression is not supported yet" +compress :: Compression -> ByteString -> ByteString +compress None = id +compress GZip = GZip.compress +compress BZip = BZip.compress -readEntries :: [FilePath] -> ByteString -> [TarEntry] -readEntries files = (if null files then id else keepFiles files) - . archiveEntries . readTarArchive +decompress :: Compression -> ByteString -> ByteString +decompress None = id +decompress GZip = GZip.decompress +decompress BZip = BZip.decompress --- 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) +data Verbosity = Verbose | Concise -createEntry :: Bool -> FilePath -> IO TarEntry -createEntry verbose file = - do when verbose $ putStrLn file - createTarEntry file +------------------------ +-- List archive contents -extractEntry :: Bool -> TarEntry -> IO () -extractEntry verbose e = - do when verbose $ putStrLn $ tarFileName $ entryHeader e - extractTarEntry e +entryInfo :: Verbosity -> Tar.Entry -> String +entryInfo Verbose = detailedInfo +entryInfo Concise = Tar.entryPath -die :: [String] -> IO a -die errs = do mapM_ (\e -> hPutStrLn stderr $ "htar: " ++ e) $ errs - hPutStrLn stderr "Try `htar --help' for more information." - exitFailure +detailedInfo :: Tar.Entry -> String +detailedInfo entry = + unwords [ typeCode : permissions + , justify 19 (owner ++ '/' : group) size + , time + , name ++ link ] + where + typeCode = case Tar.entryContent entry of + Tar.HardLink _ -> 'h' + Tar.SymbolicLink _ -> 'l' + Tar.CharacterDevice _ _ -> 'c' + Tar.BlockDevice _ _ -> 'b' + Tar.Directory -> 'd' + Tar.NamedPipe -> 'p' + _ -> '-' + permissions = concat [userPerms, groupPerms, otherPerms] + where + userPerms = formatPerms 8 7 6 11 's' + groupPerms = formatPerms 5 4 3 10 's' + otherPerms = formatPerms 2 1 0 9 't' + formatPerms 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 '-'] + m = Tar.entryPermissions entry + owner = nameOrID ownerName ownerId + group = nameOrID groupName groupId + (Tar.Ownership ownerName groupName ownerId groupId) = + Tar.entryOwnership entry + nameOrID n i = if null n then show i else n + size = case Tar.entryContent entry of + Tar.NormalFile _ fileSize -> show fileSize + _ -> "0" -usage :: IO a -usage = do putStrLn (usageInfo hdr optDescr) - exitWith ExitSuccess - where hdr = unlines ["htar creates and extracts TAR archives.", - "", - "Usage: htar [OPTION ...] [FILE ...]"] + time = formatEpochTime "%Y-%m-%d %H:%M" (Tar.entryTime entry) + name = Tar.entryPath entry + link = case Tar.entryContent entry of + Tar.HardLink l -> " link to " ++ Tar.fromLinkTarget l + Tar.SymbolicLink l -> " -> " ++ Tar.fromLinkTarget l + _ -> "" --- * Options +justify :: Int -> String -> String -> String +justify width left right = left ++ padding ++ right + where + padding = replicate padWidth ' ' + padWidth = max 1 (width - length left - length right) -data Options = Options - { - optFile :: FilePath, -- "-" means stdin/stdout - optAction :: Maybe Action, - optCompression :: Maybe Compression, - optVerbose :: Bool - } - deriving Show +formatEpochTime :: String -> Tar.EpochTime -> String +formatEpochTime f = + formatCalendarTime defaultTimeLocale f . toUTCTime . epochTimeToClockTime -data Action = Create - | Extract - | List - deriving Show +epochTimeToClockTime :: Tar.EpochTime -> ClockTime +epochTimeToClockTime e = TOD s (truncate (1000000000 * f)) + where (s,f) = properFraction (toRational e) -data Compression = GZip | BZip2 - deriving Show +------------------------ +-- Command line handling +data Options = Options { + optFile :: FilePath, -- "-" means stdin/stdout + optAction :: Action, + optCompression :: Compression, + optVerbosity :: Verbosity + } + 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 + optFile = "-", + optAction = NoAction, + optCompression = None, + optVerbosity = Concise + } -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 - _ -> "" +data Action = NoAction + | Help + | Create + | Extract + | List + deriving Show -lpad :: Int -> a -> [a] -> [a] -lpad n x xs = replicate (n - length xs) x ++ xs +optDescr :: [OptDescr (Options -> Options)] +optDescr = + [ Option ['c'] ["create"] + (action Create) + "Create a new archive." + , Option ['x'] ["extract", "get"] + (action Extract) + "Extract files from an archive." + , Option ['t'] ["list"] + (action List) + "List the contents of an archive." + , Option ['f'] ["file"] + (ReqArg (\f o -> o { optFile = f}) "ARCHIVE") + "Use archive file ARCHIVE." + , Option ['z'] ["gzip", "gunzip", "ungzip"] + (compression GZip) + "Use gzip compression." + , Option ['j'] ["bzip2"] + (compression BZip) + "Use bzip2 compression." + , Option ['v'] ["verbose"] + (NoArg (\o -> o { optVerbosity = Verbose })) + "Verbosely list files processed." + , Option ['h', '?'] ["help"] + (action Help) + "Print this help output." + ] + where + action a = NoArg (\o -> o { optAction = a }) + compression c = NoArg (\o -> o { optCompression = c }) -rpad :: Int -> a -> [a] -> [a] -rpad n x xs = xs ++ replicate (n - length xs) x +printUsage :: IO () +printUsage = putStrLn (usageInfo headder optDescr) + where + headder = unlines ["htar creates and extracts TAR archives.", + "", + "Usage: htar [OPTION ...] [FILE ...]"] -formatEpochTime :: String -> EpochTime -> String -formatEpochTime f = - formatCalendarTime defaultTimeLocale f . toUTCTime . epochTimeToClockTime +parseOptions :: [String] -> IO (Options, [FilePath]) +parseOptions args = + let (fs, files, nonopts, errors) = getOpt' Permute optDescr args + in case (nonopts, errors) of + ([], []) -> return $ (foldl (flip ($)) defaultOptions fs, files) + (_ , (_:_)) -> die errors + (_ , _) -> die (map (("unrecognized option "++).show) nonopts) -epochTimeToClockTime :: EpochTime -> ClockTime -epochTimeToClockTime e = TOD s (truncate (1000000000 * f)) - where (s,f) = properFraction (toRational e) +die :: [String] -> IO a +die errs = do + mapM_ (\e -> hPutStrLn stderr $ "htar: " ++ e) $ errs + hPutStrLn stderr "Try `htar --help' for more information." + exitFailure