1 {-# OPTIONS_GHC -cpp #-}
    2 {-# LANGUAGE CPP #-}
    3 
    4 module Workaround ( renameFile, setExecutable, getCurrentDirectory,
    5                     installHandler, raiseSignal, Handler(..), Signal,
    6                     sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE ) where
    7 
    8 #ifdef WIN32
    9 import qualified System.Directory ( renameFile, getCurrentDirectory, removeFile )
   10 import qualified Control.Exception ( block )
   11 import qualified System.IO.Error ( isDoesNotExistError, ioError, catch )
   12 #else
   13 import System.Posix.Signals(installHandler, raiseSignal, Handler(..), Signal,
   14                             sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE)
   15 import System.Directory ( renameFile, getCurrentDirectory )
   16 import System.Posix.Files (fileMode,getFileStatus, setFileMode,
   17                            setFileCreationMask,
   18                            ownerReadMode, ownerWriteMode, ownerExecuteMode,
   19                            groupReadMode, groupWriteMode, groupExecuteMode,
   20                            otherReadMode, otherWriteMode, otherExecuteMode)
   21 import Data.Bits ( (.&.), (.|.), complement )
   22 #endif
   23 
   24 #ifdef WIN32
   25 -- Dummy implementation of POSIX signals
   26 data Handler = Default | Ignore | Catch (IO ())
   27 type Signal = Int
   28 
   29 installHandler :: Signal -> Handler -> Maybe () -> IO ()
   30 installHandler _ _ _ = return ()
   31 
   32 raiseSignal :: Signal -> IO ()
   33 raiseSignal _ = return ()
   34 
   35 sigINT, {- sigKILL, -} sigHUP, {- sigQUIT, -} sigABRT, sigALRM, sigTERM, sigPIPE :: Signal
   36 sigINT = 0
   37 -- not used: sigKILL = 0
   38 sigHUP = 0
   39 -- not used: sigQUIT = 0
   40 sigABRT = 0
   41 sigTERM = 0
   42 sigPIPE = 0
   43 sigALRM = 0
   44 
   45 {-
   46 System.Directory.renameFile incorrectly fails when the new file already
   47 exists.  This code works around that bug at the cost of losing atomic
   48 writes.
   49 -}
   50 
   51 renameFile :: FilePath -> FilePath -> IO ()
   52 renameFile old new = Control.Exception.block $
   53    System.Directory.renameFile old new
   54    `System.IO.Error.catch` \_ ->
   55    do System.Directory.removeFile new
   56         `System.IO.Error.catch`
   57          (\e -> if System.IO.Error.isDoesNotExistError e
   58                    then return ()
   59                    else System.IO.Error.ioError e)
   60       System.Directory.renameFile old new
   61 
   62 setExecutable :: FilePath -> Bool -> IO ()
   63 setExecutable _ _ = return ()
   64 
   65 {-
   66 System.Directory.getCurrentDirectory returns a path with backslashes in it
   67 under windows, and some of the code gets confused by that, so we override
   68 getCurrentDirectory and translates '\\' to '/'
   69 -}
   70 
   71 getCurrentDirectory :: IO FilePath
   72 getCurrentDirectory = do d <- System.Directory.getCurrentDirectory
   73                          return $ map rb d
   74     where rb '\\' = '/'
   75           rb c = c
   76 
   77 #else
   78 
   79 setExecutable :: FilePath -> Bool -> IO ()
   80 setExecutable f ex =
   81   do st <- getFileStatus f
   82      umask <- setFileCreationMask 0
   83      setFileCreationMask umask
   84      let rw = fileMode st .&.
   85               (ownerReadMode .|. ownerWriteMode .|.
   86                groupReadMode .|. groupWriteMode .|.
   87                otherReadMode .|. otherWriteMode)
   88          total = if ex then rw .|.
   89                            ((ownerExecuteMode .|. groupExecuteMode .|. otherExecuteMode)
   90                             .&. complement umask)
   91                        else rw
   92      setFileMode f total
   93 
   94 #endif