summaryrefslogtreecommitdiffhomepage
path: root/src/lib/Xmobar/IPC/DBus.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/lib/Xmobar/IPC/DBus.hs')
-rw-r--r--src/lib/Xmobar/IPC/DBus.hs73
1 files changed, 0 insertions, 73 deletions
diff --git a/src/lib/Xmobar/IPC/DBus.hs b/src/lib/Xmobar/IPC/DBus.hs
deleted file mode 100644
index 894637b..0000000
--- a/src/lib/Xmobar/IPC/DBus.hs
+++ /dev/null
@@ -1,73 +0,0 @@
------------------------------------------------------------------------------
--- |
--- 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.IPC.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.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)