#line 23 "src/match-rules.anansi"

#line 30 "src/introduction.anansi"
-- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com>
-- 
-- 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 <http://www.gnu.org/licenses/>.

#line 24 "src/match-rules.anansi"

#line 52 "src/introduction.anansi"
{-# LANGUAGE OverloadedStrings #-}

#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"
-- | 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)

#line 62 "src/match-rules.anansi"
-- | 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)

#line 76 "src/match-rules.anansi"
-- | 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)

#line 92 "src/match-rules.anansi"

#line 126 "src/api-docs.anansi"
-- | Format a 'MatchRule' as the bus expects to receive in a call to
-- @AddMatch@.

#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"
-- | Build a 'M.MethodCall' for adding a match rule to the bus.

#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"
-- | An empty match rule, which matches everything.

#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"
-- | Whether a 'M.ReceivedMessage' matches a given rule. This is useful
-- for implementing signal handlers.

#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