-- 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/>.
{-# LANGUAGE OverloadedStrings #-}
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)
-- | 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)
-- | 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)
-- | 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)
-- | Format a 'MatchRule' as the bus expects to receive in a call to
-- @AddMatch@.
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"
-- | Build a 'M.MethodCall' for adding a match rule to the bus.
addMatch :: MatchRule -> M.MethodCall
addMatch rule = M.MethodCall
	C.dbusPath
	"AddMatch"
	(Just C.dbusInterface)
	(Just C.dbusName)
	Set.empty
	[T.toVariant $ formatRule rule]
-- | An empty match rule, which matches everything.
matchAll :: MatchRule
matchAll = MatchRule
	{ matchType        = Nothing
	, matchSender      = Nothing
	, matchInterface   = Nothing
	, matchMember      = Nothing
	, matchPath        = Nothing
	, matchDestination = Nothing
	, matchParameters  = []
	}
-- | Whether a 'M.ReceivedMessage' matches a given rule. This is useful
-- for implementing signal handlers.
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