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