MatchRule.hs

{-
  Copyright (C) 2009 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 (catMaybes, fromMaybe)
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 = catMaybes $ map 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 . catMaybes . map ($ 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