1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100
|
% Copyright (C) 2003 David Roundy
%
% This program is free software; you can redistribute it and/or modify
% it under the terms of the GNU General Public License as published by
% the Free Software Foundation; either version 2, or (at your option)
% any later version.
%
% This program is distributed in the hope that it will be useful,
% but WITHOUT ANY WARRANTY; without even the implied warranty of
% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
% GNU General Public License for more details.
%
% You should have received a copy of the GNU General Public License
% along with this program; if not, write to the Free Software Foundation,
% Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
\begin{code}
{-# OPTIONS -fglasgow-exts #-}
module SignalHandler ( withSignalsHandled, withSignalsBlocked,
) where
import System.IO.Error ( isUserError, ioeGetErrorString, ioeGetFileName )
import Control.Exception ( catchJust, Exception ( IOException ) )
import System.Exit ( exitWith, ExitCode ( ExitFailure ) )
import Control.Concurrent ( ThreadId, myThreadId )
import Control.Exception ( catchDyn, throwDynTo, block )
import Data.Dynamic ( Typeable )
import Workaround ( installHandler, Handler(..), Signal,
sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE,
)
import System.IO ( hPutStrLn, stderr )
import Control.Monad ( when )
#ifdef WIN32
import CtrlC ( withCtrlCHandler )
#endif
\end{code}
\begin{code}
withSignalsHandled :: IO a -> IO a
newtype SignalException = SignalException Signal deriving (Typeable)
foreign import ccall unsafe "static compat.h stdout_is_a_pipe"
stdout_is_a_pipe :: IO Int
withSignalsHandled job = do
thid <- myThreadId
sequence_ $ map (ih thid) [sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE]
catchJust just_usererrors (job' thid `catchSignal` defaults) die_with_string
where defaults s | s == sigINT = ew "Interrupted!"
| s == sigHUP = ew "HUP"
| s == sigABRT = ew "ABRT"
| s == sigALRM = ew "ALRM"
| s == sigTERM = ew "TERM"
| s == sigPIPE = exitWith $ ExitFailure $ 1
| otherwise = ew "Unhandled signal!"
ew s = do hPutStrLn stderr $ s
exitWith $ ExitFailure $ 1
die_with_string e | take 6 e == "STDOUT" =
do is_pipe <- stdout_is_a_pipe
when (is_pipe /= 0) $
hPutStrLn stderr $ "\ndarcs failed: "++drop 6 e
exitWith $ ExitFailure $ 2
die_with_string e = do hPutStrLn stderr $ "\ndarcs failed: "++e
exitWith $ ExitFailure $ 2
#ifdef WIN32
job' thid =
withCtrlCHandler (throwDynTo thid $ SignalException sigINT) job
#else
job' _ = job
#endif
ih :: ThreadId -> Signal -> IO ()
ih thid s =
do installHandler s (Catch $ throwDynTo thid $ SignalException s) Nothing
return ()
catchSignal :: IO a -> (Signal -> IO a) -> IO a
catchSignal job handler =
job `Control.Exception.catchDyn` (\(SignalException sig) -> handler sig)
just_usererrors :: Control.Exception.Exception -> Maybe String
just_usererrors (IOException e) | isUserError e = Just $ ioeGetErrorString e
just_usererrors (IOException e) | ioeGetFileName e == Just "<stdout>"
= Just $ "STDOUT"++ioeGetErrorString e
just_usererrors _ = Nothing
\end{code}
\begin{code}
withSignalsBlocked :: IO () -> IO ()
withSignalsBlocked job = (block job) `catchSignal` couldnt_do
where couldnt_do s | s == sigINT = oops "interrupt"
| s == sigHUP = oops "HUP"
| s == sigABRT = oops "ABRT"
| s == sigALRM = oops "ALRM"
| s == sigTERM = oops "TERM"
| s == sigPIPE = return ()
| otherwise = oops "unknown signal"
oops s = hPutStrLn stderr $ "Couldn't handle " ++ s ++
" since darcs was in a sensitive job."
\end{code}
|