{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_HADDOCK hide #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Avoid restricted function" #-}

-----------------------------------------------------------------------------
-- |
-- 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,
    pack',
    defaultRead,
    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.Int (Int64)
import Control.Applicative
import Prelude hiding (Applicative(..))
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, hClose )
import System.IO.Unsafe (unsafeInterleaveIO)
import Control.Exception (throwIO, SomeException)
import System.IO.Error (annotateIOError)

-- | 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', 'Directory' and 'SymbolicLink'
-- entries. Hard links are treated like ordinary files. Special files like
-- FIFOs (named pipes), sockets or device files will cause problems.
--
-- * This function returns results lazily. Subdirectories are scanned
-- and files are read one by one as the list of entries is consumed.
-- Do not change their contents before the output of 'Codec.Archive.Tar.pack' was consumed in full.
--
pack
  :: FilePath   -- ^ Base directory
  -> [FilePath] -- ^ Files and directories to pack, relative to the base dir
  -> IO [Entry]
pack :: FilePath -> [FilePath] -> IO [Entry]
pack = (GenEntry ByteString FilePath FilePath -> Maybe SomeException)
-> FilePath -> [FilePath] -> IO [Entry]
packAndCheck (Maybe SomeException
-> GenEntry ByteString FilePath FilePath -> Maybe SomeException
forall a b. a -> b -> a
const Maybe SomeException
forall a. Maybe a
Nothing)

-- | 'pack'' is like 'pack', but doesn't read the contents of files,
-- only creating entries with 'OsPath' as contents.
--
-- @since 0.7.0.0
pack'
  :: FilePath
  -> [FilePath]
  -> IO [GenEntry OsPath TarPath LinkTarget]
pack' :: FilePath -> [FilePath] -> IO [GenEntry OsPath TarPath LinkTarget]
pack' = (EpochTime -> OsPath -> IO OsPath)
-> (GenEntry OsPath FilePath FilePath -> Maybe SomeException)
-> FilePath
-> [FilePath]
-> IO [GenEntry OsPath TarPath LinkTarget]
forall content.
(EpochTime -> OsPath -> IO content)
-> (GenEntry content FilePath FilePath -> Maybe SomeException)
-> FilePath
-> [FilePath]
-> IO [GenEntry content TarPath LinkTarget]
packAndCheckWithRead (\EpochTime
_ -> OsPath -> IO OsPath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return) (Maybe SomeException
-> GenEntry OsPath FilePath FilePath -> Maybe SomeException
forall a b. a -> b -> a
const Maybe SomeException
forall a. Maybe a
Nothing)

-- | Like 'Codec.Archive.Tar.pack', but allows to specify additional sanity/security
-- checks on the input filenames. This is useful if you know which
-- check will be used on client side
-- in 'Codec.Archive.Tar.unpack' / 'Codec.Archive.Tar.unpackAndCheck'.
--
-- @since 0.6.0.0
packAndCheck
  :: (GenEntry BL.ByteString FilePath FilePath -> Maybe SomeException)
  -> FilePath   -- ^ Base directory
  -> [FilePath] -- ^ Files and directories to pack, relative to the base dir
  -> IO [Entry]
packAndCheck :: (GenEntry ByteString FilePath FilePath -> Maybe SomeException)
-> FilePath -> [FilePath] -> IO [Entry]
packAndCheck = (EpochTime -> OsPath -> IO ByteString)
-> (GenEntry ByteString FilePath FilePath -> Maybe SomeException)
-> FilePath
-> [FilePath]
-> IO [Entry]
forall content.
(EpochTime -> OsPath -> IO content)
-> (GenEntry content FilePath FilePath -> Maybe SomeException)
-> FilePath
-> [FilePath]
-> IO [GenEntry content TarPath LinkTarget]
packAndCheckWithRead EpochTime -> OsPath -> IO ByteString
defaultRead

packAndCheckWithRead
  :: (Int64 -> OsPath -> IO content)
  -> (GenEntry content FilePath FilePath -> Maybe SomeException)
  -> FilePath
  -> [FilePath]
  -> IO [GenEntry content TarPath LinkTarget]
