From a7158c426ae008fb268f603f75d027683f726757 Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Fri, 10 Aug 2012 11:35:35 +0200 Subject: Add an initial (working) version of the DBus IPC module --- src/IPC/DBus.hs | 66 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 66 insertions(+) create mode 100644 src/IPC/DBus.hs (limited to 'src/IPC') diff --git a/src/IPC/DBus.hs b/src/IPC/DBus.hs new file mode 100644 index 0000000..64e3cca --- /dev/null +++ b/src/IPC/DBus.hs @@ -0,0 +1,66 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DBus +-- Copyright : (c) Jochen Keil +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jochen Keil +-- Stability : unstable +-- Portability : unportable +-- +-- DBus IPC module for Xmobar +-- +----------------------------------------------------------------------------- + +module IPC.DBus ( runIPC ) where + +import DBus +import DBus.Client +import Control.Monad ((>=>), join, when) +import Control.Concurrent + +import Signal + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x:_) = Just x + +instance IsVariant SignalType where + toVariant = toVariant . show + fromVariant = fromVariant >=> parseSignalType + +parseSignalType :: String -> Maybe SignalType +parseSignalType = fmap fst . safeHead . reads + +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 = 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) -- cgit v1.2.3 From 1f603c25eea15d302a4aa1ebb879bbd8198a3b82 Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Fri, 10 Aug 2012 11:37:22 +0200 Subject: Move safeHead to Plugins.Utils safeHead is a very general utility function with suits better into a common Util module. --- src/IPC/DBus.hs | 5 +---- src/Plugins/Utils.hs | 6 +++++- 2 files changed, 6 insertions(+), 5 deletions(-) (limited to 'src/IPC') diff --git a/src/IPC/DBus.hs b/src/IPC/DBus.hs index 64e3cca..4357c48 100644 --- a/src/IPC/DBus.hs +++ b/src/IPC/DBus.hs @@ -20,10 +20,7 @@ import Control.Monad ((>=>), join, when) import Control.Concurrent import Signal - -safeHead :: [a] -> Maybe a -safeHead [] = Nothing -safeHead (x:_) = Just x +import Plugins.Utils (safeHead) instance IsVariant SignalType where toVariant = toVariant . show diff --git a/src/Plugins/Utils.hs b/src/Plugins/Utils.hs index 1dbcd40..bbfa84f 100644 --- a/src/Plugins/Utils.hs +++ b/src/Plugins/Utils.hs @@ -15,7 +15,7 @@ ------------------------------------------------------------------------------ -module Plugins.Utils (expandHome, changeLoop) where +module Plugins.Utils (expandHome, changeLoop, safeHead) where import Control.Monad import Control.Concurrent.STM @@ -37,3 +37,7 @@ changeLoop s f = atomically s >>= go new <- s guard (new /= old) return new) + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x:_) = Just x -- cgit v1.2.3 From b318c3c18d3c2d4866c3f325f8ec6f00a42876fb Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Fri, 10 Aug 2012 11:38:52 +0200 Subject: Move the IsVariant SignalType instance to Signal module This belongs here, otherwise ghc will complain about orphaned instances --- src/IPC/DBus.hs | 9 +-------- src/Signal.hs | 18 +++++++++++++++++- 2 files changed, 18 insertions(+), 9 deletions(-) (limited to 'src/IPC') diff --git a/src/IPC/DBus.hs b/src/IPC/DBus.hs index 4357c48..b0597a4 100644 --- a/src/IPC/DBus.hs +++ b/src/IPC/DBus.hs @@ -16,19 +16,12 @@ module IPC.DBus ( runIPC ) where import DBus import DBus.Client -import Control.Monad ((>=>), join, when) +import Control.Monad (join, when) import Control.Concurrent import Signal import Plugins.Utils (safeHead) -instance IsVariant SignalType where - toVariant = toVariant . show - fromVariant = fromVariant >=> parseSignalType - -parseSignalType :: String -> Maybe SignalType -parseSignalType = fmap fst . safeHead . reads - busName :: BusName busName = busName_ "org.Xmobar.Control" diff --git a/src/Signal.hs b/src/Signal.hs index ad19fdd..f634c16 100644 --- a/src/Signal.hs +++ b/src/Signal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, CPP #-} module Signal where @@ -7,6 +7,13 @@ import Control.Concurrent import Control.Exception hiding (handle) import System.Posix.Signals +#ifdef DBUS +import DBus (IsVariant(..)) +import Control.Monad ((>=>)) + +import Plugins.Utils (safeHead) +#endif + data WakeUp = WakeUp deriving (Show,Typeable) instance Exception WakeUp @@ -19,6 +26,15 @@ data SignalType = Wakeup | TogglePersistent deriving (Read, Show) +#ifdef DBUS +instance IsVariant SignalType where + toVariant = toVariant . show + fromVariant = fromVariant >=> parseSignalType +#endif + +parseSignalType :: String -> Maybe SignalType +parseSignalType = fmap fst . safeHead . reads + -- | Signal handling setupSignalHandler :: IO (MVar SignalType) setupSignalHandler = do -- cgit v1.2.3 From 8a53271cd677bea3223f7d25eb1f697aa3d96540 Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Sun, 12 Aug 2012 10:33:41 +0200 Subject: Catch error when DBus connection fails connectSession throws a ClientError Exception when DBUS_SESSION_BUS_ADDRESS is unset. Without exception handler this will result in program termination. Since the DBus handler merely sends a signal to the event loop it does no harm when it won't run. Normal operation will continue just if compiled without dbus support. --- src/IPC/DBus.hs | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) (limited to 'src/IPC') diff --git a/src/IPC/DBus.hs b/src/IPC/DBus.hs index b0597a4..469a7c6 100644 --- a/src/IPC/DBus.hs +++ b/src/IPC/DBus.hs @@ -14,10 +14,14 @@ 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) @@ -32,10 +36,14 @@ interfaceName :: InterfaceName interfaceName = interfaceName_ "org.Xmobar.Control" runIPC :: MVar SignalType -> IO () -runIPC mvst = do - client <- connectSession - requestName client busName [ nameDoNotQueue ] - export client objectPath [ sendSignalMethod mvst ] +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 -- cgit v1.2.3