{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_HADDOCK hide #-}
module Codec.Archive.Tar.Pack (
pack,
packAndCheck,
packFileEntry,
packDirectoryEntry,
packSymlinkEntry,
longLinkEntry,
getDirectoryContentsRecursive,
) where
import Codec.Archive.Tar.LongNames
import Codec.Archive.Tar.Types
import Control.Monad (join, when, forM, (>=>))
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Foldable
import System.FilePath
( (</>) )
import qualified System.FilePath as FilePath.Native
( addTrailingPathSeparator, hasTrailingPathSeparator, splitDirectories )
import System.Directory
( listDirectory, doesDirectoryExist, getModificationTime
, pathIsSymbolicLink, getSymbolicLinkTarget
, Permissions(..), getPermissions, getFileSize )
import Data.Time.Clock
( UTCTime )
import Data.Time.Clock.POSIX
( utcTimeToPOSIXSeconds )
import System.IO
( IOMode(ReadMode), openBinaryFile, hFileSize )
import System.IO.Unsafe (unsafeInterleaveIO)
import Control.Exception (throwIO, SomeException)
import Codec.Archive.Tar.Check.Internal (checkEntrySecurity)
pack
:: FilePath
-> [FilePath]
-> IO [Entry]
pack :: FilePath -> [FilePath] -> IO [Entry]
pack = (GenEntry FilePath FilePath -> Maybe SomeException)
-> FilePath -> [FilePath] -> IO [Entry]
packAndCheck (Maybe SomeException
-> GenEntry FilePath FilePath -> Maybe SomeException
forall a b. a -> b -> a
const Maybe SomeException
forall a. Maybe a
Nothing)
packAndCheck
:: (GenEntry FilePath FilePath -> Maybe SomeException)
-> FilePath
-> [FilePath]
-> IO [Entry]
packAndCheck :: (GenEntry FilePath FilePath -> Maybe SomeException)
-> FilePath -> [FilePath] -> IO [Entry]
packAndCheck GenEntry FilePath FilePath -> Maybe SomeException
secCB FilePath
baseDir [FilePath]
relpaths = do
[FilePath]
paths <- FilePath -> [FilePath] -> IO [FilePath]
preparePaths FilePath
baseDir [FilePath]
relpaths
[GenEntry FilePath FilePath]
entries <- FilePath -> [FilePath] -> IO [GenEntry FilePath FilePath]
packPaths FilePath
baseDir [FilePath]
paths
(GenEntry FilePath FilePath -> IO ())
-> [GenEntry FilePath FilePath] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (IO () -> (SomeException -> IO ()) -> Maybe SomeException -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (Maybe SomeException -> IO ())
-> (GenEntry FilePath FilePath -> Maybe SomeException)
-> GenEntry FilePath FilePath
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenEntry FilePath FilePath -> Maybe SomeException
secCB) [GenEntry FilePath FilePath]
entries
[Entry] -> IO [Entry]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Entry] -> IO [Entry]) -> [Entry] -> IO [Entry]
forall a b. (a -> b) -> a -> b
$ (GenEntry FilePath FilePath -> [Entry])
-> [GenEntry FilePath FilePath] -> [Entry]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenEntry FilePath FilePath -> [Entry]
encodeLongNames [GenEntry FilePath FilePath]
entries
preparePaths :: FilePath -> [FilePath] -> IO [FilePath]
preparePaths :: FilePath -> [FilePath] -> IO [FilePath]
preparePaths FilePath
baseDir = ([[FilePath]] -> [FilePath]) -> IO [[FilePath]] -> IO [FilePath]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[FilePath]] -> IO [FilePath])
-> ([FilePath] -> IO [[FilePath]]) -> [FilePath] -> IO [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IO [FilePath]] -> IO [[FilePath]]
forall a. [IO a] -> IO [a]
interleave ([IO [FilePath]] -> IO [[FilePath]])
-> ([FilePath] -> [IO [FilePath]]) -> [FilePath] -> IO [[FilePath]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> IO [FilePath]) -> [FilePath] -> [IO [FilePath]]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> IO [FilePath]
go
where
go :: FilePath -> IO [FilePath]
go FilePath
relpath = do
let abspath :: FilePath
abspath = FilePath
baseDir FilePath -> FilePath -> FilePath
</> FilePath
relpath
Bool
isDir <- FilePath -> IO Bool
doesDirectoryExist FilePath
abspath
Bool
isSymlink <- FilePath -> IO Bool
pathIsSymbolicLink FilePath
abspath
if Bool
isDir Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isSymlink then do
[FilePath]
entries <- FilePath -> IO [FilePath]
getDirectoryContentsRecursive FilePath
abspath
let entries' :: [FilePath]
entries' = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
relpath FilePath -> FilePath -> FilePath
</>) [FilePath]
entries
[FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ if FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
relpath
then [FilePath]
entries'
else FilePath -> FilePath
FilePath.Native.addTrailingPathSeparator FilePath
relpath FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
entries'
else [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath
relpath]
packPaths
:: FilePath
-> [FilePath]
-> IO [GenEntry FilePath FilePath]
packPaths :: FilePath -> [FilePath] -> IO [GenEntry FilePath FilePath]
packPaths FilePath
baseDir [FilePath]
paths = [IO (GenEntry FilePath FilePath)]
-> IO [GenEntry FilePath FilePath]
forall a. [IO a] -> IO [a]
interleave ([IO (GenEntry FilePath FilePath)]
-> IO [GenEntry FilePath FilePath])
-> [IO (GenEntry FilePath FilePath)]
-> IO [GenEntry FilePath FilePath]
forall a b. (a -> b) -> a -> b
$ ((FilePath -> IO (GenEntry FilePath FilePath))
-> [FilePath] -> [IO (GenEntry FilePath FilePath)])
-> [FilePath]
-> (FilePath -> IO (GenEntry FilePath FilePath))
-> [IO (GenEntry FilePath FilePath)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (FilePath -> IO (GenEntry FilePath FilePath))
-> [FilePath] -> [IO (GenEntry FilePath FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map [FilePath]
paths ((FilePath -> IO (GenEntry FilePath FilePath))
-> [IO (GenEntry FilePath FilePath)])
-> (FilePath -> IO (GenEntry FilePath FilePath))
-> [IO (GenEntry FilePath FilePath)]
forall a b. (a -> b) -> a -> b
$ \FilePath
relpath -> do
let isDir :: Bool
isDir = FilePath -> Bool
FilePath.Native.hasTrailingPathSeparator FilePath
abspath
abspath :: FilePath
abspath = FilePath
baseDir FilePath -> FilePath -> FilePath
</> FilePath
relpath
Bool
isSymlink <- FilePath -> IO Bool
pathIsSymbolicLink FilePath
abspath
let mkEntry :: FilePath -> tarPath -> IO (GenEntry tarPath FilePath)
mkEntry
| Bool
isSymlink = FilePath -> tarPath -> IO (GenEntry tarPath FilePath)
forall tarPath.
FilePath -> tarPath -> IO (GenEntry tarPath FilePath)
packSymlinkEntry
| Bool
isDir = FilePath -> tarPath -> IO (GenEntry tarPath FilePath)
forall tarPath linkTarget.
FilePath -> tarPath -> IO (GenEntry tarPath linkTarget)
packDirectoryEntry
| Bool
otherwise = FilePath -> tarPath -> IO (GenEntry tarPath FilePath)
forall tarPath linkTarget.
FilePath -> tarPath -> IO (GenEntry tarPath linkTarget)
packFileEntry
FilePath -> FilePath -> IO (GenEntry FilePath FilePath)
forall tarPath.
FilePath -> tarPath -> IO (GenEntry tarPath FilePath)
mkEntry FilePath
abspath FilePath
relpath
interleave :: [IO a] -> IO [a]
interleave :: forall a. [IO a] -> IO [a]
interleave = IO [a] -> IO [a]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [a] -> IO [a]) -> ([IO a] -> IO [a]) -> [IO a] -> IO [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IO a] -> IO [a]
forall a. [IO a] -> IO [a]
go
where
go :: [IO a] -> IO [a]
go [] = [a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
go (IO a
x:[IO a]
xs) = do
a
x' <- IO a
x
[a]
xs' <- [IO a] -> IO [a]
forall a. [IO a] -> IO [a]
interleave [IO a]
xs
[a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x'a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs')
packFileEntry
:: FilePath
-> tarPath
-> IO (GenEntry tarPath linkTarget)
packFileEntry :: forall tarPath linkTarget.
FilePath -> tarPath -> IO (GenEntry tarPath linkTarget)
packFileEntry FilePath
filepath tarPath
tarpath = do
EpochTime
mtime <- FilePath -> IO EpochTime
getModTime FilePath
filepath
Permissions
perms <- FilePath -> IO Permissions
getPermissions FilePath
filepath
Integer
approxSize <- FilePath -> IO Integer
getFileSize FilePath
filepath
(ByteString
content, EpochTime
size) <- if Integer
approxSize Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
131072
then do
ByteString
cnt <- FilePath -> IO ByteString
B.readFile FilePath
filepath
(ByteString, EpochTime) -> IO (ByteString, EpochTime)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> ByteString
BL.fromStrict ByteString
cnt, Int -> EpochTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> EpochTime) -> Int -> EpochTime
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
cnt)
else do
Handle
hndl <- FilePath -> IOMode -> IO Handle
openBinaryFile FilePath
filepath IOMode
ReadMode
Integer
sz <- Handle -> IO Integer
hFileSize Handle
hndl
ByteString
cnt <- Handle -> IO ByteString
BL.hGetContents Handle
hndl
(ByteString, EpochTime) -> IO (ByteString, EpochTime)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
cnt, Integer -> EpochTime
forall a. Num a => Integer -> a
fromInteger Integer
sz)
GenEntry tarPath linkTarget -> IO (GenEntry tarPath linkTarget)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (tarPath
-> GenEntryContent linkTarget -> GenEntry tarPath linkTarget
forall tarPath linkTarget.
tarPath
-> GenEntryContent linkTarget -> GenEntry tarPath linkTarget
simpleEntry tarPath
tarpath (ByteString -> EpochTime -> GenEntryContent linkTarget
forall linkTarget.
ByteString -> EpochTime -> GenEntryContent linkTarget
NormalFile ByteString
content EpochTime
size))
{ entryPermissions =
if executable perms then executableFilePermissions else ordinaryFilePermissions
, entryTime = mtime
}
packDirectoryEntry
:: FilePath
-> tarPath
-> IO (GenEntry tarPath linkTarget)
packDirectoryEntry :: forall tarPath linkTarget.
FilePath -> tarPath -> IO (GenEntry tarPath linkTarget)
packDirectoryEntry FilePath
filepath tarPath
tarpath = do
EpochTime
mtime <- FilePath -> IO EpochTime
getModTime FilePath
filepath
GenEntry tarPath linkTarget -> IO (GenEntry tarPath linkTarget)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (tarPath -> GenEntry tarPath linkTarget
forall tarPath linkTarget. tarPath -> GenEntry tarPath linkTarget
directoryEntry tarPath
tarpath) {
entryTime = mtime
}
packSymlinkEntry
:: FilePath
-> tarPath
-> IO (GenEntry tarPath FilePath)
packSymlinkEntry :: forall tarPath.
FilePath -> tarPath -> IO (GenEntry tarPath FilePath)
packSymlinkEntry FilePath
filepath tarPath
tarpath = do
FilePath
linkTarget <- FilePath -> IO FilePath
getSymbolicLinkTarget FilePath
filepath
GenEntry tarPath FilePath -> IO (GenEntry tarPath FilePath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenEntry tarPath FilePath -> IO (GenEntry tarPath FilePath))
-> GenEntry tarPath FilePath -> IO (GenEntry tarPath FilePath)
forall a b. (a -> b) -> a -> b
$ tarPath -> FilePath -> GenEntry tarPath FilePath
forall tarPath linkTarget.
tarPath -> linkTarget -> GenEntry tarPath linkTarget
symlinkEntry tarPath
tarpath FilePath
linkTarget
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive FilePath
dir0 =
([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
drop Int
1) (FilePath -> [FilePath] -> IO [FilePath]
recurseDirectories FilePath
dir0 [FilePath
""])
recurseDirectories :: FilePath -> [FilePath] -> IO [FilePath]
recurseDirectories :: FilePath -> [FilePath] -> IO [FilePath]
recurseDirectories FilePath
_ [] = [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
recurseDirectories FilePath
base (FilePath
dir:[FilePath]
dirs) = IO [FilePath] -> IO [FilePath]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ do
([FilePath]
files, [FilePath]
dirs') <- [FilePath]
-> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
collect [] [] ([FilePath] -> IO ([FilePath], [FilePath]))
-> IO [FilePath] -> IO ([FilePath], [FilePath])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO [FilePath]
listDirectory (FilePath
base FilePath -> FilePath -> FilePath
</> FilePath
dir)
[FilePath]
files' <- FilePath -> [FilePath] -> IO [FilePath]
recurseDirectories FilePath
base ([FilePath]
dirs' [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
dirs)
[FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
dir FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
files [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
files')
where
collect :: [FilePath]
-> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
collect [FilePath]
files [FilePath]
dirs' [] = ([FilePath], [FilePath]) -> IO ([FilePath], [FilePath])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse [FilePath]
files, [FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse [FilePath]
dirs')
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)
Bool
isSymlink <- FilePath -> IO Bool
pathIsSymbolicLink (FilePath
base FilePath -> FilePath -> FilePath
</> FilePath
dirEntry)
if Bool
isDirectory Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isSymlink
then [FilePath]
-> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
collect [FilePath]
files (FilePath
dirEntry'FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
dirs') [FilePath]
entries
else [FilePath]
-> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
collect (FilePath
dirEntryFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
files) [FilePath]
dirs' [FilePath]
entries
getModTime :: FilePath -> IO EpochTime
getModTime :: FilePath -> IO EpochTime
getModTime FilePath
path = do
UTCTime
t <- FilePath -> IO UTCTime
getModificationTime FilePath
path
EpochTime -> IO EpochTime
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (EpochTime -> IO EpochTime)
-> (UTCTime -> EpochTime) -> UTCTime -> IO EpochTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> EpochTime
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime -> EpochTime)
-> (UTCTime -> POSIXTime) -> UTCTime -> EpochTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> POSIXTime
utcTimeToPOSIXSeconds (UTCTime -> IO EpochTime) -> UTCTime -> IO EpochTime
forall a b. (a -> b) -> a -> b
$ UTCTime
t