blob: b9bffd556151f31de2cc83292daaf09fd08fb68e (
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
|
-----------------------------------------------------------------------------
-- |
-- 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 hiding (interfaceName)
import qualified DBus.Client as DC
import Control.Monad (when)
import Control.Concurrent.STM
import Control.Exception (handle)
import System.IO (stderr, hPutStrLn)
import Control.Monad.IO.Class (liftIO)
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 = handle printException exportConnection
where
printException :: ClientError -> IO ()
printException = hPutStrLn stderr . clientErrorMessage
exportConnection = do
client <- connectSession
requestName client busName [ nameDoNotQueue ]
export client objectPath defaultInterface
{ DC.interfaceName = interfaceName
, DC.interfaceMethods = [ sendSignalMethod mvst ]
}
sendSignalMethod :: TMVar SignalType -> Method
sendSignalMethod mvst = makeMethod sendSignalName
(signature_ [variantType $ toVariant (undefined :: SignalType)])
(signature_ [])
sendSignalMethodCall
where
sendSignalName :: MemberName
sendSignalName = memberName_ "SendSignal"
sendSignalMethodCall :: MethodCall -> DBusR Reply
sendSignalMethodCall mc = liftIO $ do
when ( methodCallMember mc == sendSignalName )
$ mapM_ (sendSignal . fromVariant) (methodCallBody mc)
return ( ReplyReturn [] )
sendSignal :: Maybe SignalType -> IO ()
sendSignal = maybe (return ()) (atomically . putTMVar mvst)
|
