{-# LANGUAGE ScopedTypeVariables #-}
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)