{-# LANGUAGE CPP #-}
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
( addTrailingPathSeparator, hasTrailingPathSeparator )
import System.Directory
( getDirectoryContents, doesDirectoryExist, getModificationTime
, Permissions(..), getPermissions )
#if MIN_VERSION_directory(1,2,0)
import Data.Time.Clock
( UTCTime )
import Data.Time.Clock.POSIX
( utcTimeToPOSIXSeconds )
#else
import System.Time
( ClockTime(..) )
#endif
import System.IO
( IOMode(ReadMode), openBinaryFile, hFileSize )
import System.IO.Unsafe (unsafeInterleaveIO)
pack :: FilePath
-> [FilePath]
-> IO [Entry]
pack :: FilePath -> [FilePath] -> IO [Entry]
pack FilePath
baseDir [FilePath]
paths0 = FilePath -> [FilePath] -> IO [FilePath]
preparePaths FilePath
baseDir [FilePath]
paths0 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> [FilePath] -> IO [Entry]
packPaths FilePath
baseDir
preparePaths :: FilePath -> [FilePath] -> IO [FilePath]
preparePaths :: FilePath -> [FilePath] -> IO [FilePath]
preparePaths FilePath
baseDir [FilePath]
paths =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. [IO a] -> IO [a]
interleave
[ do Bool
isDir <- FilePath -> IO Bool
doesDirectoryExist (FilePath
baseDir FilePath -> FilePath -> FilePath
</> FilePath
path)
if Bool
isDir
then do [FilePath]
entries <- FilePath -> IO [FilePath]
getDirectoryContentsRecursive (FilePath
baseDir FilePath -> FilePath -> FilePath
</> FilePath
path)
let entries' :: [FilePath]
entries' = forall a b. (a -> b) -> [a] -> [b]
map (FilePath
path FilePath -> FilePath -> FilePath
</>) [FilePath]
entries
dir :: FilePath
dir = FilePath -> FilePath
FilePath.Native.addTrailingPathSeparator FilePath
path
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
path then forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath]
entries'
else forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
dir forall a. a -> [a] -> [a]
: [FilePath]
entries')
else forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath
path]
| FilePath
path <- [FilePath]
paths ]
packPaths :: FilePath -> [FilePath] -> IO [Entry]
packPaths :: FilePath -> [FilePath] -> IO [Entry]
packPaths FilePath
baseDir [FilePath]
paths =
forall a. [IO a] -> IO [a]
interleave
[ do TarPath
tarpath <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> FilePath -> Either FilePath TarPath
toTarPath Bool
isDir FilePath
relpath)
if Bool
isDir then FilePath -> TarPath -> IO Entry
packDirectoryEntry FilePath
filepath TarPath
tarpath
else FilePath -> TarPath -> IO Entry
packFileEntry FilePath
filepath TarPath
tarpath
| FilePath
relpath <- [FilePath]
paths
, let isDir :: Bool
isDir = FilePath -> Bool
FilePath.Native.hasTrailingPathSeparator FilePath
filepath
filepath :: FilePath
filepath = FilePath
baseDir FilePath -> FilePath -> FilePath
</> FilePath
relpath ]
interleave :: [IO a] -> IO [a]
interleave :: forall a. [IO a] -> IO [a]
interleave = forall a. IO a -> IO a
unsafeInterleaveIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [IO a] -> IO [a]
go
where
go :: [IO a] -> IO [a]
go [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
go (IO a
x:[IO a]
xs) = do
a
x' <- IO a
x
[a]
xs' <- forall a. [IO a] -> IO [a]
interleave [IO a]
xs
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x'forall a. a -> [a] -> [a]
:[a]
xs')
packFileEntry :: FilePath
-> TarPath
-> IO Entry
packFileEntry :: FilePath -> TarPath -> IO Entry
packFileEntry FilePath
filepath TarPath
tarpath = do
EpochTime
mtime <- FilePath -> IO EpochTime
getModTime FilePath
filepath
Permissions
perms <- FilePath -> IO Permissions
getPermissions FilePath
filepath
Handle
file <- FilePath -> IOMode -> IO Handle
openBinaryFile FilePath
filepath IOMode
ReadMode
Integer
size <- Handle -> IO Integer
hFileSize Handle
file
ByteString
content <- Handle -> IO ByteString
BS.hGetContents Handle
file
forall (m :: * -> *) a. Monad m => a -> m a
return (TarPath -> EntryContent -> Entry
simpleEntry TarPath
tarpath (ByteString -> EpochTime -> EntryContent
NormalFile ByteString
content (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
size))) {
entryPermissions :: Permissions
entryPermissions = if Permissions -> Bool
executable Permissions
perms then Permissions
executableFilePermissions
else Permissions
ordinaryFilePermissions,
entryTime :: EpochTime
entryTime = EpochTime
mtime
}
packDirectoryEntry :: FilePath
-> TarPath
-> IO Entry
packDirectoryEntry :: FilePath -> TarPath -> IO Entry
packDirectoryEntry FilePath
filepath TarPath
tarpath = do
EpochTime
mtime <- FilePath -> IO EpochTime
getModTime FilePath
filepath
forall (m :: * -> *) a. Monad m => a -> m a
return (TarPath -> Entry
directoryEntry TarPath
tarpath) {
entryTime :: EpochTime
entryTime = EpochTime
mtime
}
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive FilePath
dir0 =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> [a]
tail (FilePath -> [FilePath] -> IO [FilePath]
recurseDirectories FilePath
dir0 [FilePath
""])
recurseDirectories :: FilePath -> [FilePath] -> IO [FilePath]
recurseDirectories :: FilePath -> [FilePath] -> IO [FilePath]
recurseDirectories FilePath
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
recurseDirectories FilePath
base (FilePath
dir:[FilePath]
dirs) = forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$ do
([FilePath]
files, [FilePath]
dirs') <- [FilePath]
-> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
collect [] [] forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO [FilePath]
getDirectoryContents (FilePath
base FilePath -> FilePath -> FilePath
</> FilePath
dir)
[FilePath]
files' <- FilePath -> [FilePath] -> IO [FilePath]
recurseDirectories FilePath
base ([FilePath]
dirs' forall a. [a] -> [a] -> [a]
++ [FilePath]
dirs)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
dir forall a. a -> [a] -> [a]
: [FilePath]
files forall a. [a] -> [a] -> [a]
++ [FilePath]
files')
where
collect :: [FilePath]
-> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
collect [FilePath]
files [FilePath]
dirs' [] = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse [FilePath]
files, forall a. [a] -> [a]
reverse [FilePath]
dirs')
collect [FilePath]
files [FilePath]
dirs' (FilePath
entry:[FilePath]
entries) | FilePath -> Bool
ignore FilePath
entry
= [FilePath]
-> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
collect [FilePath]
files [FilePath]
dirs' [FilePath]
entries
collect [FilePath]
files [FilePath]
dirs' (FilePath
entry:[FilePath]
entries) = do
let dirEntry :: FilePath
dirEntry = FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
entry
dirEntry' :: FilePath
dirEntry' = FilePath -> FilePath
FilePath.Native.addTrailingPathSeparator FilePath
dirEntry
Bool
isDirectory <- FilePath -> IO Bool
doesDirectoryExist (FilePath
base FilePath -> FilePath -> FilePath
</> FilePath
dirEntry)
if Bool
isDirectory
then [FilePath]
-> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
collect [FilePath]
files (FilePath
dirEntry'forall a. a -> [a] -> [a]
:[FilePath]
dirs') [FilePath]
entries
else [FilePath]
-> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
collect (FilePath
dirEntryforall a. a -> [a] -> [a]
:[FilePath]
files) [FilePath]
dirs' [FilePath]
entries
ignore :: FilePath -> Bool
ignore [Char
'.'] = Bool
True
ignore [Char
'.', Char
'.'] = Bool
True
ignore FilePath
_ = Bool
False
getModTime :: FilePath -> IO EpochTime
getModTime :: FilePath -> IO EpochTime
getModTime FilePath
path = do
#if MIN_VERSION_directory(1,2,0)
UTCTime
t <- FilePath -> IO UTCTime
getModificationTime FilePath
path
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
floor forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> POSIXTime
utcTimeToPOSIXSeconds forall a b. (a -> b) -> a -> b
$ UTCTime
t
#else
(TOD s _) <- getModificationTime path
return $! fromIntegral s
#endif