{-# 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 :: forall e. Entries e -> Entries (Either e FileNameError)
checkSecurity = 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 -> String -> Maybe FileNameError
check (Entry -> String
entryPath Entry
entry)
                 forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` String -> Maybe FileNameError
check (LinkTarget -> String
fromLinkTarget LinkTarget
link)
    SymbolicLink LinkTarget
link -> String -> Maybe FileNameError
check (Entry -> String
entryPath Entry
entry)
                 forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` String -> Maybe FileNameError
check (LinkTarget -> String
fromLinkTarget LinkTarget
link)
    EntryContent
_                 -> String -> Maybe FileNameError
check (Entry -> String
entryPath Entry
entry)

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

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

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

      | Bool
otherwise = 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 -> String
show = Maybe String -> FileNameError -> String
showFileNameError forall a. Maybe a
Nothing

instance Exception FileNameError

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

checkEntryTarbomb :: FilePath -> Entry -> Maybe TarBombError
checkEntryTarbomb :: String -> Entry -> Maybe TarBombError
checkEntryTarbomb String
_ Entry
entry | Bool
nonFilesystemEntry = 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 String
expectedTopDir Entry
entry =
  case String -> [String]
FilePath.Native.splitDirectories (Entry -> String
entryPath Entry
entry) of
    (String
topDir:[String]
_) | String
topDir forall a. Eq a => a -> a -> Bool
== String
expectedTopDir -> forall a. Maybe a
Nothing
    [String]
_ -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> TarBombError
TarBombError String
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 -> String
show (TarBombError String
expectedTopDir)
    = String
"File in tar archive is not in the expected directory " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
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 :: forall e. Entries e -> Entries (Either e PortabilityError)
checkPortability = 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Format
V7Format, Format
GnuFormat]
  = forall a. a -> Maybe a
Just 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))
  = forall a. a -> Maybe a
Just PortabilityError
NonPortableFileType

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

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

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

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

  | Bool
otherwise = forall a. Maybe a
Nothing

  where
    tarPath :: TarPath
tarPath     = Entry -> TarPath
entryTarPath Entry
entry
    posixPath :: String
posixPath   = TarPath -> String
fromTarPathToPosixPath   TarPath
tarPath
    windowsPath :: String
windowsPath = TarPath -> String
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 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 -> String
show (NonPortableFormat Format
format) = String
"Archive is in the " forall a. [a] -> [a] -> [a]
++ String
fmt forall a. [a] -> [a] -> [a]
++ String
" format"
    where fmt :: String
fmt = case Format
format of Format
V7Format    -> String
"old Unix V7 tar"
                               Format
UstarFormat -> String
"ustar" -- I never generate this but a user might
                               Format
GnuFormat   -> String
"GNU tar"
  show PortabilityError
NonPortableFileType        = String
"Non-portable file type in archive"
  show (NonPortableEntryNameChar String
posixPath)
    = String
"Non-portable character in archive entry name: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
posixPath
  show (NonPortableFileName String
platform FileNameError
err)
    = Maybe String -> FileNameError -> String
showFileNameError (forall a. a -> Maybe a
Just String
platform) FileNameError
err


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

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