Cabal/src/Distribution/Compat/CopyFile.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# OPTIONS_HADDOCK hide #-}
   3
   4 module Distribution.Compat.CopyFile
   5   ( copyFile
   6   , copyFileChanged
   7   , filesEqual
   8   , copyOrdinaryFile
   9   , copyExecutableFile
  10   , setFileOrdinary
  11   , setFileExecutable
  12   , setDirOrdinary
  13   ) where
  14
  15 import Distribution.Compat.Prelude
  16 import Prelude ()
  17
  18 #ifndef mingw32_HOST_OS
  19 import Distribution.Compat.Internal.TempFile
  20
  21 import Control.Exception
  22          ( bracketOnError )
  23 import qualified Data.ByteString.Lazy as BSL
  24 import Data.Bits
  25          ( (.|.) )
  26 import System.IO.Error
  27          ( ioeSetLocation )
  28 import System.Directory
  29          ( doesFileExist, renameFile, removeFile )
  30 import System.FilePath
  31          ( takeDirectory )
  32 import System.IO
  33          ( IOMode(ReadMode), hClose, hGetBuf, hPutBuf, hFileSize
  34          , withBinaryFile )
  35 import Foreign
  36          ( allocaBytes )
  37
  38 import System.Posix.Types
  39          ( FileMode )
  40 import System.Posix.Files
  41          ( getFileStatus, fileMode, setFileMode )
  42
  43 #else /* else mingw32_HOST_OS */
  44
  45 import qualified Data.ByteString.Lazy as BSL
  46 import System.IO.Error
  47   ( ioeSetLocation )
  48 import System.Directory
  49   ( doesFileExist )
  50 import System.FilePath
  51   ( addTrailingPathSeparator
  52   , hasTrailingPathSeparator
  53   , isPathSeparator
  54   , isRelative
  55   , joinDrive
  56   , joinPath
  57   , pathSeparator
  58   , pathSeparators
  59   , splitDirectories
  60   , splitDrive
  61   )
  62 import System.IO
  63   ( IOMode(ReadMode), hFileSize
  64   , withBinaryFile )
  65
  66 import qualified System.Win32.File as Win32 ( copyFile )
  67 #endif /* mingw32_HOST_OS */
  68
  69 copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO ()
  70 copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest
  71 copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest
  72
  73 setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO ()
  74 #ifndef mingw32_HOST_OS
  75 -- When running with a restrictive UMASK such as 0077 we still want to
  76 -- install files and directories that are accessible to other users.
  77 setFileOrdinary   path = addFileMode path 0o644 -- file perms -rw-r--r--
  78 setFileExecutable path = addFileMode path 0o755 -- file perms -rwxr-xr-x
  79
  80 addFileMode :: FilePath -> FileMode -> IO ()
  81 addFileMode name m = do
  82   o <- fileMode <$> getFileStatus name
  83   setFileMode name (m .|. o)
  84 #else
  85 setFileOrdinary   _ = return ()
  86 setFileExecutable _ = return ()
  87 #endif
  88 -- This happens to be true on Unix and currently on Windows too:
  89 setDirOrdinary = setFileExecutable
  90
  91 -- | Copies a file to a new destination.
  92 -- Often you should use `copyFileChanged` instead.
  93 copyFile :: FilePath -> FilePath -> IO ()
  94 copyFile fromFPath toFPath =
  95   copy
  96     `catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile"))
  97   where
  98 #ifndef mingw32_HOST_OS
  99       copy = withBinaryFile fromFPath ReadMode $ \hFrom ->
 100              bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) ->
 101              do allocaBytes bufferSize $ copyContents hFrom hTmp
 102                 hClose hTmp
 103                 renameFile tmpFPath toFPath
 104       openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp"
 105       cleanTmp (tmpFPath, hTmp) = do
 106         hClose hTmp          `catchIO` \_ -> return ()
 107         removeFile tmpFPath  `catchIO` \_ -> return ()
 108       bufferSize = 4096
 109
 110       copyContents hFrom hTo buffer = do
 111               count <- hGetBuf hFrom buffer bufferSize
 112               when (count > 0) $ do
 113                       hPutBuf hTo buffer count
 114                       copyContents hFrom hTo buffer
 115 #else
 116       copy = Win32.copyFile (toExtendedLengthPath fromFPath)
 117                             (toExtendedLengthPath toFPath)
 118                             False
 119
 120 -- NOTE: Shamelessly lifted from System.Directory.Internal.Windows
 121
 122 -- | Add the @"\\\\?\\"@ prefix if necessary or possible.  The path remains
 123 -- unchanged if the prefix is not added.  This function can sometimes be used
 124 -- to bypass the @MAX_PATH@ length restriction in Windows API calls.
 125 --
 126 -- See Note [Path normalization].
 127 toExtendedLengthPath :: FilePath -> FilePath
 128 toExtendedLengthPath path
 129   | isRelative path = path
 130   | otherwise =
 131       case normalisedPath of
 132         '\\' : '?'  : '?' : '\\' : _ -> normalisedPath
 133         '\\' : '\\' : '?' : '\\' : _ -> normalisedPath
 134         '\\' : '\\' : '.' : '\\' : _ -> normalisedPath
 135         '\\' : subpath@('\\' : _)    -> "\\\\?\\UNC" <> subpath
 136         _                            -> "\\\\?\\" <> normalisedPath
 137     where normalisedPath = simplifyWindows path
 138
 139 -- | Similar to 'normalise' but:
 140 --
 141 -- * empty paths stay empty,
 142 -- * parent dirs (@..@) are expanded, and
 143 -- * paths starting with @\\\\?\\@ are preserved.
 144 --
 145 -- The goal is to preserve the meaning of paths better than 'normalise'.
 146 --
 147 -- Note [Path normalization]
 148 -- 'normalise' doesn't simplify path names but will convert / into \\
 149 -- this would normally not be a problem as once the path hits the RTS we would
 150 -- have simplified the path then.  However since we're calling the WIn32 API
 151 -- directly we have to do the simplification before the call.  Without this the
 152 -- path Z:// would become Z:\\\\ and when converted to a device path the path
 153 -- becomes \\?\Z:\\\\ which is an invalid path.
 154 --
 155 -- This is not a bug in normalise as it explicitly states that it won't simplify
 156 -- a FilePath.
 157 simplifyWindows :: FilePath -> FilePath
 158 simplifyWindows "" = ""
 159 simplifyWindows path =
 160   case drive' of
 161     "\\\\?\\" -> drive' <> subpath
 162     _ -> simplifiedPath
 163   where
 164     simplifiedPath = joinDrive drive' subpath'
 165     (drive, subpath) = splitDrive path
 166     drive' = upperDrive (normaliseTrailingSep (normalisePathSeps drive))
 167     subpath' = appendSep . avoidEmpty . prependSep . joinPath .
 168                stripPardirs . expandDots . skipSeps .
 169                splitDirectories $ subpath
 170
 171     upperDrive d = case d of
 172       c : ':' : s | isAlpha c && all isPathSeparator s -> toUpper c : ':' : s
 173       _ -> d
 174     skipSeps = filter (not . (`elem` (pure <$> pathSeparators)))
 175     stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== "..")
 176                  | otherwise = id
 177     prependSep | subpathIsAbsolute = (pathSeparator :)
 178                | otherwise = id
 179     avoidEmpty | not pathIsAbsolute
 180                  && (null drive || hasTrailingPathSep) -- prefer "C:" over "C:."
 181                  = emptyToCurDir
 182                | otherwise = id
 183     appendSep p | hasTrailingPathSep
 184                   && not (pathIsAbsolute && null p)
 185                   = addTrailingPathSeparator p
 186                 | otherwise = p
 187     pathIsAbsolute = not (isRelative path)
 188     subpathIsAbsolute = any isPathSeparator (take 1 subpath)
 189     hasTrailingPathSep = hasTrailingPathSeparator subpath
 190
 191 -- | Given a list of path segments, expand @.@ and @..@.  The path segments
 192 -- must not contain path separators.
 193 expandDots :: [FilePath] -> [FilePath]
 194 expandDots = reverse . go []
 195   where
 196     go ys' xs' =
 197       case xs' of
 198         [] -> ys'
 199         x : xs ->
 200           case x of
 201             "." -> go ys' xs
 202             ".." ->
 203               case ys' of
 204                 [] -> go (x : ys') xs
 205                 ".." : _ -> go (x : ys') xs
 206                 _ : ys -> go ys xs
 207             _ -> go (x : ys') xs
 208
 209 -- | Convert to the right kind of slashes.
 210 normalisePathSeps :: FilePath -> FilePath
 211 normalisePathSeps p = (\ c -> if isPathSeparator c then pathSeparator else c) <$> p
 212
 213 -- | Remove redundant trailing slashes and pick the right kind of slash.
 214 normaliseTrailingSep :: FilePath -> FilePath
 215 normaliseTrailingSep path = do
 216   let path' = reverse path
 217   let (sep, path'') = span isPathSeparator path'
 218   let addSep = if null sep then id else (pathSeparator :)
 219   reverse (addSep path'')
 220
 221 -- | Convert empty paths to the current directory, otherwise leave it
 222 -- unchanged.
 223 emptyToCurDir :: FilePath -> FilePath
 224 emptyToCurDir ""   = "."
 225 emptyToCurDir path = path
 226 #endif /* mingw32_HOST_OS */
 227
 228 -- | Like `copyFile`, but does not touch the target if source and destination
 229 -- are already byte-identical. This is recommended as it is useful for
 230 -- time-stamp based recompilation avoidance.
 231 copyFileChanged :: FilePath -> FilePath -> IO ()
 232 copyFileChanged src dest = do
 233   equal <- filesEqual src dest
 234   unless equal $ copyFile src dest
 235
 236 -- | Checks if two files are byte-identical.
 237 -- Returns False if either of the files do not exist or if files
 238 -- are of different size.
 239 filesEqual :: FilePath -> FilePath -> IO Bool
 240 filesEqual f1 f2 = do
 241   ex1 <- doesFileExist f1
 242   ex2 <- doesFileExist f2
 243   if not (ex1 && ex2)
 244     then return False
 245     else withBinaryFile f1 ReadMode $ \h1 ->
 246       withBinaryFile f2 ReadMode $ \h2 -> do
 247         s1 <- hFileSize h1
 248         s2 <- hFileSize h2
 249         if s1 /= s2
 250           then return False
 251           else do
 252             c1 <- BSL.hGetContents h1
 253             c2 <- BSL.hGetContents h2
 254             return $! c1 == c2