{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module DBus.Object where import Control.Applicative ((<$>)) import Control.Monad import Data.List (intercalate, find) import Data.Maybe import Data.Singletons import Data.Singletons.List import Data.Singletons.TH import qualified Data.Text as Text import DBus.Types class IsMethod f where type ArgTypes f type ResultType f toMethod :: f -> MethodWrapper (ArgTypes f) (ResultType f) instance SingI t => IsMethod (IO (DBusValue t)) where type ArgTypes (IO (DBusValue t)) = '[] type ResultType (IO (DBusValue t)) = t toMethod = MReturn instance (IsMethod f, SingI t) => IsMethod (DBusValue t -> f) where type ArgTypes (DBusValue t -> f) = (t ': ArgTypes f) type ResultType (DBusValue t -> f) = ResultType f toMethod f = MAsk $ \x -> toMethod (f x) class RepMethod f where type RepMethodArgs f :: [DBusType] type RepMethodValue f :: DBusType repMethod :: f -> MethodWrapper (RepMethodArgs f) (RepMethodValue f) instance (Representable t, SingI (RepType t)) => RepMethod (IO t) where type RepMethodArgs (IO t) = '[] type RepMethodValue (IO t) = RepType t repMethod f = MReturn $ toRep `liftM` f instance (RepMethod b, Representable a, SingI (RepType a) ) => RepMethod (a -> b) where type RepMethodArgs (a -> b) = (RepType a ': RepMethodArgs b) type RepMethodValue (a -> b) = RepMethodValue b repMethod f = MAsk $ \x -> case fromRep x of Nothing -> error "marshalling error" -- TODO Just x -> repMethod $ f x runMethodW :: SingI at => MethodWrapper at rt -> [SomeDBusValue] -> Maybe (IO (DBusValue rt)) runMethodW m args = runMethodW' sing args m runMethodW' :: Sing at -> [SomeDBusValue] -> MethodWrapper at rt -> Maybe (IO (DBusValue rt)) runMethodW' SNil [] (MReturn f) = Just f runMethodW' (SCons t ts) (arg:args) (MAsk f) = (runMethodW' ts args . f ) =<< dbusValue arg runMethodW' _ _ _ = Nothing methodWSignature :: (SingI at, SingI rt) => MethodWrapper (at :: [DBusType]) (rt :: DBusType) -> ([DBusType], Maybe DBusType) methodWSignature (_ :: MethodWrapper at rt) = ( fromSing (sing :: Sing at) , case fromSing (sing :: Sing rt) of TypeUnit -> Nothing t -> Just t) runMethod :: Method -> [SomeDBusValue] -> Maybe (IO SomeDBusValue) runMethod (Method m _ _) args = liftM DBV <$> runMethodW m args methodSignature :: Method -> ([DBusType], Maybe DBusType) methodSignature (Method m _ _) = methodWSignature m methodName :: Method -> Text.Text methodName (Method _ n _) = n argDescriptions :: MethodDescription t -> ([Text.Text], Text.Text) argDescriptions (Result t) = ([], t) argDescriptions (t :-> ts) = let (ts', r) = argDescriptions ts in (t : ts', r) instance Show Method where show m@(Method _ n desc) = let (args, res) = argDescriptions desc (argst, rest) = methodSignature m components = zipWith (\name tp -> (Text.unpack name ++ ":" ++ ppType tp)) (args ++ [res]) (argst ++ [fromMaybe TypeUnit rest]) in Text.unpack n ++ " :: " ++ intercalate " -> " components instance Show Interface where show i = "Interface " ++ show (interfaceName i) ++ " [{" ++ intercalate "}, {" (map show $ interfaceMethods i) ++ "}]" instance Show Object where show o = "Object " ++ show (objectPathToText $ objectObjectPath o) ++ " [(" ++ intercalate "), (" (map show $ objectInterfaces o) ++ ")]" findObject :: ObjectPath -> Object -> Maybe Object findObject path o = case stripObjectPrefix (objectObjectPath o) path of Nothing -> Nothing Just suff -> if isEmpty suff then Just o else listToMaybe . catMaybes $ (findObject suff <$> objectSubObjects o) callAtPath :: Object -> ObjectPath -> Text.Text -> Text.Text -> [SomeDBusValue] -> Either MsgError (IO SomeDBusValue) callAtPath root path interface member args = case findObject path root of Nothing -> Left (MsgError "org.freedesktop.DBus.Error.Failed" (Just . Text.pack $ "No such object " ++ show path) []) Just o -> case find ((== interface) . interfaceName) $ objectInterfaces o of Nothing -> Left (MsgError "org.freedesktop.DBus.Error.Failed" (Just "No such interface") []) Just i -> case find ((== member) . methodName) $ interfaceMethods i of Nothing -> Left (MsgError "org.freedesktop.DBus.Error.Failed" (Just "No such interface") []) Just m -> case runMethod m args of Nothing -> Left (MsgError "org.freedesktop.DBus.Error.InvalidArgs" (Just "Argument type missmatch") []) Just ret -> Right ret