{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}

-- | The signal story.
-- Posix signals are external events that invoke signal handlers in
-- Haskell. The signal handlers in turn throw dynamic exceptions.  Our
-- instance of MonadError for LB maps the dynamic exceptions to
-- SignalCaughts, which can then be caught by a normal catchError

-- Here's where we do that.
module Lambdabot.Util.Signals
    ( Signal
    , SignalException(..)
    , ircSignalMessage
    , withIrcSignalCatch
    ) where

import Data.Typeable
import Control.Exception (Exception)

#ifdef mingw32_HOST_OS

import Control.Monad.Trans.Control

type Signal = String
newtype SignalException = SignalException Signal deriving (Show, Typeable)
instance Exception SignalException

ircSignalMessage :: Signal -> [Char]
ircSignalMessage s = s

withIrcSignalCatch :: MonadBaseControl IO m => m a -> m a
withIrcSignalCatch m = m

#else

import Control.Concurrent.Lifted (myThreadId, newEmptyMVar, putMVar, MVar, ThreadId)
import Control.Exception.Lifted (bracket, throwTo)
import Control.Monad
import Control.Monad.Base
import Control.Monad.Trans.Control

import System.IO.Unsafe
import System.Posix.Signals

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

--
-- A bit of sugar for installing a new handler
--
withHandler :: MonadBaseControl IO m => Signal -> Handler -> m a -> m a
withHandler :: Signal -> Handler -> m a -> m a
withHandler Signal
s Handler
h m a
m = m Handler -> (Handler -> m Handler) -> (Handler -> m a) -> m a
forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
    (IO Handler -> m Handler
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
s Handler
h Maybe SignalSet
forall a. Maybe a
Nothing))
    (IO Handler -> m Handler
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO Handler -> m Handler)
-> (Handler -> IO Handler) -> Handler -> m Handler
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Handler -> Maybe SignalSet -> IO Handler)
-> Maybe SignalSet -> Handler -> IO Handler
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
s) Maybe SignalSet
forall a. Maybe a
Nothing)
    (m a -> Handler -> m a
forall a b. a -> b -> a
const m a
m)

-- And more sugar for installing a list of handlers
withHandlerList :: MonadBaseControl IO m => [Signal] -> (Signal -> Handler) -> m a -> m a
withHandlerList :: [Signal] -> (Signal -> Handler) -> m a -> m a
withHandlerList [Signal]
sl Signal -> Handler
h m a
m = (Signal -> m a -> m a) -> m a -> [Signal] -> m a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Signal -> Handler -> m a -> m a
forall (m :: * -> *) a.
MonadBaseControl IO m =>
Signal -> Handler -> m a -> m a
withHandler (Signal -> Handler -> m a -> m a)
-> (Signal -> Handler) -> Signal -> m a -> m a
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` Signal -> Handler
h) m a
m [Signal]
sl

--
-- Signals we care about. They're all fatal.
--
-- Be careful adding signals, some signals can't be caught and
-- installHandler just raises an exception if you try
--
ircSignalsToCatch :: [(Signal, String)]
ircSignalsToCatch :: [(Signal, String)]
ircSignalsToCatch = 
    [ (Signal
busError,              String
"SIGBUS"  )
    , (Signal
segmentationViolation, String
"SIGSEGV" )
    , (Signal
keyboardSignal,        String
"SIGINT"  )
    , (Signal
softwareTermination,   String
"SIGTERM" )
    , (Signal
keyboardTermination,   String
"SIGQUIT" )
    , (Signal
lostConnection,        String
"SIGHUP"  )
    , (Signal
internalAbort,         String
"SIGABRT" )
    ]

--
-- User friendly names for the signals that we can catch
--
ircSignalMessage :: Signal -> String
ircSignalMessage :: Signal -> String
ircSignalMessage Signal
sig = case Signal -> [(Signal, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Signal
sig [(Signal, String)]
ircSignalsToCatch of
    Just String
sigName -> String
sigName
    Maybe String
Nothing      -> String
"killed by unknown signal"

--
-- The actual signal handler. It is this function we register for each
-- signal flavour. On receiving a signal, the signal handler maps the
-- signal to a a dynamic exception, and throws it out to the main
-- thread. The LB MonadError instance can then do its trickery to catch
-- it in handler/catchError
--
ircSignalHandler :: ThreadId -> Signal -> Handler
ircSignalHandler :: ThreadId -> Signal -> Handler
ircSignalHandler ThreadId
threadid Signal
s
    = IO () -> Handler
CatchOnce (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ do
        MVar () -> () -> IO ()
forall (m :: * -> *) a. MonadBase IO m => MVar a -> a -> m ()
putMVar MVar ()
catchLock ()
        IO ()
releaseSignals
        ThreadId -> SignalException -> IO ()
forall (m :: * -> *) e.
(MonadBase IO m, Exception e) =>
ThreadId -> e -> m ()
throwTo ThreadId
threadid (SignalException -> IO ()) -> SignalException -> IO ()
forall a b. (a -> b) -> a -> b
$ Signal -> SignalException
SignalException Signal
s

--
-- | Release all signal handlers
--
releaseSignals :: IO ()
releaseSignals :: IO ()
releaseSignals = [IO Handler] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ 
    [ Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sig Handler
Default Maybe SignalSet
forall a. Maybe a
Nothing
    | (Signal
sig, String
_) <- [(Signal, String)]
ircSignalsToCatch
    ]

--
-- Mututally exclusive signal handlers
--
-- This is clearly a hack, but I have no idea how to accomplish the same
-- thing correctly. The main problem is that signals are often thrown
-- multiple times, and the threads start killing each other if we allow
-- the SignalException to be thrown more than once.
{-# NOINLINE catchLock #-}
catchLock :: MVar ()
catchLock :: MVar ()
catchLock = IO (MVar ()) -> MVar ()
forall a. IO a -> a
unsafePerformIO IO (MVar ())
forall (m :: * -> *) a. MonadBase IO m => m (MVar a)
newEmptyMVar

--
-- | Register signal handlers to catch external signals
--
withIrcSignalCatch :: MonadBaseControl IO m => m a -> m a
withIrcSignalCatch :: m a -> m a
withIrcSignalCatch m a
m = do
    Handler
_ <- IO Handler -> m Handler
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO Handler -> m Handler) -> IO Handler -> m Handler
forall a b. (a -> b) -> a -> b
$ Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigPIPE Handler
Ignore Maybe SignalSet
forall a. Maybe a
Nothing
    Handler
_ <- IO Handler -> m Handler
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO Handler -> m Handler) -> IO Handler -> m Handler
forall a b. (a -> b) -> a -> b
$ Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigALRM Handler
Ignore Maybe SignalSet
forall a. Maybe a
Nothing
    ThreadId
threadid <- m ThreadId
forall (m :: * -> *). MonadBase IO m => m ThreadId
myThreadId
    [Signal] -> (Signal -> Handler) -> m a -> m a
forall (m :: * -> *) a.
MonadBaseControl IO m =>
[Signal] -> (Signal -> Handler) -> m a -> m a
withHandlerList (((Signal, String) -> Signal) -> [(Signal, String)] -> [Signal]
forall a b. (a -> b) -> [a] -> [b]
map (Signal, String) -> Signal
forall a b. (a, b) -> a
fst [(Signal, String)]
ircSignalsToCatch) (ThreadId -> Signal -> Handler
ircSignalHandler ThreadId
threadid) m a
m
#endif