{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- 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 DBus.Socket
import Data.Maybe (isNothing)
import Control.Concurrent.STM
import Control.Exception
import System.IO (stderr, hPutStrLn)
import Control.Monad.IO.Class (liftIO)

import Xmobar.System.Signal

busName :: BusName
busName :: BusName
busName = String -> BusName
busName_ String
"org.Xmobar.Control"

objectPath :: ObjectPath
objectPath :: ObjectPath
objectPath = String -> ObjectPath
objectPath_ String
"/org/Xmobar/Control"

interfaceName :: InterfaceName
interfaceName :: InterfaceName
interfaceName = String -> InterfaceName
interfaceName_ String
"org.Xmobar.Control"

runIPC :: TMVar SignalType -> IO ()
runIPC :: TMVar SignalType -> IO ()
runIPC TMVar SignalType
mvst = IO ()
exportConnection IO () -> [Handler ()] -> IO ()
forall a. IO a -> [Handler a] -> IO a
`catches` [
      (ClientError -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler(\ (ClientError
ex :: ClientError) -> Handle -> String -> IO ()
hPutStrLn Handle
stderr (ClientError -> String
clientErrorMessage ClientError
ex)),
      (SocketError -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler(\ (SocketError
ex :: SocketError) -> Handle -> String -> IO ()
hPutStrLn Handle
stderr (SocketError -> String
socketErrorMessage SocketError
ex))]
    where
    exportConnection :: IO ()
exportConnection = do
        client <- IO Client
connectSession
        requestName client busName [ nameDoNotQueue ]
        export client objectPath defaultInterface
          { DC.interfaceName = interfaceName
          , DC.interfaceMethods = [ sendSignalMethod mvst ]
          }

sendSignalMethod :: TMVar SignalType -> Method
sendSignalMethod :: TMVar SignalType -> Method
sendSignalMethod TMVar SignalType
mvst = MemberName
-> Signature -> Signature -> (MethodCall -> DBusR Reply) -> Method
makeMethod MemberName
sendSignalName
    ([Type] -> Signature
signature_ [Variant -> Type
variantType (Variant -> Type) -> Variant -> Type
forall a b. (a -> b) -> a -> b
$ SignalType -> Variant
forall a. IsVariant a => a -> Variant
toVariant (SignalType
forall a. HasCallStack => a
undefined :: SignalType)])
    ([Type] -> Signature
signature_ [])
    MethodCall -> DBusR Reply
sendSignalMethodCall
    where
    sendSignalName :: MemberName
    sendSignalName :: MemberName
sendSignalName = String -> MemberName
memberName_ String
"SendSignal"

    sendSignalMethodCall :: MethodCall -> DBusR Reply
    sendSignalMethodCall :: MethodCall -> DBusR Reply
sendSignalMethodCall MethodCall
mc = IO Reply -> DBusR Reply
forall a. IO a -> ReaderT Client IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Reply -> DBusR Reply) -> IO Reply -> DBusR Reply
forall a b. (a -> b) -> a -> b
$
        if MethodCall -> MemberName
methodCallMember MethodCall
mc MemberName -> MemberName -> Bool
forall a. Eq a => a -> a -> Bool
== MemberName
sendSignalName
          then do
            let signals :: [Maybe SignalType]
                signals :: [Maybe SignalType]
signals = (Variant -> Maybe SignalType) -> [Variant] -> [Maybe SignalType]
forall a b. (a -> b) -> [a] -> [b]
map Variant -> Maybe SignalType
forall a. IsVariant a => Variant -> Maybe a
fromVariant (MethodCall -> [Variant]
methodCallBody MethodCall
mc)
            (Maybe SignalType -> IO ()) -> [Maybe SignalType] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Maybe SignalType -> IO ()
sendSignal [Maybe SignalType]
signals
            if (Maybe SignalType -> Bool) -> [Maybe SignalType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe SignalType -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe SignalType]
signals
              then Reply -> IO Reply
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ( ErrorName -> [Variant] -> Reply
ReplyError ErrorName
errorInvalidParameters [] )
              else Reply -> IO Reply
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [Variant] -> Reply
ReplyReturn [] )
          else
            Reply -> IO Reply
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ( ErrorName -> [Variant] -> Reply
ReplyError ErrorName
errorUnknownMethod [] )

    sendSignal :: Maybe SignalType -> IO ()
    sendSignal :: Maybe SignalType -> IO ()
sendSignal = IO () -> (SignalType -> IO ()) -> Maybe SignalType -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (SignalType -> STM ()) -> SignalType -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar SignalType -> SignalType -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar SignalType
mvst)