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