:# Copyright (C) 2009-2010 John Millikin :# :# This program is free software: you can redistribute it and/or modify :# it under the terms of the GNU General Public License as published by :# the Free Software Foundation, either version 3 of the License, or :# any later version. :# :# This program is distributed in the hope that it will be useful, :# but WITHOUT ANY WARRANTY; without even the implied warranty of :# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the :# GNU General Public License for more details. :# :# You should have received a copy of the GNU General Public License :# along with this program. If not, see . \section{Match rules} Match rules are used to indicate that the client is interested in messages matching a particular filter. This module provides an interface for building match rule strings. Eventually, it will support parsing them also. :f DBus/MatchRule.hs |copyright| |text extensions| module DBus.MatchRule ( MatchRule (..) , MessageType (..) , ParameterValue (..) , formatRule , addMatch , matchAll , matches ) where |text imports| import Data.Word (Word8) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set import qualified DBus.Types as T import qualified DBus.Message as M import qualified DBus.Constants as C import DBus.Util (maybeIndex) : :f DBus/MatchRule.hs -- | A match rule is a set of filters; most filters may have one possible -- value assigned, such as a single message type. The exception are parameter -- filters, which are limited in number only by the server implementation. -- data MatchRule = MatchRule { matchType :: Maybe MessageType , matchSender :: Maybe T.BusName , matchInterface :: Maybe T.InterfaceName , matchMember :: Maybe T.MemberName , matchPath :: Maybe T.ObjectPath , matchDestination :: Maybe T.BusName , matchParameters :: [ParameterValue] } deriving (Show) : :f DBus/MatchRule.hs -- | Parameters may match against two types, strings and object paths. It's -- probably an error to have two values for the same parameter. -- -- The constructor @StringValue 3 \"hello\"@ means that the fourth parameter -- in the message body must be the string @\"hello\"@. @PathValue@ is the -- same, but its value must be an object path. -- data ParameterValue = StringValue Word8 Text | PathValue Word8 T.ObjectPath deriving (Show, Eq) : :f DBus/MatchRule.hs -- | The set of allowed message types to filter on is separate from the set -- supported for sending over the wire. This allows the server to support -- additional types not yet implemented in the library, or vice-versa. -- data MessageType = MethodCall | MethodReturn | Signal | Error deriving (Show, Eq) : There's currently only one operation to perform on match rules, and that's to format them. :f DBus/MatchRule.hs |apidoc formatRule| formatRule :: MatchRule -> Text formatRule rule = TL.intercalate "," filters where filters = structureFilters ++ parameterFilters parameterFilters = map formatParameter $ matchParameters rule structureFilters = mapMaybe unpack [ ("type", fmap formatType . matchType) , ("sender", fmap T.strBusName . matchSender) , ("interface", fmap T.strInterfaceName . matchInterface) , ("member", fmap T.strMemberName . matchMember) , ("path", fmap T.strObjectPath . matchPath) , ("destination", fmap T.strBusName . matchDestination) ] unpack (key, mkValue) = formatFilter' key `fmap` mkValue rule : :f DBus/MatchRule.hs formatParameter :: ParameterValue -> Text formatParameter (StringValue index x) = formatFilter' key x where key = "arg" `TL.append` TL.pack (show index) formatParameter (PathValue index x) = formatFilter' key value where key = "arg" `TL.append` TL.pack (show index) `TL.append` "path" value = T.strObjectPath x : FIXME: what are the escaping rules for match rules? Other bindings don't seem to perform any escaping at all. :f DBus/MatchRule.hs formatFilter' :: Text -> Text -> Text formatFilter' key value = TL.concat [key, "='", value, "'"] formatType :: MessageType -> Text formatType MethodCall = "method_call" formatType MethodReturn = "method_return" formatType Signal = "signal" formatType Error = "error" : And since the only real reason for formatting a match rule is to send it, it's useful to have a message-building function pre-defined. :f DBus/MatchRule.hs |apidoc addMatch| addMatch :: MatchRule -> M.MethodCall addMatch rule = M.MethodCall C.dbusPath "AddMatch" (Just C.dbusInterface) (Just C.dbusName) Set.empty [T.toVariant $ formatRule rule] : Most match rules will have only one or two fields filled in, so defining an empty rule allows clients to set only the fields they care about. :f DBus/MatchRule.hs |apidoc matchAll| matchAll :: MatchRule matchAll = MatchRule { matchType = Nothing , matchSender = Nothing , matchInterface = Nothing , matchMember = Nothing , matchPath = Nothing , matchDestination = Nothing , matchParameters = [] } : It's useful to match against a rule client-side, eg when listening for signals. :f DBus/MatchRule.hs |apidoc matches| matches :: MatchRule -> M.ReceivedMessage -> Bool matches rule msg = and . mapMaybe ($ rule) $ [ fmap (typeMatches msg) . matchType , fmap (senderMatches msg) . matchSender , fmap (ifaceMatches msg) . matchInterface , fmap (memberMatches msg) . matchMember , fmap (pathMatches msg) . matchPath , fmap (destMatches msg) . matchDestination , Just . parametersMatch msg . matchParameters ] : :f DBus/MatchRule.hs typeMatches :: M.ReceivedMessage -> MessageType -> Bool typeMatches (M.ReceivedMethodCall _ _ _) MethodCall = True typeMatches (M.ReceivedMethodReturn _ _ _) MethodReturn = True typeMatches (M.ReceivedSignal _ _ _) Signal = True typeMatches (M.ReceivedError _ _ _) Error = True typeMatches _ _ = False : :f DBus/MatchRule.hs senderMatches :: M.ReceivedMessage -> T.BusName -> Bool senderMatches msg name = M.receivedSender msg == Just name : :f DBus/MatchRule.hs ifaceMatches :: M.ReceivedMessage -> T.InterfaceName -> Bool ifaceMatches (M.ReceivedMethodCall _ _ msg) name = Just name == M.methodCallInterface msg ifaceMatches (M.ReceivedSignal _ _ msg) name = name == M.signalInterface msg ifaceMatches _ _ = False : :f DBus/MatchRule.hs memberMatches :: M.ReceivedMessage -> T.MemberName -> Bool memberMatches (M.ReceivedMethodCall _ _ msg) name = name == M.methodCallMember msg memberMatches (M.ReceivedSignal _ _ msg) name = name == M.signalMember msg memberMatches _ _ = False : :f DBus/MatchRule.hs pathMatches :: M.ReceivedMessage -> T.ObjectPath -> Bool pathMatches (M.ReceivedMethodCall _ _ msg) path = path == M.methodCallPath msg pathMatches (M.ReceivedSignal _ _ msg) path = path == M.signalPath msg pathMatches _ _ = False : :f DBus/MatchRule.hs destMatches :: M.ReceivedMessage -> T.BusName -> Bool destMatches (M.ReceivedMethodCall _ _ msg) name = Just name == M.methodCallDestination msg destMatches (M.ReceivedMethodReturn _ _ msg) name = Just name == M.methodReturnDestination msg destMatches (M.ReceivedError _ _ msg) name = Just name == M.errorDestination msg destMatches (M.ReceivedSignal _ _ msg) name = Just name == M.signalDestination msg destMatches _ _ = False : :f DBus/MatchRule.hs parametersMatch :: M.ReceivedMessage -> [ParameterValue] -> Bool parametersMatch _ [] = True parametersMatch msg values = all validParam values where body = M.receivedBody msg validParam (StringValue idx x) = validParam' idx x validParam (PathValue idx x) = validParam' idx x validParam' idx x = fromMaybe False $ do var <- maybeIndex body $ fromIntegral idx fmap (== x) $ T.fromVariant var :