    {-# 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 a b. IO a -> (a -> IO b) -> IO b
    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 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])
    -> 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 a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null FilePath
    path then [FilePath] -> IO [FilePath]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [FilePath]
    entries'
                                    else [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]
    entries')
               else [FilePath] -> IO [FilePath]
    forall a. a -> IO a
    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 a. FilePath -> IO a
    forall (m :: * -> *) a. MonadFail m => FilePath -> m a
    fail TarPath -> IO TarPath
    forall a. a -> IO a
    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 = 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')

    -- | 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 a. a -> IO a
    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 = if executable perms then executableFilePermissions
                                               else ordinaryFilePermissions,
        entryTime = 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 a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TarPath -> Entry
    directoryEntry TarPath
    tarpath) {
        entryTime = 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 a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap [FilePath] -> [FilePath]
    forall a. HasCallStack => [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 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]
    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 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) | 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 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
    #else
      (TOD s _) <- getModificationTime path
      return $! fromIntegral s
    #endif