packAndCheckWithRead :: forall content.
(EpochTime -> OsPath -> IO content)
-> (GenEntry content FilePath FilePath -> Maybe SomeException)
-> FilePath
-> [FilePath]
-> IO [GenEntry content TarPath LinkTarget]
packAndCheckWithRead EpochTime -> OsPath -> IO content
r GenEntry content 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 content OsPath OsPath]
entries' <- (EpochTime -> OsPath -> IO content)
-> OsPath -> [OsPath] -> IO [GenEntry content OsPath OsPath]
forall content.
(EpochTime -> OsPath -> IO content)
-> OsPath -> [OsPath] -> IO [GenEntry content OsPath OsPath]
packPathsWithRead EpochTime -> OsPath -> IO content
r OsPath
baseDir [OsPath]
paths
  let entries :: [GenEntry content FilePath FilePath]
entries = (GenEntry content OsPath OsPath
 -> GenEntry content FilePath FilePath)
-> [GenEntry content OsPath OsPath]
-> [GenEntry content FilePath FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ((OsPath -> FilePath)
-> (OsPath -> FilePath)
-> GenEntry content OsPath OsPath
-> GenEntry content FilePath FilePath
forall a b c d.
(a -> b)
-> (c -> d) -> GenEntry content a c -> GenEntry content 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 content OsPath OsPath]
entries'
  (GenEntry content FilePath FilePath -> IO ())
-> [GenEntry content 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 content FilePath FilePath -> Maybe SomeException)
-> GenEntry content FilePath FilePath
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenEntry content FilePath FilePath -> Maybe SomeException
secCB) [GenEntry content FilePath FilePath]
entries
  [GenEntry content TarPath LinkTarget]
-> IO [GenEntry content TarPath LinkTarget]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GenEntry content TarPath LinkTarget]
 -> IO [GenEntry content TarPath LinkTarget])
-> [GenEntry content TarPath LinkTarget]
-> IO [GenEntry content TarPath LinkTarget]
forall a b. (a -> b) -> a -> b
$ (GenEntry content FilePath FilePath
 -> [GenEntry content TarPath LinkTarget])
-> [GenEntry content FilePath FilePath]
-> [GenEntry content TarPath LinkTarget]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenEntry content FilePath FilePath
-> [GenEntry content TarPath LinkTarget]
forall content.
GenEntry content FilePath FilePath
-> [GenEntry content TarPath LinkTarget]
encodeLongNames [GenEntry content 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]
interleavedSequence ([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

-- | Pack paths while accounting for overlong filepaths.
packPathsWithRead
  :: (Int64 -> OsPath -> IO content)
  -> OsPath
  -> [OsPath]
  -> IO [GenEntry content OsPath OsPath]
packPathsWithRead :: forall content.
(EpochTime -> OsPath -> IO content)
-> OsPath -> [OsPath] -> IO [GenEntry content OsPath OsPath]
packPathsWithRead EpochTime -> OsPath -> IO content
r OsPath
baseDir [OsPath]
paths = [IO (GenEntry content OsPath OsPath)]
-> IO [GenEntry content OsPath OsPath]
forall a. [IO a] -> IO [a]
interleavedSequence ([IO (GenEntry content OsPath OsPath)]
 -> IO [GenEntry content OsPath OsPath])
-> [IO (GenEntry content OsPath OsPath)]
-> IO [GenEntry content OsPath OsPath]
forall a b. (a -> b) -> a -> b
$ ((OsPath -> IO (GenEntry content OsPath OsPath))
 -> [OsPath] -> [IO (GenEntry content OsPath OsPath)])
-> [OsPath]
-> (OsPath -> IO (GenEntry content OsPath OsPath))
-> [IO (GenEntry content OsPath OsPath)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (OsPath -> IO (GenEntry content OsPath OsPath))
-> [OsPath] -> [IO (GenEntry content OsPath OsPath)]
forall a b. (a -> b) -> [a] -> [b]
map [OsPath]
paths ((OsPath -> IO (GenEntry content OsPath OsPath))
 -> [IO (GenEntry content OsPath OsPath)])
-> (OsPath -> IO (GenEntry content OsPath OsPath))
-> [IO (GenEntry content 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 content tarPath OsPath)
mkEntry
        | Bool
isSymlink = OsPath -> tarPath -> IO (GenEntry content tarPath OsPath)
forall tarPath content.
OsPath -> tarPath -> IO (GenEntry content tarPath OsPath)
packSymlinkEntry'
        | Bool
isDir = OsPath -> tarPath -> IO (GenEntry content tarPath OsPath)
forall tarPath content linkTarget.
OsPath -> tarPath -> IO (GenEntry content tarPath linkTarget)
packDirectoryEntry'
        | Bool
otherwise = (EpochTime -> OsPath -> IO content)
-> OsPath -> tarPath -> IO (GenEntry content tarPath OsPath)
forall content tarPath linkTarget.
(EpochTime -> OsPath -> IO content)
-> OsPath -> tarPath -> IO (GenEntry content tarPath linkTarget)
packFileEntryWithRead' EpochTime -> OsPath -> IO content
r
  OsPath -> OsPath -> IO (GenEntry content OsPath OsPath)
forall {tarPath}.
OsPath -> tarPath -> IO (GenEntry content tarPath OsPath)
mkEntry OsPath
abspath OsPath
relpath

-- | As a normal 'sequence', but interleaving IO actions.
interleavedSequence :: [IO a] -> IO [a]
interleavedSequence :: forall a. [IO a] -> IO [a]
interleavedSequence =
  (IO a -> IO [a] -> IO [a]) -> IO [a] -> [IO a] -> IO [a]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((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]) -> IO [a] -> IO [a])
-> (IO a -> IO [a] -> IO [a]) -> IO a -> IO [a] -> IO [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [a] -> [a]) -> IO a -> IO [a] -> IO [a]
forall a b c. (a -> b -> c) -> IO a -> IO b -> IO c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:)) ([a] -> IO [a]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])

