module Codec.Archive.Tar.Pack (
pack,
packFileEntry,
packDirectoryEntry,
getDirectoryContentsRecursive,
) where
import Codec.Archive.Tar.Types
import qualified Data.ByteString.Lazy as BS
import System.FilePath
( (</>) )
import qualified System.FilePath as FilePath.Native
( makeRelative, addTrailingPathSeparator, hasTrailingPathSeparator )
import System.Directory
( getDirectoryContents, doesDirectoryExist, getModificationTime
, Permissions(..), getPermissions )
import System.Posix.Types
( FileMode )
import System.Time
( ClockTime(..) )
import System.IO
( IOMode(ReadMode), openBinaryFile, hFileSize )
import System.IO.Unsafe (unsafeInterleaveIO)
pack :: FilePath
-> [FilePath]
-> IO [Entry]
pack baseDir paths0 = preparePaths baseDir paths0 >>= packPaths baseDir
preparePaths :: FilePath -> [FilePath] -> IO [FilePath]
preparePaths baseDir paths =
fmap concat $ interleave
[ do isDir <- doesDirectoryExist path
if isDir then getDirectoryContentsRecursive (baseDir </> path)
else return [path]
| path <- paths ]
packPaths :: FilePath -> [FilePath] -> IO [Entry]
packPaths baseDir paths =
interleave
[ do tarpath <- either fail return (toTarPath isDir relPath)
if isDir then packDirectoryEntry filepath tarpath
else packFileEntry filepath tarpath
| filepath <- paths
, let isDir = FilePath.Native.hasTrailingPathSeparator filepath
relPath = FilePath.Native.makeRelative baseDir filepath ]
interleave :: [IO a] -> IO [a]
interleave = unsafeInterleaveIO . go
where
go [] = return []
go (x:xs) = do
x' <- x
xs' <- interleave xs
return (x':xs')
packFileEntry :: FilePath
-> TarPath
-> IO Entry
packFileEntry filepath tarpath = do
mtime <- getModTime filepath
perms <- getPermissions filepath
file <- openBinaryFile filepath ReadMode
size <- hFileSize file
content <- BS.hGetContents file
return (simpleEntry tarpath (NormalFile content (fromIntegral size))) {
entryPermissions = if executable perms then executableFilePermissions
else ordinaryFilePermissions,
entryTime = mtime
}
packDirectoryEntry :: FilePath
-> TarPath
-> IO Entry
packDirectoryEntry filepath tarpath = do
mtime <- getModTime filepath
return (directoryEntry tarpath) {
entryTime = mtime
}
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive dir0 =
recurseDirectories [FilePath.Native.addTrailingPathSeparator dir0]
recurseDirectories :: [FilePath] -> IO [FilePath]
recurseDirectories [] = return []
recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do
(files, dirs') <- collect [] [] =<< getDirectoryContents dir
files' <- recurseDirectories (dirs' ++ dirs)
return (dir : 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
dirEntry' = FilePath.Native.addTrailingPathSeparator dirEntry
isDirectory <- doesDirectoryExist dirEntry
if isDirectory
then collect files (dirEntry':dirs') entries
else collect (dirEntry:files) dirs' entries
ignore ['.'] = True
ignore ['.', '.'] = True
ignore _ = False
getModTime :: FilePath -> IO EpochTime
getModTime path = do
(TOD s _) <- getModificationTime path
return $! fromIntegral s