    {-# 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 = (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 -> String -> Maybe FileNameError
    check (Entry -> String
    entryPath Entry
    entry)
                     Maybe FileNameError -> Maybe FileNameError -> Maybe FileNameError
    forall a. Maybe a -> Maybe a -> Maybe a
    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)
                     Maybe FileNameError -> Maybe FileNameError -> Maybe FileNameError
    forall a. Maybe a -> Maybe a -> Maybe a
    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
          = FileNameError -> Maybe FileNameError
    forall a. a -> Maybe a
    Just (FileNameError -> Maybe FileNameError)
    -> FileNameError -> Maybe FileNameError
    forall a b. (a -> b) -> a -> b
    $ String -> FileNameError
    AbsoluteFileName String
    name

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

          | (String -> Bool) -> [String] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    ==String
    "..") (String -> [String]
    FilePath.Native.splitDirectories String
    name)
          = FileNameError -> Maybe FileNameError
    forall a. a -> Maybe a
    Just (FileNameError -> Maybe FileNameError)
    -> FileNameError -> Maybe FileNameError
    forall a b. (a -> b) -> a -> b
    $ String -> FileNameError
    InvalidFileName String
    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 -> String
    show = Maybe String -> FileNameError -> String
    showFileNameError Maybe String
    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"  String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    plat String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    " file name in tar archive: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ ShowS
    forall a. Show a => a -> String
    show String
    path
        AbsoluteFileName String
    path -> String
    "Absolute" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    plat String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    " file name in tar archive: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ ShowS
    forall a. Show a => a -> String
    show String
    path
      where plat :: String
    plat = String -> ShowS -> Maybe String -> String
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe String
    "" (Char
    ' 'Char -> ShowS
    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 = (Entry -> Maybe TarBombError)
    -> Entries e -> Entries (Either e TarBombError)
    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 = 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 String
    expectedTopDir Entry
    entry =
      case String -> [String]
    FilePath.Native.splitDirectories (Entry -> String
    entryPath Entry
    entry) of
        (String
    topDir:[String]
    _) | String
    topDir String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String
    expectedTopDir -> Maybe TarBombError
    forall a. Maybe a
    Nothing
        [String]
    _ -> TarBombError -> Maybe TarBombError
    forall a. a -> Maybe a
    Just (TarBombError -> Maybe TarBombError)
    -> TarBombError -> Maybe TarBombError
    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 " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ ShowS
    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 = (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 a. Eq a => a -> [a] -> 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) -> String -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Char -> Bool
    portableChar String
    posixPath)
      = PortabilityError -> Maybe PortabilityError
    forall a. a -> Maybe a
    Just (PortabilityError -> Maybe PortabilityError)
    -> PortabilityError -> Maybe PortabilityError
    forall a b. (a -> b) -> a -> b
    $ String -> PortabilityError
    NonPortableEntryNameChar String
    posixPath

      | Bool -> Bool
    not (String -> Bool
    FilePath.Posix.isValid String
    posixPath)
      = PortabilityError -> Maybe PortabilityError
    forall a. a -> Maybe a
    Just (PortabilityError -> Maybe PortabilityError)
    -> PortabilityError -> Maybe PortabilityError
    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)
      = PortabilityError -> Maybe PortabilityError
    forall a. a -> Maybe a
    Just (PortabilityError -> Maybe PortabilityError)
    -> PortabilityError -> Maybe PortabilityError
    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
      = PortabilityError -> Maybe PortabilityError
    forall a. a -> Maybe a
    Just (PortabilityError -> Maybe PortabilityError)
    -> PortabilityError -> Maybe PortabilityError
    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
      = PortabilityError -> Maybe PortabilityError
    forall a. a -> Maybe a
    Just (PortabilityError -> Maybe PortabilityError)
    -> PortabilityError -> Maybe PortabilityError
    forall a b. (a -> b) -> a -> b
    $ String -> FileNameError -> PortabilityError
    NonPortableFileName String
    "windows" (String -> FileNameError
    AbsoluteFileName String
    windowsPath)

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

      | Bool
    otherwise = Maybe PortabilityError
    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 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 -> String
    show (NonPortableFormat Format
    format) = String
    "Archive is in the " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    fmt String -> ShowS
    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: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ ShowS
    forall a. Show a => a -> String
    show String
    posixPath
      show (NonPortableFileName String
    platform FileNameError
    err)
        = Maybe String -> FileNameError -> String
    showFileNameError (String -> Maybe String
    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 =
      (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))