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

{-# OPTIONS_HADDOCK hide #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use for_" #-}
{-# 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.Unpack (
  unpack,
  unpackAndCheck,
  ) where

import Codec.Archive.Tar.Types
import Codec.Archive.Tar.Check
import Codec.Archive.Tar.LongNames
import Codec.Archive.Tar.PackAscii (filePathToOsPath)

import Data.Bits
         ( testBit )
import Data.List (partition, nub)
import Data.Maybe ( fromMaybe )
import qualified Data.ByteString.Char8 as Char8
import qualified Data.ByteString.Lazy as BS
import Prelude hiding (writeFile)
import System.File.OsPath
import System.OsPath
         ( OsPath, (</>) )
import qualified System.OsPath as FilePath.Native
         ( takeDirectory )
import System.Directory.OsPath
    ( createDirectoryIfMissing,
      copyFile,
      setPermissions,
      listDirectory,
      doesDirectoryExist,
      createDirectoryLink,
      createFileLink,
      setModificationTime,
      emptyPermissions,
      setOwnerReadable,
      setOwnerWritable,
      setOwnerExecutable,
      setOwnerSearchable )
import Control.Exception
         ( Exception, throwIO, handle )
import System.IO ( stderr, hPutStr )
import System.IO.Error ( ioeGetErrorType, isPermissionError )
import GHC.IO (unsafeInterleaveIO)
import Data.Foldable (traverse_)
import GHC.IO.Exception (IOErrorType(InappropriateType, IllegalOperation, PermissionDenied, InvalidArgument))
import Data.Time.Clock.POSIX
         ( posixSecondsToUTCTime )
import Control.Exception as Exception
         ( catch, SomeException(..) )

-- | Create local files and directories based on the entries of a tar archive.
--
-- This is a portable implementation of unpacking suitable for portable
-- archives. It handles 'NormalFile' and 'Directory' entries and has simulated
-- support for 'SymbolicLink' and 'HardLink' entries. Links are implemented by
-- copying the target file. This therefore works on Windows as well as Unix.
-- All other entry types are ignored, that is they are not unpacked and no
-- exception is raised.
--
-- If the 'Entries' ends in an error then it is raised an an exception. Any
-- files or directories that have been unpacked before the error was
-- encountered will not be deleted. For this reason you may want to unpack
-- into an empty directory so that you can easily clean up if unpacking fails
-- part-way.
--
-- On its own, this function only checks for security (using 'checkEntrySecurity').
-- Use 'unpackAndCheck' if you need more checks.
--
unpack
  :: Exception e
  => FilePath
  -- ^ Base directory
  -> Entries e
  -- ^ Entries to upack
  -> IO ()
unpack :: forall e. Exception e => FilePath -> Entries e -> IO ()
unpack = (GenEntry FilePath FilePath -> Maybe SomeException)
-> FilePath -> Entries e -> IO ()
forall e.
Exception e =>
(GenEntry FilePath FilePath -> Maybe SomeException)
-> FilePath -> Entries e -> IO ()
unpackAndCheck ((FileNameError -> SomeException)
-> Maybe FileNameError -> Maybe SomeException
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileNameError -> SomeException
forall e. (Exception e, HasExceptionContext) => e -> SomeException
SomeException (Maybe FileNameError -> Maybe SomeException)
-> (GenEntry FilePath FilePath -> Maybe FileNameError)
-> GenEntry FilePath FilePath
-> Maybe SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenEntry FilePath FilePath -> Maybe FileNameError
checkEntrySecurity)

-- | Like 'Codec.Archive.Tar.unpack', but run custom sanity/security checks instead of 'checkEntrySecurity'.
-- For example,
--
-- > import Control.Exception (SomeException(..))
-- > import Control.Applicative ((<|>))
-- >
-- > unpackAndCheck (\x -> SomeException <$> checkEntryPortability x
-- >                   <|> SomeException <$> checkEntrySecurity x) dir entries
--
-- @since 0.6.0.0
unpackAndCheck
  :: Exception e
  => (GenEntry FilePath FilePath -> Maybe SomeException)
  -- ^ Checks to run on each entry before unpacking
  -> FilePath
  -- ^ Base directory
  -> Entries e
  -- ^ Entries to upack
  -> IO ()
unpackAndCheck :: forall e.
Exception e =>
(GenEntry FilePath FilePath -> Maybe SomeException)
-> FilePath -> Entries e -> IO ()
unpackAndCheck GenEntry FilePath FilePath -> Maybe SomeException
secCB (FilePath -> OsString
filePathToOsPath -> OsString
baseDir) Entries e
entries = do
  let resolvedEntries :: GenEntries FilePath FilePath (Either e DecodeLongNamesError)
resolvedEntries = Entries e
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
forall e.
Entries e
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
decodeLongNames Entries e
entries
  uEntries <- [(OsString, OsString, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsString, OsString, Bool)]
forall e.
Exception e =>
[(OsString, OsString, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsString, OsString, Bool)]
unpackEntries [] GenEntries FilePath FilePath (Either e DecodeLongNamesError)
resolvedEntries
  let (hardlinks, symlinks) = partition (\(OsString
_, OsString
_, Bool
x) -> Bool
x) uEntries
  -- handle hardlinks first, in case a symlink points to it
  handleHardLinks hardlinks
  handleSymlinks symlinks

  where
    -- We're relying here on 'secCB' to make sure we're not scribbling
    -- files all over the place.

    unpackEntries :: Exception e
                  => [(OsPath, OsPath, Bool)]
                  -- ^ links (path, link, isHardLink)
                  -> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
                  -- ^ entries
                  -> IO [(OsPath, OsPath, Bool)]
    unpackEntries :: forall e.
Exception e =>
[(OsString, OsString, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsString, OsString, Bool)]
unpackEntries [(OsString, OsString, Bool)]
_     (Fail Either e DecodeLongNamesError
err)      = (e -> IO [(OsString, OsString, Bool)])
-> (DecodeLongNamesError -> IO [(OsString, OsString, Bool)])
-> Either e DecodeLongNamesError
-> IO [(OsString, OsString, Bool)]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> IO [(OsString, OsString, Bool)]
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO DecodeLongNamesError -> IO [(OsString, OsString, Bool)]
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO Either e DecodeLongNamesError
err
    unpackEntries [(OsString, OsString, Bool)]
links GenEntries FilePath FilePath (Either e DecodeLongNamesError)
Done            = [(OsString, OsString, Bool)] -> IO [(OsString, OsString, Bool)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(OsString, OsString, Bool)]
links
    unpackEntries [(OsString, OsString, Bool)]
links (Next GenEntry FilePath FilePath
entry GenEntries FilePath FilePath (Either e DecodeLongNamesError)
es) = do
      case GenEntry FilePath FilePath -> Maybe SomeException
secCB GenEntry FilePath FilePath
entry of
        Maybe SomeException
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just SomeException
e -> SomeException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
e

      case GenEntry FilePath FilePath -> GenEntryContent FilePath
forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
entryContent GenEntry FilePath FilePath
entry of
        NormalFile ByteString
file Int64
_ -> do
          Permissions -> FilePath -> ByteString -> Int64 -> IO ()
extractFile (GenEntry FilePath FilePath -> Permissions
forall tarPath linkTarget.
GenEntry tarPath linkTarget -> Permissions
entryPermissions GenEntry FilePath FilePath
entry) (GenEntry FilePath FilePath -> FilePath
forall tarPath linkTarget. GenEntry tarPath linkTarget -> tarPath
entryTarPath GenEntry FilePath FilePath
entry) ByteString
file (GenEntry FilePath FilePath -> Int64
forall tarPath linkTarget. GenEntry tarPath linkTarget -> Int64
entryTime GenEntry FilePath FilePath
entry)
          [(OsString, OsString, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsString, OsString, Bool)]
forall e.
Exception e =>
[(OsString, OsString, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsString, OsString, Bool)]
unpackEntries [(OsString, OsString, Bool)]
links GenEntries FilePath FilePath (Either e DecodeLongNamesError)
es
        GenEntryContent FilePath
Directory -> do
          FilePath -> Int64 -> IO ()
extractDir (GenEntry FilePath FilePath -> FilePath
forall tarPath linkTarget. GenEntry tarPath linkTarget -> tarPath
entryTarPath GenEntry FilePath FilePath
entry) (GenEntry FilePath FilePath -> Int64
forall tarPath linkTarget. GenEntry tarPath linkTarget -> Int64
entryTime GenEntry FilePath FilePath
entry)
          [(OsString, OsString, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsString, OsString, Bool)]
forall e.
Exception e =>
[(OsString, OsString, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsString, OsString, Bool)]
unpackEntries [(OsString, OsString, Bool)]
links GenEntries FilePath FilePath (Either e DecodeLongNamesError)
es
        HardLink FilePath
link -> do
          ([(OsString, OsString, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsString, OsString, Bool)]
forall e.
Exception e =>
[(OsString, OsString, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsString, OsString, Bool)]
unpackEntries ([(OsString, OsString, Bool)]
 -> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
 -> IO [(OsString, OsString, Bool)])
-> [(OsString, OsString, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsString, OsString, Bool)]
forall a b. (a -> b) -> a -> b
$! Bool
-> FilePath
-> FilePath
-> [(OsString, OsString, Bool)]
-> [(OsString, OsString, Bool)]
forall t.
t
-> FilePath
-> FilePath
-> [(OsString, OsString, t)]
-> [(OsString, OsString, t)]
saveLink Bool
True (GenEntry FilePath FilePath -> FilePath
forall tarPath linkTarget. GenEntry tarPath linkTarget -> tarPath
entryTarPath GenEntry FilePath FilePath
entry) FilePath
link [(OsString, OsString, Bool)]
links) GenEntries FilePath FilePath (Either e DecodeLongNamesError)
es
        SymbolicLink FilePath
link -> do
          ([(OsString, OsString, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsString, OsString, Bool)]
forall e.
Exception e =>
[(OsString, OsString, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsString, OsString, Bool)]
unpackEntries ([(OsString, OsString, Bool)]
 -> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
 -> IO [(OsString, OsString, Bool)])
-> [(OsString, OsString, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsString, OsString, Bool)]
forall a b. (a -> b) -> a -> b
$! Bool
-> FilePath
-> FilePath
-> [(OsString, OsString, Bool)]
-> [(OsString, OsString, Bool)]
forall t.
t
-> FilePath
-> FilePath
-> [(OsString, OsString, t)]
-> [(OsString, OsString, t)]
saveLink Bool
False (GenEntry FilePath FilePath -> FilePath
forall tarPath linkTarget. GenEntry tarPath linkTarget -> tarPath
entryTarPath GenEntry FilePath FilePath
entry) FilePath
link [(OsString, OsString, Bool)]
links) GenEntries FilePath FilePath (Either e DecodeLongNamesError)
es
        OtherEntryType{} ->
          -- the spec demands that we attempt to extract as normal file on unknown typecode,
          -- but we just skip it
          [(OsString, OsString, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsString, OsString, Bool)]
forall e.
Exception e =>
[(OsString, OsString, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsString, OsString, Bool)]
unpackEntries [(OsString, OsString, Bool)]
links GenEntries FilePath FilePath (Either e DecodeLongNamesError)
es
        CharacterDevice{} -> [(OsString, OsString, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsString, OsString, Bool)]
forall e.
Exception e =>
[(OsString, OsString, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsString, OsString, Bool)]
unpackEntries [(OsString, OsString, Bool)]
links GenEntries FilePath FilePath (Either e DecodeLongNamesError)
es
        BlockDevice{} -> [(OsString, OsString, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsString, OsString, Bool)]
forall e.
Exception e =>
[(OsString, OsString, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsString, OsString, Bool)]
unpackEntries [(OsString, OsString, Bool)]
links GenEntries FilePath FilePath (Either e DecodeLongNamesError)
es
        GenEntryContent FilePath
NamedPipe -> [(OsString, OsString, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsString, OsString, Bool)]
forall e.
Exception e =>
[(OsString, OsString, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsString, OsString, Bool)]
unpackEntries [(OsString, OsString, Bool)]
links GenEntries FilePath FilePath (Either e DecodeLongNamesError)
es

    extractFile :: Permissions -> FilePath -> BS.ByteString -> EpochTime -> IO ()
    extractFile :: Permissions -> FilePath -> ByteString -> Int64 -> IO ()
extractFile Permissions
permissions (FilePath -> OsString
filePathToNativeOsPath -> OsString
path) ByteString
content Int64
mtime = do
      -- Note that tar archives do not make sure each directory is created
      -- before files they contain, indeed we may have to create several
      -- levels of directory.
      Bool -> OsString -> IO ()
createDirectoryIfMissing Bool
True OsString
absDir
      OsString -> ByteString -> IO ()
writeFile OsString
absPath ByteString
content
      OsString -> Permissions -> IO ()
setOwnerPermissions OsString
absPath Permissions
permissions
      OsString -> Int64 -> IO ()
setModTime OsString
absPath Int64
mtime
      where
        absDir :: OsString
absDir  = OsString
baseDir OsString -> OsString -> OsString
</> OsString -> OsString
FilePath.Native.takeDirectory OsString
path
        absPath :: OsString
absPath = OsString
baseDir OsString -> OsString -> OsString
</> OsString
path

    extractDir :: FilePath -> EpochTime -> IO ()
    extractDir :: FilePath -> Int64 -> IO ()
extractDir (FilePath -> OsString
filePathToNativeOsPath -> OsString
path) Int64
mtime = do
      Bool -> OsString -> IO ()
createDirectoryIfMissing Bool
True OsString
absPath
      OsString -> Int64 -> IO ()
setModTime OsString
absPath Int64
mtime
      where
        absPath :: OsString
absPath = OsString
baseDir OsString -> OsString -> OsString
</> OsString
path

    saveLink
      :: t
      -> FilePath
      -> FilePath
      -> [(OsPath, OsPath, t)]
      -> [(OsPath, OsPath, t)]
    saveLink :: forall t.
t
-> FilePath
-> FilePath
-> [(OsString, OsString, t)]
-> [(OsString, OsString, t)]
saveLink t
isHardLink (FilePath -> OsString
filePathToNativeOsPath -> OsString
path) (FilePath -> OsString
filePathToNativeOsPath -> OsString
link) =
      OsString
path OsString
-> ([(OsString, OsString, t)] -> [(OsString, OsString, t)])
-> [(OsString, OsString, t)]
-> [(OsString, OsString, t)]
forall a b. a -> b -> b
`seq` OsString
link OsString
-> ([(OsString, OsString, t)] -> [(OsString, OsString, t)])
-> [(OsString, OsString, t)]
-> [(OsString, OsString, t)]
forall a b. a -> b -> b
`seq` ((OsString
path, OsString
link, t
isHardLink) (OsString, OsString, t)
-> [(OsString, OsString, t)] -> [(OsString, OsString, t)]
forall a. a -> [a] -> [a]
:)

    -- for hardlinks, we just copy
    handleHardLinks :: [(OsPath, OsPath, t)] -> IO ()
    handleHardLinks :: forall t. [(OsString, OsString, t)] -> IO ()
handleHardLinks = ((OsString, OsString, t) -> IO ())
-> [(OsString, OsString, t)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (((OsString, OsString, t) -> IO ())
 -> [(OsString, OsString, t)] -> IO ())
-> ((OsString, OsString, t) -> IO ())
-> [(OsString, OsString, t)]
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(OsString
relPath, OsString
relLinkTarget, t
_) ->
      let absPath :: OsString
absPath   = OsString
baseDir OsString -> OsString -> OsString
</> OsString
relPath
          -- hard links link targets are always "absolute" paths in
          -- the context of the tar root
          absTarget :: OsString
absTarget = OsString
baseDir OsString -> OsString -> OsString
</> OsString
relLinkTarget
      -- we don't expect races here, since we should be the
      -- only process unpacking the tar archive and writing to
      -- the destination
      in OsString -> IO Bool
doesDirectoryExist OsString
absTarget IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Bool
True -> OsString -> OsString -> IO ()
copyDirectoryRecursive OsString
absTarget OsString
absPath
          Bool
False -> OsString -> OsString -> IO ()
copyFile OsString
absTarget OsString
absPath

    -- For symlinks, we first try to recreate them and if that fails
    -- with 'IllegalOperation', 'PermissionDenied' or 'InvalidArgument',
    -- we fall back to copying.
    -- This error handling isn't too fine grained and maybe should be
    -- platform specific, but this way it might catch erros on unix even on
    -- FAT32 fuse mounted volumes.
    handleSymlinks :: [(OsPath, OsPath, c)] -> IO ()
    handleSymlinks :: forall t. [(OsString, OsString, t)] -> IO ()
handleSymlinks = ((OsString, OsString, c) -> IO ())
-> [(OsString, OsString, c)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (((OsString, OsString, c) -> IO ())
 -> [(OsString, OsString, c)] -> IO ())
-> ((OsString, OsString, c) -> IO ())
-> [(OsString, OsString, c)]
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(OsString
relPath, OsString
relLinkTarget, c
_) ->
      let absPath :: OsString
absPath   = OsString
baseDir OsString -> OsString -> OsString
</> OsString
relPath
          -- hard links link targets are always "absolute" paths in
          -- the context of the tar root
          absTarget :: OsString
absTarget = OsString -> OsString
FilePath.Native.takeDirectory OsString
absPath OsString -> OsString -> OsString
</> OsString
relLinkTarget
      -- we don't expect races here, since we should be the
      -- only process unpacking the tar archive and writing to
      -- the destination
      in OsString -> IO Bool
doesDirectoryExist OsString
absTarget IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Bool
True -> IO () -> IO () -> IO ()
forall {a}. IO a -> IO a -> IO a
handleSymlinkError (OsString -> OsString -> IO ()
copyDirectoryRecursive OsString
absTarget OsString
absPath)
            (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ OsString -> OsString -> IO ()
createDirectoryLink OsString
relLinkTarget OsString
absPath
          Bool
False -> IO () -> IO () -> IO ()
forall {a}. IO a -> IO a -> IO a
handleSymlinkError (OsString -> OsString -> IO ()
copyFile OsString
absTarget OsString
absPath)
            (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ OsString -> OsString -> IO ()
createFileLink OsString
relLinkTarget OsString
absPath

      where
        handleSymlinkError :: IO a -> IO a -> IO a
handleSymlinkError IO a
action =
          (IOException -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\IOException
e -> if IOException -> IOErrorType
ioeGetErrorType IOException
e IOErrorType -> [IOErrorType] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [IOErrorType
IllegalOperation
                                                    ,IOErrorType
PermissionDenied
                                                    ,IOErrorType
InvalidArgument]
                      then IO a
action
                      else IOException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO IOException
e
                 )

filePathToNativeOsPath :: FilePath -> OsPath
filePathToNativeOsPath :: FilePath -> OsString
filePathToNativeOsPath = FilePath -> OsString
filePathToOsPath (FilePath -> OsString)
-> (FilePath -> FilePath) -> FilePath -> OsString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
fromFilePathToNative

-- | Recursively copy the contents of one directory to another path.
--
-- This is a rip-off of Cabal library.
copyDirectoryRecursive :: OsPath -> OsPath -> IO ()
copyDirectoryRecursive :: OsString -> OsString -> IO ()
copyDirectoryRecursive OsString
srcDir OsString
destDir = do
  srcFiles <- OsString -> IO [OsString]
getDirectoryContentsRecursive OsString
srcDir
  copyFilesWith copyFile destDir [ (srcDir, f)
                                   | f <- srcFiles ]
  where
    -- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
    -- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
    copyFilesWith :: (OsPath -> OsPath -> IO ())
                  -> OsPath -> [(OsPath, OsPath)] -> IO ()
    copyFilesWith :: (OsString -> OsString -> IO ())
-> OsString -> [(OsString, OsString)] -> IO ()
copyFilesWith OsString -> OsString -> IO ()
doCopy OsString
targetDir [(OsString, OsString)]
srcFiles = do

      -- Create parent directories for everything
      let dirs :: [OsString]
dirs = (OsString -> OsString) -> [OsString] -> [OsString]
forall a b. (a -> b) -> [a] -> [b]
map (OsString
targetDir OsString -> OsString -> OsString
</>) ([OsString] -> [OsString])
-> ([(OsString, OsString)] -> [OsString])
-> [(OsString, OsString)]
-> [OsString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [OsString] -> [OsString]
forall a. Eq a => [a] -> [a]
nub ([OsString] -> [OsString])
-> ([(OsString, OsString)] -> [OsString])
-> [(OsString, OsString)]
-> [OsString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((OsString, OsString) -> OsString)
-> [(OsString, OsString)] -> [OsString]
forall a b. (a -> b) -> [a] -> [b]
map (OsString -> OsString
FilePath.Native.takeDirectory (OsString -> OsString)
-> ((OsString, OsString) -> OsString)
-> (OsString, OsString)
-> OsString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OsString, OsString) -> OsString
forall a b. (a, b) -> b
snd) ([(OsString, OsString)] -> [OsString])
-> [(OsString, OsString)] -> [OsString]
forall a b. (a -> b) -> a -> b
$ [(OsString, OsString)]
srcFiles
      (OsString -> IO ()) -> [OsString] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Bool -> OsString -> IO ()
createDirectoryIfMissing Bool
True) [OsString]
dirs

      -- Copy all the files
      [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ let src :: OsString
src  = OsString
srcBase   OsString -> OsString -> OsString
</> OsString
srcFile
                      dest :: OsString
dest = OsString
targetDir OsString -> OsString -> OsString
</> OsString
srcFile
                   in OsString -> OsString -> IO ()
doCopy OsString
src OsString
dest
                | (OsString
srcBase, OsString
srcFile) <- [(OsString, OsString)]
srcFiles ]

    -- | List all the files in a directory and all subdirectories.
    --
    -- The order places files in sub-directories after all the files in their
    -- parent directories. The list is generated lazily so is not well defined if
    -- the source directory structure changes before the list is used.
    --
    getDirectoryContentsRecursive :: OsPath -> IO [OsPath]
    getDirectoryContentsRecursive :: OsString -> IO [OsString]
getDirectoryContentsRecursive OsString
topdir = [OsString] -> IO [OsString]
recurseDirectories [OsString
forall a. Monoid a => a
mempty]
      where
        recurseDirectories :: [OsPath] -> IO [OsPath]
        recurseDirectories :: [OsString] -> IO [OsString]
recurseDirectories []         = [OsString] -> IO [OsString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        recurseDirectories (OsString
dir:[OsString]
dirs) = IO [OsString] -> IO [OsString]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [OsString] -> IO [OsString]) -> IO [OsString] -> IO [OsString]
forall a b. (a -> b) -> a -> b
$ do
          (files, dirs') <- [OsString]
-> [OsString] -> [OsString] -> IO ([OsString], [OsString])
collect [] [] ([OsString] -> IO ([OsString], [OsString]))
-> IO [OsString] -> IO ([OsString], [OsString])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< OsString -> IO [OsString]
listDirectory (OsString
topdir OsString -> OsString -> OsString
</> OsString
dir)
          files' <- recurseDirectories (dirs' ++ dirs)
          return (files ++ files')

          where
            collect :: [OsString]
-> [OsString] -> [OsString] -> IO ([OsString], [OsString])
collect [OsString]
files [OsString]
dirs' []              = ([OsString], [OsString]) -> IO ([OsString], [OsString])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([OsString] -> [OsString]
forall a. [a] -> [a]
reverse [OsString]
files
                                                         ,[OsString] -> [OsString]
forall a. [a] -> [a]
reverse [OsString]
dirs')
            collect [OsString]
files [OsString]
dirs' (OsString
entry:[OsString]
entries) = do
              let dirEntry :: OsString
dirEntry = OsString
dir OsString -> OsString -> OsString
</> OsString
entry
              isDirectory <- OsString -> IO Bool
doesDirectoryExist (OsString
topdir OsString -> OsString -> OsString
</> OsString
dirEntry)
              if isDirectory
                then collect files (dirEntry:dirs') entries
                else collect (dirEntry:files) dirs' entries

setModTime :: OsPath -> EpochTime -> IO ()
setModTime :: OsString -> Int64 -> IO ()
setModTime OsString
path Int64
t =
    OsString -> UTCTime -> IO ()
setModificationTime OsString
path (NominalDiffTime -> UTCTime
posixSecondsToUTCTime (Int64 -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
t))
      IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch` \IOException
e -> case IOException -> IOErrorType
ioeGetErrorType IOException
e of
        IOErrorType
PermissionDenied -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        -- On FAT32 file system setting time prior to DOS Epoch (1980-01-01)
        -- throws InvalidArgument, https://github.com/haskell/tar/issues/37
        IOErrorType
InvalidArgument -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        IOErrorType
_ -> IOException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO IOException
e

setOwnerPermissions :: OsPath -> Permissions -> IO ()
setOwnerPermissions :: OsString -> Permissions -> IO ()
setOwnerPermissions OsString
path Permissions
permissions =
  OsString -> Permissions -> IO ()
setPermissions OsString
path Permissions
ownerPermissions
  where
    -- | Info on Permission bits can be found here:
    -- https://www.gnu.org/software/libc/manual/html_node/Permission-Bits.html
    ownerPermissions :: Permissions
ownerPermissions =
      Bool -> Permissions -> Permissions
setOwnerReadable   (Permissions -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Permissions
permissions Int
8) (Permissions -> Permissions) -> Permissions -> Permissions
forall a b. (a -> b) -> a -> b
$
      Bool -> Permissions -> Permissions
setOwnerWritable   (Permissions -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Permissions
permissions Int
7) (Permissions -> Permissions) -> Permissions -> Permissions
forall a b. (a -> b) -> a -> b
$
      Bool -> Permissions -> Permissions
setOwnerExecutable (Permissions -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Permissions
permissions Int
6) (Permissions -> Permissions) -> Permissions -> Permissions
forall a b. (a -> b) -> a -> b
$
      Bool -> Permissions -> Permissions
setOwnerSearchable (Permissions -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Permissions
permissions Int
6)
      Permissions
emptyPermissions