blob: 4357c48226e2b4f9ff27527f050d1e2d5bd49003 (
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
|
-----------------------------------------------------------------------------
-- |
-- Module : DBus
-- Copyright : (c) Jochen Keil
-- License : BSD-style (see LICENSE)
--
-- Maintainer : Jochen Keil <jochen dot keil at gmail dot com>
-- Stability : unstable
-- Portability : unportable
--
-- DBus IPC module for Xmobar
--
-----------------------------------------------------------------------------
module IPC.DBus ( runIPC ) where
import DBus
import DBus.Client
import Control.Monad ((>=>), join, when)
import Control.Concurrent
import Signal
import Plugins.Utils (safeHead)
instance IsVariant SignalType where
toVariant = toVariant . show
fromVariant = fromVariant >=> parseSignalType
parseSignalType :: String -> Maybe SignalType
parseSignalType = fmap fst . safeHead . reads
busName :: BusName
busName = busName_ "org.Xmobar.Control"
objectPath :: ObjectPath
objectPath = objectPath_ "/org/Xmobar/Control"
interfaceName :: InterfaceName
interfaceName = interfaceName_ "org.Xmobar.Control"
runIPC :: MVar SignalType -> IO ()
runIPC mvst = do
client <- connectSession
requestName client busName [ nameDoNotQueue ]
export client objectPath [ sendSignalMethod mvst ]
sendSignalMethod :: MVar SignalType -> Method
sendSignalMethod mvst = method interfaceName sendSignalName
(signature_ [variantType $ toVariant $ (undefined :: SignalType)])
(signature_ [])
sendSignalMethodCall
where
sendSignalName :: MemberName
sendSignalName = memberName_ "SendSignal"
sendSignalMethodCall :: MethodCall -> IO Reply
sendSignalMethodCall mc = do
when ( methodCallMember mc == sendSignalName ) $ sendSignal $
join $ safeHead $ map fromVariant $ methodCallBody mc
return ( replyReturn [] )
sendSignal :: Maybe SignalType -> IO ()
sendSignal = maybe (return ()) (putMVar mvst)
|
