{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Codec.Archive.Tar.Check.Internal
-- 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.Internal (

  -- * Security
  checkSecurity,
  checkEntrySecurity,
  FileNameError(..),

  -- * Tarbombs
  checkTarbomb,
  checkEntryTarbomb,
  TarBombError(..),

  -- * Portability
  checkPortability,
  checkEntryPortability,
  PortabilityError(..),
  PortabilityPlatform,
  ) where

import Codec.Archive.Tar.LongNames
import Codec.Archive.Tar.Types
import Control.Applicative ((<|>))
import qualified Data.ByteString.Lazy.Char8 as Char8
import Data.Maybe (fromMaybe)
import Data.Typeable (Typeable)
import Control.Exception (Exception(..))
import qualified System.FilePath as FilePath.Native
         ( splitDirectories, isAbsolute, isValid, (</>), takeDirectory, hasDrive )

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 refer outside of the archive
--
-- * 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.
--
-- Whenever possible, consider fusing 'Codec.Archive.Tar.Check.checkSecurity'
-- with packing / unpacking by using
-- 'Codec.Archive.Tar.packAndCheck' / 'Codec.Archive.Tar.unpackAndCheck'
-- with 'Codec.Archive.Tar.Check.checkEntrySecurity'.
-- Not only it is faster, but also alleviates issues with lazy I/O
-- such as exhaustion of file handlers.
checkSecurity
  :: Entries e
  -> GenEntries FilePath FilePath (Either (Either e DecodeLongNamesError) FileNameError)
checkSecurity :: forall e.
Entries e
-> GenEntries
     FilePath
     FilePath
     (Either (Either e DecodeLongNamesError) FileNameError)
checkSecurity = (GenEntry FilePath FilePath -> Maybe FileNameError)
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> GenEntries
     FilePath
     FilePath
     (Either (Either e DecodeLongNamesError) FileNameError)
forall tarPath linkTarget e' e.
(GenEntry tarPath linkTarget -> Maybe e')
-> GenEntries tarPath linkTarget e
-> GenEntries tarPath linkTarget (Either e e')
checkEntries GenEntry FilePath FilePath -> Maybe FileNameError
checkEntrySecurity (GenEntries FilePath FilePath (Either e DecodeLongNamesError)
 -> GenEntries
      FilePath
      FilePath
      (Either (Either e DecodeLongNamesError) FileNameError))
-> (Entries e
    -> GenEntries FilePath FilePath (Either e DecodeLongNamesError))
-> Entries e
-> GenEntries
     FilePath
     FilePath
     (Either (Either e DecodeLongNamesError) FileNameError)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entries e
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
forall e.
Entries e
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
decodeLongNames

-- | Worker of 'Codec.Archive.Tar.Check.checkSecurity'.
--
-- @since 0.6.0.0
checkEntrySecurity :: GenEntry FilePath FilePath -> Maybe FileNameError
checkEntrySecurity :: GenEntry FilePath FilePath -> Maybe FileNameError
checkEntrySecurity GenEntry FilePath FilePath
e =
  FilePath -> Maybe FileNameError
check (GenEntry FilePath FilePath -> FilePath
forall tarPath linkTarget. GenEntry tarPath linkTarget -> tarPath
entryTarPath GenEntry FilePath FilePath
e) Maybe FileNameError -> Maybe FileNameError -> Maybe FileNameError
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  case GenEntry FilePath FilePath -> GenEntryContent FilePath
forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
entryContent GenEntry FilePath FilePath
e of
    HardLink     FilePath
link ->
      FilePath -> Maybe FileNameError
check FilePath
link
    SymbolicLink FilePath
link ->
      FilePath -> Maybe FileNameError
check (FilePath -> FilePath
FilePath.Posix.takeDirectory (GenEntry FilePath FilePath -> FilePath
forall tarPath linkTarget. GenEntry tarPath linkTarget -> tarPath
entryTarPath GenEntry FilePath FilePath
e) FilePath -> FilePath -> FilePath
FilePath.Posix.</> FilePath
link)
    GenEntryContent FilePath
_ -> Maybe FileNameError
forall a. Maybe a
Nothing
  where
    checkPosix :: FilePath -> Maybe FileNameError
checkPosix FilePath
name
      | FilePath -> Bool
FilePath.Posix.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.Posix.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
      | Bool -> Bool
not ([FilePath] -> Bool
isInsideBaseDir (FilePath -> [FilePath]
FilePath.Posix.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
UnsafeLinkTarget FilePath
name
      | Bool
otherwise = Maybe FileNameError
forall a. Maybe a
Nothing

    checkNative :: FilePath -> Maybe FileNameError
checkNative (FilePath -> FilePath
fromFilePathToNative -> FilePath
name)
      | FilePath -> Bool
FilePath.Native.isAbsolute FilePath
name Bool -> Bool -> Bool
|| FilePath -> Bool
FilePath.Native.hasDrive 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
      | Bool -> Bool
not ([FilePath] -> Bool
isInsideBaseDir (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
UnsafeLinkTarget FilePath
name
      | Bool
otherwise = Maybe FileNameError
forall a. Maybe a
Nothing

    check :: FilePath -> Maybe FileNameError
check FilePath
name = FilePath -> Maybe FileNameError
checkPosix FilePath
name Maybe FileNameError -> Maybe FileNameError -> Maybe FileNameError
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FilePath -> Maybe FileNameError
checkNative (FilePath -> FilePath
fromFilePathToNative FilePath
name)

isInsideBaseDir :: [FilePath] -> Bool
isInsideBaseDir :: [FilePath] -> Bool
isInsideBaseDir = Word -> [FilePath] -> Bool
go Word
0
  where
    go :: Word -> [FilePath] -> Bool
    go :: Word -> [FilePath] -> Bool
go !Word
_ [] = Bool
True
    go Word
0 (FilePath
".." : [FilePath]
_) = Bool
False
    go Word
lvl (FilePath
".." : [FilePath]
xs) = Word -> [FilePath] -> Bool
go (Word
lvl Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
1) [FilePath]
xs
    go Word
lvl (FilePath
"." : [FilePath]
xs) = Word -> [FilePath] -> Bool
go Word
lvl [FilePath]
xs
    go Word
lvl (FilePath
_ : [FilePath]
xs) = Word -> [FilePath] -> Bool
go (Word
lvl Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1) [FilePath]
xs

-- | Errors arising from tar file names being in some way invalid or dangerous
data FileNameError
  = InvalidFileName FilePath
  | AbsoluteFileName FilePath
  | UnsafeLinkTarget FilePath
  -- ^ @since 0.6.0.0
  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 -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
plat FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" file name in tar archive: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
path
    AbsoluteFileName FilePath
path -> FilePath
"Absolute" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
plat FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" file name in tar archive: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
path
    UnsafeLinkTarget FilePath
path -> FilePath
"Unsafe"   FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
plat FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" link target in tar archive: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
path
  where plat :: FilePath
plat = FilePath -> (FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" (Char
' 'Char -> FilePath -> FilePath
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 'Codec.Archive.Tar.Check.checkSecurity'
-- (or 'Codec.Archive.Tar.Check.checkPortability').
--
-- Whenever possible, consider fusing 'Codec.Archive.Tar.Check.checkTarbomb'
-- with packing / unpacking by using
-- 'Codec.Archive.Tar.packAndCheck' / 'Codec.Archive.Tar.unpackAndCheck'
-- with 'Codec.Archive.Tar.Check.checkEntryTarbomb'.
-- Not only it is faster, but also alleviates issues with lazy I/O
-- such as exhaustion of file handlers.
checkTarbomb
  :: FilePath
  -> Entries e
  -> GenEntries FilePath FilePath (Either (Either e DecodeLongNamesError) TarBombError)
checkTarbomb :: forall e.
FilePath
-> Entries e
-> GenEntries
     FilePath
     FilePath
     (Either (Either e DecodeLongNamesError) TarBombError)
checkTarbomb FilePath
expectedTopDir
  = (GenEntry FilePath FilePath -> Maybe TarBombError)
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> GenEntries
     FilePath
     FilePath
     (Either (Either e DecodeLongNamesError) TarBombError)
forall tarPath linkTarget e' e.
(GenEntry tarPath linkTarget -> Maybe e')
-> GenEntries tarPath linkTarget e
-> GenEntries tarPath linkTarget (Either e e')
checkEntries (FilePath -> GenEntry FilePath FilePath -> Maybe TarBombError
forall linkTarget.
FilePath -> GenEntry FilePath linkTarget -> Maybe TarBombError
checkEntryTarbomb FilePath
expectedTopDir)
  (GenEntries FilePath FilePath (Either e DecodeLongNamesError)
 -> GenEntries
      FilePath
      FilePath
      (Either (Either e DecodeLongNamesError) TarBombError))
-> (Entries e
    -> GenEntries FilePath FilePath (Either e DecodeLongNamesError))
-> Entries e
-> GenEntries
     FilePath
     FilePath
     (Either (Either e DecodeLongNamesError) TarBombError)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entries e
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
forall e.
Entries e
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
decodeLongNames

-- | Worker of 'checkTarbomb'.
--
-- @since 0.6.0.0
checkEntryTarbomb :: FilePath -> GenEntry FilePath linkTarget -> Maybe TarBombError
checkEntryTarbomb :: forall linkTarget.
FilePath -> GenEntry FilePath linkTarget -> Maybe TarBombError
checkEntryTarbomb FilePath
expectedTopDir GenEntry FilePath linkTarget
entry = do
  case GenEntry FilePath linkTarget -> GenEntryContent linkTarget
forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
entryContent GenEntry FilePath linkTarget
entry of
    -- Global extended header aka XGLTYPE aka pax_global_header
    -- https://pubs.opengroup.org/onlinepubs/9699919799/utilities/pax.html#tag_20_92_13_02
    OtherEntryType Char
'g' ByteString
_ FileSize
_ -> Maybe TarBombError
forall a. Maybe a
Nothing
    -- Extended header referring to the next file in the archive aka XHDTYPE
    OtherEntryType Char
'x' ByteString
_ FileSize
_ -> Maybe TarBombError
forall a. Maybe a
Nothing
    GenEntryContent linkTarget
_                      ->
      case FilePath -> [FilePath]
FilePath.Posix.splitDirectories (GenEntry FilePath linkTarget -> FilePath
forall tarPath linkTarget. GenEntry tarPath linkTarget -> tarPath
entryTarPath GenEntry FilePath linkTarget
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 -> FilePath -> TarBombError
TarBombError FilePath
expectedTopDir (GenEntry FilePath linkTarget -> FilePath
forall tarPath linkTarget. GenEntry tarPath linkTarget -> tarPath
entryTarPath GenEntry FilePath linkTarget
entry)

-- | 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 -- ^ Path inside archive.
             --
             -- @since 0.6.0.0
    FilePath -- ^ Expected top directory.
  deriving (Typeable)

instance Exception TarBombError

instance Show TarBombError where
  show :: TarBombError -> FilePath
show (TarBombError FilePath
expectedTopDir FilePath
tarBombPath)
    = FilePath
"File in tar archive, " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
tarBombPath FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
    FilePath
", is not in the expected directory " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
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.
--
-- Whenever possible, consider fusing 'checkPortability' with packing / unpacking by using
-- 'Codec.Archive.Tar.packAndCheck' / 'Codec.Archive.Tar.unpackAndCheck'
-- with 'checkEntryPortability'.
-- Not only it is faster, but also alleviates issues with lazy I/O
-- such as exhaustion of file handlers.
checkPortability
  :: Entries e
  -> GenEntries FilePath FilePath (Either (Either e DecodeLongNamesError) PortabilityError)
checkPortability :: forall e.
Entries e
-> GenEntries
     FilePath
     FilePath
     (Either (Either e DecodeLongNamesError) PortabilityError)
checkPortability = (GenEntry FilePath FilePath -> Maybe PortabilityError)
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> GenEntries
     FilePath
     FilePath
     (Either (Either e DecodeLongNamesError) PortabilityError)
forall tarPath linkTarget e' e.
(GenEntry tarPath linkTarget -> Maybe e')
-> GenEntries tarPath linkTarget e
-> GenEntries tarPath linkTarget (Either e e')
checkEntries GenEntry FilePath FilePath -> Maybe PortabilityError
forall linkTarget.
GenEntry FilePath linkTarget -> Maybe PortabilityError
checkEntryPortability (GenEntries FilePath FilePath (Either e DecodeLongNamesError)
 -> GenEntries
      FilePath
      FilePath
      (Either (Either e DecodeLongNamesError) PortabilityError))
-> (Entries e
    -> GenEntries FilePath FilePath (Either e DecodeLongNamesError))
-> Entries e
-> GenEntries
     FilePath
     FilePath
     (Either (Either e DecodeLongNamesError) PortabilityError)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entries e
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
forall e.
Entries e
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
decodeLongNames

-- | Worker of 'checkPortability'.
--
-- @since 0.6.0.0
checkEntryPortability :: GenEntry FilePath linkTarget -> Maybe PortabilityError
checkEntryPortability :: forall linkTarget.
GenEntry FilePath linkTarget -> Maybe PortabilityError
checkEntryPortability GenEntry FilePath linkTarget
entry
  | GenEntry FilePath linkTarget -> Format
forall tarPath linkTarget. GenEntry tarPath linkTarget -> Format
entryFormat GenEntry FilePath linkTarget
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 (GenEntry FilePath linkTarget -> Format
forall tarPath linkTarget. GenEntry tarPath linkTarget -> Format
entryFormat GenEntry FilePath linkTarget
entry)

  | Bool -> Bool
not (GenEntryContent linkTarget -> Bool
forall {linkTarget}. GenEntryContent linkTarget -> Bool
portableFileType (GenEntry FilePath linkTarget -> GenEntryContent linkTarget
forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
entryContent GenEntry FilePath linkTarget
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
    posixPath :: FilePath
posixPath   = GenEntry FilePath linkTarget -> FilePath
forall tarPath linkTarget. GenEntry tarPath linkTarget -> tarPath
entryTarPath GenEntry FilePath linkTarget
entry
    windowsPath :: FilePath
windowsPath = FilePath -> FilePath
fromFilePathToWindowsPath FilePath
posixPath

    portableFileType :: GenEntryContent linkTarget -> Bool
portableFileType GenEntryContent linkTarget
ftype = case GenEntryContent linkTarget
ftype of
      NormalFile   {} -> Bool
True
      HardLink     {} -> Bool
True
      SymbolicLink {} -> Bool
True
      GenEntryContent linkTarget
Directory       -> Bool
True
      GenEntryContent linkTarget
_               -> 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 -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
fmt FilePath -> FilePath -> FilePath
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 -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
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
  :: (GenEntry tarPath linkTarget -> Maybe e')
  -> GenEntries tarPath linkTarget e
  -> GenEntries tarPath linkTarget (Either e e')
checkEntries :: forall tarPath linkTarget e' e.
(GenEntry tarPath linkTarget -> Maybe e')
-> GenEntries tarPath linkTarget e
-> GenEntries tarPath linkTarget (Either e e')
checkEntries GenEntry tarPath linkTarget -> Maybe e'
checkEntry =
  (GenEntry tarPath linkTarget
 -> Either e' (GenEntry tarPath linkTarget))
-> GenEntries tarPath linkTarget e
-> GenEntries tarPath linkTarget (Either e e')
forall tarPath linkTarget e' e.
(GenEntry tarPath linkTarget
 -> Either e' (GenEntry tarPath linkTarget))
-> GenEntries tarPath linkTarget e
-> GenEntries tarPath linkTarget (Either e e')
mapEntries (\GenEntry tarPath linkTarget
entry -> Either e' (GenEntry tarPath linkTarget)
-> (e' -> Either e' (GenEntry tarPath linkTarget))
-> Maybe e'
-> Either e' (GenEntry tarPath linkTarget)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (GenEntry tarPath linkTarget
-> Either e' (GenEntry tarPath linkTarget)
forall a b. b -> Either a b
Right GenEntry tarPath linkTarget
entry) e' -> Either e' (GenEntry tarPath linkTarget)
forall a b. a -> Either a b
Left (GenEntry tarPath linkTarget -> Maybe e'
checkEntry GenEntry tarPath linkTarget
entry))