src/Workaround.hs

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