module Manatee.Core.DBus where
import Control.Concurrent.MVar
import Control.Monad
import DBus.Client hiding (Signal)
import DBus.MatchRule
import DBus.Message (Signal, signalBody, MethodReturn, Error)
import DBus.Types
import Data.Maybe (fromMaybe)
import Data.Text.Lazy (Text, empty, append)
import Graphics.UI.Gtk.General.General
import Manatee.Core.TH
import Manatee.Core.Types
import Manatee.Toolkit.General.DBus
import Manatee.Toolkit.General.Misc
import System.Posix.Process
import System.Posix.Types (ProcessID)
import qualified Data.Map as M
daemonBusName :: Text
daemonBusName = "org.manatee.daemon"
daemonInterfaceName :: Text
daemonInterfaceName = "org.manatee.daemon.interface"
daemonPathName :: Text
daemonPathName = "/path"
daemonBroadcastInterfaceName :: Text
daemonBroadcastInterfaceName = "org.manatee.daemon.broadcast.interface"
daemonBroadcastPathName :: Text
daemonBroadcastPathName = "/broadcastpath"
daemonInteractiveErrorName :: Text
daemonInteractiveErrorName = "org.manatee.daemon.interactive.error"
renderBusName :: Text
renderBusName = "org.manatee.render"
renderInterfaceName :: Text
renderInterfaceName = "org.manatee.daemon.interface"
renderPathName :: Text
renderPathName = "/path"
mkRenderClientName :: ProcessID -> Text
mkRenderClientName processId = append renderBusName $ showText processId
mkFunDec "unpackDaemonSignalArgs_" (unpackVariantList ''DaemonMember ''DaemonSignalArgs)
mkFunDec "unpackDaemonBroadcastSignalArgs_" (unpackVariantList ''DaemonBroadcastMember ''DaemonBroadcastSignalArgs)
mkFunDec "unpackRenderSignalArgs_" (unpackVariantList ''RenderMember ''RenderSignalArgs)
$(packVariantList "packDaemonSignalArgs" ''DaemonSignalArgs)
$(packVariantList "packRenderSignalArgs" ''RenderSignalArgs)
$(packVariantList "packDaemonBroadcastSignalArgs" ''DaemonBroadcastSignalArgs)
mkFunDec "checkDaemonSignalArgs" (checkSignalArgs ''DaemonMember ''DaemonSignalArgs)
mkFunDec "checkRenderSignalArgs" (checkSignalArgs ''RenderMember ''RenderSignalArgs)
mkFunDec "checkDaemonBroadcastSignalArgs" (checkSignalArgs ''DaemonBroadcastMember ''DaemonBroadcastSignalArgs)
mkDaemonBroadcastSignal :: Client -> DaemonBroadcastMember -> DaemonBroadcastSignalArgs -> IO ()
mkDaemonBroadcastSignal client memberName args
| checkDaemonBroadcastSignalArgs memberName args
= emitSignal client signal
| otherwise
= putStrLn $ "mkDaemonBroadcastSignal CRITICAL: Invalid argument for dbus daemon broadcast member: " ++ show memberName
where signal = mkMessageSignal
daemonBroadcastPathName
(showText memberName)
daemonBroadcastInterfaceName
empty
(packDaemonBroadcastSignalArgs args)
mkDaemonBroadcastMatchRule :: Client -> (DaemonBroadcastMember, DaemonBroadcastSignalArgs -> IO ()) -> IO ()
mkDaemonBroadcastMatchRule client (member, fun) =
onSignal client matchRule $ \_ signal ->
fun $ pickDaemonBroadcastSignalArgs member signal
where matchRule = mkMatchRule
(Just Signal)
empty
daemonBroadcastInterfaceName
(showText member)
daemonBroadcastPathName
empty
[]
mkDaemonSignal :: Client -> DaemonMember -> DaemonSignalArgs -> IO ()
mkDaemonSignal client memberName args
| checkDaemonSignalArgs memberName args
= emitSignal client signal
| otherwise
= putStrLn $ "mkDaemonSignal CRITICAL: Invalid argument for dbus daemon member: " ++ show memberName
where signal = mkMessageSignal
daemonPathName
(showText memberName)
daemonInterfaceName
daemonBusName
(packDaemonSignalArgs args)
mkDaemonMatchRule :: Client -> (DaemonMember, DaemonSignalArgs -> IO ()) -> IO ()
mkDaemonMatchRule client (member, fun) =
onSignal client matchRule $ \_ signal ->
postGUIAsync $ fun $ pickDaemonSignalArgs member signal
where matchRule = mkMatchRule
(Just Signal)
empty
daemonInterfaceName
(showText member)
daemonPathName
daemonBusName
[]
mkDaemonMatchRules :: Client -> [(DaemonMember, DaemonSignalArgs -> IO ())] -> IO ()
mkDaemonMatchRules client = mapM_ (mkDaemonMatchRule client)
pickDaemonSignalArgs :: DaemonMember -> Signal -> DaemonSignalArgs
pickDaemonSignalArgs member signal = unpackDaemonSignalArgs member $ signalBody signal
pickDaemonBroadcastSignalArgs :: DaemonBroadcastMember -> Signal -> DaemonBroadcastSignalArgs
pickDaemonBroadcastSignalArgs member signal = unpackDaemonBroadcastSignalArgs member $ signalBody signal
mkRenderSignal :: Client -> ProcessID -> RenderMember -> RenderSignalArgs -> IO ()
mkRenderSignal client processId memberName args
| checkRenderSignalArgs memberName args
= emitSignal client signal
| otherwise
= putStrLn $ "mkRenderSignal CRITICAL: Invalid argument for dbus render member: " ++ show memberName
where signal = mkMessageSignal
renderPathName
(showText memberName)
renderInterfaceName
(mkRenderClientName processId)
(packRenderSignalArgs args)
mkRenderMatchRule :: Client -> (RenderMember, RenderSignalArgs -> IO ()) -> IO ()
mkRenderMatchRule client (member, fun) = do
processId <- getProcessID
let matchRule = mkMatchRule
(Just Signal)
empty
renderInterfaceName
(showText member)
renderPathName
(mkRenderClientName processId)
[]
onSignal client matchRule $ \_ signal ->
postGUIAsync $ fun $ pickRenderSignalArgs member signal
mkRenderMatchRuleUnsafe :: Client -> (RenderMember, RenderSignalArgs -> IO ()) -> IO ()
mkRenderMatchRuleUnsafe client (member, fun) = do
processId <- getProcessID
let matchRule = mkMatchRule
(Just Signal)
empty
renderInterfaceName
(showText member)
renderPathName
(mkRenderClientName processId)
[]
onSignal client matchRule $ \_ signal ->
fun $ pickRenderSignalArgs member signal
mkRenderMatchRules :: Client -> [(RenderMember, RenderSignalArgs -> IO ())] -> IO ()
mkRenderMatchRules client = mapM_ (mkRenderMatchRule client)
pickRenderSignalArgs :: RenderMember -> Signal -> RenderSignalArgs
pickRenderSignalArgs member signal = unpackRenderSignalArgs member $ signalBody signal
unpackDaemonSignalArgs member args =
fromMaybe
(error $ "unpackDaemonSignalArgs: Miss pattern for " ++ show member)
(unpackDaemonSignalArgs_ member args)
unpackDaemonBroadcastSignalArgs member args =
fromMaybe
(error $ "unpackDaemonBroadcastSignalArgs: Miss pattern for " ++ show member)
(unpackDaemonBroadcastSignalArgs_ member args)
unpackRenderSignalArgs member args =
fromMaybe
(error $ "unpackRenderSignalArgs: Miss pattern for " ++ show member)
(unpackRenderSignalArgs_ member args)
waitBroadcastExitSignal :: Client -> IO ()
waitBroadcastExitSignal client = do
exitSignal :: MVar String <- newEmptyMVar
mkDaemonBroadcastMatchRule client (ExitDaemonProcess, \_ -> putMVar exitSignal "Exit")
readMVar exitSignal
return ()
mkDaemonMethods :: [(Text, Member)] -> IO ()
mkDaemonMethods methods =
forM_ methods $ \ (name, member) -> do
let object = LocalObject $ M.fromList [(mkInterfaceName_ daemonInterfaceName
,Interface $ M.fromList [(mkMemberName_ name, member)])]
client <- mkSessionClientWithName (append daemonBusName name)
export client (mkObjectPath_ daemonPathName) object
callDaemonMethod :: Client -> Text -> [Variant] -> IO (Either Error MethodReturn)
callDaemonMethod client methodName =
callProxyBlocking client (Proxy (RemoteObject
(mkBusName_ (append daemonBusName methodName))
(mkObjectPath_ daemonPathName))
(mkInterfaceName_ daemonInterfaceName))
(mkMemberName_ methodName) []
callDaemonMethodAsync :: Client -> Text -> [Variant] -> (Error -> IO ()) -> (MethodReturn -> IO ()) -> IO ()
callDaemonMethodAsync client methodName =
callProxy client (Proxy (RemoteObject
(mkBusName_ (append daemonBusName methodName))
(mkObjectPath_ daemonPathName))
(mkInterfaceName_ daemonInterfaceName))
(mkMemberName_ methodName) []