{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Codec.Archive.Tar
-- Copyright   :  (c) 2007 Bjorn Bringert,
--                    2008 Andrea Vezzosi,
--                    2008-2009, 2012, 2016 Duncan Coutts
-- License     :  BSD3
--
-- Maintainer  :  duncan@community.haskell.org
-- Portability :  portable
--
-----------------------------------------------------------------------------
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)
-- The directory package switched to the new time package
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)

-- | Creates a tar archive from a list of directory or files. Any directories
-- specified will have their contents included recursively. Paths in the
-- archive will be relative to the given base directory.
--
-- This is a portable implementation of packing suitable for portable archives.
-- In particular it only constructs 'NormalFile' and 'Directory' entries. Hard
-- links and symbolic links are treated like ordinary files. It cannot be used
-- to pack directories containing recursive symbolic links. Special files like
-- FIFOs (named pipes), sockets or device files will also cause problems.
--
-- An exception will be thrown for any file names that are too long to
-- represent as a 'TarPath'.
--
-- * This function returns results lazily. Subdirectories are scanned
-- and files are read one by one as the list of entries is consumed.
--
pack :: FilePath   -- ^ Base directory
     -> [FilePath] -- ^ Files and directories to pack, relative to the base dir
     -> IO [Entry]
pack :: FilePath -> [FilePath] -> IO [Entry]
pack FilePath
baseDir [FilePath]
paths0 = FilePath -> [FilePath] -> IO [FilePath]
preparePaths FilePath
baseDir [FilePath]
paths0 IO [FilePath] -> ([FilePath] -> IO [Entry]) -> IO [Entry]
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 =
  ([[FilePath]] -> [FilePath]) -> IO [[FilePath]] -> IO [FilePath]
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])
-> IO [[FilePath]] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ [IO [FilePath]] -> IO [[FilePath]]
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' = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
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 FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
path then [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath]
entries'
                                else [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
dir FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
entries')
           else [FilePath] -> IO [FilePath]
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 =
  [IO Entry] -> IO [Entry]
forall a. [IO a] -> IO [a]
interleave
    [ do TarPath
tarpath <- (FilePath -> IO TarPath)
-> (TarPath -> IO TarPath) -> Either FilePath TarPath -> IO TarPath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> IO TarPath
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail TarPath -> IO TarPath
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 :: [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 (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 (m :: * -> *) a. Monad m => a -> m a
return (a
x'a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs')

-- | Construct a tar 'Entry' based on a local file.
--
-- This sets the entry size, the data contained in the file and the file's
-- modification time. If the file is executable then that information is also
-- preserved. File ownership and detailed permissions are not preserved.
--
-- * The file contents is read lazily.
--
packFileEntry :: FilePath -- ^ Full path to find the file on the local disk
              -> TarPath  -- ^ Path to use for the tar Entry in the archive
              -> 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
  Entry -> IO Entry
forall (m :: * -> *) a. Monad m => a -> m a
return (TarPath -> EntryContent -> Entry
simpleEntry TarPath
tarpath (ByteString -> EpochTime -> EntryContent
NormalFile ByteString
content (Integer -> EpochTime
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
  }

-- | Construct a tar 'Entry' based on a local directory (but not its contents).
--
-- The only attribute of the directory that is used is its modification time.
-- Directory ownership and detailed permissions are not preserved.
--
packDirectoryEntry :: FilePath -- ^ Full path to find the file on the local disk
                   -> TarPath  -- ^ Path to use for the tar Entry in the archive
                   -> IO Entry
packDirectoryEntry :: FilePath -> TarPath -> IO Entry
packDirectoryEntry FilePath
filepath TarPath
tarpath = do
  EpochTime
mtime   <- FilePath -> IO EpochTime
getModTime FilePath
filepath
  Entry -> IO Entry
forall (m :: * -> *) a. Monad m => a -> m a
return (TarPath -> Entry
directoryEntry TarPath
tarpath) {
    entryTime :: EpochTime
entryTime = EpochTime
mtime
  }

-- | This is a utility function, much like 'getDirectoryContents'. The
-- difference is that it includes the contents of subdirectories.
--
-- The paths returned are all relative to the top directory. Directory paths
-- are distinguishable by having a trailing path separator
-- (see 'FilePath.Native.hasTrailingPathSeparator').
--
-- All directories are listed before the files that they contain. Amongst the
-- contents of a directory, subdirectories are listed after normal files. The
-- overall result is that files within a directory will be together in a single
-- contiguous group. This tends to improve file layout and IO performance when
-- creating or extracting tar archives.
--
-- * This function returns results lazily. Subdirectories are not scanned
-- until the files entries in the parent directory have been consumed.
--
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive FilePath
dir0 =
  ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [FilePath] -> [FilePath]
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
_    []         = [FilePath] -> IO [FilePath]
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]
getDirectoryContents (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 (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 (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) | 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'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

    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)
  -- The directory package switched to the new time package
  UTCTime
t <- FilePath -> IO UTCTime
getModificationTime FilePath
path
  EpochTime -> IO EpochTime
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 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
#else
  (TOD s _) <- getModificationTime path
  return $! fromIntegral s
#endif