{-# 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
     [Char]
     [Char]
     (Either (Either e DecodeLongNamesError) FileNameError)
checkSecurity = (GenEntry [Char] [Char] -> Maybe FileNameError)
-> GenEntries [Char] [Char] (Either e DecodeLongNamesError)
-> GenEntries
     [Char]
     [Char]
     (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 [Char] [Char] -> Maybe FileNameError
checkEntrySecurity (GenEntries [Char] [Char] (Either e DecodeLongNamesError)
 -> GenEntries
      [Char]
      [Char]
      (Either (Either e DecodeLongNamesError) FileNameError))
-> (GenEntries TarPath LinkTarget e
    -> GenEntries [Char] [Char] (Either e DecodeLongNamesError))
-> GenEntries TarPath LinkTarget e
-> GenEntries
     [Char]
     [Char]
     (Either (Either e DecodeLongNamesError) FileNameError)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenEntries TarPath LinkTarget e
-> GenEntries [Char] [Char] (Either e DecodeLongNamesError)
forall e.
Entries e
-> GenEntries [Char] [Char] (Either e DecodeLongNamesError)
decodeLongNames

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

    checkNative :: [Char] -> Maybe FileNameError
checkNative ([Char] -> [Char]
fromFilePathToNative -> [Char]
name)
      | [Char] -> Bool
FilePath.Native.isAbsolute [Char]
name Bool -> Bool -> Bool
|| [Char] -> Bool
FilePath.Native.hasDrive [Char]
name
      = FileNameError -> Maybe FileNameError
forall a. a -> Maybe a
Just (FileNameError -> Maybe FileNameError)
-> FileNameError -> Maybe FileNameError
forall a b. (a -> b) -> a -> b
$ [Char] -> FileNameError
AbsoluteFileName [Char]
name
      | Bool -> Bool
not ([Char] -> Bool
FilePath.Native.isValid [Char]
name)
      = FileNameError -> Maybe FileNameError
forall a. a -> Maybe a
Just (FileNameError -> Maybe FileNameError)
-> FileNameError -> Maybe FileNameError
forall a b. (a -> b) -> a -> b
$ [Char] -> FileNameError
InvalidFileName [Char]
name
      | Bool -> Bool
not ([[Char]] -> Bool
isInsideBaseDir ([Char] -> [[Char]]
FilePath.Native.splitDirectories [Char]
name))
      = FileNameError -> Maybe FileNameError
forall a. a -> Maybe a
Just (FileNameError -> Maybe FileNameError)
-> FileNameError -> Maybe FileNameError
forall a b. (a -> b) -> a -> b
$ [Char] -> FileNameError
UnsafeLinkTarget [Char]
name
      | Bool
otherwise = Maybe FileNameError
forall a. Maybe a
Nothing

    check :: [Char] -> Maybe FileNameError
check [Char]
name = [Char] -> Maybe FileNameError
checkPosix [Char]
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
<|> [Char] -> Maybe FileNameError
checkNative ([Char] -> [Char]
fromFilePathToNative [Char]
name)

isInsideBaseDir :: [FilePath] -> Bool
isInsideBaseDir :: [[Char]] -> Bool
isInsideBaseDir = Word -> [[Char]] -> Bool
go Word
0
  where
    go :: Word -> [FilePath] -> Bool
    go :: Word -> [[Char]] -> Bool
go !Word
_ [] = Bool
True
    go Word
0 ([Char]
".." : [[Char]]
_) = Bool
False
    go Word
lvl ([Char]
".." : [[Char]]
xs) = Word -> [[Char]] -> Bool
go (Word
lvl Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
1) [[Char]]
xs
    go Word
lvl ([Char]
"." : [[Char]]
xs) = Word -> [[Char]] -> Bool
go Word
lvl [[Char]]
xs
    go Word
lvl ([Char]
_ : [[Char]]
xs) = Word -> [[Char]] -> Bool
go (Word
lvl Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1) [[Char]]
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 -> [Char]
show = Maybe [Char] -> FileNameError -> [Char]
showFileNameError Maybe [Char]
forall a. Maybe a
Nothing

instance Exception FileNameError

showFileNameError :: Maybe PortabilityPlatform -> FileNameError -> String
showFileNameError :: Maybe [Char] -> FileNameError -> [Char]
showFileNameError Maybe [Char]
mb_plat FileNameError
err = case FileNameError
err of
    InvalidFileName  [Char]
path -> [Char]
"Invalid"  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
plat [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" file name in tar archive: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
path
    AbsoluteFileName [Char]
path -> [Char]
"Absolute" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
plat [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" file name in tar archive: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
path
    UnsafeLinkTarget [Char]
path -> [Char]
"Unsafe"   [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
plat [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" link target in tar archive: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
path
  where plat :: [Char]
plat = [Char] -> ([Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (Char
' 'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:) Maybe [Char]
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.
[Char]
-> Entries e
-> GenEntries
     [Char] [Char] (Either (Either e DecodeLongNamesError) TarBombError)
checkTarbomb [Char]
expectedTopDir
  = (GenEntry [Char] [Char] -> Maybe TarBombError)
-> GenEntries [Char] [Char] (Either e DecodeLongNamesError)
-> GenEntries
     [Char] [Char] (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 ([Char] -> GenEntry [Char] [Char] -> Maybe TarBombError
forall linkTarget.
[Char] -> GenEntry [Char] linkTarget -> Maybe TarBombError
checkEntryTarbomb [Char]
expectedTopDir)
  (GenEntries [Char] [Char] (Either e DecodeLongNamesError)
 -> GenEntries
      [Char]
      [Char]
      (Either (Either e DecodeLongNamesError) TarBombError))
-> (GenEntries TarPath LinkTarget e
    -> GenEntries [Char] [Char] (Either e DecodeLongNamesError))
-> GenEntries TarPath LinkTarget e
-> GenEntries
     [Char] [Char] (Either (Either e DecodeLongNamesError) TarBombError)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenEntries TarPath LinkTarget e
-> GenEntries [Char] [Char] (Either e DecodeLongNamesError)
forall e.
Entries e
-> GenEntries [Char] [Char] (Either e DecodeLongNamesError)
decodeLongNames

-- | Worker of 'checkTarbomb'.
--
-- @since 0.6.0.0
checkEntryTarbomb :: FilePath -> GenEntry FilePath linkTarget -> Maybe TarBombError
checkEntryTarbomb :: forall linkTarget.
[Char] -> GenEntry [Char] linkTarget -> Maybe TarBombError
checkEntryTarbomb [Char]
expectedTopDir GenEntry [Char] linkTarget
entry = do
  case GenEntry [Char] linkTarget -> GenEntryContent linkTarget
forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
entryContent GenEntry [Char] 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 [Char] -> [[Char]]
FilePath.Posix.splitDirectories (GenEntry [Char] linkTarget -> [Char]
forall tarPath linkTarget. GenEntry tarPath linkTarget -> tarPath
entryTarPath GenEntry [Char] linkTarget
entry) of
        ([Char]
topDir:[[Char]]
_) | [Char]
topDir [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
expectedTopDir -> Maybe TarBombError
forall a. Maybe a
Nothing
        [[Char]]
_ -> TarBombError -> Maybe TarBombError
forall a. a -> Maybe a
Just (TarBombError -> Maybe TarBombError)
-> TarBombError -> Maybe TarBombError
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> TarBombError
TarBombError [Char]
expectedTopDir (GenEntry [Char] linkTarget -> [Char]
forall tarPath linkTarget. GenEntry tarPath linkTarget -> tarPath
entryTarPath GenEntry [Char] 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 -> [Char]
show (TarBombError [Char]
expectedTopDir [Char]
tarBombPath)
    = [Char]
"File in tar archive, " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
tarBombPath [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
    [Char]
", is not in the expected directory " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
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
     [Char]
     [Char]
     (Either (Either e DecodeLongNamesError) PortabilityError)
checkPortability = (GenEntry [Char] [Char] -> Maybe PortabilityError)
-> GenEntries [Char] [Char] (Either e DecodeLongNamesError)
-> GenEntries
     [Char]
     [Char]
     (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 [Char] [Char] -> Maybe PortabilityError
forall linkTarget.
GenEntry [Char] linkTarget -> Maybe PortabilityError
checkEntryPortability (GenEntries [Char] [Char] (Either e DecodeLongNamesError)
 -> GenEntries
      [Char]
      [Char]
      (Either (Either e DecodeLongNamesError) PortabilityError))
-> (GenEntries TarPath LinkTarget e
    -> GenEntries [Char] [Char] (Either e DecodeLongNamesError))
-> GenEntries TarPath LinkTarget e
-> GenEntries
     [Char]
     [Char]
     (Either (Either e DecodeLongNamesError) PortabilityError)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenEntries TarPath LinkTarget e
-> GenEntries [Char] [Char] (Either e DecodeLongNamesError)
forall e.
Entries e
-> GenEntries [Char] [Char] (Either e DecodeLongNamesError)
decodeLongNames

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

  | Bool -> Bool
not (GenEntryContent linkTarget -> Bool
forall {linkTarget}. GenEntryContent linkTarget -> Bool
portableFileType (GenEntry [Char] linkTarget -> GenEntryContent linkTarget
forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
entryContent GenEntry [Char] linkTarget
entry))
  = PortabilityError -> Maybe PortabilityError
forall a. a -> Maybe a
Just PortabilityError
NonPortableFileType

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

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

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

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

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

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