{-# LANGUAGE CPP #-}
module Codec.Archive.Tar.Pack (
pack,
packFileEntry,
packDirectoryEntry,
getDirectoryContentsRecursive,
) where
import Codec.Archive.Tar.Types
import Control.Applicative
import Control.Monad (join)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
import Data.These
import qualified System.Posix.IO.ByteString as SPI
import System.Posix.FD
import System.Posix.ByteString.FilePath (RawFilePath)
import qualified System.Posix.FilePath as FilePath.Posix
import System.Posix.FilePath ( (</>), isSpecialDirectoryEntry )
import System.Posix.RawFilePath.Directory
import Data.Time.Clock
( UTCTime )
import Data.Time.Clock.POSIX
( utcTimeToPOSIXSeconds )
import System.IO
( IOMode(ReadMode), openBinaryFile, hFileSize )
import System.IO.Unsafe (unsafeInterleaveIO)
pack :: RawFilePath
-> [RawFilePath]
-> IO [Entry]
pack baseDir paths0 = preparePaths baseDir paths0 >>= packPaths baseDir
preparePaths :: RawFilePath -> [RawFilePath] -> IO [RawFilePath]
preparePaths baseDir paths =
fmap concat $ interleave
[ do isDir <- doesDirectoryExist (baseDir </> path)
if isDir
then do entries <- getDirectoryContentsRecursive (baseDir </> path)
let entries' = map (path </>) entries
dir = FilePath.Posix.addTrailingPathSeparator path
if BS.null path then return entries'
else return (dir : entries')
else return [path]
| path <- paths ]
packPaths :: RawFilePath -> [RawFilePath] -> IO [Entry]
packPaths baseDir paths =
join <$> interleave
[ do let tarpath = toTarPath isDir relpath
if isDir then packDirectoryEntry filepath tarpath
else packFileEntry filepath tarpath
| relpath <- paths
, let isDir = FilePath.Posix.hasTrailingPathSeparator filepath
filepath = baseDir </> relpath ]
interleave :: [IO a] -> IO [a]
interleave = unsafeInterleaveIO . go
where
go [] = return []
go (x:xs) = do
x' <- x
xs' <- interleave xs
return (x':xs')
packFileEntry :: RawFilePath
-> These SplitError TarPath
-> IO [Entry]
packFileEntry filepath tarpath = do
mtime <- getModTime filepath
executable <- isExecutable filepath
file <- openFd filepath SPI.ReadOnly [] Nothing >>= SPI.fdToHandle
size <- hFileSize file
content <- L.hGetContents file
let entry tp = (simpleEntry tp (NormalFile content (fromIntegral size))) {
entryPermissions = if executable then executableFilePermissions
else ordinaryFilePermissions,
entryTime = mtime
}
case tarpath of
This e -> fail $ show e
That tp -> return [entry tp]
These _ tp -> do
let lEntry = longLinkEntry filepath
return [lEntry, entry tp]
packDirectoryEntry :: RawFilePath
-> These SplitError TarPath
-> IO [Entry]
packDirectoryEntry filepath tarpath = do
mtime <- getModTime filepath
let dEntry tp = (directoryEntry tp) {
entryTime = mtime
}
case tarpath of
This e -> fail $ show e
That tp -> return [dEntry tp]
These _ tp -> do
let lEntry = longLinkEntry filepath
return [lEntry, dEntry tp]
getDirectoryContentsRecursive :: RawFilePath -> IO [RawFilePath]
getDirectoryContentsRecursive dir0 =
fmap tail (recurseDirectories dir0 [BS.empty])
recurseDirectories :: RawFilePath -> [RawFilePath] -> IO [RawFilePath]
recurseDirectories _ [] = return []
recurseDirectories base (dir:dirs) = unsafeInterleaveIO $ do
(files, dirs') <- collect [] [] =<< (getDirsFiles' (base </> dir))
files' <- recurseDirectories base (dirs' ++ dirs)
return (dir : files ++ files')
where
collect files dirs' [] = return (reverse files, reverse dirs')
collect files dirs' (entry:entries) | isSpecialDirectoryEntry entry
= collect files dirs' entries
collect files dirs' (entry:entries) = do
let dirEntry = dir </> entry
dirEntry' = FilePath.Posix.addTrailingPathSeparator dirEntry
isDirectory <- doesDirectoryExist (base </> dirEntry)
if isDirectory
then collect files (dirEntry':dirs') entries
else collect (dirEntry:files) dirs' entries
getModTime :: RawFilePath -> IO EpochTime
getModTime path = do
t <- getModificationTime path
return . floor . utcTimeToPOSIXSeconds $ t