summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar/System/Signal.hs
blob: ce39e1081e777891e6cf2c9e67f951f9a695605c (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
{-# LANGUAGE DeriveDataTypeable, CPP #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Signal
-- Copyright   :  (c) Andrea Rosatto
--             :  (c) Jose A. Ortega Ruiz
--             :  (c) Jochen Keil
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Jose A. Ortega Ruiz <jao@gnu.org>
-- Stability   :  unstable
-- Portability :  unportable
--
-- Signal handling, including DBUS when available
--
-----------------------------------------------------------------------------

module Xmobar.System.Signal where

import Data.Foldable (for_)
import Data.Typeable (Typeable)
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import System.Posix.Signals
import Graphics.X11.Types (Button)
import Graphics.X11.Xlib.Types (Position)
import System.IO

#ifdef DBUS
import DBus (IsVariant(..))
import Control.Monad ((>=>))
#endif

safeHead :: [a] -> Maybe a
safeHead    [] = Nothing
safeHead (x:_) = Just x

data WakeUp = WakeUp deriving (Show,Typeable)
instance Exception WakeUp

data SignalType = Wakeup
                | Reposition
                | ChangeScreen
                | Hide   Int
                | Reveal Int
                | Toggle Int
                | TogglePersistent
                | Action Button Position
    deriving (Read, Show)

#ifdef DBUS
instance IsVariant SignalType where
    toVariant   = toVariant . show
    fromVariant = fromVariant >=> parseSignalType
#endif

parseSignalType :: String -> Maybe SignalType
parseSignalType = fmap fst . safeHead . reads

-- | Signal handling
setupSignalHandler :: IO (TMVar SignalType)
setupSignalHandler = do
   tid   <- newEmptyTMVarIO
   installHandler sigUSR2 (Catch $ updatePosHandler tid) Nothing
   installHandler sigUSR1 (Catch $ changeScreenHandler tid) Nothing
   return tid

updatePosHandler :: TMVar SignalType -> IO ()
updatePosHandler sig = do
   atomically $ putTMVar sig Reposition
   return ()

changeScreenHandler :: TMVar SignalType -> IO ()
changeScreenHandler sig = do
   atomically $ putTMVar sig ChangeScreen
   return ()


-- | Ensures that the given IO action runs its cleanup actions ('bracket' etc.),
-- even if a signal is caught.
--
-- An exception will be thrown on the thread that called this function when a
-- signal is caught.
withDeferSignals :: IO a -> IO a
withDeferSignals thing = do
  threadId <- myThreadId
  caughtSignal <- newEmptyMVar

  let signals =
        filter (not . flip inSignalSet reservedSignals)
          [ sigQUIT
          , sigTERM
          --, sigINT -- Handler already installed by GHC
          --, sigPIPE -- Handler already installed by GHC
          --, sigUSR1 -- Handled by setupSignalHandler
          --, sigUSR2 -- Handled by setupSignalHandler

          -- One of the following appears to cause instability, see #360
          --, sigHUP
          --, sigILL
          --, sigABRT
          --, sigFPE
          --, sigSEGV
          --, sigALRM
          --, sigBUS
          --, sigPOLL
          --, sigPROF
          --, sigSYS
          --, sigTRAP
          --, sigVTALRM
          --, sigXCPU
          --, sigXFSZ
          ]

  for_ signals $ \s ->

      installHandler s
        (Catch $ do
          tryPutMVar caughtSignal s
          hPutStrLn stderr ("xmobar: Caught signal "++show s++"; exiting...")
          throwTo threadId ThreadKilled)
        Nothing

  thing `finally` do
        s0 <- tryReadMVar caughtSignal
        case s0 of
          Nothing -> pure ()
          Just s -> do
            -- Run the default handler for the signal
            -- hPutStrLn stderr ("xmobar: Running default handler for signal "++show s)
            installHandler s Default Nothing
            raiseSignal s