{-# LANGUAGE DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Codec.Archive.Tar
-- Copyright   :  (c) 2008-2012 Duncan Coutts
--                    2011 Max Bolingbroke
-- License     :  BSD3
--
-- Maintainer  :  duncan@community.haskell.org
-- Portability :  portable
--
-- Perform various checks on tar file entries.
--
-----------------------------------------------------------------------------
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 )

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:
--
-- * file paths are not absolute
--
-- * file paths do not contain any path components that are \"@..@\"
--
-- * file names are valid
--
-- These checks are from the perspective of the current OS. That means we check
-- for \"@C:\blah@\" files on Windows and \"\/blah\" files on Unix. For archive
-- entry types 'HardLink' and 'SymbolicLink' the same checks are done for the
-- link target. A failure in any entry terminates the sequence of entries with
-- an error.
--
checkSecurity :: Entries e -> Entries (Either e FileNameError)
checkSecurity :: Entries e -> Entries (Either e FileNameError)
checkSecurity = (Entry -> Maybe FileNameError)
-> Entries e -> Entries (Either e FileNameError)
forall e' e.
(Entry -> Maybe e') -> Entries e -> Entries (Either e e')
checkEntries Entry -> Maybe FileNameError
checkEntrySecurity

checkEntrySecurity :: Entry -> Maybe FileNameError
checkEntrySecurity :: Entry -> Maybe FileNameError
checkEntrySecurity Entry
entry = case Entry -> EntryContent
entryContent Entry
entry of
    HardLink     LinkTarget
link -> FilePath -> Maybe FileNameError
check (Entry -> FilePath
entryPath Entry
entry)
                 Maybe FileNameError -> Maybe FileNameError -> Maybe FileNameError
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` FilePath -> Maybe FileNameError
check (LinkTarget -> FilePath
fromLinkTarget LinkTarget
link)
    SymbolicLink LinkTarget
link -> FilePath -> Maybe FileNameError
check (Entry -> FilePath
entryPath Entry
entry)
                 Maybe FileNameError -> Maybe FileNameError -> Maybe FileNameError
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` FilePath -> Maybe FileNameError
check (LinkTarget -> FilePath
fromLinkTarget LinkTarget
link)
    EntryContent
_                 -> FilePath -> Maybe FileNameError
check (Entry -> FilePath
entryPath Entry
entry)

  where
    check :: FilePath -> Maybe FileNameError
check FilePath
name
      | FilePath -> Bool
FilePath.Native.isAbsolute FilePath
name
      = FileNameError -> Maybe FileNameError
forall a. a -> Maybe a
Just (FileNameError -> Maybe FileNameError)
-> FileNameError -> Maybe FileNameError
forall a b. (a -> b) -> a -> b
$ FilePath -> FileNameError
AbsoluteFileName FilePath
name

      | Bool -> Bool
not (FilePath -> Bool
FilePath.Native.isValid FilePath
name)
      = FileNameError -> Maybe FileNameError
forall a. a -> Maybe a
Just (FileNameError -> Maybe FileNameError)
-> FileNameError -> Maybe FileNameError
forall a b. (a -> b) -> a -> b
$ FilePath -> FileNameError
InvalidFileName FilePath
name

      | (FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
==FilePath
"..") (FilePath -> [FilePath]
FilePath.Native.splitDirectories FilePath
name)
      = FileNameError -> Maybe FileNameError
forall a. a -> Maybe a
Just (FileNameError -> Maybe FileNameError)
-> FileNameError -> Maybe FileNameError
forall a b. (a -> b) -> a -> b
$ FilePath -> FileNameError
InvalidFileName FilePath
name

      | Bool
otherwise = Maybe FileNameError
forall a. Maybe a
Nothing

-- | 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 :: FileNameError -> FilePath
show = Maybe FilePath -> FileNameError -> FilePath
showFileNameError Maybe FilePath
forall a. Maybe a
Nothing

instance Exception FileNameError

showFileNameError :: Maybe PortabilityPlatform -> FileNameError -> String
showFileNameError :: Maybe FilePath -> FileNameError -> FilePath
showFileNameError Maybe FilePath
mb_plat FileNameError
err = case FileNameError
err of
    InvalidFileName  FilePath
path -> FilePath
"Invalid"  FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
plat FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" file name in tar archive: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> FilePath
show FilePath
path
    AbsoluteFileName FilePath
path -> FilePath
"Absolute" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
plat FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" file name in tar archive: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> FilePath
show FilePath
path
  where plat :: FilePath
plat = FilePath -> ShowS -> Maybe FilePath -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" (Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) Maybe FilePath
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'
-- (or 'checkPortability').
--
checkTarbomb :: FilePath -> Entries e -> Entries (Either e TarBombError)
checkTarbomb :: FilePath -> Entries e -> Entries (Either e TarBombError)
checkTarbomb FilePath
expectedTopDir = (Entry -> Maybe TarBombError)
-> Entries e -> Entries (Either e TarBombError)
forall e' e.
(Entry -> Maybe e') -> Entries e -> Entries (Either e e')
checkEntries (FilePath -> Entry -> Maybe TarBombError
checkEntryTarbomb FilePath
expectedTopDir)

