#line 23 "src/match-rules.anansi"
#line 30 "src/introduction.anansi"
#line 24 "src/match-rules.anansi"
#line 52 "src/introduction.anansi"
#line 25 "src/match-rules.anansi"
module DBus.MatchRule (
MatchRule (..)
, MessageType (..)
, ParameterValue (..)
, formatRule
, addMatch
, matchAll
, matches
) where
#line 56 "src/introduction.anansi"
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as TL
#line 35 "src/match-rules.anansi"
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)
#line 45 "src/match-rules.anansi"
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)
#line 62 "src/match-rules.anansi"
data ParameterValue
= StringValue Word8 Text
| PathValue Word8 T.ObjectPath
deriving (Show, Eq)
#line 76 "src/match-rules.anansi"
data MessageType
= MethodCall
| MethodReturn
| Signal
| Error
deriving (Show, Eq)
#line 92 "src/match-rules.anansi"
#line 126 "src/api-docs.anansi"
#line 93 "src/match-rules.anansi"
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
#line 109 "src/match-rules.anansi"
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
#line 121 "src/match-rules.anansi"
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"
#line 135 "src/match-rules.anansi"
#line 131 "src/api-docs.anansi"
#line 136 "src/match-rules.anansi"
addMatch :: MatchRule -> M.MethodCall
addMatch rule = M.MethodCall
C.dbusPath
"AddMatch"
(Just C.dbusInterface)
(Just C.dbusName)
Set.empty
[T.toVariant $ formatRule rule]
#line 150 "src/match-rules.anansi"
#line 135 "src/api-docs.anansi"
#line 151 "src/match-rules.anansi"
matchAll :: MatchRule
matchAll = MatchRule
{ matchType = Nothing
, matchSender = Nothing
, matchInterface = Nothing
, matchMember = Nothing
, matchPath = Nothing
, matchDestination = Nothing
, matchParameters = []
}
#line 167 "src/match-rules.anansi"
#line 139 "src/api-docs.anansi"
#line 168 "src/match-rules.anansi"
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
]
#line 181 "src/match-rules.anansi"
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
#line 190 "src/match-rules.anansi"
senderMatches :: M.ReceivedMessage -> T.BusName -> Bool
senderMatches msg name = M.receivedSender msg == Just name
#line 195 "src/match-rules.anansi"
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
#line 204 "src/match-rules.anansi"
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
#line 213 "src/match-rules.anansi"
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
#line 222 "src/match-rules.anansi"
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
#line 235 "src/match-rules.anansi"
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