{-# 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, throwIO, 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FileStatus -> Bool
isNamedPipe FileStatus
stat))
(\(IOException
_ :: IOException) -> Bool -> IO Bool
forall a. a -> IO a
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
$cshowsPrec :: Int -> SignalException -> ShowS
showsPrec :: Int -> SignalException -> ShowS
$cshow :: SignalException -> String
show :: SignalException -> String
$cshowList :: [SignalException] -> ShowS
showList :: [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 :: forall a. 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
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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
catchSignal :: IO a -> (Signal -> IO a) -> IO a
catchSignal :: forall a. 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)
catchNonSignal :: IO a -> (SomeException -> IO a) -> IO a
catchNonSignal :: forall a. 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 e a. Exception e => e -> IO a
throwIO SomeException
se
catchInterrupt :: IO a -> IO a -> IO a
catchInterrupt :: forall a. 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 e a. Exception e => e -> IO a
throwIO (Signal -> SignalException
SignalException Signal
s)
tryNonSignal :: IO a -> IO (Either SomeException a)
tryNonSignal :: forall a. 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 a b. (a -> b) -> IO a -> IO b
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 a. a -> IO 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 :: forall a. 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 e a. Exception e => e -> IO a
throwIO IOException
ioe
withSignalsBlocked :: IO a -> IO a
withSignalsBlocked :: forall a. 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 a b. IO a -> (a -> IO b) -> IO b
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 a. 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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return b
r