module Codec.Archive.Tar.Types (
Entry(..),
entryPath,
EntryContent(..),
FileSize,
Permissions,
Ownership(..),
EpochTime,
TypeCode,
DevMajor,
DevMinor,
Format(..),
simpleEntry,
fileEntry,
directoryEntry,
ordinaryFilePermissions,
executableFilePermissions,
directoryPermissions,
TarPath(..),
toTarPath,
fromTarPath,
fromTarPathToPosixPath,
fromTarPathToWindowsPath,
LinkTarget(..),
toLinkTarget,
fromLinkTarget,
fromLinkTargetToPosixPath,
fromLinkTargetToWindowsPath,
Entries(..),
mapEntries,
mapEntriesNoFail,
foldEntries,
foldlEntries,
unfoldEntries,
#ifdef TESTS
limitToV7FormatCompat
#endif
) where
import Data.Int (Int64)
import Data.Monoid (Monoid(..))
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 qualified System.FilePath as FilePath.Native
( joinPath, splitDirectories, addTrailingPathSeparator )
import qualified System.FilePath.Posix as FilePath.Posix
( joinPath, splitPath, splitDirectories, hasTrailingPathSeparator
, addTrailingPathSeparator )
import qualified System.FilePath.Windows as FilePath.Windows
( joinPath, addTrailingPathSeparator )
import System.Posix.Types
( FileMode )
#ifdef TESTS
import Test.QuickCheck
import Control.Applicative ((<$>), pure, (<*>))
#endif
type FileSize = Int64
type EpochTime = Int64
type DevMajor = Int
type DevMinor = Int
type TypeCode = Char
type Permissions = FileMode
data Entry = Entry {
entryTarPath :: !TarPath,
entryContent :: !EntryContent,
entryPermissions :: !Permissions,
entryOwnership :: !Ownership,
entryTime :: !EpochTime,
entryFormat :: !Format
}
deriving (Eq, Show)
entryPath :: Entry -> FilePath
entryPath = fromTarPath . entryTarPath
data EntryContent = NormalFile LBS.ByteString !FileSize
| Directory
| SymbolicLink !LinkTarget
| HardLink !LinkTarget
| CharacterDevice !DevMajor
!DevMinor
| BlockDevice !DevMajor
!DevMinor
| NamedPipe
| OtherEntryType !TypeCode LBS.ByteString
!FileSize
deriving (Eq, Ord, Show)
data Ownership = Ownership {
ownerName :: String,
groupName :: String,
ownerId :: !Int,
groupId :: !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
}
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 !BS.ByteString
!BS.ByteString
deriving (Eq, Ord)
instance NFData TarPath where
rnf (TarPath _ _) = ()
instance Show TarPath where
show = show . fromTarPath
fromTarPath :: TarPath -> FilePath
fromTarPath (TarPath namebs prefixbs) = adjustDirectory $
FilePath.Native.joinPath $ FilePath.Posix.splitDirectories prefix
++ FilePath.Posix.splitDirectories name
where
name = BS.Char8.unpack namebs
prefix = BS.Char8.unpack prefixbs
adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name
= FilePath.Native.addTrailingPathSeparator
| otherwise = id
fromTarPathToPosixPath :: TarPath -> FilePath
fromTarPathToPosixPath (TarPath namebs prefixbs) = adjustDirectory $
FilePath.Posix.joinPath $ FilePath.Posix.splitDirectories prefix
++ FilePath.Posix.splitDirectories name
where
name = BS.Char8.unpack namebs
prefix = BS.Char8.unpack prefixbs
adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name
= FilePath.Posix.addTrailingPathSeparator
| otherwise = id
fromTarPathToWindowsPath :: TarPath -> FilePath
fromTarPathToWindowsPath (TarPath namebs prefixbs) = adjustDirectory $
FilePath.Windows.joinPath $ FilePath.Posix.splitDirectories prefix
++ FilePath.Posix.splitDirectories name
where
name = BS.Char8.unpack namebs
prefix = BS.Char8.unpack prefixbs
adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name
= FilePath.Windows.addTrailingPathSeparator
| otherwise = id
toTarPath :: Bool
-> FilePath -> Either String TarPath
toTarPath isDir = splitLongPath
. addTrailingSep
. FilePath.Posix.joinPath
. FilePath.Native.splitDirectories
where
addTrailingSep | isDir = FilePath.Posix.addTrailingPathSeparator
| otherwise = id
splitLongPath :: FilePath -> Either String TarPath
splitLongPath path =
case packName nameMax (reverse (FilePath.Posix.splitPath path)) of
Left err -> Left err
Right (name, []) -> Right $! TarPath (BS.Char8.pack name)
BS.empty
Right (name, first:rest) -> case packName prefixMax remainder of
Left err -> Left err
Right (_ , (_:_)) -> Left "File name too long (cannot split)"
Right (prefix, []) -> Right $! TarPath (BS.Char8.pack name)
(BS.Char8.pack prefix)
where
remainder = init first : rest
where
nameMax, prefixMax :: Int
nameMax = 100
prefixMax = 155
packName _ [] = Left "File name empty"
packName maxLen (c:cs)
| n > maxLen = Left "File name too long"
| otherwise = Right (packName' maxLen n [c] cs)
where n = length c
packName' maxLen n ok (c:cs)
| n' <= maxLen = packName' maxLen n' (c:ok) cs
where n' = n + 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 :: FilePath -> Maybe LinkTarget
toLinkTarget path | length path <= 100 = Just $! LinkTarget (BS.Char8.pack path)
| otherwise = Nothing
fromLinkTarget :: LinkTarget -> FilePath
fromLinkTarget (LinkTarget pathbs) = adjustDirectory $
FilePath.Native.joinPath $ FilePath.Posix.splitDirectories path
where
path = BS.Char8.unpack pathbs
adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path
= FilePath.Native.addTrailingPathSeparator
| otherwise = id
fromLinkTargetToPosixPath :: LinkTarget -> FilePath
fromLinkTargetToPosixPath (LinkTarget pathbs) = adjustDirectory $
FilePath.Posix.joinPath $ FilePath.Posix.splitDirectories path
where
path = BS.Char8.unpack pathbs
adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path
= FilePath.Native.addTrailingPathSeparator
| otherwise = id
fromLinkTargetToWindowsPath :: LinkTarget -> FilePath
fromLinkTargetToWindowsPath (LinkTarget pathbs) = adjustDirectory $
FilePath.Windows.joinPath $ FilePath.Posix.splitDirectories path
where
path = BS.Char8.unpack pathbs
adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path
= FilePath.Windows.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 Monoid (Entries e) where
mempty = Done
mappend a b = foldEntries Next b Fail a
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 <$> (arbitraryOctal 7 :: Gen Int)
arbitraryEpochTime :: Gen EpochTime
arbitraryEpochTime = fromIntegral <$> (arbitraryOctal 11 :: Gen Int)
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 = either error id
. toTarPath False
. FilePath.Posix.joinPath
<$> listOf1ToN (255 `div` 5)
(elements (map (replicate 4) "abcd"))
shrink = map (either error id . 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.Native.joinPath
<$> 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 = listOf0ToN 32 (arbitrary `suchThat` (/= '\0'))
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^n1
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