{-# 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 :: 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 (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 (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
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
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
nonFilesystemEntry :: Bool
nonFilesystemEntry =
case Entry -> EntryContent
entryContent Entry
entry of
OtherEntryType Char
'g' ByteString
_ FileSize
_ -> Bool
True
OtherEntryType Char
'x' ByteString
_ FileSize
_ -> Bool
True
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
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
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 (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'
data PortabilityError
= NonPortableFormat Format
| NonPortableFileType
| NonPortableEntryNameChar FilePath
| NonPortableFileName PortabilityPlatform FileNameError
deriving (Typeable)
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"
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
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))