{-# 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 signalChan' :: Representable a => SignalDescription (FlattenRepType (RepType a)) -> Maybe Text -> MatchRule -> DBusConnection -> IO (TChan a) signalChan' desc sender rules con = do signalChan <- newTChanIO handleSignal desc sender rules (atomically . writeTChan signalChan) con 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