{-# LANGUAGE CPP #-}
{-# OPTIONS_HADDOCK hide #-}
module Distribution.Compat.CopyFile (
  copyFile,
  copyFileChanged,
  filesEqual,
  copyOrdinaryFile,
  copyExecutableFile,
  setFileOrdinary,
  setFileExecutable,
  setDirOrdinary,
  ) where

import Prelude ()
import Distribution.Compat.Prelude

import Distribution.Compat.Exception

#ifndef mingw32_HOST_OS
import Distribution.Compat.Internal.TempFile

import Control.Exception
         ( bracketOnError, throwIO )
import qualified Data.ByteString.Lazy as BSL
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.Internals
         ( c_chmod, withFilePath )
import Foreign.C
         ( throwErrnoPathIfMinus1_ )

#else /* else mingw32_HOST_OS */

import Control.Exception
  ( throwIO )
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 -> NoCallStackIO ()
copyOrdinaryFile :: FilePath -> FilePath -> NoCallStackIO ()
copyOrdinaryFile   FilePath
src FilePath
dest = FilePath -> FilePath -> NoCallStackIO ()
copyFile FilePath
src FilePath
dest NoCallStackIO () -> NoCallStackIO () -> NoCallStackIO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> NoCallStackIO ()
setFileOrdinary   FilePath
dest
copyExecutableFile :: FilePath -> FilePath -> NoCallStackIO ()
copyExecutableFile FilePath
src FilePath
dest = FilePath -> FilePath -> NoCallStackIO ()
copyFile FilePath
src FilePath
dest NoCallStackIO () -> NoCallStackIO () -> NoCallStackIO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> NoCallStackIO ()
setFileExecutable FilePath
dest

setFileOrdinary,  setFileExecutable, setDirOrdinary  :: FilePath -> NoCallStackIO ()
#ifndef mingw32_HOST_OS
setFileOrdinary :: FilePath -> NoCallStackIO ()
setFileOrdinary   FilePath
path = FilePath -> FileMode -> NoCallStackIO ()
setFileMode FilePath
path FileMode
0o644 -- file perms -rw-r--r--
setFileExecutable :: FilePath -> NoCallStackIO ()
setFileExecutable FilePath
path = FilePath -> FileMode -> NoCallStackIO ()
setFileMode FilePath
path FileMode
0o755 -- file perms -rwxr-xr-x

setFileMode :: FilePath -> FileMode -> NoCallStackIO ()
setFileMode :: FilePath -> FileMode -> NoCallStackIO ()
setFileMode FilePath
name FileMode
m =
  FilePath -> (CString -> NoCallStackIO ()) -> NoCallStackIO ()
forall a. FilePath -> (CString -> IO a) -> IO a
withFilePath FilePath
name ((CString -> NoCallStackIO ()) -> NoCallStackIO ())
-> (CString -> NoCallStackIO ()) -> NoCallStackIO ()
forall a b. (a -> b) -> a -> b
$ \CString
s -> do
    FilePath -> FilePath -> IO CInt -> NoCallStackIO ()
forall a.
(Eq a, Num a) =>
FilePath -> FilePath -> IO a -> NoCallStackIO ()
throwErrnoPathIfMinus1_ FilePath
"setFileMode" FilePath
name (CString -> FileMode -> IO CInt
c_chmod CString
s FileMode
m)
#else
setFileOrdinary   _ = return ()
setFileExecutable _ = return ()
#endif
-- This happens to be true on Unix and currently on Windows too:
setDirOrdinary :: FilePath -> NoCallStackIO ()
setDirOrdinary = FilePath -> NoCallStackIO ()
setFileExecutable

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

      copyContents :: Handle -> Handle -> Ptr a -> NoCallStackIO ()
copyContents Handle
hFrom Handle
hTo Ptr a
buffer = do
              Int
count <- Handle -> Ptr a -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBuf Handle
hFrom Ptr a
buffer Int
bufferSize
              Bool -> NoCallStackIO () -> NoCallStackIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (NoCallStackIO () -> NoCallStackIO ())
-> NoCallStackIO () -> NoCallStackIO ()
forall a b. (a -> b) -> a -> b
$ do
                      Handle -> Ptr a -> Int -> NoCallStackIO ()
forall a. Handle -> Ptr a -> Int -> NoCallStackIO ()
hPutBuf Handle
hTo Ptr a
buffer Int
count
                      Handle -> Handle -> Ptr a -> NoCallStackIO ()
copyContents Handle
hFrom Handle
hTo Ptr a
buffer
#else
      copy = Win32.copyFile (toExtendedLengthPath fromFPath)
                            (toExtendedLengthPath toFPath)
                            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 path
  | isRelative path = path
  | otherwise =
      case normalisedPath of
        '\\' : '?'  : '?' : '\\' : _ -> normalisedPath
        '\\' : '\\' : '?' : '\\' : _ -> normalisedPath
        '\\' : '\\' : '.' : '\\' : _ -> normalisedPath
        '\\' : subpath@('\\' : _)    -> "\\\\?\\UNC" <> subpath
        _                            -> "\\\\?\\" <> normalisedPath
    where normalisedPath = simplifyWindows 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 "" = ""
simplifyWindows path =
  case drive' of
    "\\\\?\\" -> drive' <> subpath
    _ -> simplifiedPath
  where
    simplifiedPath = joinDrive drive' subpath'
    (drive, subpath) = splitDrive path
    drive' = upperDrive (normaliseTrailingSep (normalisePathSeps drive))
    subpath' = appendSep . avoidEmpty . prependSep . joinPath .
               stripPardirs . expandDots . skipSeps .
               splitDirectories $ subpath

    upperDrive d = case d of
      c : ':' : s | isAlpha c && all isPathSeparator s -> toUpper c : ':' : s
      _ -> d
    skipSeps = filter (not . (`elem` (pure <$> pathSeparators)))
    stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== "..")
                 | otherwise = id
    prependSep | subpathIsAbsolute = (pathSeparator :)
               | otherwise = id
    avoidEmpty | not pathIsAbsolute
                 && (null drive || hasTrailingPathSep) -- prefer "C:" over "C:."
                 = emptyToCurDir
               | otherwise = id
    appendSep p | hasTrailingPathSep
                  && not (pathIsAbsolute && null p)
                  = addTrailingPathSeparator p
                | otherwise = p
    pathIsAbsolute = not (isRelative path)
    subpathIsAbsolute = any isPathSeparator (take 1 subpath)
    hasTrailingPathSep = hasTrailingPathSeparator subpath

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

-- | Convert to the right kind of slashes.
normalisePathSeps :: FilePath -> FilePath
normalisePathSeps p = (\ c -> if isPathSeparator c then pathSeparator else c) <$> p

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

-- | Convert empty paths to the current directory, otherwise leave it
-- unchanged.
emptyToCurDir :: FilePath -> FilePath
emptyToCurDir ""   = "."
emptyToCurDir path = 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 -> NoCallStackIO ()
copyFileChanged :: FilePath -> FilePath -> NoCallStackIO ()
copyFileChanged FilePath
src FilePath
dest = do
  Bool
equal <- FilePath -> FilePath -> NoCallStackIO Bool
filesEqual FilePath
src FilePath
dest
  Bool -> NoCallStackIO () -> NoCallStackIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
equal (NoCallStackIO () -> NoCallStackIO ())
-> NoCallStackIO () -> NoCallStackIO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> NoCallStackIO ()
copyFile FilePath
src FilePath
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 -> NoCallStackIO Bool
filesEqual :: FilePath -> FilePath -> NoCallStackIO Bool
filesEqual FilePath
f1 FilePath
f2 = do
  Bool
ex1 <- FilePath -> NoCallStackIO Bool
doesFileExist FilePath
f1
  Bool
ex2 <- FilePath -> NoCallStackIO Bool
doesFileExist FilePath
f2
  if Bool -> Bool
not (Bool
ex1 Bool -> Bool -> Bool
&& Bool
ex2) then Bool -> NoCallStackIO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False else
    FilePath
-> IOMode -> (Handle -> NoCallStackIO Bool) -> NoCallStackIO Bool
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
f1 IOMode
ReadMode ((Handle -> NoCallStackIO Bool) -> NoCallStackIO Bool)
-> (Handle -> NoCallStackIO Bool) -> NoCallStackIO Bool
forall a b. (a -> b) -> a -> b
$ \Handle
h1 ->
      FilePath
-> IOMode -> (Handle -> NoCallStackIO Bool) -> NoCallStackIO Bool
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
f2 IOMode
ReadMode ((Handle -> NoCallStackIO Bool) -> NoCallStackIO Bool)
-> (Handle -> NoCallStackIO Bool) -> NoCallStackIO Bool
forall a b. (a -> b) -> a -> b
$ \Handle
h2 -> do
        Integer
s1 <- Handle -> IO Integer
hFileSize Handle
h1
        Integer
s2 <- Handle -> IO Integer
hFileSize Handle
h2
        if Integer
s1 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
s2
          then Bool -> NoCallStackIO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
          else do
            ByteString
c1 <- Handle -> IO ByteString
BSL.hGetContents Handle
h1
            ByteString
c2 <- Handle -> IO ByteString
BSL.hGetContents Handle
h2
            Bool -> NoCallStackIO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> NoCallStackIO Bool) -> Bool -> NoCallStackIO Bool
forall a b. (a -> b) -> a -> b
$! ByteString
c1 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
c2