    {-# 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
    $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

    --
    -- A bit of sugar for installing a new handler
    --
    withHandler :: MonadBaseControl IO m => Signal -> Handler -> m a -> m a
    withHandler :: forall (m :: * -> *) a.
    MonadBaseControl IO m =>
    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 α. IO α -> m α
    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 α. IO α -> m α
    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 :: forall (m :: * -> *) a.
    MonadBaseControl IO m =>
    [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 a b. (a -> b -> b) -> b -> [a] -> b
    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 :: forall (m :: * -> *) a. MonadBaseControl IO m => m a -> m a
    withIrcSignalCatch m a
    m = do
        _ <- IO Handler -> m Handler
    forall α. IO α -> m α
    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
        _ <- liftBase $ installHandler sigALRM Ignore Nothing
        threadid <- myThreadId
        withHandlerList (map fst ircSignalsToCatch) (ircSignalHandler threadid) m
    #endif