checkEntryTarbomb :: FilePath -> Entry -> Maybe TarBombError
checkEntryTarbomb :: FilePath -> Entry -> Maybe TarBombError
checkEntryTarbomb FilePath
_ Entry
entry | Bool
nonFilesystemEntry = Maybe TarBombError
forall a. Maybe a
Nothing
  where
    -- Ignore some special entries we will not unpack anyway
    nonFilesystemEntry :: Bool
nonFilesystemEntry =
      case Entry -> EntryContent
entryContent Entry
entry of
        OtherEntryType Char
'g' ByteString
_ FileSize
_ -> Bool
True --PAX global header
        OtherEntryType Char
'x' ByteString
_ FileSize
_ -> Bool
True --PAX individual header
        EntryContent
_                      -> Bool
False

checkEntryTarbomb FilePath
expectedTopDir Entry
entry =
  case FilePath -> [FilePath]
FilePath.Native.splitDirectories (Entry -> FilePath
entryPath Entry
entry) of
    (FilePath
topDir:[FilePath]
_) | FilePath
topDir FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
expectedTopDir -> Maybe TarBombError
forall a. Maybe a
Nothing
    [FilePath]
_ -> TarBombError -> Maybe TarBombError
forall a. a -> Maybe a
Just (TarBombError -> Maybe TarBombError)
-> TarBombError -> Maybe TarBombError
forall a b. (a -> b) -> a -> b
$ FilePath -> TarBombError
TarBombError FilePath
expectedTopDir

-- | 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)

instance Exception TarBombError

instance Show TarBombError where
  show :: TarBombError -> FilePath
show (TarBombError FilePath
expectedTopDir)
    = FilePath
"File in tar archive is not in the expected directory " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> FilePath
show FilePath
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 :: Entries e -> Entries (Either e PortabilityError)
checkPortability = (Entry -> Maybe PortabilityError)
-> Entries e -> Entries (Either e PortabilityError)
forall e' e.
(Entry -> Maybe e') -> Entries e -> Entries (Either e e')
checkEntries Entry -> Maybe PortabilityError
checkEntryPortability

checkEntryPortability :: Entry -> Maybe PortabilityError
checkEntryPortability :: Entry -> Maybe PortabilityError
checkEntryPortability Entry
entry
  | Entry -> Format
entryFormat Entry
entry Format -> [Format] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Format
V7Format, Format
GnuFormat]
  = PortabilityError -> Maybe PortabilityError
forall a. a -> Maybe a
Just (PortabilityError -> Maybe PortabilityError)
-> PortabilityError -> Maybe PortabilityError
forall a b. (a -> b) -> a -> b
$ Format -> PortabilityError
NonPortableFormat (Entry -> Format
entryFormat Entry
entry)

  | Bool -> Bool
not (EntryContent -> Bool
portableFileType (Entry -> EntryContent
entryContent Entry
entry))
  = PortabilityError -> Maybe PortabilityError
forall a. a -> Maybe a
Just PortabilityError
NonPortableFileType

  | Bool -> Bool
