-- 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; see the file COPYING.  If not, write to
-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-- Boston, MA 02110-1301, USA.

{-# LANGUAGE CPP #-}

module Darcs.Util.SignalHandler
    ( withSignalsHandled, withSignalsBlocked,
      catchInterrupt, catchNonSignal,
      tryNonSignal, stdoutIsAPipe
    ) where

import Darcs.Prelude

import System.IO.Error ( isUserError, ioeGetErrorString, ioeGetFileName )
import System.Exit ( exitWith, ExitCode ( ExitFailure ) )
import Control.Concurrent ( ThreadId, myThreadId )
import Control.Exception
            ( catch, throw, throwTo, mask,
              Exception(..), SomeException(..), IOException )
import System.Posix.Files ( getFdStatus, isNamedPipe )
import System.Posix.IO ( stdOutput )
import Data.Typeable ( Typeable, cast )
import Data.List ( isPrefixOf )
import System.IO ( hPutStrLn, stderr )
import Control.Monad ( unless )

import Darcs.Util.Workaround
    ( installHandler, raiseSignal, Handler(..), Signal
    , sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE )
#ifdef WIN32
import Darcs.Util.CtrlC ( withCtrlCHandler )
#endif

stdoutIsAPipe :: IO Bool
stdoutIsAPipe :: IO Bool
stdoutIsAPipe
 = IO Bool -> (IOException -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
        (do FileStatus
stat <- Fd -> IO FileStatus
getFdStatus Fd
stdOutput
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (FileStatus -> Bool
isNamedPipe FileStatus
stat))
        (\(IOException
_ :: IOException) -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)

newtype SignalException = SignalException Signal deriving (Int -> SignalException -> ShowS
[SignalException] -> ShowS
SignalException -> String
(Int -> SignalException -> ShowS)
-> (SignalException -> String)
-> ([SignalException] -> ShowS)
-> Show SignalException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SignalException] -> ShowS
$cshowList :: [SignalException] -> ShowS
show :: SignalException -> String
$cshow :: SignalException -> String
showsPrec :: Int -> SignalException -> ShowS
$cshowsPrec :: Int -> SignalException -> ShowS
Show, Typeable)

instance Exception SignalException where
   toException :: SignalException -> SomeException
toException = SignalException -> SomeException
forall e. Exception e => e -> SomeException
SomeException
   fromException :: SomeException -> Maybe SignalException
fromException (SomeException e
e) = e -> Maybe SignalException
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e

withSignalsHandled :: IO a -> IO a
withSignalsHandled :: IO a -> IO a
withSignalsHandled IO a
job = do
    ThreadId
thid <- IO ThreadId
myThreadId
    (Signal -> IO ()) -> [Signal] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ThreadId -> Signal -> IO ()
ih ThreadId
thid) [Signal
sigINT, Signal
sigHUP, Signal
sigABRT, Signal
sigTERM, Signal
sigPIPE]
    IO a -> (String -> IO a) -> IO a
forall a. IO a -> (String -> IO a) -> IO a
catchUserErrors (ThreadId -> IO a
forall p. p -> IO a
job' ThreadId
thid IO a -> (Signal -> IO a) -> IO a
forall a. IO a -> (Signal -> IO a) -> IO a
`catchSignal` Signal -> IO a
forall b. Signal -> IO b
defaults)
                    String -> IO a
forall b. String -> IO b
die_with_string
    where defaults :: Signal -> IO b
defaults Signal
s | Signal
s Signal -> Signal -> Bool
forall a. Eq a => a -> a -> Bool
== Signal
sigINT = Signal -> String -> IO b
forall b. Signal -> String -> IO b
ew Signal
s String
"Interrupted!"
                     | Signal
s Signal -> Signal -> Bool
forall a. Eq a => a -> a -> Bool
== Signal
sigHUP = Signal -> String -> IO b
forall b. Signal -> String -> IO b
ew Signal
s String
"HUP"
                     | Signal