-- | 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 'GenEntry' in the archive
  -> IO (GenEntry BL.ByteString tarPath linkTarget)
packFileEntry :: forall tarPath linkTarget.
FilePath -> tarPath -> IO (GenEntry ByteString tarPath linkTarget)
packFileEntry = OsPath -> tarPath -> IO (GenEntry ByteString tarPath linkTarget)
forall tarPath linkTarget.
OsPath -> tarPath -> IO (GenEntry ByteString tarPath linkTarget)
packFileEntry' (OsPath -> tarPath -> IO (GenEntry ByteString tarPath linkTarget))
-> (FilePath -> OsPath)
-> FilePath
-> tarPath
-> IO (GenEntry ByteString tarPath linkTarget)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> OsPath
filePathToOsPath

packFileEntry'
  :: OsPath  -- ^ Full path to find the file on the local disk
  -> tarPath -- ^ Path to use for the tar 'GenEntry' in the archive
  -> IO (GenEntry BL.ByteString tarPath linkTarget)
packFileEntry' :: forall tarPath linkTarget.
OsPath -> tarPath -> IO (GenEntry ByteString tarPath linkTarget)
packFileEntry' OsPath
filepath tarPath
tarpath = do
  EpochTime
mtime   <- OsPath -> IO EpochTime
getModTime OsPath
filepath
  Permissions
perms   <- OsPath -> IO Permissions
getPermissions OsPath
filepath
  -- Get file size without opening it.
  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
    -- If file is short enough, just read it strictly
    -- so that no file handle dangles around indefinitely.
    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
      -- File size could have changed between measuring approxSize
      -- and here. Measuring again.
      Integer
sz <- Handle -> IO Integer
hFileSize Handle
hndl
      -- Lazy I/O at its best: once cnt is forced in full,
      -- BL.hGetContents will close the handle.
      ByteString
cnt <- Handle -> IO ByteString
BL.hGetContents Handle
hndl
      -- It would be wrong to return (cnt, BL.length sz):
      -- NormalFile constructor below forces size which in turn
      -- allocates entire cnt in memory at once.
      (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 ByteString tarPath linkTarget
-> IO (GenEntry ByteString tarPath linkTarget)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (tarPath
-> GenEntryContent ByteString linkTarget
-> GenEntry ByteString tarPath linkTarget
forall tarPath content linkTarget.
tarPath
-> GenEntryContent content linkTarget
-> GenEntry content tarPath linkTarget
simpleEntry tarPath
tarpath (ByteString -> EpochTime -> GenEntryContent ByteString linkTarget
forall content linkTarget.
content -> EpochTime -> GenEntryContent content linkTarget
NormalFile ByteString
content EpochTime
size))
    { entryPermissions =
      if executable perms then executableFilePermissions else ordinaryFilePermissions
    , entryTime = mtime
    }

-- |
--
-- @since 0.7.0.0
defaultRead
  :: Int64 -- ^ expected size
  -> OsPath
  -> IO BL.ByteString
defaultRead :: EpochTime -> OsPath -> IO ByteString
defaultRead EpochTime
approxSize OsPath
filepath = do
  if EpochTime
approxSize EpochTime -> EpochTime -> Bool
forall a. Ord a => a -> a -> Bool
< EpochTime
131072
    -- If file is short enough, just read it strictly
    -- so that no file handle dangles around indefinitely.
    then do
      ByteString
cnt <- OsPath -> IO ByteString
readFile' OsPath
filepath
      let sz :: EpochTime
sz = Int -> EpochTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
cnt) :: Int64
      if EpochTime
