{-# LANGUAGE DeriveDataTypeable #-}
module Codec.Archive.Tar.Check (
checkSecurity,
FileNameError(..),
checkTarbomb,
TarBombError(..),
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
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
entry = case Entry -> EntryContent
entryContent Entry
entry of
HardLink link :: 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 link :: 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)
_ -> FilePath -> Maybe FileNameError
check (Entry -> FilePath
entryPath Entry
entry)
where
check :: FilePath -> Maybe FileNameError
check name :: 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.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
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 mb_plat :: Maybe FilePath
mb_plat err :: FileNameError
err = case FileNameError
err of
InvalidFileName path :: FilePath
path -> "Invalid" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
plat FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ " file name in tar archive: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> FilePath
show FilePath
path
AbsoluteFileName path :: FilePath
path -> "Absolute" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
plat FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ " 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 "" (' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) Maybe FilePath
mb_plat
checkTarbomb :: FilePath -> Entries e -> Entries (Either e TarBombError)
checkTarbomb :: FilePath -> Entries e -> Entries (Either e TarBombError)
checkTarbomb expectedTopDir :: 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 _ entry :: Entry
entry | Bool
nonFilesystemEntry = Maybe TarBombError
forall a. Maybe a
Nothing
where
nonFilesystemEntry :: Bool
nonFilesystemEntry =
case Entry -> EntryContent
entryContent Entry
entry of
OtherEntryType 'g' _ _ -> Bool
True
OtherEntryType 'x' _ _ -> Bool
True
_ -> Bool
False
checkEntryTarbomb expectedTopDir :: FilePath
expectedTopDir entry :: Entry
entry =
case FilePath -> [FilePath]
FilePath.Native.splitDirectories (Entry -> FilePath
entryPath Entry
entry) of
(topDir :: FilePath
topDir:_) | FilePath
topDir FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
expectedTopDir -> Maybe TarBombError
forall a. Maybe a
Nothing
_ -> 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
data TarBombError = TarBombError FilePath
deriving (Typeable)
instance Exception TarBombError
instance Show TarBombError where
show :: TarBombError -> FilePath
show (TarBombError expectedTopDir :: FilePath
expectedTopDir)
= "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
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
| 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 "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 "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 "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 "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.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 "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.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 "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 ftype :: EntryContent
ftype = case EntryContent
ftype of
NormalFile {} -> Bool
True
HardLink {} -> Bool
True
SymbolicLink {} -> Bool
True
Directory -> Bool
True
_ -> Bool
False
portableChar :: Char -> Bool
portableChar c :: Char
c = Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '\127'
data PortabilityError
= NonPortableFormat Format
| NonPortableFileType
| NonPortableEntryNameChar FilePath
| NonPortableFileName PortabilityPlatform FileNameError
deriving (Typeable)
type PortabilityPlatform = String
instance Exception PortabilityError
instance Show PortabilityError where
show :: PortabilityError -> FilePath
show (NonPortableFormat format :: Format
format) = "Archive is in the " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
fmt FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ " format"
where fmt :: FilePath
fmt = case Format
format of V7Format -> "old Unix V7 tar"
UstarFormat -> "ustar"
GnuFormat -> "GNU tar"
show NonPortableFileType = "Non-portable file type in archive"
show (NonPortableEntryNameChar posixPath :: FilePath
posixPath)
= "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 platform :: FilePath
platform err :: FileNameError
err)
= Maybe FilePath -> FileNameError -> FilePath
showFileNameError (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
platform) FileNameError
err
checkEntries :: (Entry -> Maybe e') -> Entries e -> Entries (Either e e')
checkEntries :: (Entry -> Maybe e') -> Entries e -> Entries (Either e e')
checkEntries checkEntry :: 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
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))