module DBus.Signal where
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.Maybe
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
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"
fromMessageType _ = "fromMessageType: Invalid and Other not handled"
num i = TB.fromText . Text.pack $ show i
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
]
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
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
}
addSignalHandler :: MatchSignal
-> MatchRule
-> (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
(r :: DBusArguments ats) ->
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
_ -> error "castSignalBody: impossible case"
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 "
Just x -> f x
addSignalHandler mSignal rules f' con
signalChan :: MatchSignal
-> DBusConnection
-> IO (TChan SomeSignal)
signalChan match dbc = do
sChan <- newTChanIO
addSignalHandler match mempty (atomically . writeTChan sChan) dbc
return sChan
signalChan' :: Representable a =>
SignalDescription (FlattenRepType (RepType a))
-> Maybe Text
-> MatchRule
-> DBusConnection
-> IO (TChan a)
signalChan' desc sender rules con = do
sChan <- newTChanIO
handleSignal desc sender rules (atomically . writeTChan sChan) con
return sChan
createSignal ::
Representable a
=> SignalDescription (FlattenRepType (RepType a))
-> a
-> Signal (FlattenRepType (RepType a))
createSignal desc x = Signal{ signalPath = signalDPath desc
, signalInterface = signalDInterface desc
, signalMember = signalDMember desc
, signalBody = flattenRep $ toRep x
}
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 -> DBusConnection -> IO ()
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