{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_HADDOCK hide #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Avoid restricted function" #-}
module Codec.Archive.Tar.Pack (
pack,
packAndCheck,
packFileEntry,
packDirectoryEntry,
packSymlinkEntry,
longLinkEntry,
) where
import Codec.Archive.Tar.LongNames
import Codec.Archive.Tar.PackAscii (filePathToOsPath, osPathToFilePath)
import Codec.Archive.Tar.Types
import Data.Bifunctor (bimap)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Foldable
import System.File.OsPath
import System.OsPath
( OsPath, (</>) )
import qualified System.OsPath as FilePath.Native
( addTrailingPathSeparator, hasTrailingPathSeparator )
import System.Directory.OsPath
( doesDirectoryExist, getModificationTime
, pathIsSymbolicLink, getSymbolicLinkTarget
, Permissions(..), getPermissions, getFileSize )
import qualified System.Directory.OsPath.Types as FT
import System.Directory.OsPath.Streaming (getDirectoryContentsRecursive)
import Data.Time.Clock.POSIX
( utcTimeToPOSIXSeconds )
import System.IO
( IOMode(ReadMode), hFileSize )
import System.IO.Unsafe (unsafeInterleaveIO)
import Control.Exception (throwIO, SomeException)
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 -> OsPath
filePathToOsPath -> OsPath
baseDir) ((FilePath -> OsPath) -> [FilePath] -> [OsPath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> OsPath
filePathToOsPath -> [OsPath]
relpaths) = do
[OsPath]
paths <- OsPath -> [OsPath] -> IO [OsPath]
preparePaths OsPath
baseDir [OsPath]
relpaths
[GenEntry OsPath OsPath]
entries' <- OsPath -> [OsPath] -> IO [GenEntry OsPath OsPath]
packPaths OsPath
baseDir [OsPath]
paths
let entries :: [GenEntry FilePath FilePath]
entries = (GenEntry OsPath OsPath -> GenEntry FilePath FilePath)
-> [GenEntry OsPath OsPath] -> [GenEntry FilePath FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ((OsPath -> FilePath)
-> (OsPath -> FilePath)
-> GenEntry OsPath OsPath
-> GenEntry FilePath FilePath
forall a b c d.
(a -> b) -> (c -> d) -> GenEntry a c -> GenEntry b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap OsPath -> FilePath
osPathToFilePath OsPath -> FilePath
osPathToFilePath) [GenEntry OsPath OsPath]
entries'
(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 :: OsPath -> [OsPath] -> IO [OsPath]
preparePaths :: OsPath -> [OsPath] -> IO [OsPath]
preparePaths OsPath
baseDir = ([[OsPath]] -> [OsPath]) -> IO [[OsPath]] -> IO [OsPath]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[OsPath]] -> [OsPath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[OsPath]] -> IO [OsPath])
-> ([OsPath] -> IO [[OsPath]]) -> [OsPath] -> IO [OsPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IO [OsPath]] -> IO [[OsPath]]
forall a. [IO a] -> IO [a]
interleave ([IO [OsPath]] -> IO [[OsPath]])
-> ([OsPath] -> [IO [OsPath]]) -> [OsPath] -> IO [[OsPath]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OsPath -> IO [OsPath]) -> [OsPath] -> [IO [OsPath]]
forall a b. (a -> b) -> [a] -> [b]
map OsPath -> IO [OsPath]
go
where
go :: OsPath -> IO [OsPath]
go :: OsPath -> IO [OsPath]
go OsPath
relpath = do
let abspath :: OsPath
abspath = OsPath
baseDir OsPath -> OsPath -> OsPath
</> OsPath
relpath
Bool
isDir <- OsPath -> IO Bool
doesDirectoryExist OsPath
abspath
Bool
isSymlink <- OsPath -> IO Bool
pathIsSymbolicLink OsPath
abspath
if Bool
isDir Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isSymlink then do
[(OsPath, FileType)]
entries <- OsPath -> IO [(OsPath, FileType)]
getDirectoryContentsRecursive OsPath
abspath
let entries' :: [OsPath]
entries' = ((OsPath, FileType) -> OsPath) -> [(OsPath, FileType)] -> [OsPath]
forall a b. (a -> b) -> [a] -> [b]
map ((OsPath
relpath OsPath -> OsPath -> OsPath
</>) (OsPath -> OsPath)
-> ((OsPath, FileType) -> OsPath) -> (OsPath, FileType) -> OsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OsPath, FileType) -> OsPath
addSeparatorIfDir) [(OsPath, FileType)]
entries
[OsPath] -> IO [OsPath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([OsPath] -> IO [OsPath]) -> [OsPath] -> IO [OsPath]
forall a b. (a -> b) -> a -> b
$ if OsPath
relpath OsPath -> OsPath -> Bool
forall a. Eq a => a -> a -> Bool
== OsPath
forall a. Monoid a => a
mempty
then [OsPath]
entries'
else OsPath -> OsPath
FilePath.Native.addTrailingPathSeparator OsPath
relpath OsPath -> [OsPath] -> [OsPath]
forall a. a -> [a] -> [a]
: [OsPath]
entries'
else [OsPath] -> IO [OsPath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [OsPath
relpath]
addSeparatorIfDir :: (OsPath, FileType) -> OsPath
addSeparatorIfDir (OsPath
fn, FileType
ty) = case FileType
ty of
FT.Directory{} -> OsPath -> OsPath
FilePath.Native.addTrailingPathSeparator OsPath
fn
FileType
_ -> OsPath
fn
packPaths
:: OsPath
-> [OsPath]
-> IO [GenEntry OsPath OsPath]
packPaths :: OsPath -> [OsPath] -> IO [GenEntry OsPath OsPath]
packPaths OsPath
baseDir [OsPath]
paths = [IO (GenEntry OsPath OsPath)] -> IO [GenEntry OsPath OsPath]
forall a. [IO a] -> IO [a]
interleave ([IO (GenEntry OsPath OsPath)] -> IO [GenEntry OsPath OsPath])
-> [IO (GenEntry OsPath OsPath)] -> IO [GenEntry OsPath OsPath]
forall a b. (a -> b) -> a -> b
$ ((OsPath -> IO (GenEntry OsPath OsPath))
-> [OsPath] -> [IO (GenEntry OsPath OsPath)])
-> [OsPath]
-> (OsPath -> IO (GenEntry OsPath OsPath))
-> [IO (GenEntry OsPath OsPath)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (OsPath -> IO (GenEntry OsPath OsPath))
-> [OsPath] -> [IO (GenEntry OsPath OsPath)]
forall a b. (a -> b) -> [a] -> [b]
map [OsPath]
paths ((OsPath -> IO (GenEntry OsPath OsPath))
-> [IO (GenEntry OsPath OsPath)])
-> (OsPath -> IO (GenEntry OsPath OsPath))
-> [IO (GenEntry OsPath OsPath)]
forall a b. (a -> b) -> a -> b
$ \OsPath
relpath -> do
let isDir :: Bool
isDir = OsPath -> Bool
FilePath.Native.hasTrailingPathSeparator OsPath
abspath
abspath :: OsPath
abspath = OsPath
baseDir OsPath -> OsPath -> OsPath
</> OsPath
relpath
Bool
isSymlink <- OsPath -> IO Bool
pathIsSymbolicLink OsPath
abspath
let mkEntry :: OsPath -> tarPath -> IO (GenEntry tarPath OsPath)
mkEntry
| Bool
isSymlink = OsPath -> tarPath -> IO (GenEntry tarPath OsPath)
forall tarPath. OsPath -> tarPath -> IO (GenEntry tarPath OsPath)
packSymlinkEntry'
| Bool
isDir = OsPath -> tarPath -> IO (GenEntry tarPath OsPath)
forall tarPath linkTarget.
OsPath -> tarPath -> IO (GenEntry tarPath linkTarget)
packDirectoryEntry'
| Bool
otherwise = OsPath -> tarPath -> IO (GenEntry tarPath OsPath)
forall tarPath linkTarget.
OsPath -> tarPath -> IO (GenEntry tarPath linkTarget)
packFileEntry'
OsPath -> OsPath -> IO (GenEntry OsPath OsPath)
forall tarPath. OsPath -> tarPath -> IO (GenEntry tarPath OsPath)
mkEntry OsPath
abspath OsPath
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 = OsPath -> tarPath -> IO (GenEntry tarPath linkTarget)
forall tarPath linkTarget.
OsPath -> tarPath -> IO (GenEntry tarPath linkTarget)
packFileEntry' (OsPath -> tarPath -> IO (GenEntry tarPath linkTarget))
-> (FilePath -> OsPath)
-> FilePath
-> tarPath
-> IO (GenEntry tarPath linkTarget)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> OsPath
filePathToOsPath
packFileEntry'
:: OsPath
-> tarPath
-> IO (GenEntry tarPath linkTarget)
packFileEntry' :: forall tarPath linkTarget.
OsPath -> tarPath -> IO (GenEntry tarPath linkTarget)
packFileEntry' OsPath
filepath tarPath
tarpath = do
EpochTime
mtime <- OsPath -> IO EpochTime
getModTime OsPath
filepath
Permissions
perms <- OsPath -> IO Permissions
getPermissions OsPath
filepath
Integer
approxSize <- OsPath -> IO Integer
getFileSize OsPath
filepath
(ByteString
content, EpochTime
size) <- if Integer
approxSize Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
131072
then do
ByteString
cnt <- OsPath -> IO ByteString
readFile' OsPath
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 <- OsPath -> IOMode -> IO Handle
openBinaryFile OsPath
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 = OsPath -> tarPath -> IO (GenEntry tarPath linkTarget)
forall tarPath linkTarget.
OsPath -> tarPath -> IO (GenEntry tarPath linkTarget)
packDirectoryEntry' (OsPath -> tarPath -> IO (GenEntry tarPath linkTarget))
-> (FilePath -> OsPath)
-> FilePath
-> tarPath
-> IO (GenEntry tarPath linkTarget)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> OsPath
filePathToOsPath
packDirectoryEntry'
:: OsPath
-> tarPath
-> IO (GenEntry tarPath linkTarget)
packDirectoryEntry' :: forall tarPath linkTarget.
OsPath -> tarPath -> IO (GenEntry tarPath linkTarget)
packDirectoryEntry' OsPath
filepath tarPath
tarpath = do
EpochTime
mtime <- OsPath -> IO EpochTime
getModTime OsPath
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 = (((GenEntry tarPath OsPath -> GenEntry tarPath FilePath)
-> IO (GenEntry tarPath OsPath) -> IO (GenEntry tarPath FilePath)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((OsPath -> FilePath)
-> GenEntry tarPath OsPath -> GenEntry tarPath FilePath
forall a b. (a -> b) -> GenEntry tarPath a -> GenEntry tarPath b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OsPath -> FilePath
osPathToFilePath) (IO (GenEntry tarPath OsPath) -> IO (GenEntry tarPath FilePath))
-> (tarPath -> IO (GenEntry tarPath OsPath))
-> tarPath
-> IO (GenEntry tarPath FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((tarPath -> IO (GenEntry tarPath OsPath))
-> tarPath -> IO (GenEntry tarPath FilePath))
-> (OsPath -> tarPath -> IO (GenEntry tarPath OsPath))
-> OsPath
-> tarPath
-> IO (GenEntry tarPath FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OsPath -> tarPath -> IO (GenEntry tarPath OsPath)
forall tarPath. OsPath -> tarPath -> IO (GenEntry tarPath OsPath)
packSymlinkEntry') (OsPath -> tarPath -> IO (GenEntry tarPath FilePath))
-> (FilePath -> OsPath)
-> FilePath
-> tarPath
-> IO (GenEntry tarPath FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> OsPath
filePathToOsPath
packSymlinkEntry'
:: OsPath
-> tarPath
-> IO (GenEntry tarPath OsPath)
packSymlinkEntry' :: forall tarPath. OsPath -> tarPath -> IO (GenEntry tarPath OsPath)
packSymlinkEntry' OsPath
filepath tarPath
tarpath = do
OsPath
linkTarget <- OsPath -> IO OsPath
getSymbolicLinkTarget OsPath
filepath
GenEntry tarPath OsPath -> IO (GenEntry tarPath OsPath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenEntry tarPath OsPath -> IO (GenEntry tarPath OsPath))
-> GenEntry tarPath OsPath -> IO (GenEntry tarPath OsPath)
forall a b. (a -> b) -> a -> b
$ tarPath -> OsPath -> GenEntry tarPath OsPath
forall tarPath linkTarget.
tarPath -> linkTarget -> GenEntry tarPath linkTarget
symlinkEntry tarPath
tarpath OsPath
linkTarget
getModTime :: OsPath -> IO EpochTime
getModTime :: OsPath -> IO EpochTime
getModTime OsPath
path = do
UTCTime
t <- OsPath -> IO UTCTime
getModificationTime OsPath
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