d-bus-0.1.3: src/DBus/Signal.hs
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
module DBus.Signal where
import Control.Applicative
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Catch (MonadThrow)
import Control.Monad.Trans
import Control.Monad.Writer
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
import Data.Singletons
import Data.Singletons.Decide
import Data.Singletons.Prelude.List
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TextL
import qualified Data.Text.Lazy.Builder as TB
import DBus.Types
import DBus.Message
import DBus.MessageBus
import DBus.Representable
data MatchRule = MatchRule { mrType :: Maybe MessageType
, mrSender :: Maybe Text.Text
, mrInterface :: Maybe Text.Text
, mrMember :: Maybe Text.Text
, mrPath :: Maybe (Bool, ObjectPath)
, mrDestination :: Maybe Text.Text
, mrArgs :: [(Int,Text.Text)]
, mrArgPaths :: [(Int,Text.Text)]
, mrArg0namespace :: Maybe Text.Text
, mrEavesdrop :: Maybe Bool
}
matchAll :: MatchRule
matchAll = MatchRule Nothing Nothing Nothing Nothing Nothing Nothing
[] [] Nothing Nothing
-- Left-biased monoid
instance Monoid MatchRule where
mempty = matchAll
mappend lr rr =
MatchRule
{ mrType = mrType lr `mplus` mrType rr
, mrSender = mrSender lr `mplus` mrSender rr
, mrInterface = mrInterface lr `mplus` mrInterface rr
, mrMember = mrMember lr `mplus` mrMember rr
, mrPath = mrPath lr `mplus` mrPath rr
, mrDestination = mrDestination lr `mplus` mrDestination rr
, mrArgs = mrArgs lr `mplus` mrArgs rr
, mrArgPaths = mrArgPaths lr `mplus` mrArgPaths rr
, mrArg0namespace = mrArg0namespace lr `mplus` mrArg0namespace rr
, mrEavesdrop = mrEavesdrop lr `mplus` mrEavesdrop rr
}
renderRule :: MatchRule -> Text.Text
renderRule mr = Text.concat . TextL.toChunks . TB.toLazyText .
mconcat . List.intersperse (TB.singleton ',') $
(catMaybes
[ toRule "type" fromMessageType <$> mrType mr
, toRule "sender" id <$> mrSender mr
, toRule "interface" id <$> mrInterface mr
, toRule "member" id <$> mrMember mr
, (\(namespace, path) ->
toRule ("path" <> if namespace then "_namespace" else mempty)
objectPathToText path) <$> mrPath mr
, toRule "destination" id <$> mrDestination mr
, toRule "arg0namespace" id <$> mrArg0namespace mr
, toRule "eavesdrop" boolToText <$> mrEavesdrop mr
])
++ ((\(i, v) -> toRule ("arg" <> num i) id v) <$> mrArgs mr)
++ ((\(i, v) -> toRule ("arg" <> num i <> "path") id v)
<$> mrArgPaths mr)
where
toRule name toValue v = name
<> "='"
<> TB.fromText (toValue v)
<> TB.singleton '\''
boolToText True = "true"
boolToText False = "false"
fromMessageType MessageTypeMethodCall = "method_call"
fromMessageType MessageTypeMethodReturn = "method_return"
fromMessageType MessageTypeSignal = "signal"
fromMessageType MessageTypeError = "error"
ft = TB.fromText
num i = TB.fromText . Text.pack $ show i
-- | Match a Signal against a rule. The argN, argNPath and arg0namespace
-- parameter are ignored at the moment
matchSignal :: Signal a -> MatchRule -> Bool
matchSignal sig rule = and $ catMaybes
[ (\x -> signalMember sig == x ) <$> mrMember rule
, (\x -> signalInterface sig == x ) <$> mrInterface rule
, (\(ns, x) -> let p = (signalPath sig)
in if ns then isPathPrefix x p
else x == p) <$> mrPath rule
]
-- | Add a match rule
addMatch :: (MonadIO m, MonadThrow m ) =>
MatchRule
-> DBusConnection
-> m ()
addMatch rule con = do
let renderedRule = (renderRule rule)
liftIO . logDebug $ "adding signal match rule: " ++ show renderedRule
messageBusMethod "AddMatch" renderedRule con
-- | Remove a match rule
removeMatch :: (MonadIO m, MonadThrow m ) =>
MatchRule
-> DBusConnection
-> m ()
removeMatch rule = messageBusMethod "RemoveMatch" (renderRule rule)
matchSignalToMatchRule :: MatchSignal -> MatchRule
matchSignalToMatchRule ms=
matchAll { mrType = Just MessageTypeSignal
, mrInterface = matchInterface ms
, mrMember = matchMember ms
, mrPath = (False,) <$> matchPath ms
, mrSender = matchSender ms
}
-- | Add a match rule for the given signal specification and call function on
-- all incoming matching signals
addSignalHandler :: MatchSignal
-> MatchRule -- Addition Match rules. mempty for none
-> (SomeSignal -> IO ())
-> DBusConnection
-> IO ()
addSignalHandler ms rules m dbc = do
atomically $ modifyTVar (dbusSignalSlots dbc) ((fromSlot ms, m):)
let rule = rules <> matchSignalToMatchRule ms
addMatch rule dbc
where
fromSlot s = ( maybeToMatch $ matchInterface s
, maybeToMatch $ matchMember s
, maybeToMatch $ matchPath s
, maybeToMatch $ matchSender s)
castSignalBody :: SingI a => SomeSignal -> Maybe (DBusValue a)
castSignalBody (SomeSignal s) =
case (signalBody s) of
sr@(r :: DBusArguments ats) ->
-- Use fix to access the return type (We only care about the type)
fix $ \(_ :: Maybe (DBusValue ret)) ->
case sing :: Sing ret of
STypeStruct ts -> case (r, sing :: Sing ats) of
(ArgsNil, SNil) -> Nothing
(ArgsCons r' ArgsNil, SCons a SNil) ->
case a %~ (sing :: Sing ret) of
Proved Refl -> Just r'
Disproved _ -> Nothing
_ -> withSingI ts (DBVStruct <$> maybeArgsToStruct r)
STypeUnit -> case r of
ArgsNil -> Just DBVUnit
_ -> Nothing
_ -> case (sing :: Sing ats, r) of
(SCons at SNil, ArgsCons r' ArgsNil) ->
case at %~ (sing :: Sing ret) of
Proved Refl -> Just r'
Disproved _ -> Nothing
-- | Add a match rule (computed from the SignalDescription) and install a
-- handler that tries to convert the Signal's body and passes it to the callback
handleSignal :: Representable a =>
SignalDescription (FlattenRepType (RepType a))
-> Maybe Text
-> MatchRule
-> (a -> IO ())
-> DBusConnection
-> IO ()
handleSignal desc sender rules f con = do
let mSignal = MatchSignal { matchInterface = Just $ signalDInterface desc
, matchMember = Just $ signalDMember desc
, matchPath = Just $ signalDPath desc
, matchSender = sender
}
f' = \s -> case fromRep =<< castSignalBody s of
Nothing -> logWarning $ "Received signal "
++ ((\(SomeSignal ss) -> show ss) s)
++ " could not be converted to to"
++ " type "
-- ++ (show . fromSing
-- $ (sing :: Sing ts))
Just x -> f x
addSignalHandler mSignal rules f' con
-- | Add a match rule for the given signal specification and put all incoming
-- signals into the TChan
signalChan :: MatchSignal
-> DBusConnection
-> IO (TChan SomeSignal)
signalChan match dbc = do
signalChan <- newTChanIO
addSignalHandler match mempty (atomically . writeTChan signalChan) dbc
return signalChan
createSignal desc x = Signal{ signalPath = signalDPath desc
, signalInterface = signalDInterface desc
, signalMember = signalDMember desc
, signalBody = flattenRep $ toRep x
}
----------------------
-- Emitting signals --
----------------------
signal :: (Representable a, Monad m) =>
SignalDescription (FlattenRepType (RepType a))
-> a
-> MethodHandlerT m ()
signal desc (x :: a) =
let s = (sing :: Sing (RepType a))
fs = sFlattenRepType s
in withSingI fs $ signal' (SomeSignal $ createSignal desc x)
signal' :: Monad m => SomeSignal -> MethodHandlerT m ()
signal' sig = MHT $ tell [sig]
emitSignal' (SomeSignal s) con = do
sid <- atomically $ dBusCreateSerial con
logDebug $ "Emitting signal (ID = " ++ show sid ++ "): " ++ show s
sendBS con $ mkSignal sid [] s
emitSignal :: Representable a =>
SignalDescription (FlattenRepType (RepType a))
-> a
-> DBusConnection -> IO ()
emitSignal sigD (x :: a) con =
let s = (sing :: Sing (RepType a))
fs = sFlattenRepType s
in withSingI fs $ emitSignal' (SomeSignal $ createSignal sigD x) con
execSignalT :: MethodHandlerT IO a -> DBusConnection -> IO (Either MsgError a)
execSignalT m con = do
(x, sigs) <- runMethodHandlerT m
forM_ sigs $ flip emitSignal' con
return x