s Signal -> Signal -> Bool
forall a. Eq a => a -> a -> Bool
== Signal
sigABRT = Signal -> String -> IO b
forall b. Signal -> String -> IO b
ew Signal
s String
"ABRT"
                     | Signal
s Signal -> Signal -> Bool
forall a. Eq a => a -> a -> Bool
== Signal
sigTERM = Signal -> String -> IO b
forall b. Signal -> String -> IO b
ew Signal
s String
"TERM"
                     | Signal
s Signal -> Signal -> Bool
forall a. Eq a => a -> a -> Bool
== Signal
sigPIPE = ExitCode -> IO b
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO b) -> ExitCode -> IO b
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
                     | Bool
otherwise = Signal -> String -> IO b
forall b. Signal -> String -> IO b
ew Signal
s String
"Unhandled signal!"
          ew :: Signal -> String -> IO b
ew Signal
sig String
s = do Handle -> String -> IO ()
hPutStrLn Handle
stderr String
s
                        Signal -> IO ()
resethandler Signal
sig
                        Signal -> IO ()
raiseSignal Signal
sig -- ensure that our caller knows how we died
                        ExitCode -> IO b
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO b) -> ExitCode -> IO b
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
          die_with_string :: String -> IO b
die_with_string String
e | String
"STDOUT" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
e =
                do Bool
is_pipe <- IO Bool
stdoutIsAPipe
                   Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
is_pipe (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                        Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
6 String
e
                   ExitCode -> IO b
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO b) -> ExitCode -> IO b
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
2
          die_with_string String
e = do Handle -> String -> IO ()
hPutStrLn Handle
stderr String
e
                                 ExitCode -> IO b
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO b) -> ExitCode -> IO b
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
2
#ifdef WIN32
          job' thid =
             withCtrlCHandler (throwTo thid $ SignalException sigINT) job
#else
          job' :: p -> IO a
job' p
_ = IO a
job
#endif

resethandler :: Signal -> IO ()
resethandler :: Signal -> IO ()
resethandler Signal
s = do Handler
_ <- Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
s Handler
Default Maybe SignalSet
forall a. Maybe a
Nothing
                    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

ih :: ThreadId -> Signal -> IO ()
ih :: ThreadId -> Signal -> IO ()
ih ThreadId
thid Signal
s =
  do Handler