sz EpochTime -> EpochTime -> Bool
forall a. Eq a => a -> a -> Bool
/= EpochTime
approxSize
      then EpochTime -> IO ByteString
forall a. EpochTime -> IO a
throwWrongSize EpochTime
sz
      else ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> ByteString
BL.fromStrict ByteString
cnt)
    else do
      Handle
hndl <- OsPath -> IOMode -> IO Handle
openBinaryFile OsPath
filepath IOMode
ReadMode
      -- File size could have changed between measuring approxSize
      -- and here. Measuring again.
      EpochTime
sz <- Integer -> EpochTime
forall a. Num a => Integer -> a
fromInteger (Integer -> EpochTime) -> IO Integer -> IO EpochTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Integer
hFileSize Handle
hndl
      if EpochTime
sz EpochTime -> EpochTime -> Bool
forall a. Eq a => a -> a -> Bool
/= EpochTime
approxSize
      then do
        Handle -> IO ()
hClose Handle
hndl
        EpochTime -> IO ByteString
forall a. EpochTime -> IO a
throwWrongSize EpochTime
sz
      else do
        -- Lazy I/O at its best: once cnt is forced in full,
        -- BL.hGetContents will close the handle.
        ByteString
cnt <- Handle -> IO ByteString
BL.hGetContents Handle
hndl
        -- It would be wrong to return (cnt, BL.length sz):
        -- NormalFile constructor below forces size which in turn
        -- allocates entire cnt in memory at once.
        ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
cnt
  where
    throwWrongSize :: Int64 -> IO a
    throwWrongSize :: forall a. EpochTime -> IO a
throwWrongSize EpochTime
sz = do
        let msg :: FilePath
msg = FilePath
"File size changed, expecting " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ EpochTime -> FilePath
forall a. Show a => a -> FilePath
show EpochTime
approxSize FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"; got " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ EpochTime -> FilePath
forall a. Show a => a -> FilePath
show EpochTime
sz
        IOError -> IO a
forall a. IOError -> IO a
ioError (IOError -> FilePath -> Maybe Handle -> Maybe FilePath -> IOError
annotateIOError (FilePath -> IOError
userError FilePath
msg) FilePath
"defaultRead" Maybe Handle
forall a. Maybe a
Nothing (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (OsPath -> FilePath
osPathToFilePath OsPath
filepath)))

packFileEntryWithRead'
  :: (Int64 -> OsPath -> IO content)
  -> OsPath  -- ^ Full path to find the file on the local disk
  -> tarPath -- ^ Path to use for the tar 'GenEntry' in the archive
  -> IO (GenEntry content tarPath linkTarget)
packFileEntryWithRead' :: forall content tarPath linkTarget.
(EpochTime -> OsPath -> IO content)
-> OsPath -> tarPath -> IO (GenEntry content tarPath linkTarget)
packFileEntryWithRead' EpochTime -> OsPath -> IO content
r OsPath
filepath tarPath
tarpath = do
  EpochTime
mtime   <- OsPath -> IO EpochTime
getModTime OsPath
filepath
  Permissions
perms   <- OsPath -> IO Permissions
getPermissions OsPath
filepath
  -- Get file size without opening it.
  EpochTime
size <- Integer -> EpochTime
forall a. Num a => Integer -> a
fromInteger (Integer -> EpochTime) -> IO Integer -> IO EpochTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OsPath -> IO Integer
getFileSize OsPath
filepath
  content
content <- EpochTime -> OsPath -> IO content
r EpochTime
size OsPath
filepath

  GenEntry content tarPath linkTarget
