module DBus.MatchRule (
MatchRule (..)
, MessageType (..)
, ParameterValue (..)
, formatRule
, addMatch
, matchAll
, matches
) where
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as TL
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)
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)
data ParameterValue
= StringValue Word8 Text
| PathValue Word8 T.ObjectPath
deriving (Show, Eq)
data MessageType
= MethodCall
| MethodReturn
| Signal
| Error
deriving (Show, Eq)
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
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
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"
addMatch :: MatchRule -> M.MethodCall
addMatch rule = M.MethodCall
C.dbusPath
"AddMatch"
(Just C.dbusInterface)
(Just C.dbusName)
Set.empty
[T.toVariant $ formatRule rule]
matchAll :: MatchRule
matchAll = MatchRule
{ matchType = Nothing
, matchSender = Nothing
, matchInterface = Nothing
, matchMember = Nothing
, matchPath = Nothing
, matchDestination = Nothing
, matchParameters = []
}
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
]
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
senderMatches :: M.ReceivedMessage -> T.BusName -> Bool
senderMatches msg name = M.receivedSender msg == Just name
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
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
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
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
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