module DBus.Object where
import Control.Applicative ((<$>))
import Control.Monad
import Control.Monad (liftM)
import Data.List (find)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as Text
import DBus.Types
import DBus.Error
import DBus.Property
import DBus.Method
findProperty :: Object -> Text -> Text -> Either MsgError SomeProperty
findProperty (Object o) ifaceName prop
= case Map.lookup ifaceName o of
Nothing -> Left noSuchInterface
Just iface -> case find (\(SomeProperty p) -> propertyName p == prop)
$ interfaceProperties iface of
Nothing -> Left noSuchProperty
Just p -> Right p
getAllProperties :: Interface -> MethodHandlerT IO SomeDBusArguments
getAllProperties iface = liftM (SDBA . singletonArg . toRep . mconcat)
. forM (interfaceProperties iface)
$ \(SomeProperty p) ->
case propertyGet p of
Nothing -> return (Map.empty :: Map Text (DBusValue 'TypeVariant))
Just g -> flip catchMethodError (\_ -> return Map.empty) $ do
res <- g
return $ Map.singleton (propertyName p) (DBVVariant res)
handleProperty :: Object
-> ObjectPath
-> MemberName
-> [SomeDBusValue]
-> Either MsgError (MethodHandlerT IO SomeDBusArguments)
handleProperty o _ "Get" [mbIface, mbProp]
| Just ifaceName <- fromRep =<< dbusValue mbIface
, Just propName <- fromRep =<< dbusValue mbProp
= findProperty o ifaceName propName
>>= (\(SomeProperty prop) ->
case propertyGet prop of
Nothing -> Left propertyNotReadable
Just rd -> Right $ SDBA . singletonArg . DBVVariant <$> rd)
handleProperty o _ "Set" [mbIface , mbProp, mbVal]
| Just ifaceName <- fromRep =<< dbusValue mbIface
, Just propName <- fromRep =<< dbusValue mbProp
= findProperty o ifaceName propName
>>= (\(SomeProperty prop@Property{propertySet = set}) -> do
wt <- maybe (Left propertyNotWriteable) Right set
v <- maybe (Left argTypeMismatch) Right
(fromVariant =<< dbusValue mbVal)
Right $ do
invalidated <- wt v
when invalidated $ propertyChanged prop v
return (SDBA ArgsNil))
handleProperty (Object o) _ "GetAll" [mbIface]
| Just ifaceName <- fromRep =<< dbusValue mbIface
= case Map.lookup ifaceName o of
Just iface -> Right $ getAllProperties iface
Nothing -> if ifaceName `elem` [""
, "org.freedesktop.DBus.Properties"
]
then Right $ getAllProperties (mconcat $ Map.elems o)
else Left noSuchInterface
handleProperty _ _ _ _ = Left argTypeMismatch
callAtPath :: Objects
-> ObjectPath
-> Text.Text
-> Text.Text
-> [SomeDBusValue]
-> Either MsgError (MethodHandlerT IO SomeDBusArguments)
callAtPath (Objects root') path interface member args = case Map.lookup path root' of
Nothing -> Left (MsgError "org.freedesktop.DBus.Error.Failed"
(Just . Text.pack $ "No such object "
++ show path)
[])
Just obj@(Object o) -> case interface of
"org.freedesktop.DBus.Properties" -> handleProperty obj path member args
_ -> case Map.lookup interface o of
Nothing -> Left noSuchInterface
Just i -> case find ((== member) . methodName) $ interfaceMethods i of
Nothing -> Left (MsgError "org.freedesktop.DBus.Error.Failed"
(Just "No such member")
[])
Just m -> case runMethod m args of
Nothing ->
Left (MsgError "org.freedesktop.DBus.Error.InvalidArgs"
(Just "Argument type missmatch")
[])
Just ret -> Right ret