not ((Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
portableChar FilePath
posixPath)
  = PortabilityError -> Maybe PortabilityError
forall a. a -> Maybe a
Just (PortabilityError -> Maybe PortabilityError)
-> PortabilityError -> Maybe PortabilityError
forall a b. (a -> b) -> a -> b
$ FilePath -> PortabilityError
NonPortableEntryNameChar FilePath
posixPath

  | Bool -> Bool
not (FilePath -> Bool
FilePath.Posix.isValid FilePath
posixPath)
  = PortabilityError -> Maybe PortabilityError
forall a. a -> Maybe a
Just (PortabilityError -> Maybe PortabilityError)
-> PortabilityError -> Maybe PortabilityError
forall a b. (a -> b) -> a -> b
$ FilePath -> FileNameError -> PortabilityError
NonPortableFileName FilePath
"unix"    (FilePath -> FileNameError
InvalidFileName FilePath
posixPath)
  | Bool -> Bool
not (FilePath -> Bool
FilePath.Windows.isValid FilePath
windowsPath)
  = PortabilityError -> Maybe PortabilityError
forall a. a -> Maybe a
Just (PortabilityError -> Maybe PortabilityError)
-> PortabilityError -> Maybe PortabilityError
forall a b. (a -> b) -> a -> b
$ FilePath -> FileNameError -> PortabilityError
NonPortableFileName FilePath
"windows" (FilePath -> FileNameError
InvalidFileName FilePath
windowsPath)

  | FilePath -> Bool
FilePath.Posix.isAbsolute FilePath
posixPath
  = PortabilityError -> Maybe PortabilityError
forall a. a -> Maybe a
Just (PortabilityError -> Maybe PortabilityError)
-> PortabilityError -> Maybe PortabilityError
forall a b. (a -> b) -> a -> b
$ FilePath -> FileNameError -> PortabilityError
NonPortableFileName FilePath
"unix"    (FilePath -> FileNameError
AbsoluteFileName FilePath
posixPath)
  | FilePath -> Bool
FilePath.Windows.isAbsolute FilePath
windowsPath
  = PortabilityError -> Maybe PortabilityError
forall a. a -> Maybe a
Just (PortabilityError -> Maybe PortabilityError)
-> PortabilityError -> Maybe PortabilityError
forall a b. (a -> b) -> a -> b
$ FilePath -> FileNameError -> PortabilityError
NonPortableFileName FilePath
"windows" (FilePath -> FileNameError
AbsoluteFileName FilePath
windowsPath)

  | (FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
==FilePath
"..") (FilePath -> [FilePath]
FilePath.Posix.splitDirectories FilePath
posixPath)
  = PortabilityError -> Maybe PortabilityError
forall a. a -> Maybe a
Just (PortabilityError -> Maybe PortabilityError)
-> PortabilityError -> Maybe PortabilityError
forall a b. (a -> b) -> a -> b
$ FilePath -> FileNameError -> PortabilityError
NonPortableFileName FilePath
"unix"    (FilePath -> FileNameError
InvalidFileName FilePath
posixPath)
  | (FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
==FilePath
"..") (FilePath -> [FilePath]
FilePath.Windows.splitDirectories FilePath
windowsPath)
  = PortabilityError -> Maybe PortabilityError
forall a. a -> Maybe a
Just (PortabilityError -> Maybe PortabilityError)
-> PortabilityError -> Maybe PortabilityError
forall a b. (a -> b) -> a -> b
$ FilePath -> FileNameError -> PortabilityError
NonPortableFileName FilePath
"windows" (FilePath -> FileNameError
InvalidFileName FilePath
windowsPath)

  | Bool
otherwise = Maybe PortabilityError
forall a. Maybe a
Nothing

  where
    tarPath :: TarPath
tarPath     = Entry -> TarPath
entryTarPath Entry
entry
    posixPath :: FilePath
posixPath   = TarPath -> FilePath
fromTarPathToPosixPath   TarPath
tarPath
    windowsPath :: FilePath
windowsPath = TarPath -> FilePath
fromTarPathToWindowsPath TarPath
tarPath

    portableFileType :: EntryContent -> Bool
portableFileType EntryContent
ftype = case EntryContent
ftype of
      NormalFile   {} -> Bool
True
      HardLink     {} -> Bool
True
      SymbolicLink {} -> Bool
True
      EntryContent
Directory       -> Bool
True
      EntryContent
_               -> Bool
False

    portableChar :: Char -> Bool
portableChar Char
c = Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\127'

-- | Portability problems in a tar archive
data PortabilityError
  = NonPortableFormat Format
  | NonPortableFileType
  | NonPortableEntryNameChar FilePath
  | NonPortableFileName PortabilityPlatform FileNameError
  deriving (Typeable)

-- | The name of a platform that portability issues arise from
type PortabilityPlatform = String

instance Exception PortabilityError

instance Show PortabilityError where
  show :: PortabilityError -> FilePath
show (NonPortableFormat Format
format) = FilePath
"Archive is in the " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
fmt FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" format"
    where fmt :: FilePath
fmt = case Format
format of Format
V7Format    -> FilePath
"old Unix V7 tar"
                               Format
UstarFormat -> FilePath
"ustar" -- I never generate this but a user might
                               Format
GnuFormat   -> FilePath
"GNU tar"
  show PortabilityError
NonPortableFileType        = FilePath
"Non-portable file type in archive"
  show (NonPortableEntryNameChar FilePath
posixPath)
    = FilePath
"Non-portable character in archive entry name: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> FilePath
show FilePath
posixPath
  show (NonPortableFileName FilePath
platform FileNameError
err)
    = Maybe FilePath -> FileNameError -> FilePath
showFileNameError (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
platform) FileNameError
err


--------------------------
-- Utils
--

checkEntries :: (Entry -> Maybe e') -> Entries e -> Entries (Either e e')
checkEntries :: (Entry -> Maybe e') -> Entries e -> Entries (Either e e')
checkEntries Entry -> Maybe e'
checkEntry =
  (Entry -> Either e' Entry) -> Entries e -> Entries (Either e e')
forall e' e.
(Entry -> Either e' Entry) -> Entries e -> Entries (Either e e')
mapEntries (\Entry
entry -> Either e' Entry
-> (e' -> Either e' Entry) -> Maybe e' -> Either e' Entry
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Entry -> Either e' Entry
forall a b. b -> Either a b
Right Entry
entry) e' -> Either e' Entry
forall a b. a -> Either a b
Left (Entry -> Maybe e'
checkEntry Entry
entry))