Ticket #6104: CopyFile.hs

File CopyFile.hs, 2.0 KB (added by igloo, 3 years ago)
Line 
1
2module CopyFile (
3  myCopyFile,
4  copyOrdinaryFile,
5  copyExecutableFile,
6  setFileOrdinary,
7  setFileExecutable,
8  setDirOrdinary,
9  ) where
10
11import Control.Exception as Exception
12import Control.Monad
13import Foreign
14import Foreign.C
15import System.Directory
16import System.FilePath
17import System.IO
18import System.IO.Error
19import System.Posix.Internals
20import System.Posix.Types
21
22copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO ()
23copyOrdinaryFile   src dest = myCopyFile src dest >> setFileOrdinary   dest
24copyExecutableFile src dest = myCopyFile src dest >> setFileExecutable dest
25
26setFileOrdinary,  setFileExecutable, setDirOrdinary  :: FilePath -> IO ()
27setFileOrdinary   path = setFileMode path 0o644
28setFileExecutable path = setFileMode path 0o755
29
30setFileMode :: FilePath -> FileMode -> IO ()
31setFileMode name m =
32  withFilePath name $ \s -> do
33    throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)
34setDirOrdinary = setFileExecutable
35
36myCopyFile :: FilePath -> FilePath -> IO ()
37myCopyFile fromFPath toFPath =
38  copy
39    `catchIO` (\ioe -> throwIOIO (ioeSetLocation ioe "myCopyFile"))
40    where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
41                 bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) ->
42                 do allocaBytes bufferSize $ copyContents hFrom hTmp
43                    hClose hTmp
44                    renameFile tmpFPath toFPath
45          openTmp = openBinaryTempFile (takeDirectory toFPath) ".myCopyFile.tmp"
46          cleanTmp (tmpFPath, hTmp) = do
47            hClose hTmp          `catchIO` \_ -> return ()
48            removeFile tmpFPath  `catchIO` \_ -> return ()
49          bufferSize = 4096
50
51          copyContents hFrom hTo buffer = do
52                  count <- hGetBuf hFrom buffer bufferSize
53                  when (count > 0) $ do
54                          hPutBuf hTo buffer count
55                          copyContents hFrom hTo buffer
56
57catchIO :: IO a -> (IOException -> IO a) -> IO a
58catchIO = Exception.catch
59
60throwIOIO :: IOException -> IO a
61throwIOIO = Exception.throwIO
62