cabal-install-0.5.2: Distribution/Client/Tar.hs
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Tar
-- Copyright : (c) 2007 Bjorn Bringert,
-- 2008 Andrea Vezzosi,
-- 2008 Duncan Coutts
-- License : BSD-like
--
-- Maintainer : duncan@haskell.org
-- Stability : provisional
-- Portability : portable
--
-- TAR archive reading and writing
--
-----------------------------------------------------------------------------
module Distribution.Client.Tar (
-- * High level all in one operations on files
createTarGzFile,
extractTarGzFile,
-- * Reading and writing the tar format
read,
write,
-- * Packing and unpacking files to\/from a tar archive
pack,
unpack,
-- * Tar archive 'Entry'
Entry(..), fileName,
ExtendedHeader(..),
FileType(..),
UserId,
GroupId,
EpochTime,
DevMajor,
DevMinor,
FileSize,
-- ** Constructing entries
emptyEntry,
simpleFileEntry,
simpleDirectoryEntry,
-- ** 'TarPath's
TarPath,
toTarPath,
fromTarPath,
-- * Sequence of 'Entry' records with failures
Entries(..),
foldEntries,
unfoldEntries,
mapEntries,
-- * Sanity checking tar contents
checkEntryNames
) where
import Data.Char (ord)
import Data.Int (Int64)
import Data.List (foldl')
import Data.Monoid (Monoid(..))
import Numeric (readOct, showOct)
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
import Data.ByteString.Lazy (ByteString)
import qualified Codec.Compression.GZip as GZip
import System.FilePath
( (</>) )
import qualified System.FilePath as FilePath.Native
( (</>), joinPath, splitDirectories, takeDirectory
, isAbsolute, isValid, makeRelative )
import qualified System.FilePath.Posix as FilePath.Posix
( joinPath, pathSeparator, splitPath, splitDirectories )
import System.Directory
( getDirectoryContents, doesDirectoryExist
, getModificationTime, createDirectoryIfMissing, copyFile
, Permissions(..), getPermissions )
import System.Posix.Types
( FileMode )
import System.Time
( ClockTime(..) )
import System.IO
( IOMode(ReadMode), openBinaryFile, hFileSize )
import System.IO.Unsafe (unsafeInterleaveIO)
import Distribution.Client.Utils
( writeFileAtomic )
import Prelude hiding (read)
--
-- * High level operations
--
createTarGzFile :: FilePath -- ^ Full Tarball path
-> FilePath -- ^ Base directory
-> FilePath -- ^ Directory to archive, relative to base dir
-> IO ()
createTarGzFile tar base dir =
writeFileAtomic tar . GZip.compress . write =<< pack base dir
extractTarGzFile :: FilePath -- ^ Destination directory
-> FilePath -- ^ Tarball
-> IO ()
extractTarGzFile dir tar =
unpack dir . checkEntryNames . read . GZip.decompress =<< BS.readFile tar
--
-- * Entry type
--
type UserId = Int
type GroupId = Int
type EpochTime = Int -- ^ The number of seconds since the UNIX epoch
type DevMajor = Int
type DevMinor = Int
type FileSize = Int64
-- | TAR archive entry
data Entry = Entry {
-- | Path of the file or directory. The path separator should be @/@ for
-- portable TAR archives.
filePath :: TarPath,
-- | UNIX file mode.
fileMode :: FileMode,
-- | Numeric owner user id. Should be set to @0@ if unknown.
ownerId :: UserId,
-- | Numeric owner group id. Should be set to @0@ if unknown.
groupId :: GroupId,
-- | File size in bytes. Should be 0 for entries other than normal files.
fileSize :: FileSize,
-- | Last modification time.
modTime :: EpochTime,
-- | Type of this entry.
fileType :: FileType,
-- | If the entry is a hard link or a symbolic link, this is the path of
-- the link target. For all other entry types this should be @\"\"@.
linkTarget :: FilePath,
-- | The remaining meta-data is in the V7, ustar/posix or gnu formats
-- For V7 there is no extended info at all and for posix/ustar the
-- information is the same though the kind affects the way the information
-- is encoded.
headerExt :: ExtendedHeader,
-- | Entry contents. For entries other than normal
-- files, this should be an empty string.
fileContent :: ByteString
}
fileName :: Entry -> FilePath
fileName = fromTarPath . filePath
data ExtendedHeader
= V7
| USTAR {
-- | The owner user name. Should be set to @\"\"@ if unknown.
ownerName :: String,
-- | The owner group name. Should be set to @\"\"@ if unknown.
groupName :: String,
-- | For character and block device entries, this is the
-- major number of the device. For all other entry types, it
-- should be set to @0@.
deviceMajor :: DevMajor,
-- | For character and block device entries, this is the
-- minor number of the device. For all other entry types, it
-- should be set to @0@.
deviceMinor :: DevMinor
}
| GNU {
-- | The owner user name. Should be set to @\"\"@ if unknown.
ownerName :: String,
-- | The owner group name. Should be set to @\"\"@ if unknown.
groupName :: String,
-- | For character and block device entries, this is the
-- major number of the device. For all other entry types, it
-- should be set to @0@.
deviceMajor :: DevMajor,
-- | For character and block device entries, this is the
-- minor number of the device. For all other entry types, it
-- should be set to @0@.
deviceMinor :: DevMinor
}
-- | TAR archive entry types.
data FileType = NormalFile
| HardLink
| SymbolicLink
| CharacterDevice
| BlockDevice
| Directory
| FIFO
| ExtendedHeader
| GlobalHeader
| Custom Char -- 'A' .. 'Z'
| Reserved Char -- other / reserved / unknown
deriving (Eq, Show)
toFileTypeCode :: FileType -> Char
toFileTypeCode NormalFile = '0'
toFileTypeCode HardLink = '1'
toFileTypeCode SymbolicLink = '2'
toFileTypeCode CharacterDevice = '3'
toFileTypeCode BlockDevice = '4'
toFileTypeCode Directory = '5'
toFileTypeCode FIFO = '6'
toFileTypeCode ExtendedHeader = 'x'
toFileTypeCode GlobalHeader = 'g'
toFileTypeCode (Custom c) = c
toFileTypeCode (Reserved c) = c
fromFileTypeCode :: Char -> FileType
fromFileTypeCode '0' = NormalFile
fromFileTypeCode '\0' = NormalFile
fromFileTypeCode '1' = HardLink
fromFileTypeCode '2' = SymbolicLink
fromFileTypeCode '3' = CharacterDevice
fromFileTypeCode '4' = BlockDevice
fromFileTypeCode '5' = Directory
fromFileTypeCode '6' = FIFO
fromFileTypeCode '7' = NormalFile
fromFileTypeCode 'x' = ExtendedHeader
fromFileTypeCode 'g' = GlobalHeader
fromFileTypeCode c | c >= 'A' && c <= 'Z'
= Custom c
fromFileTypeCode c = Reserved c
emptyEntry :: FileType -> TarPath -> Entry
emptyEntry ftype tarpath = Entry {
filePath = tarpath,
fileMode = case ftype of
Directory -> 0o0755 -- rwxr-xr-x for directories
_ -> 0o0644, -- rw-r--r-- for normal files
ownerId = 0,
groupId = 0,
fileSize = 0,
modTime = 0,
fileType = ftype,
linkTarget = "",
headerExt = USTAR {
ownerName = "",
groupName = "",
deviceMajor = 0,
deviceMinor = 0
},
fileContent = BS.empty
}
simpleFileEntry :: TarPath -> ByteString -> Entry
simpleFileEntry name content = (emptyEntry NormalFile name) {
fileSize = BS.length content,
fileContent = content
}
simpleDirectoryEntry :: TarPath -> Entry
simpleDirectoryEntry name = emptyEntry Directory name
--
-- * Tar paths
--
-- | The classic tar format allowed just 100 charcters for the file name. The
-- USTAR format extended this with an extra 155 characters, however it uses a
-- complex method of splitting the name between the two sections.
--
-- Instead of just putting any overflow into the extended area, it uses the
-- extended area as a prefix. The agrevating insane bit however is that the
-- prefix (if any) must only contain a directory prefix. That is the split
-- between the two areas must be on a directory separator boundary. So there is
-- no simple calculation to work out if a file name is too long. Instead we
-- have to try to find a valid split that makes the name fit in the two areas.
--
-- The rationale presumably was to make it a bit more compatible with tar
-- programs that only understand the classic format. A classic tar would be
-- able to extract the file name and possibly some dir prefix, but not the
-- full dir prefix. So the files would end up in the wrong place, but that's
-- probably better than ending up with the wrong names too.
--
-- So it's understandable but rather annoying.
--
-- * Tar paths use posix format (ie @\'/\'@ directory separators), irrespective
-- of the local path conventions.
--
-- * The directory separator between the prefix and name is /not/ stored.
--
data TarPath = TarPath FilePath -- path name, 100 characters max.
FilePath -- path prefix, 155 characters max.
-- | Convert a 'TarPath' to a native 'FilePath'.
--
-- The native 'FilePath' will use the native directory separator but it is not
-- otherwise checked for validity or sanity. In particular:
--
-- * The tar path may be invalid as a native path, eg the filename @\"nul\"@ is
-- not valid on Windows.
-- * The tar path may be an absolute path or may contain @\"..\"@ components.
-- For security reasons this should not usually be allowed, but it is your
-- responsibility to check for these conditions.
--
fromTarPath :: TarPath -> FilePath
fromTarPath (TarPath name prefix) =
FilePath.Native.joinPath $ FilePath.Posix.splitDirectories prefix
++ FilePath.Posix.splitDirectories name
-- | Convert a native 'FilePath' to a 'TarPath'. The 'FileType' is needed
-- because for directories a 'TarPath' uses a trailing @\/@.
--
-- The conversion may fail if the 'FilePath' is too long. See 'TarPath' for a
-- description of the problem with splitting long 'FilePath's.
--
toTarPath :: FileType -> FilePath -> Either String TarPath
toTarPath ftype = splitLongPath
. addTrailingSep ftype
. FilePath.Posix.joinPath
. FilePath.Native.splitDirectories
where
addTrailingSep Directory path = path ++ [FilePath.Posix.pathSeparator]
addTrailingSep _ path = path
-- | Takes a sanitized path, split on directory separators and tries to pack it
-- into the 155 + 100 tar file name format.
--
-- The stragey is this: take the name-directory components in reverse order
-- and try to fit as many components into the 100 long name area as possible.
-- If all the remaining components fit in the 155 name area then we win.
--
splitLongPath :: FilePath -> Either String TarPath
splitLongPath path =
case packName nameMax (reverse (FilePath.Posix.splitPath path)) of
Left err -> Left err
Right (name, []) -> Right (TarPath name "")
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 name prefix)
where
-- drop the '/' between the name and prefix:
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)
--
-- * Entries type
--
-- | A tar archive is a sequence of entries.
data Entries = Next Entry Entries
| Done
| Fail String
unfoldEntries :: (a -> Either String (Maybe (Entry, a))) -> a -> Entries
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 -> (String -> a) -> Entries -> a
foldEntries next done fail' = fold
where
fold (Next e es) = next e (fold es)
fold Done = done
fold (Fail err) = fail' err
mapEntries :: (Entry -> Either String Entry) -> Entries -> Entries
mapEntries f =
foldEntries (\entry rest -> either Fail (flip Next rest) (f entry)) Done Fail
--
-- * Checking
--
checkEntryNames :: Entries -> Entries
checkEntryNames =
mapEntries (\entry -> maybe (Right entry) Left (checkEntryName entry))
checkEntryName :: Entry -> Maybe String
checkEntryName entry = case fileType entry of
HardLink -> check (fileName entry) `mappend` check (linkTarget entry)
SymbolicLink -> check (fileName entry) `mappend` check (linkTarget entry)
_ -> check (fileName entry)
where
check name
| FilePath.Native.isAbsolute name
= Just $ "Absolute file name in tar archive: " ++ show name
| not (FilePath.Native.isValid name)
= Just $ "Invalid file name in tar archive: " ++ show name
| any (=="..") (FilePath.Native.splitDirectories name)
= Just $ "Invalid file name in tar archive: " ++ show name
| otherwise = Nothing
--
-- * Reading
--
read :: ByteString -> Entries
read = unfoldEntries getEntry
getEntry :: ByteString -> Either String (Maybe (Entry, ByteString))
getEntry bs
| BS.length header < 512 = Left "Truncated TAR archive"
| endBlock = Right Nothing --FIXME: force last two blocks to close fds!
| not (correctChecksum header chksum) = Left "TAR checksum error"
| magic /= "ustar\NUL00"
&& magic /= "ustar \NUL" = Left $ "TAR entry not ustar format: " ++ show magic
| otherwise = Right (Just (entry, bs'''))
where
(header,bs') = BS.splitAt 512 bs
endBlock = getByte 0 header == '\0'
name = getString 0 100 header
mode = getOct 100 8 header
uid = getOct 108 8 header
gid = getOct 116 8 header
size = getOct 124 12 header
mtime = getOct 136 12 header
chksum = getOct 148 8 header
typecode = getByte 156 header
linkname = getString 157 100 header
magic = getChars 257 8 header
uname = getString 265 32 header
gname = getString 297 32 header
devmajor = getOct 329 8 header
devminor = getOct 337 8 header
prefix = getString 345 155 header
-- trailing = getBytes 500 12 header --TODO: check all \0's
padding = (512 - size) `mod` 512
(cnt,bs'') = BS.splitAt size bs'
bs''' = BS.drop padding bs''
entry = Entry {
filePath = TarPath name prefix,
fileMode = mode,
ownerId = uid,
groupId = gid,
fileSize = size,
modTime = mtime,
fileType = fromFileTypeCode typecode,
linkTarget = linkname,
headerExt = case magic of
"\0\0\0\0\0\0\0\0" -> V7
"ustar\NUL00" -> USTAR {
ownerName = uname,
groupName = gname,
deviceMajor = devmajor,
deviceMinor = devminor
}
"ustar \NUL" -> GNU {
ownerName = uname,
groupName = gname,
deviceMajor = devmajor,
deviceMinor = devminor
}
_ -> V7, --FIXME: fail instead
fileContent = cnt
}
correctChecksum :: ByteString -> Int -> Bool
correctChecksum header checksum = checksum == checksum'
where
-- sum of all 512 bytes in the header block,
-- treating each byte as an 8-bit unsigned value
checksum' = BS.Char8.foldl' (\x y -> x + ord y) 0 header'
-- treating the 8 bytes of chksum as blank characters.
header' = BS.concat [BS.take 148 header,
BS.Char8.replicate 8 ' ',
BS.drop 156 header]
-- * TAR format primitive input
getOct :: Integral a => Int64 -> Int64 -> ByteString -> a
getOct off len = parseOct
. BS.Char8.unpack
. BS.Char8.takeWhile (\c -> c /= '\NUL' && c /= ' ')
. getBytes off len
where
parseOct "" = 0
parseOct s = case readOct s of
[(x,[])] -> x
_ -> error $ "Number format error: " ++ show s
getBytes :: Int64 -> Int64 -> ByteString -> ByteString
getBytes off len = BS.take len . BS.drop off
getByte :: Int64 -> ByteString -> Char
getByte off bs = BS.Char8.index bs off
getChars :: Int64 -> Int64 -> ByteString -> String
getChars off len = BS.Char8.unpack . getBytes off len
getString :: Int64 -> Int64 -> ByteString -> String
getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0') . getBytes off len
--
-- * Writing
--
-- | Creates an uncompressed archive
write :: [Entry] -> ByteString
write es = BS.concat $ map putEntry es ++ [BS.replicate (512*2) 0]
putEntry :: Entry -> ByteString
putEntry entry = BS.concat [ header, content, padding ]
where
header = putHeader entry
content = fileContent entry
padding = BS.replicate paddingSize 0
paddingSize = fromIntegral $ negate (fileSize entry) `mod` 512
putHeader :: Entry -> BS.ByteString
putHeader entry =
BS.Char8.pack $ take 148 block
++ putOct 7 checksum
++ ' ' : drop 156 block
where
block = putHeaderNoChkSum entry
checksum = foldl' (\x y -> x + ord y) 0 block
putHeaderNoChkSum :: Entry -> String
putHeaderNoChkSum entry = concat
[ putString 100 $ name
, putOct 8 $ fileMode entry
, putOct 8 $ ownerId entry
, putOct 8 $ groupId entry
, putOct 12 $ fileSize entry
, putOct 12 $ modTime entry
, fill 8 $ ' ' -- dummy checksum
, putChar8 $ toFileTypeCode (fileType entry)
, putString 100 $ linkTarget entry
] ++
case headerExt entry of
V7 ->
fill 255 '\NUL'
ext@USTAR {}-> concat
[ putString 8 $ "ustar\NUL00"
, putString 32 $ ownerName ext
, putString 32 $ groupName ext
, putOct 8 $ deviceMajor ext
, putOct 8 $ deviceMinor ext
, putString 155 $ prefix
, fill 12 $ '\NUL'
]
ext@GNU {} -> concat
[ putString 8 $ "ustar \NUL"
, putString 32 $ ownerName ext
, putString 32 $ groupName ext
, putGnuDev 8 $ deviceMajor ext
, putGnuDev 8 $ deviceMinor ext
, putString 155 $ prefix
, fill 12 $ '\NUL'
]
where
TarPath name prefix = filePath entry
putGnuDev w n = case fileType entry of
CharacterDevice -> putOct w n
BlockDevice -> putOct w n
_ -> replicate w '\NUL'
-- * TAR format primitive output
type FieldWidth = Int
putString :: FieldWidth -> String -> String
putString n s = take n s ++ fill (n - length s) '\NUL'
putOct :: Integral a => FieldWidth -> a -> String
putOct n x =
let octStr = take (n-1) $ showOct x ""
in fill (n - length octStr - 1) '0'
++ octStr
++ putChar8 '\NUL'
putChar8 :: Char -> String
putChar8 c = [c]
fill :: FieldWidth -> Char -> String
fill n c = replicate n c
--
-- * Unpacking
--
unpack :: FilePath -> Entries -> IO ()
unpack dir entries = extractLinks =<< extractFiles [] entries
where
extractFiles _ (Fail err) = Prelude.fail err
extractFiles links Done = return links
extractFiles links (Next entry entries') = case fileType entry of
NormalFile -> BS.writeFile (dir </> fileName entry) (fileContent entry)
>> extractFiles links entries'
HardLink -> saveLink
SymbolicLink -> saveLink
Directory -> createDirectoryIfMissing False (dir </> fileName entry)
>> extractFiles links entries'
_ -> extractFiles links entries' -- FIXME: warning?
where
saveLink = seq (length name)
$ seq (length name)
$ extractFiles (link:links) entries'
where
name = fileName entry
target = linkTarget entry
link = (name, target)
extractLinks = mapM_ $ \(name, target) ->
let path = dir </> name
in copyFile (FilePath.Native.takeDirectory path </> target) path
--
-- * Packing
--
-- | Creates a tar archive from a directory of files, the paths in the archive
-- will be relative to the given base directory.
--
pack :: FilePath -- ^ Base directory
-> FilePath -- ^ Directory or file to package, relative to the base dir
-> IO [Entry]
pack baseDir sourceDir =
mapM (unsafeInterleaveIO . uncurry (createFileEntry baseDir))
=<< recurseDirectories [baseDir </> sourceDir]
recurseDirectories :: [FilePath] -> IO [(FileType, FilePath)]
recurseDirectories [] = return []
recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do
(files, dirs') <- collect [] [] =<< getDirectoryContents dir
files' <- recurseDirectories (dirs' ++ dirs)
return ((Directory, dir) : map ((,) NormalFile) files ++ files')
where
collect files dirs' [] = return (reverse files, reverse dirs')
collect files dirs' (entry:entries) | ignore entry
= collect files dirs' entries
collect files dirs' (entry:entries) = do
let dirEntry = dir </> entry
isDirectory <- doesDirectoryExist dirEntry
if isDirectory
then collect files (dirEntry:dirs') entries
else collect (dirEntry:files) dirs' entries
ignore ['.'] = True
ignore ['.', '.'] = True
ignore _ = False
createFileEntry :: FilePath -- ^ path to find the file
-> FileType
-> FilePath -- ^ path to use for the tar Entry
-> IO Entry
createFileEntry baseDir ftype absPath = do
let relPath = FilePath.Native.makeRelative baseDir absPath
tarpath <- either Prelude.fail return (toTarPath ftype relPath)
mtime <- getModTime absPath
case ftype of
NormalFile -> do
file <- openBinaryFile absPath ReadMode
mode <- getFileMode absPath
size <- hFileSize file
content <- BS.hGetContents file
return (emptyEntry NormalFile tarpath) {
fileMode = mode,
modTime = mtime,
fileSize = fromIntegral size,
fileContent = content
}
_ ->
return (emptyEntry Directory tarpath) {
modTime = mtime
}
-- | We can't be precise because of portability, so we default to rw-r--r-- for
-- normal filesand rwxr-xr-x for executables.
getFileMode :: FilePath -> IO FileMode
getFileMode path = do
perms <- getPermissions path
if executable perms
then return 0o0755
else return 0o0644
getModTime :: FilePath -> IO EpochTime
getModTime path =
do (TOD s _) <- getModificationTime path
return (fromIntegral s)