summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar/System/DBus.hs
diff options
context:
space:
mode:
authorjao <jao@gnu.org>2018-11-25 15:10:29 +0000
committerjao <jao@gnu.org>2018-11-25 15:10:29 +0000
commit77df1ac30fa7af5948f7ff64f5fee9aed64552b3 (patch)
tree647a4eb67ff1c293a5c530538ee88fc0093b577a /src/Xmobar/System/DBus.hs
parente0d6da82de8d0d1cef98896164c6016b84e47068 (diff)
downloadxmobar-77df1ac30fa7af5948f7ff64f5fee9aed64552b3.tar.gz
xmobar-77df1ac30fa7af5948f7ff64f5fee9aed64552b3.tar.bz2
Back to app/src, since it seems they're the default convention for stack
Diffstat (limited to 'src/Xmobar/System/DBus.hs')
-rw-r--r--src/Xmobar/System/DBus.hs73
1 files changed, 73 insertions, 0 deletions
diff --git a/src/Xmobar/System/DBus.hs b/src/Xmobar/System/DBus.hs
new file mode 100644
index 0000000..103a5a9
--- /dev/null
+++ b/src/Xmobar/System/DBus.hs
@@ -0,0 +1,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)