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

{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# OPTIONS_HADDOCK hide #-}
{-# HLINT ignore "Use for_" #-}

-----------------------------------------------------------------------------
-- |
-- 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 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 System.FilePath
         ( (</>) )
import qualified System.FilePath as FilePath.Native
         ( takeDirectory )
import System.Directory
    ( 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 => 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
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
  [(FilePath, FilePath, Bool)]
uEntries <- [(FilePath, FilePath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(FilePath, FilePath, Bool)]
forall e.
Exception e =>
[(FilePath, FilePath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(FilePath, FilePath, Bool)]
unpackEntries [] GenEntries FilePath FilePath (Either e DecodeLongNamesError)
resolvedEntries
  let ([(FilePath, FilePath, Bool)]
hardlinks, [(FilePath, FilePath, Bool)]
symlinks) = ((FilePath, FilePath, Bool) -> Bool)
-> [(FilePath, FilePath, Bool)]
-> ([(FilePath, FilePath, Bool)], [(FilePath, FilePath, Bool)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(FilePath
_, FilePath
_, Bool
x) -> Bool
x) [(FilePath, FilePath, Bool)]
uEntries
  -- handle hardlinks first, in case a symlink points to it
  [(FilePath, FilePath, Bool)] -> IO ()
forall {c}. [(FilePath, FilePath, c)] -> IO ()
handleHardLinks [(FilePath, FilePath, Bool)]
hardlinks
  [(FilePath, FilePath, Bool)] -> IO ()
forall {c}. [(FilePath, FilePath, c)] -> IO ()
handleSymlinks [(FilePath, FilePath, Bool)]
symlinks

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

    unpackEntries :: Exception e
                  => [(FilePath, FilePath, Bool)]
                  -- ^ links (path, link, isHardLink)
                  -> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
                  -- ^ entries
                  -> IO [(FilePath, FilePath, Bool)]
    unpackEntries :: forall e.
Exception e =>
[(FilePath, FilePath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(FilePath, FilePath, Bool)]
unpackEntries [(FilePath, FilePath, Bool)]
_     (Fail Either e DecodeLongNamesError
err)      = (e -> IO [(FilePath, FilePath, Bool)])
-> (DecodeLongNamesError -> IO [(FilePath, FilePath, Bool)])
-> Either e DecodeLongNamesError
-> IO [(FilePath, FilePath, Bool)]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> IO [(FilePath, FilePath, Bool)]
forall e a. Exception e => e -> IO a
throwIO DecodeLongNamesError -> IO [(FilePath, FilePath, Bool)]
forall e a. Exception e => e -> IO a
throwIO Either e DecodeLongNamesError
err
    unpackEntries [(FilePath, FilePath, Bool)]
links GenEntries FilePath FilePath (Either e DecodeLongNamesError)
Done            = [(FilePath, FilePath, Bool)] -> IO [(FilePath, FilePath, Bool)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(FilePath, FilePath, Bool)]
links
    unpackEntries [(FilePath, FilePath, 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. 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 EpochTime
_ -> do
          Permissions -> FilePath -> ByteString -> EpochTime -> 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 -> EpochTime
forall tarPath linkTarget. GenEntry tarPath linkTarget -> EpochTime
entryTime GenEntry FilePath FilePath
entry)
          [(FilePath, FilePath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(FilePath, FilePath, Bool)]
forall e.
Exception e =>
[(FilePath, FilePath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(FilePath, FilePath, Bool)]
unpackEntries [(FilePath, FilePath, Bool)]
links GenEntries FilePath FilePath (Either e DecodeLongNamesError)
es
        GenEntryContent FilePath
Directory -> do
          FilePath -> EpochTime -> IO ()
extractDir (GenEntry FilePath FilePath -> FilePath
forall tarPath linkTarget. GenEntry tarPath linkTarget -> tarPath
entryTarPath GenEntry FilePath FilePath
entry) (GenEntry FilePath FilePath -> EpochTime
forall tarPath linkTarget. GenEntry tarPath linkTarget -> EpochTime
entryTime GenEntry FilePath FilePath
entry)
          [(FilePath, FilePath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(FilePath, FilePath, Bool)]
forall e.
Exception e =>
[(FilePath, FilePath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(FilePath, FilePath, Bool)]
unpackEntries [(FilePath, FilePath, Bool)]
links GenEntries FilePath FilePath (Either e DecodeLongNamesError)
es
        HardLink FilePath
link -> do
          ([(FilePath, FilePath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(FilePath, FilePath, Bool)]
forall e.
Exception e =>
[(FilePath, FilePath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(FilePath, FilePath, Bool)]
unpackEntries ([(FilePath, FilePath, Bool)]
 -> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
 -> IO [(FilePath, FilePath, Bool)])
-> [(FilePath, FilePath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(FilePath, FilePath, Bool)]
forall a b. (a -> b) -> a -> b
$! Bool
-> FilePath
-> FilePath
-> [(FilePath, FilePath, Bool)]
-> [(FilePath, FilePath, Bool)]
forall {c}.
c
-> FilePath
-> FilePath
-> [(FilePath, FilePath, c)]
-> [(FilePath, FilePath, c)]
saveLink Bool
True (GenEntry FilePath FilePath -> FilePath
forall tarPath linkTarget. GenEntry tarPath linkTarget -> tarPath
entryTarPath GenEntry FilePath FilePath
entry) FilePath
link [(FilePath, FilePath, Bool)]
links) GenEntries FilePath FilePath (Either e DecodeLongNamesError)
es
        SymbolicLink FilePath
link -> do
          ([(FilePath, FilePath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(FilePath, FilePath, Bool)]
forall e.
Exception e =>
[(FilePath, FilePath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(FilePath, FilePath, Bool)]
unpackEntries ([(FilePath, FilePath, Bool)]
 -> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
 -> IO [(FilePath, FilePath, Bool)])
-> [(FilePath, FilePath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(FilePath, FilePath, Bool)]
forall a b. (a -> b) -> a -> b
$! Bool
-> FilePath
-> FilePath
-> [(FilePath, FilePath, Bool)]
-> [(FilePath, FilePath, Bool)]
forall {c}.
c
-> FilePath
-> FilePath
-> [(FilePath, FilePath, c)]
-> [(FilePath, FilePath, c)]
saveLink Bool
False (GenEntry FilePath FilePath -> FilePath
forall tarPath linkTarget. GenEntry tarPath linkTarget -> tarPath
entryTarPath GenEntry FilePath FilePath
entry) FilePath
link [(FilePath, FilePath, 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
          [(FilePath, FilePath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(FilePath, FilePath, Bool)]
forall e.
Exception e =>
[(FilePath, FilePath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(FilePath, FilePath, Bool)]
unpackEntries [(FilePath, FilePath, Bool)]
links GenEntries FilePath FilePath (Either e DecodeLongNamesError)
es
        CharacterDevice{} -> [(FilePath, FilePath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(FilePath, FilePath, Bool)]
forall e.
Exception e =>
[(FilePath, FilePath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(FilePath, FilePath, Bool)]
unpackEntries [(FilePath, FilePath, Bool)]
links GenEntries FilePath FilePath (Either e DecodeLongNamesError)
es
        BlockDevice{} -> [(FilePath, FilePath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(FilePath, FilePath, Bool)]
forall e.
Exception e =>
[(FilePath, FilePath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(FilePath, FilePath, Bool)]
unpackEntries [(FilePath, FilePath, Bool)]
links GenEntries FilePath FilePath (Either e DecodeLongNamesError)
es
        GenEntryContent FilePath
NamedPipe -> [(FilePath, FilePath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(FilePath, FilePath, Bool)]
forall e.
Exception e =>
[(FilePath, FilePath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(FilePath, FilePath, Bool)]
unpackEntries [(FilePath, FilePath, Bool)]
links GenEntries FilePath FilePath (Either e DecodeLongNamesError)
es

    extractFile :: Permissions -> FilePath -> ByteString -> EpochTime -> IO ()
extractFile Permissions
permissions (FilePath -> FilePath
fromFilePathToNative -> FilePath
path) ByteString
content EpochTime
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 -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
absDir
      FilePath -> ByteString -> IO ()
BS.writeFile FilePath
absPath ByteString
content
      FilePath -> Permissions -> IO ()
setOwnerPermissions FilePath
absPath Permissions
permissions
      FilePath -> EpochTime -> IO ()
setModTime FilePath
absPath EpochTime
mtime
      where
        absDir :: FilePath
absDir  = FilePath
baseDir FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
FilePath.Native.takeDirectory FilePath
path
        absPath :: FilePath
absPath = FilePath
baseDir FilePath -> FilePath -> FilePath
</> FilePath
path

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

    saveLink :: c
-> FilePath
-> FilePath
-> [(FilePath, FilePath, c)]
-> [(FilePath, FilePath, c)]
saveLink c
isHardLink (FilePath -> FilePath
fromFilePathToNative -> FilePath
path) (FilePath -> FilePath
fromFilePathToNative -> FilePath
link) [(FilePath, FilePath, c)]
links
      = Int -> [(FilePath, FilePath, c)] -> [(FilePath, FilePath, c)]
forall a b. a -> b -> b
seq (FilePath -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
path)
          ([(FilePath, FilePath, c)] -> [(FilePath, FilePath, c)])
-> [(FilePath, FilePath, c)] -> [(FilePath, FilePath, c)]
forall a b. (a -> b) -> a -> b
$ Int -> [(FilePath, FilePath, c)] -> [(FilePath, FilePath, c)]
forall a b. a -> b -> b
seq (FilePath -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
link)
          ([(FilePath, FilePath, c)] -> [(FilePath, FilePath, c)])
-> [(FilePath, FilePath, c)] -> [(FilePath, FilePath, c)]
forall a b. (a -> b) -> a -> b
$ (FilePath
path, FilePath
link, c
isHardLink)(FilePath, FilePath, c)
-> [(FilePath, FilePath, c)] -> [(FilePath, FilePath, c)]
forall a. a -> [a] -> [a]
:[(FilePath, FilePath, c)]
links


    -- for hardlinks, we just copy
    handleHardLinks :: [(FilePath, FilePath, c)] -> IO ()
handleHardLinks = ((FilePath, FilePath, c) -> IO ())
-> [(FilePath, FilePath, c)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (((FilePath, FilePath, c) -> IO ())
 -> [(FilePath, FilePath, c)] -> IO ())
-> ((FilePath, FilePath, c) -> IO ())
-> [(FilePath, FilePath, c)]
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(FilePath
relPath, FilePath
relLinkTarget, c
_) ->
      let absPath :: FilePath
absPath   = FilePath
baseDir FilePath -> FilePath -> FilePath
</> FilePath
relPath
          -- hard links link targets are always "absolute" paths in
          -- the context of the tar root
          absTarget :: FilePath
absTarget = FilePath
baseDir FilePath -> FilePath -> FilePath
</> FilePath
relLinkTarget
      -- we don't expect races here, since we should be the
      -- only process unpacking the tar archive and writing to
      -- the destination
      in FilePath -> IO Bool
doesDirectoryExist FilePath
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 -> FilePath -> FilePath -> IO ()
copyDirectoryRecursive FilePath
absTarget FilePath
absPath
          Bool
False -> FilePath -> FilePath -> IO ()
copyFile FilePath
absTarget FilePath
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 :: [(FilePath, FilePath, c)] -> IO ()
handleSymlinks = ((FilePath, FilePath, c) -> IO ())
-> [(FilePath, FilePath, c)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (((FilePath, FilePath, c) -> IO ())
 -> [(FilePath, FilePath, c)] -> IO ())
-> ((FilePath, FilePath, c) -> IO ())
-> [(FilePath, FilePath, c)]
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(FilePath
relPath, FilePath
relLinkTarget, c
_) ->
      let absPath :: FilePath
absPath   = FilePath
baseDir FilePath -> FilePath -> FilePath
</> FilePath
relPath
          -- hard links link targets are always "absolute" paths in
          -- the context of the tar root
          absTarget :: FilePath
absTarget = FilePath -> FilePath
FilePath.Native.takeDirectory FilePath
absPath FilePath -> FilePath -> FilePath
</> FilePath
relLinkTarget
      -- we don't expect races here, since we should be the
      -- only process unpacking the tar archive and writing to
      -- the destination
      in FilePath -> IO Bool
doesDirectoryExist FilePath
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 (FilePath -> FilePath -> IO ()
copyDirectoryRecursive FilePath
absTarget FilePath
absPath)
            (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
createDirectoryLink FilePath
relLinkTarget FilePath
absPath
          Bool
False -> IO () -> IO () -> IO ()
forall {a}. IO a -> IO a -> IO a
handleSymlinkError (FilePath -> FilePath -> IO ()
copyFile FilePath
absTarget FilePath
absPath)
            (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
createFileLink FilePath
relLinkTarget FilePath
absPath

      where
        handleSymlinkError :: IO a -> IO a -> IO a
handleSymlinkError IO a
action =
          (IOError -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\IOError
e -> if IOError -> IOErrorType
ioeGetErrorType IOError
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 IOError -> IO a
forall e a. Exception e => e -> IO a
throwIO IOError
e
                 )

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

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

      -- Copy all the files
      [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ let src :: FilePath
src  = FilePath
srcBase   FilePath -> FilePath -> FilePath
</> FilePath
srcFile
                      dest :: FilePath
dest = FilePath
targetDir FilePath -> FilePath -> FilePath
</> FilePath
srcFile
                   in FilePath -> FilePath -> IO ()
doCopy FilePath
src FilePath
dest
                | (FilePath
srcBase, FilePath
srcFile) <- [(FilePath, FilePath)]
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 :: FilePath -> IO [FilePath]
    getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive FilePath
topdir = [FilePath] -> IO [FilePath]
recurseDirectories [FilePath
""]
      where
        recurseDirectories :: [FilePath] -> IO [FilePath]
        recurseDirectories :: [FilePath] -> IO [FilePath]
recurseDirectories []         = [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        recurseDirectories (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]
listDirectory (FilePath
topdir FilePath -> FilePath -> FilePath
</> FilePath
dir)
          [FilePath]
files' <- [FilePath] -> IO [FilePath]
recurseDirectories ([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]
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) = do
              let dirEntry :: FilePath
dirEntry = FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
entry
              Bool
isDirectory <- FilePath -> IO Bool
doesDirectoryExist (FilePath
topdir FilePath -> FilePath -> FilePath
</> FilePath
dirEntry)
              if Bool
isDirectory
                then [FilePath]
-> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
collect [FilePath]
files (FilePath
dirEntryFilePath -> [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

setModTime :: FilePath -> EpochTime -> IO ()
setModTime :: FilePath -> EpochTime -> IO ()
setModTime FilePath
path EpochTime
t =
    FilePath -> UTCTime -> IO ()
setModificationTime FilePath
path (POSIXTime -> UTCTime
posixSecondsToUTCTime (EpochTime -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral EpochTime
t))
      IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch` \IOError
e -> case IOError -> IOErrorType
ioeGetErrorType IOError
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
_ -> IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOError
e

setOwnerPermissions :: FilePath -> Permissions -> IO ()
setOwnerPermissions :: FilePath -> Permissions -> IO ()
setOwnerPermissions FilePath
path Permissions
permissions =
  FilePath -> Permissions -> IO ()
setPermissions FilePath
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 -> Permissions) -> Permissions -> Permissions
forall a b. (a -> b) -> a -> b
$
      Permissions
emptyPermissions