-> IO (GenEntry content tarPath linkTarget)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (tarPath
-> GenEntryContent content linkTarget
-> GenEntry content tarPath linkTarget
forall tarPath content linkTarget.
tarPath
-> GenEntryContent content linkTarget
-> GenEntry content tarPath linkTarget
simpleEntry tarPath
tarpath (content -> EpochTime -> GenEntryContent content linkTarget
forall content linkTarget.
content -> EpochTime -> GenEntryContent content linkTarget
NormalFile content
content EpochTime
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 'GenEntry' in the archive
  -> IO (GenEntry content tarPath linkTarget)
packDirectoryEntry :: forall tarPath content linkTarget.
FilePath -> tarPath -> IO (GenEntry content tarPath linkTarget)
packDirectoryEntry = OsPath -> tarPath -> IO (GenEntry content tarPath linkTarget)
forall tarPath content linkTarget.
OsPath -> tarPath -> IO (GenEntry content tarPath linkTarget)
packDirectoryEntry' (OsPath -> tarPath -> IO (GenEntry content tarPath linkTarget))
-> (FilePath -> OsPath)
-> FilePath
-> tarPath
-> IO (GenEntry content tarPath linkTarget)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> OsPath
filePathToOsPath

packDirectoryEntry'
  :: OsPath  -- ^ Full path to find the file on the local disk
  -> tarPath -- ^ Path to use for the tar 'GenEntry' in the archive
  -> IO (GenEntry content tarPath linkTarget)
packDirectoryEntry' :: forall tarPath content linkTarget.
OsPath -> tarPath -> IO (GenEntry content tarPath linkTarget)
packDirectoryEntry' OsPath
filepath tarPath
tarpath = do
  EpochTime
mtime   <- OsPath -> IO EpochTime
getModTime OsPath
filepath
  GenEntry content tarPath linkTarget
-> IO (GenEntry content tarPath linkTarget)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (tarPath -> GenEntry content tarPath linkTarget
forall tarPath content linkTarget.
tarPath -> GenEntry content tarPath linkTarget
directoryEntry tarPath
tarpath) {
    entryTime = mtime
  }

-- | Construct a tar entry based on a local symlink.
--
-- @since 0.6.0.0
packSymlinkEntry
  :: FilePath -- ^ Full path to find the file on the local disk
  -> tarPath  -- ^ Path to use for the tar 'GenEntry' in the archive
  -> IO (GenEntry content tarPath FilePath)
packSymlinkEntry :: forall tarPath content.
FilePath -> tarPath -> IO (GenEntry content tarPath FilePath)
packSymlinkEntry = (((GenEntry content tarPath OsPath
 -> GenEntry content tarPath FilePath)
-> IO (GenEntry content tarPath OsPath)
-> IO (GenEntry content 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 content tarPath OsPath
-> GenEntry content tarPath FilePath
forall a b.
(a -> b)
-> GenEntry content tarPath a -> GenEntry content tarPath b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OsPath -> FilePath
osPathToFilePath) (IO (GenEntry content tarPath OsPath)
 -> IO (GenEntry content tarPath FilePath))
-> (tarPath -> IO (GenEntry content tarPath OsPath))
-> tarPath
-> IO (GenEntry content tarPath FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((tarPath -> IO (GenEntry content tarPath OsPath))
 -> tarPath -> IO (GenEntry content tarPath FilePath))
-> (OsPath -> tarPath -> IO (GenEntry content tarPath OsPath))
-> OsPath
-> tarPath
-> IO (GenEntry content tarPath FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OsPath -> tarPath -> IO (GenEntry content tarPath OsPath)
forall tarPath content.
OsPath -> tarPath -> IO (GenEntry content tarPath OsPath)
packSymlinkEntry') (OsPath -> tarPath -> IO (GenEntry content tarPath FilePath))
-> (FilePath -> OsPath)
-> FilePath
-> tarPath
-> IO (GenEntry content tarPath FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> OsPath
filePathToOsPath

packSymlinkEntry'
  :: OsPath  -- ^ Full path to find the file on the local disk
  -> tarPath -- ^ Path to use for the tar 'GenEntry' in the archive
  -> IO (GenEntry content tarPath OsPath)
packSymlinkEntry' :: forall tarPath content.
OsPath -> tarPath -> IO (GenEntry content tarPath OsPath)
packSymlinkEntry' OsPath
filepath tarPath
tarpath = do
  OsPath
linkTarget <- OsPath -> IO OsPath
getSymbolicLinkTarget OsPath
filepath
  GenEntry content tarPath OsPath
-> IO (GenEntry content tarPath OsPath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenEntry content tarPath OsPath
 -> IO (GenEntry content tarPath OsPath))
-> GenEntry content tarPath OsPath
-> IO (GenEntry content tarPath OsPath)
forall a b. (a -> b) -> a -> b
$ tarPath -> OsPath -> GenEntry content tarPath OsPath
forall tarPath linkTarget content.
tarPath -> linkTarget -> GenEntry content tarPath linkTarget
symlinkEntry tarPath
tarpath OsPath
linkTarget

getModTime :: OsPath -> IO EpochTime
getModTime :: OsPath -> IO EpochTime
getModTime OsPath
path = do
  -- The directory package switched to the new time package
  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