module DBus.Object where
import Control.Applicative ((<$>))
import Control.Concurrent.STM
import qualified Control.Exception as Ex
import Control.Monad
import Control.Monad (liftM)
import Control.Monad.Except
import Control.Monad.Trans
import Data.List (intercalate, find)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
import Data.Singletons.TH
import Data.String
import Data.Text (Text)
import qualified Data.Text as Text
import Unsafe.Coerce (unsafeCoerce)
import DBus.Types
import DBus.Representable
import DBus.Error
import DBus.Property
import DBus.Signal
import DBus.Method
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 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 path "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) path "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