module Codec.Archive.Tar.Create (
createTarArchive, createTarEntry,
recurseDirectories,
mkTarHeader) where
import Codec.Archive.Tar.Types
import Codec.Archive.Tar.Util
import System.PosixCompat.Extensions
import System.PosixCompat.Files
import Control.Monad
import qualified Data.ByteString.Lazy as L
import Data.List
import System.Directory
import System.IO
import System.IO.Unsafe (unsafeInterleaveIO)
createTarArchive :: [FilePath]
-> IO TarArchive
createTarArchive = liftM TarArchive . mapM createTarEntry
createTarEntry :: FilePath -> IO TarEntry
createTarEntry path =
do stat <- getSymbolicLinkStatus path
let t = fileType stat
path' <- sanitizePath t path
target <- case t of
TarSymbolicLink -> readSymbolicLink path
_ -> return ""
let (major,minor) = if t == TarCharacterDevice || t == TarBlockDevice
then let dev = deviceID stat
in (deviceMajor dev, deviceMinor dev)
else (0,0)
owner <- return ""
grp <- return ""
let hdr = TarHeader {
tarFileName = path',
tarFileMode = fileMode stat,
tarOwnerID = fileOwner stat,
tarGroupID = fileGroup stat,
tarFileSize = fromIntegral $ fileSize stat,
tarModTime = modificationTime stat,
tarFileType = t,
tarLinkTarget = target,
tarOwnerName = owner,
tarGroupName = grp,
tarDeviceMajor = major,
tarDeviceMinor = minor
}
cnt <- case t of
TarNormalFile -> L.readFile path
_ -> return L.empty
return $ TarEntry hdr cnt
fileType :: FileStatus -> TarFileType
fileType stat | isRegularFile stat = TarNormalFile
| isSymbolicLink stat = TarSymbolicLink
| isCharacterDevice stat = TarCharacterDevice
| isBlockDevice stat = TarBlockDevice
| isDirectory stat = TarDirectory
| isNamedPipe stat = TarFIFO
| otherwise = error "Unknown file type."
mkTarHeader :: FilePath -> TarHeader
mkTarHeader path = TarHeader {
tarFileName = path,
tarFileMode = stdFileMode,
tarOwnerID = 0,
tarGroupID = 0,
tarFileSize = 0,
tarModTime = 0,
tarFileType = TarNormalFile,
tarLinkTarget = "",
tarOwnerName = "",
tarGroupName = "",
tarDeviceMajor = 0,
tarDeviceMinor = 0
}
sanitizePath :: TarFileType -> FilePath -> IO FilePath
sanitizePath t path =
do path' <- liftM (removeDuplSep . addTrailingSep) $ forceRelativePath path
when (null path' || length path' > 255) $
fail $ "Path too long: " ++ show path'
return path'
where
addTrailingSep = if t == TarDirectory then (++[pathSep]) else id
removeDuplSep =
concat . map (\g -> if all (==pathSep) g then [pathSep] else g) . group
recurseDirectories :: [FilePath] -> IO [FilePath]
recurseDirectories =
liftM concat . mapM (\p -> liftM (p:) $ unsafeInterleaveIO $ descendants p)
where
descendants path =
do d <- doesDirectoryExist path
if d then do cs <- getDirectoryContents path
let cs' = [path++[pathSep]++c | c <- cs, includeDir c]
ds <- recurseDirectories cs'
return ds
else return []
where includeDir "." = False
includeDir ".." = False
includeDir _ = True