summaryrefslogtreecommitdiffhomepage
path: root/src/IPC
diff options
context:
space:
mode:
authorJose Antonio Ortega Ruiz <jao@gnu.org>2012-08-13 15:11:55 +0200
committerJose Antonio Ortega Ruiz <jao@gnu.org>2012-08-13 15:12:11 +0200
commit359769944a8cb0ac80537458af0e49cc8f68d01b (patch)
tree484068988be1571b25ff0a81c7e74cb9cd579325 /src/IPC
parent73837127825529d44e2e0d4ed440da0d7b180020 (diff)
parent05f268c3a831325f65a662c6ccdff75a1c441d83 (diff)
downloadxmobar-359769944a8cb0ac80537458af0e49cc8f68d01b.tar.gz
xmobar-359769944a8cb0ac80537458af0e49cc8f68d01b.tar.bz2
Merge for pull request #53
Diffstat (limited to 'src/IPC')
-rw-r--r--src/IPC/DBus.hs64
1 files changed, 64 insertions, 0 deletions
diff --git a/src/IPC/DBus.hs b/src/IPC/DBus.hs
new file mode 100644
index 0000000..469a7c6
--- /dev/null
+++ b/src/IPC/DBus.hs
@@ -0,0 +1,64 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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 (join, when)
+import Control.Concurrent
+import Control.Exception (catch)
+import System.IO (stderr, hPutStrLn)
+
+import Signal
+import Plugins.Utils (safeHead)
+
+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 = 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 :: 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)