blob: 60544a95399ed82cc9739cab60f08410e78f54e9 (
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 Prelude hiding (catch)
import DBus
import DBus.Client
import Control.Monad (when)
import Control.Concurrent.STM
import Control.Exception (catch)
import System.IO (stderr, hPutStrLn)
import Signal
busName :: BusName
busName = busName_ "org.Xmobar.Control"
objectPath :: ObjectPath
objectPath = objectPath_ "/org/Xmobar/Control"
interfaceName :: InterfaceName
interfaceName = interfaceName_ "org.Xmobar.Control"
runIPC :: TMVar SignalType -> IO ()
runIPC mvst = catch exportConnection printException
where
printException :: ClientError -> IO ()
printException = hPutStrLn stderr . clientErrorMessage
exportConnection = do
client <- connectSession
requestName client busName [ nameDoNotQueue ]
export client objectPath [ sendSignalMethod mvst ]
sendSignalMethod :: TMVar 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 )
$ mapM_ (sendSignal . fromVariant) (methodCallBody mc)
return ( replyReturn [] )
sendSignal :: Maybe SignalType -> IO ()
sendSignal = maybe (return ()) (atomically . putTMVar mvst)
|
