src/Darcs/SignalHandler.lhs

   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
  19 \begin{code}
  20 {-# OPTIONS_GHC -cpp -fglasgow-exts #-}
  21 {-# LANGUAGE CPP #-}
  22 -- , DeriveDataTypeable #-}
  23
  24 module Darcs.SignalHandler ( withSignalsHandled, withSignalsBlocked,
  25                              catchInterrupt, catchNonSignal,
  26                              tryNonSignal, stdout_is_a_pipe ) where
  27
  28 import System.IO.Error ( isUserError, ioeGetErrorString, ioeGetFileName )
  29 import Control.Exception ( dynExceptions, ioErrors, catchJust, Exception ( IOException ) )
  30 import System.Exit ( exitWith, ExitCode ( ExitFailure ) )
  31 import Control.Concurrent ( ThreadId, myThreadId )
  32 import Control.Exception ( catchDyn, throwDyn, throwDynTo, block )
  33 import System.Posix.Files ( getFdStatus, isNamedPipe )
  34 import System.Posix.IO ( stdOutput )
  35 import Data.Dynamic ( Typeable, fromDynamic )
  36 import System.IO ( hPutStrLn, stderr )
  37 import Control.Monad ( when )
  38
  39 import Workaround ( installHandler, raiseSignal, Handler(..), Signal,
  40                     sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE )
  41 #ifdef WIN32
  42 import CtrlC ( withCtrlCHandler )
  43 #endif
  44 \end{code}
  45
  46 \begin{code}
  47
  48 stdout_is_a_pipe :: IO Bool
  49 stdout_is_a_pipe
  50  = catchJust ioErrors
  51         (do stat <- getFdStatus stdOutput
  52             return (isNamedPipe stat))
  53         (\_ -> return False)
  54
  55 withSignalsHandled :: IO a -> IO a
  56 newtype SignalException = SignalException Signal deriving (Typeable)
  57
  58 withSignalsHandled job = do
  59     thid <- myThreadId
  60     mapM_ (ih thid) [sigINT, sigHUP, sigABRT, sigTERM, sigPIPE]
  61     catchJust just_usererrors (job' thid `catchSignal` defaults)
  62               die_with_string
  63     where defaults s | s == sigINT = ew s "Interrupted!"
  64                      | s == sigHUP = ew s "HUP"
  65                      | s == sigABRT = ew s "ABRT"
  66                      | s == sigTERM = ew s "TERM"
  67                      | s == sigPIPE = exitWith $ ExitFailure $ 1
  68                      | otherwise = ew s "Unhandled signal!"
  69           ew sig s = do hPutStrLn stderr $ ("withSignalsHandled: " ++ s)
  70                         resethandler sig
  71                         raiseSignal sig -- ensure that our caller knows how we died
  72                         exitWith $ ExitFailure $ 1
  73           die_with_string e | take 6 e == "STDOUT" =
  74                 do is_pipe <- stdout_is_a_pipe
  75                    when (not is_pipe) $
  76                         hPutStrLn stderr $ "\ndarcs failed:  "++drop 6 e
  77                    exitWith $ ExitFailure $ 2
  78           die_with_string e = do hPutStrLn stderr $ "\ndarcs failed:  "++e
  79                                  exitWith $ ExitFailure $ 2
  80 #ifdef WIN32
  81           job' thid =
  82              withCtrlCHandler (throwDynTo thid $ SignalException sigINT) job
  83 #else
  84           job' _ = job
  85 #endif
  86
  87 resethandler :: Signal -> IO ()
  88 resethandler s = do installHandler s Default Nothing
  89                     return ()
  90
  91 ih :: ThreadId -> Signal -> IO ()
  92 ih thid s =
  93   do installHandler s (Catch $ throwDynTo thid $ SignalException s) Nothing
  94      return ()
  95
  96 catchSignal :: IO a -> (Signal -> IO a) -> IO a
  97 catchSignal job handler =
  98     job `Control.Exception.catchDyn` (\(SignalException sig) -> handler sig)
  99
 100 -- catchNonSignal is a drop-in replacement for Control.Exception.catch, which allows
 101 -- us to catch anything but a signal.  Useful for situations where we want
 102 -- don't want to inhibit ctrl-C.
 103
 104 catchNonSignal :: IO a -> (Control.Exception.Exception -> IO a) -> IO a
 105 catchNonSignal = Control.Exception.catchJust notSig
 106     where notSig x = case dynExceptions x of
 107                      Nothing -> Just x
 108                      Just d -> case fromDynamic d :: Maybe SignalException of
 109                                Just _ -> Nothing
 110                                Nothing -> Just x
 111
 112 catchInterrupt :: IO a -> IO a -> IO a
 113 catchInterrupt job handler =
 114     job `catchSignal` h
 115         where h s | s == sigINT = handler
 116                   | otherwise   = throwDyn (SignalException s)
 117
 118 tryNonSignal :: IO a -> IO (Either Control.Exception.Exception a)
 119 tryNonSignal j = (Right `fmap` j) `catchNonSignal` \e -> return (Left e)
 120
 121 just_usererrors :: Control.Exception.Exception -> Maybe String
 122 just_usererrors (IOException e) | isUserError e = Just $ ioeGetErrorString e
 123 just_usererrors (IOException e) | ioeGetFileName e == Just "<stdout>"
 124                                       = Just $ "STDOUT"++ioeGetErrorString e
 125 just_usererrors _ = Nothing
 126 \end{code}
 127
 128 \begin{code}
 129 withSignalsBlocked :: IO () -> IO ()
 130 withSignalsBlocked job = (block job) `catchSignal` couldnt_do
 131     where couldnt_do s | s == sigINT = oops "interrupt"
 132                        | s ==  sigHUP = oops "HUP"
 133                        | s ==  sigABRT = oops "ABRT"
 134                        | s ==  sigALRM = oops "ALRM"
 135                        | s ==  sigTERM = oops "TERM"
 136                        | s ==  sigPIPE = return ()
 137                        | otherwise = oops "unknown signal"
 138           oops s = hPutStrLn stderr $ "Couldn't handle " ++ s ++
 139                    " since darcs was in a sensitive job."
 140 \end{code}