{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, BangPatterns #-}
module Codec.Archive.Tar.Types (
Entry(..),
entryPath,
EntryContent(..),
FileSize,
Permissions,
Ownership(..),
EpochTime,
TypeCode,
DevMajor,
DevMinor,
Format(..),
RawFilePath,
simpleEntry,
longLinkEntry,
fileEntry,
directoryEntry,
ordinaryFilePermissions,
executableFilePermissions,
directoryPermissions,
TarPath(..),
SplitError(..),
toTarPath,
fromTarPath,
fromTarPathToPosixPath,
LinkTarget(..),
toLinkTarget,
fromLinkTarget,
fromLinkTargetToPosixPath,
Entries(..),
mapEntries,
mapEntriesNoFail,
foldEntries,
foldlEntries,
unfoldEntries,
filePerms,
dirPerms,
#ifdef TESTS
limitToV7FormatCompat
#endif
) where
import Data.Int (Int64)
import Data.Monoid (Monoid(..))
import Data.Semigroup as Sem
import Data.These
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS.Char8
import qualified Data.ByteString.Lazy as LBS
import Control.DeepSeq
import System.Posix.ByteString.FilePath (RawFilePath)
import qualified System.Posix.FilePath as FilePath.Posix
import System.Posix.Files.ByteString
import System.Posix.Types ( FileMode )
#ifdef TESTS
import Test.QuickCheck
import Control.Applicative ((<$>), (<*>), pure)
import Data.Word (Word16)
#endif
type FileSize = Int64
type EpochTime = Int64
type DevMajor = Int
type DevMinor = Int
type TypeCode = Char
type Permissions = FileMode
data Entry = Entry {
entryTarPath :: {-# UNPACK #-} !TarPath,
entryContent :: !EntryContent,
entryPermissions :: {-# UNPACK #-} !Permissions,
entryOwnership :: {-# UNPACK #-} !Ownership,
entryTime :: {-# UNPACK #-} !EpochTime,
entryFormat :: !Format
}
deriving (Eq, Show)
filePerms :: FileMode
filePerms =
ownerWriteMode
`unionFileModes` ownerReadMode
`unionFileModes` groupWriteMode
`unionFileModes` groupReadMode
`unionFileModes` otherWriteMode
`unionFileModes` otherReadMode
dirPerms :: FileMode
dirPerms =
ownerModes
`unionFileModes` groupModes
`unionFileModes` otherExecuteMode
`unionFileModes` otherReadMode
entryPath :: Entry -> RawFilePath
entryPath = fromTarPath . entryTarPath
data EntryContent = NormalFile LBS.ByteString {-# UNPACK #-} !FileSize
| Directory
| SymbolicLink !LinkTarget
| HardLink !LinkTarget
| CharacterDevice {-# UNPACK #-} !DevMajor
{-# UNPACK #-} !DevMinor
| BlockDevice {-# UNPACK #-} !DevMajor
{-# UNPACK #-} !DevMinor
| NamedPipe
| OtherEntryType {-# UNPACK #-} !TypeCode LBS.ByteString
{-# UNPACK #-} !FileSize
deriving (Eq, Ord, Show)
data Ownership = Ownership {
ownerName :: String,
groupName :: String,
ownerId :: {-# UNPACK #-} !Int,
groupId :: {-# UNPACK #-} !Int
}
deriving (Eq, Ord, Show)
data Format =
V7Format
| UstarFormat
| GnuFormat
deriving (Eq, Ord, Show)
instance NFData Entry where
rnf (Entry _ c _ _ _ _) = rnf c
instance NFData EntryContent where
rnf x = case x of
NormalFile c _ -> rnflbs c
OtherEntryType _ c _ -> rnflbs c
_ -> seq x ()
where
#if MIN_VERSION_bytestring(0,10,0)
rnflbs = rnf
#else
rnflbs = foldr (\ !_bs r -> r) () . LBS.toChunks
#endif
instance NFData Ownership where
rnf (Ownership o g _ _) = rnf o `seq` rnf g
ordinaryFilePermissions :: Permissions
ordinaryFilePermissions = 0o0644
executableFilePermissions :: Permissions
executableFilePermissions = 0o0755
directoryPermissions :: Permissions
directoryPermissions = 0o0755
simpleEntry :: TarPath -> EntryContent -> Entry
simpleEntry tarpath content = Entry {
entryTarPath = tarpath,
entryContent = content,
entryPermissions = case content of
Directory -> directoryPermissions
_ -> ordinaryFilePermissions,
entryOwnership = Ownership "" "" 0 0,
entryTime = 0,
entryFormat = UstarFormat
}
longLinkEntry :: RawFilePath -> Entry
longLinkEntry tarpath = Entry {
entryTarPath = TarPath (BS.Char8.pack "././@LongLink") BS.empty,
entryContent = OtherEntryType 'L' (LBS.fromStrict tarpath) (fromIntegral $ BS.length tarpath),
entryPermissions = ordinaryFilePermissions,
entryOwnership = Ownership "" "" 0 0,
entryTime = 0,
entryFormat = GnuFormat
}
fileEntry :: TarPath -> LBS.ByteString -> Entry
fileEntry name fileContent =
simpleEntry name (NormalFile fileContent (LBS.length fileContent))
directoryEntry :: TarPath -> Entry
directoryEntry name = simpleEntry name Directory
data TarPath = TarPath {-# UNPACK #-} !BS.ByteString
{-# UNPACK #-} !BS.ByteString
deriving (Eq, Ord)
instance NFData TarPath where
rnf (TarPath _ _) = ()
instance Show TarPath where
show = show . fromTarPath
fromTarPath :: TarPath -> RawFilePath
fromTarPath (TarPath name prefix) = adjustDirectory $
FilePath.Posix.joinPath $ FilePath.Posix.splitDirectories prefix
++ FilePath.Posix.splitDirectories name
where
adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name
= FilePath.Posix.addTrailingPathSeparator
| otherwise = id
fromTarPathToPosixPath :: TarPath -> RawFilePath
fromTarPathToPosixPath (TarPath name prefix) = adjustDirectory $
FilePath.Posix.joinPath $ FilePath.Posix.splitDirectories prefix
++ FilePath.Posix.splitDirectories name
where
adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name
= FilePath.Posix.addTrailingPathSeparator
| otherwise = id
toTarPath :: Bool
-> RawFilePath -> These SplitError TarPath
toTarPath isDir = splitLongPath
. addTrailingSep
. FilePath.Posix.joinPath
. FilePath.Posix.splitDirectories
where
addTrailingSep | isDir = FilePath.Posix.addTrailingPathSeparator
| otherwise = id
data SplitError = FileNameEmpty
| FileNameTooLong
deriving Show
splitLongPath :: RawFilePath -> These SplitError TarPath
splitLongPath path =
case packName nameMax (reverse (FilePath.Posix.splitPath path)) of
Left FileNameTooLong -> These FileNameTooLong $ TarPath (BS.take 100 path) BS.empty
Left e -> This e
Right (name, []) -> That $! TarPath name BS.empty
Right (name, first:rest) -> case packName prefixMax remainder of
Left FileNameTooLong -> These FileNameTooLong $ TarPath (BS.take 100 path) BS.empty
Left e -> This e
Right (_ , (_:_)) -> These FileNameTooLong $ TarPath (BS.take 100 path) BS.empty
Right (prefix, []) -> That $! TarPath name prefix
where
remainder = BS.init first : rest
where
nameMax, prefixMax :: Int
nameMax = 100
prefixMax = 155
packName _ [] = Left FileNameEmpty
packName maxLen (c:cs)
| n > maxLen = Left FileNameTooLong
| otherwise = Right (packName' maxLen n [c] cs)
where n = BS.length c
packName' maxLen n ok (c:cs)
| n' <= maxLen = packName' maxLen n' (c:ok) cs
where n' = n + BS.length c
packName' _ _ ok cs = (FilePath.Posix.joinPath ok, cs)
newtype LinkTarget = LinkTarget BS.ByteString
deriving (Eq, Ord, Show)
instance NFData LinkTarget where
#if MIN_VERSION_bytestring(0,10,0)
rnf (LinkTarget bs) = rnf bs
#else
rnf (LinkTarget !_bs) = ()
#endif
toLinkTarget :: RawFilePath -> Maybe LinkTarget
toLinkTarget path | BS.length path <= 100 = Just $! LinkTarget path
| otherwise = Nothing
fromLinkTarget :: LinkTarget -> RawFilePath
fromLinkTarget (LinkTarget path) = adjustDirectory $
FilePath.Posix.joinPath $ FilePath.Posix.splitDirectories path
where
adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path
= FilePath.Posix.addTrailingPathSeparator
| otherwise = id
fromLinkTargetToPosixPath :: LinkTarget -> RawFilePath
fromLinkTargetToPosixPath (LinkTarget path) = adjustDirectory $
FilePath.Posix.joinPath $ FilePath.Posix.splitDirectories path
where
adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path
= FilePath.Posix.addTrailingPathSeparator
| otherwise = id
data Entries e = Next Entry (Entries e)
| Done
| Fail e
deriving (Eq, Show)
infixr 5 `Next`
unfoldEntries :: (a -> Either e (Maybe (Entry, a))) -> a -> Entries e
unfoldEntries f = unfold
where
unfold x = case f x of
Left err -> Fail err
Right Nothing -> Done
Right (Just (e, x')) -> Next e (unfold x')
foldEntries :: (Entry -> a -> a) -> a -> (e -> a) -> Entries e -> a
foldEntries next done fail' = fold
where
fold (Next e es) = next e (fold es)
fold Done = done
fold (Fail err) = fail' err
foldlEntries :: (a -> Entry -> a) -> a -> Entries e -> Either (e, a) a
foldlEntries f z = go z
where
go !acc (Next e es) = go (f acc e) es
go !acc Done = Right acc
go !acc (Fail err) = Left (err, acc)
mapEntries :: (Entry -> Either e' Entry) -> Entries e -> Entries (Either e e')
mapEntries f =
foldEntries (\entry rest -> either (Fail . Right) (flip Next rest) (f entry)) Done (Fail . Left)
mapEntriesNoFail :: (Entry -> Entry) -> Entries e -> Entries e
mapEntriesNoFail f =
foldEntries (\entry -> Next (f entry)) Done Fail
instance Sem.Semigroup (Entries e) where
a <> b = foldEntries Next b Fail a
instance Monoid (Entries e) where
mempty = Done
mappend = (Sem.<>)
instance Functor Entries where
fmap f = foldEntries Next Done (Fail . f)
instance NFData e => NFData (Entries e) where
rnf (Next e es) = rnf e `seq` rnf es
rnf Done = ()
rnf (Fail e) = rnf e
#ifdef TESTS
instance Arbitrary Entry where
arbitrary = Entry <$> arbitrary <*> arbitrary <*> arbitraryPermissions
<*> arbitrary <*> arbitraryEpochTime <*> arbitrary
where
arbitraryPermissions :: Gen Permissions
arbitraryPermissions = fromIntegral <$> (arbitrary :: Gen Word16)
arbitraryEpochTime :: Gen EpochTime
arbitraryEpochTime = arbitraryOctal 11
shrink (Entry path content perms author time format) =
[ Entry path' content' perms author' time' format
| (path', content', author', time') <-
shrink (path, content, author, time) ]
++ [ Entry path content perms' author time format
| perms' <- shrinkIntegral perms ]
instance Arbitrary TarPath where
arbitrary = these (error . show) id (flip const)
. toTarPath False
. FilePath.Posix.joinPath
. fmap BS.Char8.pack
<$> listOf1ToN (255 `div` 5)
(elements (map (replicate 4) "abcd"))
shrink = map (these (error . show) id (flip const) . toTarPath False)
. map FilePath.Posix.joinPath
. filter (not . null)
. shrinkList shrinkNothing
. FilePath.Posix.splitPath
. fromTarPathToPosixPath
instance Arbitrary LinkTarget where
arbitrary = maybe (error "link target too large") id
. toLinkTarget
. FilePath.Posix.joinPath
. fmap BS.Char8.pack
<$> listOf1ToN (100 `div` 5)
(elements (map (replicate 4) "abcd"))
shrink = map (maybe (error "link target too large") id . toLinkTarget)
. map FilePath.Posix.joinPath
. filter (not . null)
. shrinkList shrinkNothing
. FilePath.Posix.splitPath
. fromLinkTargetToPosixPath
listOf1ToN :: Int -> Gen a -> Gen [a]
listOf1ToN n g = sized $ \sz -> do
n <- choose (1, min n (max 1 sz))
vectorOf n g
listOf0ToN :: Int -> Gen a -> Gen [a]
listOf0ToN n g = sized $ \sz -> do
n <- choose (0, min n sz)
vectorOf n g
instance Arbitrary EntryContent where
arbitrary =
frequency
[ (16, do bs <- arbitrary;
return (NormalFile bs (LBS.length bs)))
, (2, pure Directory)
, (1, SymbolicLink <$> arbitrary)
, (1, HardLink <$> arbitrary)
, (1, CharacterDevice <$> arbitraryOctal 7 <*> arbitraryOctal 7)
, (1, BlockDevice <$> arbitraryOctal 7 <*> arbitraryOctal 7)
, (1, pure NamedPipe)
, (1, do c <- elements (['A'..'Z']++['a'..'z'])
bs <- arbitrary;
return (OtherEntryType c bs (LBS.length bs)))
]
shrink (NormalFile bs _) = [ NormalFile bs' (LBS.length bs')
| bs' <- shrink bs ]
shrink Directory = []
shrink (SymbolicLink link) = [ SymbolicLink link' | link' <- shrink link ]
shrink (HardLink link) = [ HardLink link' | link' <- shrink link ]
shrink (CharacterDevice ma mi) = [ CharacterDevice ma' mi'
| (ma', mi') <- shrink (ma, mi) ]
shrink (BlockDevice ma mi) = [ BlockDevice ma' mi'
| (ma', mi') <- shrink (ma, mi) ]
shrink NamedPipe = []
shrink (OtherEntryType c bs _) = [ OtherEntryType c bs' (LBS.length bs')
| bs' <- shrink bs ]
instance Arbitrary LBS.ByteString where
arbitrary = fmap LBS.pack arbitrary
shrink = map LBS.pack . shrink . LBS.unpack
instance Arbitrary BS.ByteString where
arbitrary = fmap BS.pack arbitrary
shrink = map BS.pack . shrink . BS.unpack
instance Arbitrary Ownership where
arbitrary = Ownership <$> name <*> name
<*> idno <*> idno
where
name = do
first <- choose ('a', 'z')
rest <- listOf0ToN 30 (oneof [choose ('a', 'z'), choose ('0', '9'), pure '-'])
return $ first : rest
idno = arbitraryOctal 7
shrink (Ownership oname gname oid gid) =
[ Ownership oname' gname' oid' gid'
| (oname', gname', oid', gid') <- shrink (oname, gname, oid, gid) ]
instance Arbitrary Format where
arbitrary = elements [V7Format, UstarFormat, GnuFormat]
arbitraryOctal n =
oneof [ pure 0
, choose (0, upperBound)
, pure upperBound
]
where
upperBound = 8^n-1
limitToV7FormatCompat :: Entry -> Entry
limitToV7FormatCompat entry@Entry { entryFormat = V7Format } =
entry {
entryContent = case entryContent entry of
CharacterDevice _ _ -> OtherEntryType '3' LBS.empty 0
BlockDevice _ _ -> OtherEntryType '4' LBS.empty 0
Directory -> OtherEntryType '5' LBS.empty 0
NamedPipe -> OtherEntryType '6' LBS.empty 0
other -> other,
entryOwnership = (entryOwnership entry) {
groupName = "",
ownerName = ""
},
entryTarPath = let TarPath name _prefix = entryTarPath entry
in TarPath name BS.empty
}
limitToV7FormatCompat entry = entry
#endif