diff --git a/Codec/Archive/Tar.hs b/Codec/Archive/Tar.hs --- a/Codec/Archive/Tar.hs +++ b/Codec/Archive/Tar.hs @@ -3,7 +3,7 @@ -- Module : Codec.Archive.Tar -- Copyright : (c) 2007 Bjorn Bringert, -- 2008 Andrea Vezzosi, --- 2008-2009 Duncan Coutts +-- 2008-2012 Duncan Coutts -- License : BSD3 -- -- Maintainer : duncan@community.haskell.org @@ -54,7 +54,8 @@ -- \"@.tar.gz@\" or \"@.tar.bz2@\" files. This module does not directly -- handle compressed tar files however they can be handled easily by -- composing functions from this module and the modules - -- "Codec.Compression.GZip" or "Codec.Compression.BZip". + -- @Codec.Compression.GZip@ or @Codec.Compression.BZip@ + -- (see @zlib@ or @bzlib@ packages). -- -- Creating a compressed \"@.tar.gz@\" file is just a minor variation on the -- 'create' function, but where throw compression into the pipeline: @@ -67,17 +68,6 @@ -- > Tar.unpack dir . Tar.read . GZip.decompress =<< BS.readFile tar -- - -- ** Tarbombs - -- | A \"tarbomb\" is a @.tar@ file where not all entries are in a - -- subdirectory but instead files extract into the top level directory. The - -- 'extract' function does not check for these however if you want to do - -- that you can use the 'checkTarbomb' function like so: - -- - -- > Tar.unpack dir . Tar.checkTarbomb expectedDir - -- > . Tar.read =<< BS.readFile tar - -- - -- In this case extraction will fail if any file is outside of @expectedDir@. - -- ** Security -- | This is pretty important. A maliciously constructed tar archives could -- contain entries that specify bad file names. It could specify absolute @@ -90,6 +80,17 @@ -- 'checkSecurity' function for more details. If you need to do any custom -- unpacking then you should use this. + -- ** Tarbombs + -- | A \"tarbomb\" is a @.tar@ file where not all entries are in a + -- subdirectory but instead files extract into the top level directory. The + -- 'extract' function does not check for these however if you want to do + -- that you can use the 'checkTarbomb' function like so: + -- + -- > Tar.unpack dir . Tar.checkTarbomb expectedDir + -- > . Tar.read =<< BS.readFile tar + -- + -- In this case extraction will fail if any file is outside of @expectedDir@. + -- * Converting between internal and external representation -- | Note, you cannot expect @write . read@ to give exactly the same output -- as input. You can expect the information to be preserved exactly however. @@ -119,9 +120,23 @@ -- ** Sequences of tar entries Entries(..), mapEntries, + mapEntriesNoFail, foldEntries, unfoldEntries, + -- * Error handling + -- | Reading tar files can fail if the data does not match the tar file + -- format correctly. + -- + -- The style of error handling by returning structured errors. The pure + -- functions in the library do not throw exceptions, they return the errors + -- as data. The IO actions in the library can throw exceptions, in particular + -- the 'unpack' action does this. All the error types used are an instance of + -- the standard 'Exception' class so it is possible to 'throw' and 'catch' + -- them. + + -- ** Errors from reading tar files + FormatError(..), ) where import Codec.Archive.Tar.Types @@ -132,8 +147,9 @@ import Codec.Archive.Tar.Pack import Codec.Archive.Tar.Unpack -import Codec.Archive.Tar.Check () +import Codec.Archive.Tar.Check +import Control.Exception (Exception, throw, catch) import qualified Data.ByteString.Lazy as BS import Prelude hiding (read) diff --git a/Codec/Archive/Tar/Check.hs b/Codec/Archive/Tar/Check.hs --- a/Codec/Archive/Tar/Check.hs +++ b/Codec/Archive/Tar/Check.hs @@ -1,7 +1,8 @@ ----------------------------------------------------------------------------- -- | -- Module : Codec.Archive.Tar --- Copyright : (c) 2008-2009 Duncan Coutts +-- Copyright : (c) 2008-2012 Duncan Coutts +-- 2011 Max Bolingbroke -- License : BSD3 -- -- Maintainer : duncan@community.haskell.org @@ -11,13 +12,25 @@ -- ----------------------------------------------------------------------------- module Codec.Archive.Tar.Check ( + + -- * Security checkSecurity, + FileNameError(..), + + -- * Tarbombs checkTarbomb, + TarBombError(..), + + -- * Portability checkPortability, + PortabilityError(..), + PortabilityPlatform, ) where import Codec.Archive.Tar.Types +import Data.Typeable (Typeable) +import Control.Exception (Exception) import Control.Monad (MonadPlus(mplus)) import qualified System.FilePath as FilePath.Native ( splitDirectories, isAbsolute, isValid ) @@ -25,6 +38,11 @@ import qualified System.FilePath.Windows as FilePath.Windows import qualified System.FilePath.Posix as FilePath.Posix + +-------------------------- +-- Security +-- + -- | This function checks a sequence of tar entries for file name security -- problems. It checks that: -- @@ -40,17 +58,10 @@ -- link target. A failure in any entry terminates the sequence of entries with -- an error. -- -checkSecurity :: Entries -> Entries +checkSecurity :: Entries e -> Entries (Either e FileNameError) checkSecurity = checkEntries checkEntrySecurity -checkTarbomb :: FilePath -> Entries -> Entries -checkTarbomb expectedTopDir = checkEntries (checkEntryTarbomb expectedTopDir) - -checkPortability :: Entries -> Entries -checkPortability = checkEntries checkEntryPortability - - -checkEntrySecurity :: Entry -> Maybe String +checkEntrySecurity :: Entry -> Maybe FileNameError checkEntrySecurity entry = case entryContent entry of HardLink link -> check (entryPath entry) `mplus` check (fromLinkTarget link) @@ -61,51 +72,119 @@ where check name | FilePath.Native.isAbsolute name - = Just $ "Absolute file name in tar archive: " ++ show name + = Just $ AbsoluteFileName name | not (FilePath.Native.isValid name) - = Just $ "Invalid file name in tar archive: " ++ show name + = Just $ InvalidFileName name | any (=="..") (FilePath.Native.splitDirectories name) - = Just $ "Invalid file name in tar archive: " ++ show name + = Just $ InvalidFileName name | otherwise = Nothing -checkEntryTarbomb :: FilePath -> Entry -> Maybe String +-- | Errors arising from tar file names being in some way invalid or dangerous +data FileNameError + = InvalidFileName FilePath + | AbsoluteFileName FilePath + deriving (Typeable) + +instance Show FileNameError where + show = showFileNameError Nothing + +instance Exception FileNameError + +showFileNameError :: Maybe PortabilityPlatform -> FileNameError -> String +showFileNameError mb_plat err = case err of + InvalidFileName path -> "Invalid" ++ plat ++ " file name in tar archive: " ++ show path + AbsoluteFileName path -> "Absolute" ++ plat ++ " file name in tar archive: " ++ show path + where plat = maybe "" (' ':) mb_plat + + +-------------------------- +-- Tarbombs +-- + +-- | This function checks a sequence of tar entries for being a \"tar bomb\". +-- This means that the tar file does not follow the standard convention that +-- all entries are within a single subdirectory, e.g. a file \"foo.tar\" would +-- usually have all entries within the \"foo/\" subdirectory. +-- +-- Given the expected subdirectory, this function checks all entries are within +-- that subdirectroy. +-- +-- Note: This check must be used in conjunction with 'checkSecurity'. +-- +checkTarbomb :: FilePath -> Entries e -> Entries (Either e TarBombError) +checkTarbomb expectedTopDir = checkEntries (checkEntryTarbomb expectedTopDir) + +checkEntryTarbomb :: FilePath -> Entry -> Maybe TarBombError checkEntryTarbomb expectedTopDir entry = case FilePath.Native.splitDirectories (entryPath entry) of (topDir:_) | topDir == expectedTopDir -> Nothing - _ -> Just $ "File in tar archive is not in the expected directory " - ++ show expectedTopDir + _ -> Just $ TarBombError expectedTopDir -checkEntryPortability :: Entry -> Maybe String -checkEntryPortability entry - | entryFormat entry == V7Format - = Just "Archive is in the old Unix V7 tar format" +-- | An error that occurs if a tar file is a \"tar bomb\" that would extract +-- files outside of the intended directory. +data TarBombError = TarBombError FilePath + deriving (Typeable) - | entryFormat entry == GnuFormat - = Just "Archive is in the GNU tar format" +instance Exception TarBombError +instance Show TarBombError where + show (TarBombError expectedTopDir) + = "File in tar archive is not in the expected directory " ++ show expectedTopDir + + +-------------------------- +-- Portability +-- + +-- | This function checks a sequence of tar entries for a number of portability +-- issues. It will complain if: +-- +-- * The old \"Unix V7\" or \"gnu\" formats are used. For maximum portability +-- only the POSIX standard \"ustar\" format should be used. +-- +-- * A non-portable entry type is used. Only ordinary files, hard links, +-- symlinks and directories are portable. Device files, pipes and others are +-- not portable between all common operating systems. +-- +-- * Non-ASCII characters are used in file names. There is no agreed portable +-- convention for Unicode or other extended character sets in file names in +-- tar archives. +-- +-- * File names that would not be portable to both Unix and Windows. This check +-- includes characters that are valid in both systems and the \'/\' vs \'\\\' +-- directory separator conventions. +-- +checkPortability :: Entries e -> Entries (Either e PortabilityError) +checkPortability = checkEntries checkEntryPortability + +checkEntryPortability :: Entry -> Maybe PortabilityError +checkEntryPortability entry + | entryFormat entry `elem` [V7Format, GnuFormat] + = Just $ NonPortableFormat (entryFormat entry) + | not (portableFileType (entryContent entry)) - = Just "Non-portable file type in archive" + = Just NonPortableFileType | not (all portableChar posixPath) - = Just $ "Non-portable character in archive entry name: " ++ show posixPath + = Just $ NonPortableEntryNameChar posixPath | not (FilePath.Posix.isValid posixPath) - = Just $ "Invalid unix file name in tar archive: " ++ show posixPath + = Just $ NonPortableFileName "unix" (InvalidFileName posixPath) | not (FilePath.Windows.isValid windowsPath) - = Just $ "Invalid windows file name in tar archive: " ++ show windowsPath + = Just $ NonPortableFileName "windows" (InvalidFileName windowsPath) | FilePath.Posix.isAbsolute posixPath - = Just $ "Absolute unix file name in tar archive: " ++ show posixPath + = Just $ NonPortableFileName "unix" (AbsoluteFileName posixPath) | FilePath.Windows.isAbsolute windowsPath - = Just $ "Absolute windows file name in tar archive: " ++ show windowsPath + = Just $ NonPortableFileName "windows" (AbsoluteFileName windowsPath) | any (=="..") (FilePath.Posix.splitDirectories posixPath) - = Just $ "Invalid unix file name in tar archive: " ++ show posixPath + = Just $ NonPortableFileName "unix" (InvalidFileName posixPath) | any (=="..") (FilePath.Windows.splitDirectories windowsPath) - = Just $ "Invalid windows file name in tar archive: " ++ show windowsPath + = Just $ NonPortableFileName "windows" (InvalidFileName windowsPath) | otherwise = Nothing @@ -122,7 +201,35 @@ portableChar c = c <= '\127' +-- | Potential portability issues in a tar archive +data PortabilityError + = NonPortableFormat Format + | NonPortableFileType + | NonPortableEntryNameChar FilePath + | NonPortableFileName PortabilityPlatform FileNameError + deriving (Typeable) -checkEntries :: (Entry -> Maybe String) -> Entries -> Entries +-- | The name of a platform that portability issues arise from +type PortabilityPlatform = String + +instance Exception PortabilityError + +instance Show PortabilityError where + show (NonPortableFormat format) = "Archive is in the " ++ fmt ++ " format" + where fmt = case format of V7Format -> "old Unix V7 tar" + UstarFormat -> "ustar" -- I never generate this but a user might + GnuFormat -> "GNU tar" + show NonPortableFileType = "Non-portable file type in archive" + show (NonPortableEntryNameChar posixPath) + = "Non-portable character in archive entry name: " ++ show posixPath + show (NonPortableFileName platform err) + = showFileNameError (Just platform) err + + +-------------------------- +-- Utils +-- + +checkEntries :: (Entry -> Maybe e') -> Entries e -> Entries (Either e e') checkEntries checkEntry = mapEntries (\entry -> maybe (Right entry) Left (checkEntry entry)) diff --git a/Codec/Archive/Tar/Read.hs b/Codec/Archive/Tar/Read.hs --- a/Codec/Archive/Tar/Read.hs +++ b/Codec/Archive/Tar/Read.hs @@ -3,20 +3,23 @@ -- Module : Codec.Archive.Tar.Read -- Copyright : (c) 2007 Bjorn Bringert, -- 2008 Andrea Vezzosi, --- 2008-2009 Duncan Coutts +-- 2008-2009 Duncan Coutts, +-- 2011 Max Bolingbroke -- License : BSD3 -- -- Maintainer : duncan@community.haskell.org -- Portability : portable -- ----------------------------------------------------------------------------- -module Codec.Archive.Tar.Read (read) where +module Codec.Archive.Tar.Read (read, FormatError(..)) where import Codec.Archive.Tar.Types import Data.Char (ord) import Data.Int (Int64) import Numeric (readOct) +import Control.Exception (Exception) +import Data.Typeable (Typeable) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 @@ -24,35 +27,61 @@ import Prelude hiding (read) + +-- | Errors that can be encountered when parsing a Tar archive. +data FormatError + = TruncatedArchive + | ShortTrailer + | BadTrailer + | TrailingJunk + | ChecksumIncorrect + | NotTarFormat + | UnrecognisedTarFormat + | HeaderBadNumericEncoding + deriving (Typeable) + +instance Show FormatError where + show TruncatedArchive = "truncated tar archive" + show ShortTrailer = "short tar trailer" + show BadTrailer = "bad tar trailer" + show TrailingJunk = "tar file has trailing junk" + show ChecksumIncorrect = "tar checksum error" + show NotTarFormat = "data is not in tar format" + show UnrecognisedTarFormat = "tar entry not in a recognised format" + show HeaderBadNumericEncoding = "tar header is malformed (bad numeric encoding)" + +instance Exception FormatError + + -- | Convert a data stream in the tar file format into an internal data -- structure. Decoding errors are reported by the 'Fail' constructor of the -- 'Entries' type. -- -- * The conversion is done lazily. -- -read :: ByteString -> Entries +read :: ByteString -> Entries FormatError read = unfoldEntries getEntry -getEntry :: ByteString -> Either String (Maybe (Entry, ByteString)) +getEntry :: ByteString -> Either FormatError (Maybe (Entry, ByteString)) getEntry bs - | BS.length header < 512 = Left "truncated tar archive" + | BS.length header < 512 = Left TruncatedArchive -- Tar files end with at least two blocks of all '0'. Checking this serves -- two purposes. It checks the format but also forces the tail of the data -- which is necessary to close the file if it came from a lazily read file. | BS.head bs == 0 = case BS.splitAt 1024 bs of (end, trailing) - | BS.length end /= 1024 -> Left "short tar trailer" - | not (BS.all (== 0) end) -> Left "bad tar trailer" - | not (BS.all (== 0) trailing) -> Left "tar file has trailing junk" + | BS.length end /= 1024 -> Left ShortTrailer + | not (BS.all (== 0) end) -> Left BadTrailer + | not (BS.all (== 0) trailing) -> Left TrailingJunk | otherwise -> Right Nothing | otherwise = partial $ do case (chksum_, format_) of (Ok chksum, _ ) | correctChecksum header chksum -> return () - (Ok _, Ok _) -> fail "tar checksum error" - _ -> fail "data is not in tar format" + (Ok _, Ok _) -> Error ChecksumIncorrect + _ -> Error NotTarFormat -- These fields are partial, have to check them format <- format_; mode <- mode_; @@ -109,7 +138,7 @@ "\0\0\0\0\0\0\0\0" -> return V7Format "ustar\NUL00" -> return UstarFormat "ustar \NUL" -> return GnuFormat - _ -> fail "tar entry not in a recognised format" + _ -> Error UnrecognisedTarFormat correctChecksum :: ByteString -> Int -> Bool correctChecksum header checksum = checksum == checksum' @@ -124,7 +153,7 @@ -- * TAR format primitive input -getOct :: Integral a => Int64 -> Int64 -> ByteString -> Partial a +getOct :: Integral a => Int64 -> Int64 -> ByteString -> Partial FormatError a getOct off len = parseOct . BS.Char8.unpack . BS.Char8.takeWhile (\c -> c /= '\NUL' && c /= ' ') @@ -132,11 +161,27 @@ . getBytes off len where parseOct "" = return 0 - parseOct ('\128':_) = fail "tar header uses non-standard number encoding" + -- As a star extension, octal fields can hold a base-256 value if the high + -- bit of the initial character is set. The initial character can be: + -- 0x80 ==> trailing characters hold a positive base-256 value + -- 0xFF ==> trailing characters hold a negative base-256 value + -- + -- In both cases, there won't be a trailing NUL/space. + -- + -- GNU tar seems to contain a half-implementation of code that deals with + -- extra bits in the first character, but I don't think it works and the + -- docs I can find on star seem to suggest that these will always be 0, + -- which is what I will assume. + parseOct ('\128':xs) = return (readBytes xs) + parseOct ('\255':xs) = return (negate (readBytes xs)) parseOct s = case readOct s of [(x,[])] -> return x - _ -> fail "tar header is malformed (bad numeric encoding)" + _ -> Error HeaderBadNumericEncoding + readBytes = go 0 + where go acc [] = acc + go acc (x:xs) = go (acc * 256 + fromIntegral (ord x)) xs + getBytes :: Int64 -> Int64 -> ByteString -> ByteString getBytes off len = BS.take len . BS.drop off @@ -149,14 +194,14 @@ getString :: Int64 -> Int64 -> ByteString -> String getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0') . getBytes off len -data Partial a = Error String | Ok a +data Partial e a = Error e | Ok a -partial :: Partial a -> Either String a +partial :: Partial e a -> Either e a partial (Error msg) = Left msg partial (Ok x) = Right x -instance Monad Partial where +instance Monad (Partial e) where return = Ok Error m >>= _ = Error m Ok x >>= k = k x - fail = Error + fail = error "fail @(Partial e)" diff --git a/Codec/Archive/Tar/Types.hs b/Codec/Archive/Tar/Types.hs --- a/Codec/Archive/Tar/Types.hs +++ b/Codec/Archive/Tar/Types.hs @@ -4,6 +4,7 @@ -- Copyright : (c) 2007 Bjorn Bringert, -- 2008 Andrea Vezzosi, -- 2008-2009 Duncan Coutts +-- 2011 Max Bolingbroke -- License : BSD3 -- -- Maintainer : duncan@community.haskell.org @@ -48,6 +49,7 @@ Entries(..), mapEntries, + mapEntriesNoFail, foldEntries, unfoldEntries, @@ -410,9 +412,9 @@ -- The 'Monoid' instance lets you concatenate archives or append entries to an -- archive. -- -data Entries = Next Entry Entries - | Done - | Fail String +data Entries e = Next Entry (Entries e) + | Done + | Fail e -- | This is like the standard 'unfoldr' function on lists, but for 'Entries'. -- It includes failure as an extra possibility that the stepper function may @@ -421,7 +423,7 @@ -- It can be used to generate 'Entries' from some other type. For example it is -- used internally to lazily unfold entries from a 'ByteString'. -- -unfoldEntries :: (a -> Either String (Maybe (Entry, a))) -> a -> Entries +unfoldEntries :: (a -> Either e (Maybe (Entry, a))) -> a -> Entries e unfoldEntries f = unfold where unfold x = case f x of @@ -436,7 +438,7 @@ -- This is used to consume a sequence of entries. For example it could be used -- to scan a tarball for problems or to collect an index of the contents. -- -foldEntries :: (Entry -> a -> a) -> a -> (String -> a) -> Entries -> a +foldEntries :: (Entry -> a -> a) -> a -> (e -> a) -> Entries e -> a foldEntries next done fail' = fold where fold (Next e es) = next e (fold es) @@ -446,10 +448,18 @@ -- | This is like the standard 'map' function on lists, but for 'Entries'. It -- includes failure as a extra possible outcome of the mapping function. -- -mapEntries :: (Entry -> Either String Entry) -> Entries -> Entries +-- If your mapping function cannot fail it may be more convenient to use +-- 'mapEntriesNoFail' +mapEntries :: (Entry -> Either e' Entry) -> Entries e -> Entries (Either e e') mapEntries f = - foldEntries (\entry rest -> either Fail (flip Next rest) (f entry)) Done Fail + foldEntries (\entry rest -> either (Fail . Right) (flip Next rest) (f entry)) Done (Fail . Left) -instance Monoid Entries where +-- | Like 'mapEntries' but the mapping function itself cannot fail. +-- +mapEntriesNoFail :: (Entry -> Entry) -> Entries e -> Entries e +mapEntriesNoFail f = + foldEntries (\entry -> Next (f entry)) Done Fail + +instance Monoid (Entries e) where mempty = Done mappend a b = foldEntries Next b Fail a diff --git a/Codec/Archive/Tar/Unpack.hs b/Codec/Archive/Tar/Unpack.hs --- a/Codec/Archive/Tar/Unpack.hs +++ b/Codec/Archive/Tar/Unpack.hs @@ -24,6 +24,8 @@ ( takeDirectory ) import System.Directory ( createDirectoryIfMissing, copyFile ) +import Control.Exception + ( Exception, throwIO ) -- | Create local files and directories based on the entries of a tar archive. -- @@ -34,7 +36,7 @@ -- All other entry types are ignored, that is they are not unpacked and no -- exception is raised. -- --- If the 'Entries' ends in an error then it is raised an an IO error. Any +-- If the 'Entries' ends in an error then it is raised an an exception. Any -- files or directories that have been unpacked before the error was -- encountered will not be deleted. For this reason you may want to unpack -- into an empty directory so that you can easily clean up if unpacking fails @@ -49,7 +51,7 @@ -- If you care about the priority of the reported errors then you may want to -- use 'checkSecurity' before 'checkTarbomb' or other checks. -- -unpack :: FilePath -> Entries -> IO () +unpack :: Exception e => FilePath -> Entries e -> IO () unpack baseDir entries = unpackEntries [] (checkSecurity entries) >>= emulateLinks @@ -57,7 +59,7 @@ -- We're relying here on 'checkSecurity' to make sure we're not scribbling -- files all over the place. - unpackEntries _ (Fail err) = fail err + unpackEntries _ (Fail err) = either throwIO throwIO err unpackEntries links Done = return links unpackEntries links (Next entry es) = case entryContent entry of NormalFile file _ -> extractFile path file diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,6 @@ -Copyright (c) 2007, Björn Bringert - 2008-2009 Duncan Coutts +Copyright (c) 2007 Björn Bringert, + 2008-2012 Duncan Coutts, + 2011 Max Bolingbroke All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/tar.cabal b/tar.cabal --- a/tar.cabal +++ b/tar.cabal @@ -1,5 +1,5 @@ name: tar -version: 0.3.2.0 +version: 0.4.0.0 license: BSD3 license-file: LICENSE author: Bjorn Bringert @@ -39,4 +39,7 @@ Codec.Archive.Tar.Pack Codec.Archive.Tar.Unpack - ghc-options: -Wall + extensions: + DeriveDataTypeable + + ghc-options: -Wall -fno-warn-unused-imports