{-# 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.Safe (Exception)
import Control.Monad (MonadPlus(mplus))
import qualified System.Posix.FilePath as FilePath.Posix
import qualified Data.ByteString as BS
import Data.Word8
checkSecurity :: Entries e -> Entries (Either e FileNameError)
checkSecurity = checkEntries checkEntrySecurity
checkEntrySecurity :: Entry -> Maybe FileNameError
checkEntrySecurity entry = case entryContent entry of
HardLink link -> check (entryPath entry)
`mplus` check (fromLinkTarget link)
SymbolicLink link -> check (entryPath entry)
`mplus` check (fromLinkTarget link)
_ -> check (entryPath entry)
where
check name
| FilePath.Posix.isAbsolute name
= Just $ AbsoluteFileName name
| not (FilePath.Posix.isValid name)
= Just $ InvalidFileName name
| any (BS.pack [_period, _period] ==) (FilePath.Posix.splitDirectories name)
= Just $ InvalidFileName name
| otherwise = Nothing
data FileNameError
= InvalidFileName RawFilePath
| AbsoluteFileName RawFilePath
deriving (Typeable)
instance Show FileNameError where
show = showFileNameError Nothing
instance Exception FileNameError
showFileNameError :: Maybe PortabilityPlatform -> FileNameError -> String
showFileNameError mb_plat err = case err of
InvalidFileName path -> "Invalid" ++ plat ++ " file name in tar archive: " ++ show path
AbsoluteFileName path -> "Absolute" ++ plat ++ " file name in tar archive: " ++ show path
where plat = maybe "" (' ':) mb_plat
checkTarbomb :: RawFilePath -> Entries e -> Entries (Either e TarBombError)
checkTarbomb expectedTopDir = checkEntries (checkEntryTarbomb expectedTopDir)
checkEntryTarbomb :: RawFilePath -> Entry -> Maybe TarBombError
checkEntryTarbomb _ entry | nonFilesystemEntry = Nothing
where
nonFilesystemEntry =
case entryContent entry of
OtherEntryType 'g' _ _ -> True
OtherEntryType 'x' _ _ -> True
_ -> False
checkEntryTarbomb expectedTopDir entry =
case FilePath.Posix.splitDirectories (entryPath entry) of
(topDir:_) | topDir == expectedTopDir -> Nothing
_ -> Just $ TarBombError expectedTopDir (entryPath entry)
data TarBombError = TarBombError RawFilePath RawFilePath
deriving (Typeable)
instance Exception TarBombError
instance Show TarBombError where
show (TarBombError expectedTopDir tarBombPath)
= "File in tar archive, " ++ show tarBombPath ++
", is not in the expected directory " ++ show expectedTopDir
checkPortability :: Entries e -> Entries (Either e PortabilityError)
checkPortability = checkEntries checkEntryPortability
checkEntryPortability :: Entry -> Maybe PortabilityError
checkEntryPortability entry
| entryFormat entry `elem` [V7Format, GnuFormat]
= Just $ NonPortableFormat (entryFormat entry)
| not (portableFileType (entryContent entry))
= Just NonPortableFileType
| not (all portableChar (BS.unpack posixPath))
= Just $ NonPortableEntryNameChar posixPath
| not (FilePath.Posix.isValid posixPath)
= Just $ NonPortableFileName "unix" (InvalidFileName posixPath)
| FilePath.Posix.isAbsolute posixPath
= Just $ NonPortableFileName "unix" (AbsoluteFileName posixPath)
| any (BS.pack [_period, _period] ==) (FilePath.Posix.splitDirectories posixPath)
= Just $ NonPortableFileName "unix" (InvalidFileName posixPath)
| otherwise = Nothing
where
tarPath = entryTarPath entry
posixPath = fromTarPathToPosixPath tarPath
portableFileType ftype = case ftype of
NormalFile {} -> True
HardLink {} -> True
SymbolicLink {} -> True
Directory -> True
_ -> False
portableChar c = c <= 127
data PortabilityError
= NonPortableFormat Format
| NonPortableFileType
| NonPortableEntryNameChar RawFilePath
| NonPortableFileName PortabilityPlatform FileNameError
deriving (Typeable)
type PortabilityPlatform = String
instance Exception PortabilityError
instance Show PortabilityError where
show (NonPortableFormat format) = "Archive is in the " ++ fmt ++ " format"
where fmt = case format of V7Format -> "old Unix V7 tar"
UstarFormat -> "ustar"
GnuFormat -> "GNU tar"
show NonPortableFileType = "Non-portable file type in archive"
show (NonPortableEntryNameChar posixPath)
= "Non-portable character in archive entry name: " ++ show posixPath
show (NonPortableFileName platform err)
= showFileNameError (Just platform) err
checkEntries :: (Entry -> Maybe e') -> Entries e -> Entries (Either e e')
checkEntries checkEntry =
mapEntries (\entry -> maybe (Right entry) Left (checkEntry entry))