module Manatee.Extension.IrcClient.DBus where
import DBus.Client hiding (Signal)
import DBus.MatchRule
import DBus.Message (Signal, signalBody)
import DBus.Types
import Data.Maybe (fromMaybe)
import Data.Text.Lazy (Text, empty)
import Graphics.UI.Gtk.General.General
import Language.Haskell.TH
import Manatee.Core.DBus
import Manatee.Core.TH
import Manatee.Extension.IrcClient.Types
import Manatee.Toolkit.General.DBus
import Manatee.Toolkit.General.Misc
import Network.FastIRC.Types
import System.Posix.Process
import System.Posix.Types (ProcessID)
import qualified Data.ByteString.Char8 as B
data IrcDaemonMember = Join
| Part
| SendMessage
deriving (Show, Eq, Ord)
data IrcDaemonSignalArgs = JoinArgs Server Port Channel Nick ProcessID
| PartArgs Server Channel ProcessID
| SendMessageArgs Server B.ByteString
deriving (Show, Eq, Ord)
data IrcClientMember = ReceivePrivate
| ReceiveJoin
| ReceiveTopicReply
| ReceiveTopicWhoTime
| ReceiveChannelUrl
| ReceiveNames
| ReceiveQuit
| ReceivePart
| DaemonProcessStartup
deriving (Show, Eq, Ord)
data IrcClientSignalArgs = ReceivePrivateArgs NickName CommandArg
| ReceiveJoinArgs NickName UserName HostName
| ReceiveTopicReplyArgs CommandArg
| ReceiveTopicWhoTimeArgs NickName Integer
| ReceiveChannelUrlArgs B.ByteString
| ReceiveNamesArgs B.ByteString
| ReceiveQuitArgs NickName UserName HostName CommandArg
| ReceivePartArgs NickName UserName HostName CommandArg
| DaemonProcessStartupArgs
deriving (Show, Eq, Ord)
ircDaemonBusName :: Text
ircDaemonBusName = "org.manatee.extension.irc.daemon"
ircDaemonInterfaceName :: Text
ircDaemonInterfaceName = "org.manatee.daemon.interface"
ircDaemonPathName :: Text
ircDaemonPathName = "/path"
mkFunDec "checkIrcDaemonSignalArgs" (checkSignalArgs ''IrcDaemonMember ''IrcDaemonSignalArgs)
mkFunDec "unpackIrcDaemonSignalArgs_" (unpackVariantList ''IrcDaemonMember ''IrcDaemonSignalArgs)
$(packVariantList "packIrcDaemonSignalArgs" ''IrcDaemonSignalArgs)
mkFunDec "checkIrcClientSignalArgs" (checkSignalArgs ''IrcClientMember ''IrcClientSignalArgs)
mkFunDec "unpackIrcClientSignalArgs_" (unpackVariantList ''IrcClientMember ''IrcClientSignalArgs)
$(packVariantList "packIrcClientSignalArgs" ''IrcClientSignalArgs)
mkIrcDaemonSignal :: Client -> IrcDaemonMember -> IrcDaemonSignalArgs -> IO ()
mkIrcDaemonSignal client memberName args
| checkIrcDaemonSignalArgs memberName args
= emitSignal client signal
| otherwise
= putStrLn $ "mkIrcDaemonSignal CRITICAL: Invalid argument for dbus daemon member: " ++ show memberName
where signal = mkMessageSignal
ircDaemonPathName
(showText memberName)
ircDaemonInterfaceName
ircDaemonBusName
(packIrcDaemonSignalArgs args)
mkIrcDaemonMatchRule :: Client -> (IrcDaemonMember, IrcDaemonSignalArgs -> IO ()) -> IO ()
mkIrcDaemonMatchRule client (member, fun) =
onSignal client matchRule $ \_ signal ->
fun $ pickIrcDaemonSignalArgs member signal
where matchRule = mkMatchRule
(Just Signal)
empty
ircDaemonInterfaceName
(showText member)
ircDaemonPathName
ircDaemonBusName
[]
mkIrcDaemonMatchRules :: Client -> [(IrcDaemonMember, IrcDaemonSignalArgs -> IO ())] -> IO ()
mkIrcDaemonMatchRules client = mapM_ (mkIrcDaemonMatchRule client)
pickIrcDaemonSignalArgs :: IrcDaemonMember -> Signal -> IrcDaemonSignalArgs
pickIrcDaemonSignalArgs member signal = unpackIrcDaemonSignalArgs member $ signalBody signal
unpackIrcDaemonSignalArgs member args =
fromMaybe
(error $ "unpackIrcDaemonSignalArgs: Miss pattern for " ++ show member)
(unpackIrcDaemonSignalArgs_ member args)
pickIrcClientSignalArgs :: IrcClientMember -> Signal -> IrcClientSignalArgs
pickIrcClientSignalArgs member signal = unpackIrcClientSignalArgs member $ signalBody signal
unpackIrcClientSignalArgs member args =
fromMaybe
(error $ "unpackIrcClientSignalArgs: Miss pattern for " ++ show member)
(unpackIrcClientSignalArgs_ member args)
mkIrcClientSignal :: Client -> ProcessID -> IrcClientMember -> IrcClientSignalArgs -> IO ()
mkIrcClientSignal client processId memberName args
| checkIrcClientSignalArgs memberName args
= emitSignal client signal
| otherwise
= putStrLn $ "mkIrcClientSignal CRITICAL: Invalid argument for dbus render member: " ++ show memberName
where signal = mkMessageSignal
renderPathName
(showText memberName)
renderInterfaceName
(mkRenderClientName processId)
(packIrcClientSignalArgs args)
mkIrcClientMatchRule :: Client -> (IrcClientMember, IrcClientSignalArgs -> IO ()) -> IO ()
mkIrcClientMatchRule client (member, fun) = do
processId <- getProcessID
let matchRule = mkMatchRule
(Just Signal)
empty
renderInterfaceName
(showText member)
renderPathName
(mkRenderClientName processId)
[]
onSignal client matchRule $ \_ signal ->
postGUIAsync $ fun $ pickIrcClientSignalArgs member signal
mkIrcClientMatchRules :: Client -> [(IrcClientMember, IrcClientSignalArgs -> IO ())] -> IO ()
mkIrcClientMatchRules client = mapM_ (mkIrcClientMatchRule client)
deriveVariable (conT ''Integer)