1-- Copyright (C) 2003 David Roundy 2-- 3-- This program is free software; you can redistribute it and/or modify 4-- it under the terms of the GNU General Public License as published by 5-- the Free Software Foundation; either version 2, or (at your option) 6-- any later version. 7-- 8-- This program is distributed in the hope that it will be useful, 9-- but WITHOUT ANY WARRANTY; without even the implied warranty of 10-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11-- GNU General Public License for more details. 12-- 13-- You should have received a copy of the GNU General Public License 14-- along with this program; see the file COPYING. If not, write to 15-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 16-- Boston, MA 02110-1301, USA. 17 18{-# LANGUAGE CPP #-} 19 20module Darcs.Util.SignalHandler 21 ( withSignalsHandled, withSignalsBlocked, 22 catchInterrupt, catchNonSignal, 23 tryNonSignal, stdoutIsAPipe 24 ) where 25 26import Darcs.Prelude 27 28import System.IO.Error ( isUserError, ioeGetErrorString, ioeGetFileName ) 29import System.Exit ( exitWith, ExitCode ( ExitFailure ) ) 30import Control.Concurrent ( ThreadId, myThreadId ) 31import Control.Exception 32 ( catch, throw, throwTo, mask, 33 Exception(..), SomeException(..), IOException ) 34import System.Posix.Files ( getFdStatus, isNamedPipe ) 35import System.Posix.IO ( stdOutput ) 36import Data.Typeable ( Typeable, cast ) 37import Data.List ( isPrefixOf ) 38import System.IO ( hPutStrLn, stderr ) 39import Control.Monad ( unless ) 40 41import Darcs.Util.Workaround 42 ( installHandler, raiseSignal, Handler(..), Signal 43 , sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE ) 44#ifdef WIN32 45import Darcs.Util.CtrlC ( withCtrlCHandler ) 46#endif 47 48stdoutIsAPipe :: IO Bool 49stdoutIsAPipe 50 = catch 51 (do stat <- getFdStatus stdOutput 52 return (isNamedPipe stat)) 53 (\(_ :: IOException) -> return False) 54 55newtype SignalException = SignalException Signal deriving (Show, Typeable) 56 57instance Exception SignalException where 58 toException = SomeException 59 fromException (SomeException e) = cast e 60 61withSignalsHandled :: IO a -> IO a 62withSignalsHandled job = do 63 thid <- myThreadId 64 mapM_ (ih thid) [sigINT, sigHUP, sigABRT, sigTERM, sigPIPE] 65 catchUserErrors (job' thid `catchSignal` defaults) 66 die_with_string 67 where defaults s | s == sigINT = ew s "Interrupted!" 68 | s == sigHUP = ew s "HUP" 69 | s == sigABRT = ew s "ABRT" 70 | s == sigTERM = ew s "TERM" 71 | s == sigPIPE = exitWith $ ExitFailure 1 72 | otherwise = ew s "Unhandled signal!" 73 ew sig s = do hPutStrLn stderr s 74 resethandler sig 75 raiseSignal sig -- ensure that our caller knows how we died 76 exitWith $ ExitFailure 1 77 die_with_string e | "STDOUT" `isPrefixOf` e = 78 do is_pipe <- stdoutIsAPipe 79 unless is_pipe $ 80 hPutStrLn stderr $ drop 6 e 81 exitWith $ ExitFailure 2 82 die_with_string e = do hPutStrLn stderr e 83 exitWith $ ExitFailure 2 84#ifdef WIN32 85 job' thid = 86 withCtrlCHandler (throwTo thid $ SignalException sigINT) job 87#else 88 job' _ = job 89#endif 90 91resethandler :: Signal -> IO () 92resethandler s = do _ <- installHandler s Default Nothing 93 return () 94 95ih :: ThreadId -> Signal -> IO () 96ih thid s = 97 do _ <- installHandler s (Catch $ throwTo thid $ SignalException s) Nothing 98 return () 99 100catchSignal :: IO a -> (Signal -> IO a) -> IO a 101catchSignal job handler = 102 job `catch` (\(SignalException sig) -> handler sig) 103 104-- | A drop-in replacement for 'Control.Exception.catch', which allows 105-- us to catch anything but a signal. Useful for situations where we 106-- don't want to inhibit ctrl-C. 107catchNonSignal :: IO a -> (SomeException -> IO a) -> IO a 108catchNonSignal comp handler = catch comp handler' 109 where handler' se = 110 case fromException se :: Maybe SignalException of 111 Nothing -> handler se 112 Just _ -> throw se 113 114catchInterrupt :: IO a -> IO a -> IO a 115catchInterrupt job handler = 116 job `catchSignal` h 117 where h s | s == sigINT = handler 118 | otherwise = throw (SignalException s) 119 120tryNonSignal :: IO a -> IO (Either SomeException a) 121tryNonSignal j = (Right `fmap` j) `catchNonSignal` \e -> return (Left e) 122 123catchUserErrors :: IO a -> (String -> IO a) -> IO a 124catchUserErrors comp handler = catch comp handler' 125 where handler' ioe 126 | isUserError ioe = handler (ioeGetErrorString ioe) 127 | ioeGetFileName ioe == Just "<stdout>" = handler ("STDOUT" ++ ioeGetErrorString ioe) 128 | otherwise = throw ioe 129 130withSignalsBlocked :: IO a -> IO a 131withSignalsBlocked job = mask (\unmask -> job >>= \r -> 132 unmask (return r) `catchSignal` couldnt_do r) 133 where couldnt_do r s | s == sigINT = oops "interrupt" r 134 | s == sigHUP = oops "HUP" r 135 | s == sigABRT = oops "ABRT" r 136 | s == sigALRM = oops "ALRM" r 137 | s == sigTERM = oops "TERM" r 138 | s == sigPIPE = return r 139 | otherwise = oops "unknown signal" r 140 oops s r = do hPutStrLn stderr $ "Couldn't handle " ++ s ++ 141 " since darcs was in a sensitive job." 142 return r 143