_ <- Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
s (IO () -> Handler
Catch (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ ThreadId -> SignalException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
thid (SignalException -> IO ()) -> SignalException -> IO ()
forall a b. (a -> b) -> a -> b
$ Signal -> SignalException
SignalException Signal
s) Maybe SignalSet
forall a. Maybe a
Nothing
     () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

catchSignal :: IO a -> (Signal -> IO a) -> IO a
catchSignal :: IO a -> (Signal -> IO a) -> IO a
catchSignal IO a
job Signal -> IO a
handler =
    IO a
job IO a -> (SignalException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(SignalException Signal
sig) -> Signal -> IO a
handler Signal
sig)

-- | A drop-in replacement for 'Control.Exception.catch', which allows
-- us to catch anything but a signal.  Useful for situations where we
-- don't want to inhibit ctrl-C.
catchNonSignal :: IO a -> (SomeException -> IO a) -> IO a
catchNonSignal :: IO a -> (SomeException -> IO a) -> IO a
catchNonSignal IO a
comp SomeException -> IO a
handler = IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO a
comp SomeException -> IO a
handler'
    where handler' :: SomeException -> IO a
handler' SomeException
se =
           case SomeException -> Maybe SignalException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se :: Maybe SignalException of
             Maybe SignalException
Nothing -> SomeException -> IO a
handler SomeException
se
             Just SignalException
_ -> SomeException -> IO a
forall a e. Exception e => e -> a
throw SomeException
se

catchInterrupt :: IO a -> IO a -> IO a
catchInterrupt :: IO a -> IO a -> IO a
catchInterrupt IO a
job IO a
handler =
    IO a
job IO a -> (Signal -> IO a) -> IO a
forall a. IO a -> (Signal -> IO a) -> IO a
`catchSignal` Signal -> IO a
h
        where h :: Signal -> IO a
h Signal
s | Signal
s Signal -> Signal -> Bool
forall a. Eq a => a -> a -> Bool
== Signal
sigINT = IO a
handler
                  | Bool
otherwise   = SignalException -> IO a
forall a e. Exception e => e -> a
throw (Signal -> SignalException
SignalException Signal
s)

tryNonSignal :: IO a -> IO (Either SomeException a)
tryNonSignal :: IO a -> IO (Either SomeException a)
tryNonSignal IO a
j = (a -> Either SomeException a
forall a b. b -> Either a b
Right (a -> Either SomeException a)
-> IO a -> IO (Either SomeException a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO a
j) IO (Either SomeException a)
-> (SomeException -> IO (Either SomeException a))
-> IO (Either SomeException a)
forall a. IO a -> (SomeException -> IO a) -> IO a
`catchNonSignal` \SomeException
e -> Either SomeException a -> IO (Either SomeException a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeException -> Either SomeException a
forall a b. a -> Either a b
Left SomeException
e)

catchUserErrors :: IO a -> (String -> IO a) -> IO a
catchUserErrors :: IO a -> (String -> IO a) -> IO a
catchUserErrors IO a
comp String -> IO a
handler = IO a -> (IOException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO a
comp IOException -> IO a
handler'
  where handler' :: IOException -> IO a
handler' IOException
ioe
         | IOException -> Bool
isUserError IOException
ioe                       = String -> IO a
handler (IOException -> String
ioeGetErrorString IOException
ioe)
         | IOException -> Maybe String
ioeGetFileName IOException
ioe Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
"<stdout>" = String -> IO a
handler (String
"STDOUT" String -> ShowS
forall a. [a] -> [a] -> [a]
++ IOException -> String
ioeGetErrorString IOException
ioe)
         | Bool
otherwise                             = IOException -> IO a
forall a e. Exception e => e -> a
throw IOException
ioe

withSignalsBlocked :: IO a -> IO a
withSignalsBlocked :: IO a -> IO a
withSignalsBlocked IO a
job = ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (\forall a. IO a -> IO a
unmask -> IO a
job IO a -> (a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
r ->
                           IO a -> IO a
forall a. IO a -> IO a
unmask (a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r) IO a -> (Signal -> IO a) -> IO a
forall a. IO a -> (Signal -> IO a) -> IO a
`catchSignal` a -> Signal -> IO a
forall b. b -> Signal -> IO b
couldnt_do a
r)
    where couldnt_do :: b -> Signal -> IO b
couldnt_do b
r Signal
s | Signal
s Signal -> Signal -> Bool
forall a. Eq a => a -> a -> Bool
== Signal
sigINT = String -> b -> IO b
forall b. String -> b -> IO b
oops String
"interrupt" b
r
                         | Signal
s Signal -> Signal -> Bool
forall a. Eq a => a -> a -> Bool
==  Signal
sigHUP = String -> b -> IO b
forall b. String -> b -> IO b
oops String
"HUP" b
r
                         | Signal
s Signal -> Signal -> Bool
forall a. Eq a => a -> a -> Bool
==  Signal
sigABRT = String -> b -> IO b
forall b. String -> b -> IO b
oops String
"ABRT" b
r
                         | Signal
s Signal -> Signal -> Bool
forall a. Eq a => a -> a -> Bool
==  Signal
sigALRM = String -> b -> IO b
forall b. String -> b -> IO b
oops String
"ALRM" b
r
                         | Signal
s Signal -> Signal -> Bool
forall a. Eq a => a -> a -> Bool
==  Signal
sigTERM = String -> b -> IO b
forall b. String -> b -> IO b
oops String
"TERM" b
r
                         | Signal
s Signal -> Signal -> Bool
forall a. Eq a => a -> a -> Bool
==  Signal
sigPIPE = b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
r
                         | Bool
otherwise = String -> b -> IO b
forall b. String -> b -> IO b
oops String
"unknown signal" b
r
          oops :: String -> b -> IO b
oops String
s b
r = do Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Couldn't handle " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++
                          String
" since darcs was in a sensitive job."
                        b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
r