From 50134d5b5c4baabdfb35c0aeb8bf53d29f009c4d Mon Sep 17 00:00:00 2001 From: jao Date: Wed, 21 Nov 2018 23:51:41 +0000 Subject: All sources moved inside src --- src/Xmobar/IPC/DBus.hs | 73 -------------------------------------------------- 1 file changed, 73 deletions(-) delete mode 100644 src/Xmobar/IPC/DBus.hs (limited to 'src/Xmobar/IPC/DBus.hs') diff --git a/src/Xmobar/IPC/DBus.hs b/src/Xmobar/IPC/DBus.hs deleted file mode 100644 index 894637b..0000000 --- a/src/Xmobar/IPC/DBus.hs +++ /dev/null @@ -1,73 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : DBus --- Copyright : (c) Jochen Keil --- License : BSD-style (see LICENSE) --- --- Maintainer : Jochen Keil --- 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) -- cgit v1.2.3