{-# LANGUAGE CPP #-}
{-# OPTIONS_HADDOCK hide #-}

module Distribution.Compat.CopyFile
  ( copyFile
  , copyFileChanged
  , filesEqual
  , copyOrdinaryFile
  , copyExecutableFile
  , setFileOrdinary
  , setFileExecutable
  , setDirOrdinary
  ) where

import Distribution.Compat.Prelude
import Prelude ()

#ifndef mingw32_HOST_OS
import Distribution.Compat.Internal.TempFile

import Control.Exception
         ( bracketOnError )
import qualified Data.ByteString.Lazy as BSL
import Data.Bits
         ( (.|.) )
import System.IO.Error
         ( ioeSetLocation )
import System.Directory
         ( doesFileExist, renameFile, removeFile )
import System.FilePath
         ( takeDirectory )
import System.IO
         ( IOMode(ReadMode), hClose, hGetBuf, hPutBuf, hFileSize
         , withBinaryFile )
import Foreign
         ( allocaBytes )

import System.Posix.Types
         ( FileMode )
import System.Posix.Files
         ( getFileStatus, fileMode, setFileMode )

#else /* else mingw32_HOST_OS */

import qualified Data.ByteString.Lazy as BSL
import System.IO.Error
  ( ioeSetLocation )
import System.Directory
  ( doesFileExist )
import System.FilePath
  ( addTrailingPathSeparator
  , hasTrailingPathSeparator
  , isPathSeparator
  , isRelative
  , joinDrive
  , joinPath
  , pathSeparator
  , pathSeparators
  , splitDirectories
  , splitDrive
  )
import System.IO
  ( IOMode(ReadMode), hFileSize
  , withBinaryFile )

import qualified System.Win32.File as Win32 ( copyFile )
#endif /* mingw32_HOST_OS */

copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO ()
copyOrdinaryFile :: [Char] -> [Char] -> IO ()
copyOrdinaryFile [Char]
src [Char]
dest = [Char] -> [Char] -> IO ()
copyFile [Char]
src [Char]
dest IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> IO ()
setFileOrdinary [Char]
dest
copyExecutableFile :: [Char] -> [Char] -> IO ()
copyExecutableFile [Char]
src [Char]
dest = [Char] -> [Char] -> IO ()
copyFile [Char]
src [Char]
dest IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> IO ()
setFileExecutable [Char]
dest

setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO ()
#ifndef mingw32_HOST_OS
-- When running with a restrictive UMASK such as 0077 we still want to
-- install files and directories that are accessible to other users.
setFileOrdinary   path = addFileMode path 0o644 -- file perms -rw-r--r--
setFileExecutable path = addFileMode path 0o755 -- file perms -rwxr-xr-x

addFileMode :: FilePath -> FileMode -> IO ()
addFileMode name m = do
  o <- fileMode <$> getFileStatus name
  setFileMode name (m .|. o)
#else
setFileOrdinary :: [Char] -> IO ()
setFileOrdinary   [Char]
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
setFileExecutable :: [Char] -> IO ()
setFileExecutable [Char]
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif
-- This happens to be true on Unix and currently on Windows too:
setDirOrdinary :: [Char] -> IO ()
setDirOrdinary = [Char] -> IO ()
setFileExecutable

-- | Copies a file to a new destination.
-- Often you should use `copyFileChanged` instead.
copyFile :: FilePath -> FilePath -> IO ()
copyFile :: [Char] -> [Char] -> IO ()
copyFile [Char]
fromFPath [Char]
toFPath =
  IO ()
copy
    IO () -> (IOException -> IO ()) -> IO ()
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` (\IOException
ioe -> IOException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (IOException -> [Char] -> IOException
ioeSetLocation IOException
ioe [Char]
"copyFile"))
  where
#ifndef mingw32_HOST_OS
      copy = withBinaryFile fromFPath ReadMode $ \hFrom ->
             bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) ->
             do allocaBytes bufferSize $ copyContents hFrom hTmp
                hClose hTmp
                renameFile tmpFPath toFPath
      openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp"
      cleanTmp (tmpFPath, hTmp) = do
        hClose hTmp          `catchIO` \_ -> return ()
        removeFile tmpFPath  `catchIO` \_ -> return ()
      bufferSize = 4096

      copyContents hFrom hTo buffer = do
              count <- hGetBuf hFrom buffer bufferSize
              when (count > 0) $ do
                      hPutBuf hTo buffer count
                      copyContents hFrom hTo buffer
#else
      copy :: IO ()
copy = [Char] -> [Char] -> Bool -> IO ()
Win32.copyFile ([Char] -> [Char]
toExtendedLengthPath [Char]
fromFPath)
                            ([Char] -> [Char]
toExtendedLengthPath [Char]
toFPath)
                            Bool
False

-- NOTE: Shamelessly lifted from System.Directory.Internal.Windows

-- | Add the @"\\\\?\\"@ prefix if necessary or possible.  The path remains
-- unchanged if the prefix is not added.  This function can sometimes be used
-- to bypass the @MAX_PATH@ length restriction in Windows API calls.
--
-- See Note [Path normalization].
toExtendedLengthPath :: FilePath -> FilePath
toExtendedLengthPath :: [Char] -> [Char]
toExtendedLengthPath [Char]
path
  | [Char] -> Bool
isRelative [Char]
path = [Char]
path
  | Bool
otherwise =
      case [Char]
normalisedPath of
        Char
'\\' : Char
'?'  : Char
'?' : Char
'\\' : [Char]
_ -> [Char]
normalisedPath
        Char
'\\' : Char
'\\' : Char
'?' : Char
'\\' : [Char]
_ -> [Char]
normalisedPath
        Char
'\\' : Char
'\\' : Char
'.' : Char
'\\' : [Char]
_ -> [Char]
normalisedPath
        Char
'\\' : subpath :: [Char]
subpath@(Char
'\\' : [Char]
_)    -> [Char]
"\\\\?\\UNC" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
subpath
        [Char]
_                            -> [Char]
"\\\\?\\" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
normalisedPath
    where normalisedPath :: [Char]
normalisedPath = [Char] -> [Char]
simplifyWindows [Char]
path

-- | Similar to 'normalise' but:
--
-- * empty paths stay empty,
-- * parent dirs (@..@) are expanded, and
-- * paths starting with @\\\\?\\@ are preserved.
--
-- The goal is to preserve the meaning of paths better than 'normalise'.
--
-- Note [Path normalization]
-- 'normalise' doesn't simplify path names but will convert / into \\
-- this would normally not be a problem as once the path hits the RTS we would
-- have simplified the path then.  However since we're calling the WIn32 API
-- directly we have to do the simplification before the call.  Without this the
-- path Z:// would become Z:\\\\ and when converted to a device path the path
-- becomes \\?\Z:\\\\ which is an invalid path.
--
-- This is not a bug in normalise as it explicitly states that it won't simplify
-- a FilePath.
simplifyWindows :: FilePath -> FilePath
simplifyWindows :: [Char] -> [Char]
simplifyWindows [Char]
"" = [Char]
""
simplifyWindows [Char]
path =
  case [Char]
drive' of
    [Char]
"\\\\?\\" -> [Char]
drive' [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
subpath
    [Char]
_ -> [Char]
simplifiedPath
  where
    simplifiedPath :: [Char]
simplifiedPath = [Char] -> [Char] -> [Char]
joinDrive [Char]
drive' [Char]
subpath'
    ([Char]
drive, [Char]
subpath) = [Char] -> ([Char], [Char])
splitDrive [Char]
path
    drive' :: [Char]
drive' = [Char] -> [Char]
upperDrive ([Char] -> [Char]
normaliseTrailingSep ([Char] -> [Char]
normalisePathSeps [Char]
drive))
    subpath' :: [Char]
subpath' = [Char] -> [Char]
appendSep ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
avoidEmpty ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
prependSep ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
joinPath ([[Char]] -> [Char]) -> ([Char] -> [[Char]]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
               [[Char]] -> [[Char]]
stripPardirs ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [[Char]]
expandDots ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [[Char]]
skipSeps ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
               [Char] -> [[Char]]
splitDirectories ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
subpath

    upperDrive :: [Char] -> [Char]
upperDrive [Char]
d = case [Char]
d of
      Char
c : Char
':' : [Char]
s | Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
&& (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isPathSeparator [Char]
s -> Char -> Char
toUpper Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Char
':' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
s
      [Char]
_ -> [Char]
d
    skipSeps :: [[Char]] -> [[Char]]
skipSeps = ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Char -> [Char]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> [Char]) -> [Char] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char]
pathSeparators)))
    stripPardirs :: [[Char]] -> [[Char]]
stripPardirs | Bool
pathIsAbsolute Bool -> Bool -> Bool
|| Bool
subpathIsAbsolute = ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"..")
                 | Bool
otherwise = [[Char]] -> [[Char]]
forall a. a -> a
id
    prependSep :: [Char] -> [Char]
prependSep | Bool
subpathIsAbsolute = (Char
pathSeparator Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:)
               | Bool
otherwise = [Char] -> [Char]
forall a. a -> a
id
    avoidEmpty :: [Char] -> [Char]
avoidEmpty | Bool -> Bool
not Bool
pathIsAbsolute
                 Bool -> Bool -> Bool
&& ([Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
drive Bool -> Bool -> Bool
|| Bool
hasTrailingPathSep) -- prefer "C:" over "C:."
                 = [Char] -> [Char]
emptyToCurDir
               | Bool
otherwise = [Char] -> [Char]
forall a. a -> a
id
    appendSep :: [Char] -> [Char]
appendSep [Char]
p | Bool
hasTrailingPathSep
                  Bool -> Bool -> Bool
&& Bool -> Bool
not (Bool
pathIsAbsolute Bool -> Bool -> Bool
&& [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
p)
                  = [Char] -> [Char]
addTrailingPathSeparator [Char]
p
                | Bool
otherwise = [Char]
p
    pathIsAbsolute :: Bool
pathIsAbsolute = Bool -> Bool
not ([Char] -> Bool
isRelative [Char]
path)
    subpathIsAbsolute :: Bool
subpathIsAbsolute = (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
isPathSeparator (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
1 [Char]
subpath)
    hasTrailingPathSep :: Bool
hasTrailingPathSep = [Char] -> Bool
hasTrailingPathSeparator [Char]
subpath

-- | Given a list of path segments, expand @.@ and @..@.  The path segments
-- must not contain path separators.
expandDots :: [FilePath] -> [FilePath]
expandDots :: [[Char]] -> [[Char]]
expandDots = [[Char]] -> [[Char]]
forall a. [a] -> [a]
reverse ([[Char]] -> [[Char]])
-> ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [[Char]] -> [[Char]]
go []
  where
    go :: [[Char]] -> [[Char]] -> [[Char]]
go [[Char]]
ys' [[Char]]
xs' =
      case [[Char]]
xs' of
        [] -> [[Char]]
ys'
        [Char]
x : [[Char]]
xs ->
          case [Char]
x of
            [Char]
"." -> [[Char]] -> [[Char]] -> [[Char]]
go [[Char]]
ys' [[Char]]
xs
            [Char]
".." ->
              case [[Char]]
ys' of
                [] -> [[Char]] -> [[Char]] -> [[Char]]
go ([Char]
x [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
ys') [[Char]]
xs
                [Char]
".." : [[Char]]
_ -> [[Char]] -> [[Char]] -> [[Char]]
go ([Char]
x [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
ys') [[Char]]
xs
                [Char]
_ : [[Char]]
ys -> [[Char]] -> [[Char]] -> [[Char]]
go [[Char]]
ys [[Char]]
xs
            [Char]
_ -> [[Char]] -> [[Char]] -> [[Char]]
go ([Char]
x [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
ys') [[Char]]
xs

-- | Convert to the right kind of slashes.
normalisePathSeps :: FilePath -> FilePath
normalisePathSeps :: [Char] -> [Char]
normalisePathSeps [Char]
p = (\ Char
c -> if Char -> Bool
isPathSeparator Char
c then Char
pathSeparator else Char
c) (Char -> Char) -> [Char] -> [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char]
p

-- | Remove redundant trailing slashes and pick the right kind of slash.
normaliseTrailingSep :: FilePath -> FilePath
normaliseTrailingSep :: [Char] -> [Char]
normaliseTrailingSep [Char]
path = do
  let path' :: [Char]
path' = [Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
path
  let ([Char]
sep, [Char]
path'') = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isPathSeparator [Char]
path'
  let addSep :: [Char] -> [Char]
addSep = if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
sep then [Char] -> [Char]
forall a. a -> a
id else (Char
pathSeparator Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:)
  [Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]
addSep [Char]
path'')

-- | Convert empty paths to the current directory, otherwise leave it
-- unchanged.
emptyToCurDir :: FilePath -> FilePath
emptyToCurDir :: [Char] -> [Char]
emptyToCurDir [Char]
""   = [Char]
"."
emptyToCurDir [Char]
path = [Char]
path
#endif /* mingw32_HOST_OS */

-- | Like `copyFile`, but does not touch the target if source and destination
-- are already byte-identical. This is recommended as it is useful for
-- time-stamp based recompilation avoidance.
copyFileChanged :: FilePath -> FilePath -> IO ()
copyFileChanged :: [Char] -> [Char] -> IO ()
copyFileChanged [Char]
src [Char]
dest = do
  equal <- [Char] -> [Char] -> IO Bool
filesEqual [Char]
src [Char]
dest
  unless equal $ copyFile src dest

-- | Checks if two files are byte-identical.
-- Returns False if either of the files do not exist or if files
-- are of different size.
filesEqual :: FilePath -> FilePath -> IO Bool
filesEqual :: [Char] -> [Char] -> IO Bool
filesEqual [Char]
f1 [Char]
f2 = do
  ex1 <- [Char] -> IO Bool
doesFileExist [Char]
f1
  ex2 <- doesFileExist f2
  if not (ex1 && ex2)
    then return False
    else withBinaryFile f1 ReadMode $ \Handle
h1 ->
      [Char] -> IOMode -> (Handle -> IO Bool) -> IO Bool
forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile [Char]
f2 IOMode
ReadMode ((Handle -> IO Bool) -> IO Bool) -> (Handle -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Handle
h2 -> do
        s1 <- Handle -> IO Integer
hFileSize Handle
h1
        s2 <- hFileSize h2
        if s1 /= s2
          then return False
          else do
            c1 <- BSL.hGetContents h1
            c2 <- BSL.hGetContents h2
            return $! c1 == c2