blob: 103a5a9f4c9fd6ff565bc1d8764d19f5b67c026b (
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
|
-----------------------------------------------------------------------------
-- |
-- 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 Xmobar.System.DBus (runIPC) where
import DBus
import DBus.Client hiding (interfaceName)
import qualified DBus.Client as DC
import Data.Maybe (isNothing)
import Control.Concurrent.STM
import Control.Exception (handle)
import System.IO (stderr, hPutStrLn)
import Control.Monad.IO.Class (liftIO)
import Xmobar.System.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 $
if methodCallMember mc == sendSignalName
then do
let signals :: [Maybe SignalType]
signals = map fromVariant (methodCallBody mc)
mapM_ sendSignal signals
if any isNothing signals
then return ( ReplyError errorInvalidParameters [] )
else return ( ReplyReturn [] )
else
return ( ReplyError errorUnknownMethod [] )
sendSignal :: Maybe SignalType -> IO ()
sendSignal = maybe (return ()) (atomically . putTMVar mvst)
|
