{-# LANGUAGE CPP #-}
{-# OPTIONS_HADDOCK hide #-}
module Distribution.Compat.CopyFile (
copyFile,
copyFileChanged,
filesEqual,
copyOrdinaryFile,
copyExecutableFile,
setFileOrdinary,
setFileExecutable,
setDirOrdinary,
) where
import Prelude ()
import Distribution.Compat.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 :: FilePath -> FilePath -> IO ()
copyOrdinaryFile FilePath
src FilePath
dest = FilePath -> FilePath -> IO ()
copyFile FilePath
src FilePath
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
>> FilePath -> IO ()
setFileOrdinary FilePath
dest
copyExecutableFile :: FilePath -> FilePath -> IO ()
copyExecutableFile FilePath
src FilePath
dest = FilePath -> FilePath -> IO ()
copyFile FilePath
src FilePath
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
>> FilePath -> IO ()
setFileExecutable FilePath
dest
setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO ()
#ifndef mingw32_HOST_OS
setFileOrdinary :: FilePath -> IO ()
setFileOrdinary FilePath
path = FilePath -> FileMode -> IO ()
addFileMode FilePath
path FileMode
0o644
setFileExecutable :: FilePath -> IO ()
setFileExecutable FilePath
path = FilePath -> FileMode -> IO ()
addFileMode FilePath
path FileMode
0o755
addFileMode :: FilePath -> FileMode -> IO ()
addFileMode :: FilePath -> FileMode -> IO ()
addFileMode FilePath
name FileMode
m = do
FileMode
o <- FileStatus -> FileMode
fileMode (FileStatus -> FileMode) -> IO FileStatus -> IO FileMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FileStatus
getFileStatus FilePath
name
FilePath -> FileMode -> IO ()
setFileMode FilePath
name (FileMode
m FileMode -> FileMode -> FileMode
forall a. Bits a => a -> a -> a
.|. FileMode
o)
#else
setFileOrdinary _ = return ()
setFileExecutable _ = return ()
#endif
setDirOrdinary :: FilePath -> IO ()
setDirOrdinary = FilePath -> IO ()
setFileExecutable
copyFile :: FilePath -> FilePath -> IO ()
copyFile :: FilePath -> FilePath -> IO ()
copyFile FilePath
fromFPath FilePath
toFPath =
IO ()
copy
IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIO` (\IOError
ioe -> IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (IOError -> FilePath -> IOError
ioeSetLocation IOError
ioe FilePath
"copyFile"))
where
#ifndef mingw32_HOST_OS
copy :: IO ()
copy = FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
fromFPath IOMode
ReadMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
hFrom ->
IO (FilePath, Handle)
-> ((FilePath, Handle) -> IO ())
-> ((FilePath, Handle) -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError IO (FilePath, Handle)
openTmp (FilePath, Handle) -> IO ()
cleanTmp (((FilePath, Handle) -> IO ()) -> IO ())
-> ((FilePath, Handle) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(FilePath
tmpFPath, Handle
hTmp) ->
do Int -> (Ptr Any -> IO ()) -> IO ()
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
bufferSize ((Ptr Any -> IO ()) -> IO ()) -> (Ptr Any -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Handle -> Ptr Any -> IO ()
forall {a}. Handle -> Handle -> Ptr a -> IO ()
copyContents Handle
hFrom Handle
hTmp
Handle -> IO ()
hClose Handle
hTmp
FilePath -> FilePath -> IO ()
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) -> IO ()
cleanTmp (FilePath
tmpFPath, Handle
hTmp) = do
Handle -> IO ()
hClose Handle
hTmp IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIO` \IOError
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
FilePath -> IO ()
removeFile FilePath
tmpFPath IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIO` \IOError
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
bufferSize :: Int
bufferSize = Int
4096
copyContents :: Handle -> Handle -> Ptr a -> IO ()
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 -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Handle -> Ptr a -> Int -> IO ()
forall a. Handle -> Ptr a -> Int -> IO ()
hPutBuf Handle
hTo Ptr a
buffer Int
count
Handle -> Handle -> Ptr a -> IO ()
copyContents Handle
hFrom Handle
hTo Ptr a
buffer
#else
copy = Win32.copyFile (toExtendedLengthPath fromFPath)
(toExtendedLengthPath toFPath)
False
toExtendedLengthPath :: FilePath -> FilePath
toExtendedLengthPath path
| isRelative path = path
| otherwise =
case normalisedPath of
'\\' : '?' : '?' : '\\' : _ -> normalisedPath
'\\' : '\\' : '?' : '\\' : _ -> normalisedPath
'\\' : '\\' : '.' : '\\' : _ -> normalisedPath
'\\' : subpath@('\\' : _) -> "\\\\?\\UNC" <> subpath
_ -> "\\\\?\\" <> normalisedPath
where normalisedPath = simplifyWindows path
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)
= 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
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
normalisePathSeps :: FilePath -> FilePath
normalisePathSeps p = (\ c -> if isPathSeparator c then pathSeparator else c) <$> p
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'')
emptyToCurDir :: FilePath -> FilePath
emptyToCurDir "" = "."
emptyToCurDir path = path
#endif /* mingw32_HOST_OS */
copyFileChanged :: FilePath -> FilePath -> IO ()
copyFileChanged :: FilePath -> FilePath -> IO ()
copyFileChanged FilePath
src FilePath
dest = do
Bool
equal <- FilePath -> FilePath -> IO Bool
filesEqual FilePath
src FilePath
dest
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
equal (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
copyFile FilePath
src FilePath
dest
filesEqual :: FilePath -> FilePath -> IO Bool
filesEqual :: FilePath -> FilePath -> IO Bool
filesEqual FilePath
f1 FilePath
f2 = do
Bool
ex1 <- FilePath -> IO Bool
doesFileExist FilePath
f1
Bool
ex2 <- FilePath -> IO Bool
doesFileExist FilePath
f2
if Bool -> Bool
not (Bool
ex1 Bool -> Bool -> Bool
&& Bool
ex2) then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False else
FilePath -> IOMode -> (Handle -> IO Bool) -> IO Bool
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
f1 IOMode
ReadMode ((Handle -> IO Bool) -> IO Bool) -> (Handle -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Handle
h1 ->
FilePath -> IOMode -> (Handle -> IO Bool) -> IO Bool
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
f2 IOMode
ReadMode ((Handle -> IO Bool) -> IO Bool) -> (Handle -> IO Bool) -> IO 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 -> IO Bool
forall a. a -> IO a
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 -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! ByteString
c1 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
c2