{-# 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 => 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 -> OsPath
filePathToOsPath -> OsPath
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
  [(OsPath, OsPath, Bool)]
uEntries <- [(OsPath, OsPath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsPath, OsPath, Bool)]
forall e.
Exception e =>
[(OsPath, OsPath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsPath, OsPath, Bool)]
unpackEntries [] GenEntries FilePath FilePath (Either e DecodeLongNamesError)
resolvedEntries
  let ([(OsPath, OsPath, Bool)]
hardlinks, [(OsPath, OsPath, Bool)]
symlinks) = ((OsPath, OsPath, Bool) -> Bool)
-> [(OsPath, OsPath, Bool)]
-> ([(OsPath, OsPath, Bool)], [(OsPath, OsPath, Bool)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(OsPath
_, OsPath
_, Bool
x) -> Bool
x) [(OsPath, OsPath, Bool)]
uEntries
  -- handle hardlinks first, in case a symlink points to it
  [(OsPath, OsPath, Bool)] -> IO ()
forall t. [(OsPath, OsPath, t)] -> IO ()
handleHardLinks [(OsPath, OsPath, Bool)]
hardlinks
  [(OsPath, OsPath, Bool)] -> IO ()
forall t. [(OsPath, OsPath, t)] -> IO ()
handleSymlinks [(OsPath, OsPath, Bool)]
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 =>
[(OsPath, OsPath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsPath, OsPath, Bool)]
unpackEntries [(OsPath, OsPath, Bool)]
_     (Fail Either e DecodeLongNamesError
err)      = (e -> IO [(OsPath, OsPath, Bool)])
-> (DecodeLongNamesError -> IO [(OsPath, OsPath, Bool)])
-> Either e DecodeLongNamesError
-> IO [(OsPath, OsPath, Bool)]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> IO [(OsPath, OsPath, Bool)]
forall e a. Exception e => e -> IO a
throwIO DecodeLongNamesError -> IO [(OsPath, OsPath, Bool)]
forall e a. Exception e => e -> IO a
throwIO Either e DecodeLongNamesError
err
    unpackEntries [(OsPath, OsPath, Bool)]
links GenEntries FilePath FilePath (Either e DecodeLongNamesError)
Done            = [(OsPath, OsPath, Bool)] -> IO [(OsPath, OsPath, Bool)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(OsPath, OsPath, Bool)]
links
    unpackEntries [(OsPath, OsPath, 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)
          [(OsPath, OsPath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsPath, OsPath, Bool)]
forall e.
Exception e =>
[(OsPath, OsPath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsPath, OsPath, Bool)]
unpackEntries [(OsPath, OsPath, 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)
          [(OsPath, OsPath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsPath, OsPath, Bool)]
forall e.
Exception e =>
[(OsPath, OsPath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsPath, OsPath, Bool)]
unpackEntries [(OsPath, OsPath, Bool)]
links GenEntries FilePath FilePath (Either e DecodeLongNamesError)
es
        HardLink FilePath
link -> do
          ([(OsPath, OsPath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsPath, OsPath, Bool)]
forall e.
Exception e =>
[(OsPath, OsPath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsPath, OsPath, Bool)]
unpackEntries ([(OsPath, OsPath, Bool)]
 -> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
 -> IO [(OsPath, OsPath, Bool)])
-> [(OsPath, OsPath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsPath, OsPath, Bool)]
forall a b. (a -> b) -> a -> b
$! Bool
-> FilePath
-> FilePath
-> [(OsPath, OsPath, Bool)]
-> [(OsPath, OsPath, Bool)]
forall t.
t
-> FilePath
-> FilePath
-> [(OsPath, OsPath, t)]
-> [(OsPath, OsPath, t)]
saveLink Bool
True (GenEntry FilePath FilePath -> FilePath
forall tarPath linkTarget. GenEntry tarPath linkTarget -> tarPath
entryTarPath GenEntry FilePath FilePath
entry) FilePath
link [(OsPath, OsPath, Bool)]
links) GenEntries FilePath FilePath (Either e DecodeLongNamesError)
es
        SymbolicLink FilePath
link -> do
          ([(OsPath, OsPath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsPath, OsPath, Bool)]
forall e.
Exception e =>
[(OsPath, OsPath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsPath, OsPath, Bool)]
unpackEntries ([(OsPath, OsPath, Bool)]
 -> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
 -> IO [(OsPath, OsPath, Bool)])
-> [(OsPath, OsPath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsPath, OsPath, Bool)]
forall a b. (a -> b) -> a -> b
$! Bool
-> FilePath
-> FilePath
-> [(OsPath, OsPath, Bool)]
-> [(OsPath, OsPath, Bool)]
forall t.
t
-> FilePath
-> FilePath
-> [(OsPath, OsPath, t)]
-> [(OsPath, OsPath, t)]
saveLink Bool
False (GenEntry FilePath FilePath -> FilePath
forall tarPath linkTarget. GenEntry tarPath linkTarget -> tarPath
entryTarPath GenEntry FilePath FilePath
entry) FilePath
link [(OsPath, OsPath, 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
          [(OsPath, OsPath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsPath, OsPath, Bool)]
forall e.
Exception e =>
[(OsPath, OsPath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsPath, OsPath, Bool)]
unpackEntries [(OsPath, OsPath, Bool)]
links GenEntries FilePath FilePath (Either e DecodeLongNamesError)
es
        CharacterDevice{} -> [(OsPath, OsPath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsPath, OsPath, Bool)]
forall e.
Exception e =>
[(OsPath, OsPath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsPath, OsPath, Bool)]
unpackEntries [(OsPath, OsPath, Bool)]
links GenEntries FilePath FilePath (Either e DecodeLongNamesError)
es
        BlockDevice{} -> [(OsPath, OsPath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsPath, OsPath, Bool)]
forall e.
Exception e =>
[(OsPath, OsPath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsPath, OsPath, Bool)]
unpackEntries [(OsPath, OsPath, Bool)]
links GenEntries FilePath FilePath (Either e DecodeLongNamesError)
es
        GenEntryContent FilePath
NamedPipe -> [(OsPath, OsPath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsPath, OsPath, Bool)]
forall e.
Exception e =>
[(OsPath, OsPath, Bool)]
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
-> IO [(OsPath, OsPath, Bool)]
unpackEntries [(OsPath, OsPath, Bool)]
links GenEntries FilePath FilePath (Either e DecodeLongNamesError)
es

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

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

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

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

filePathToNativeOsPath :: FilePath -> OsPath
filePathToNativeOsPath :: FilePath -> OsPath
filePathToNativeOsPath = FilePath -> OsPath
filePathToOsPath (FilePath -> OsPath)
-> (FilePath -> FilePath) -> FilePath -> OsPath
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 :: OsPath -> OsPath -> IO ()
copyDirectoryRecursive OsPath
srcDir OsPath
destDir = do
  [OsPath]
srcFiles <- OsPath -> IO [OsPath]
getDirectoryContentsRecursive OsPath
srcDir
  (OsPath -> OsPath -> IO ())
-> OsPath -> [(OsPath, OsPath)] -> IO ()
copyFilesWith OsPath -> OsPath -> IO ()
copyFile OsPath
destDir [ (OsPath
srcDir, OsPath
f)
                                   | OsPath
f <- [OsPath]
srcFiles ]
  where
    -- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
    -- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
    copyFilesWith :: (OsPath -> OsPath -> IO ())
                  -> OsPath -> [(OsPath, OsPath)] -> IO ()
    copyFilesWith :: (OsPath -> OsPath -> IO ())
-> OsPath -> [(OsPath, OsPath)] -> IO ()
copyFilesWith OsPath -> OsPath -> IO ()
doCopy OsPath
targetDir [(OsPath, OsPath)]
srcFiles = do

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

      -- Copy all the files
      [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ let src :: OsPath
src  = OsPath
srcBase   OsPath -> OsPath -> OsPath
</> OsPath
srcFile
                      dest :: OsPath
dest = OsPath
targetDir OsPath -> OsPath -> OsPath
</> OsPath
srcFile
                   in OsPath -> OsPath -> IO ()
doCopy OsPath
src OsPath
dest
                | (OsPath
srcBase, OsPath
srcFile) <- [(OsPath, OsPath)]
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 :: OsPath -> IO [OsPath]
getDirectoryContentsRecursive OsPath
topdir = [OsPath] -> IO [OsPath]
recurseDirectories [OsPath
forall a. Monoid a => a
mempty]
      where
        recurseDirectories :: [OsPath] -> IO [OsPath]
        recurseDirectories :: [OsPath] -> IO [OsPath]
recurseDirectories []         = [OsPath] -> IO [OsPath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        recurseDirectories (OsPath
dir:[OsPath]
dirs) = IO [OsPath] -> IO [OsPath]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [OsPath] -> IO [OsPath]) -> IO [OsPath] -> IO [OsPath]
forall a b. (a -> b) -> a -> b
$ do
          ([OsPath]
files, [OsPath]
dirs') <- [OsPath] -> [OsPath] -> [OsPath] -> IO ([OsPath], [OsPath])
collect [] [] ([OsPath] -> IO ([OsPath], [OsPath]))
-> IO [OsPath] -> IO ([OsPath], [OsPath])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< OsPath -> IO [OsPath]
listDirectory (OsPath
topdir OsPath -> OsPath -> OsPath
</> OsPath
dir)
          [OsPath]
files' <- [OsPath] -> IO [OsPath]
recurseDirectories ([OsPath]
dirs' [OsPath] -> [OsPath] -> [OsPath]
forall a. [a] -> [a] -> [a]
++ [OsPath]
dirs)
          [OsPath] -> IO [OsPath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([OsPath]
files [OsPath] -> [OsPath] -> [OsPath]
forall a. [a] -> [a] -> [a]
++ [OsPath]
files')

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

setModTime :: OsPath -> EpochTime -> IO ()
setModTime :: OsPath -> EpochTime -> IO ()
setModTime OsPath
path EpochTime
t =
    OsPath -> UTCTime -> IO ()
setModificationTime OsPath
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 :: OsPath -> Permissions -> IO ()
setOwnerPermissions :: OsPath -> Permissions -> IO ()
setOwnerPermissions OsPath
path Permissions
permissions =
  OsPath -> Permissions -> IO ()
setPermissions OsPath
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