diff --git a/d-bus.cabal b/d-bus.cabal --- a/d-bus.cabal +++ b/d-bus.cabal @@ -1,5 +1,5 @@ name: d-bus -version: 0.0.3 +version: 0.1.0 synopsis: Permissively licensed D-Bus client library description: This library uses modern extensions to the Haskell type system (including GADTs, DataKinds and TypeFamilies) and the @@ -60,19 +60,35 @@ cpp-options: -DSEND_CREDENTIALS } --- test-suite tests +test-suite unittests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Main.hs + build-depends: base >= 4 && < 5 + , d-bus + , xml-hamlet + , QuickCheck + , text + , tasty + , tasty-th + , tasty-quickcheck + , singletons + , bytestring + , binary + , mtl + +test-suite integrationtest + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Runtest.hs + build-depends: base >= 4 && < 5 + , d-bus + , text + + +-- test-suite singletons -- type: exitcode-stdio-1.0 --- hs-source-dirs: tests --- main-is: Main.hs +-- hs-source-dirs: src +-- main-is: Test.hs -- build-depends: base >= 4 && < 5 --- , dbus-ext --- , xml-hamlet --- , QuickCheck --- , text --- , tasty --- , tasty-th --- , tasty-quickcheck -- , singletons --- , bytestring --- , binary --- , mtl diff --git a/src/DBus.hs b/src/DBus.hs --- a/src/DBus.hs +++ b/src/DBus.hs @@ -9,6 +9,7 @@ , waitFor -- * Message handling , objectRoot + , ignore -- * Signals , MatchRule(..) , matchAll @@ -45,11 +46,18 @@ -- * Methods , Method(..) , MethodWrapper(..) - , MethodDescription(..) + , ArgumentDescription(..) + , ResultDescription(..) , repMethod , callMethod , callMethod' , MsgError(..) +-- * Properties + , Property (..) + , PropertyWrapper(..) + , PropertyEmitsChangedSignal(..) + , mkProperty + , mkTVarProperty -- * Introspection , addIntrospectable -- * Message Bus @@ -67,16 +75,19 @@ , getConnectionUnixUser , getConnectionProcessID , getID +-- * Re-exports + , def ) where -import DBus.Introspect -import DBus.MainLoop -import DBus.MessageBus -import DBus.Object -import DBus.Types -import DBus.Signal -import DBus.TH -import DBus.Message +import DBus.Introspect +import DBus.MainLoop +import DBus.Message +import DBus.MessageBus +import DBus.Object +import DBus.Signal +import DBus.TH +import DBus.Types +import Data.Default (def) -- | Ignore all incoming messages/signals ignore _ _ _ = return () diff --git a/src/DBus/Auth.hs b/src/DBus/Auth.hs --- a/src/DBus/Auth.hs +++ b/src/DBus/Auth.hs @@ -10,8 +10,8 @@ import Control.Applicative import Control.Monad.Error import Control.Monad.Free -import qualified Data.Attoparsec as AP -import qualified Data.Attoparsec.Char8 as AP8 +import qualified Data.Attoparsec.ByteString as AP +import qualified Data.Attoparsec.ByteString.Char8 as AP8 import Data.Bits import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Builder as BS diff --git a/src/DBus/Introspect.hs b/src/DBus/Introspect.hs --- a/src/DBus/Introspect.hs +++ b/src/DBus/Introspect.hs @@ -75,7 +75,7 @@ } deriving (Eq, Show, Data, Typeable) data IProperty = IProperty { iPropertyName :: Text.Text - , iPropertType :: DBusType + , iPropertyType :: DBusType , iPropertyAccess :: IPropertyAccess , iPropertyAnnotation :: [Annotation] } deriving (Eq, Show, Data, Typeable) @@ -199,18 +199,48 @@ introspectMethods = map introspectMethod where introspectMethod m = IMethod (methodName m) (toArgs m) [] - toArgs m@(Method _ _ ds) = + toArgs m@(Method _ _ argDs resDs) = let (args, res) = methodSignature m - (ts, r) = argDescriptions ds + (ts, rs) = argDescriptions argDs resDs in zipWith (\n t -> IArgument n t (Just In)) ts args - ++ maybeToList ((\t -> IArgument r t (Just Out)) <$> res ) + ++ zipWith ((\r t -> IArgument r t (Just Out))) rs res + +introspectSignalArgument a = + IArgument { iArgumentName = signalArgumentName a + , iArgumentType = signalArgumentType a + , iArgumentDirection = Nothing + } + +introspectSignal s = + ISignal { iSignalName = signalName s + , iSignalArguments = introspectSignalArgument <$> signalArguments s + , iSignalAnnotations = signalAnnotations s + } + +propertyAccess (Property{propertyAccessors = PropertyWrapper mbSet mbGet}) + = case (mbSet, mbGet) of + (Just{}, Just{}) -> ReadWrite + (Nothing, Just{}) -> Read + (Just{}, Nothing) -> Write + (Nothing, Nothing) -> error "iPropertyAccess: Both getter and setter are Nothing" + + +introspectProperty p = IProperty { iPropertyName = propertyName p + , iPropertyType = propertyType p + , iPropertyAccess = propertyAccess p + , iPropertyAnnotation = [] -- TODO + } + introspectInterface :: Interface -> IInterface introspectInterface i = IInterface { iInterfaceName = interfaceName i , iInterfaceMethods = introspectMethods $ interfaceMethods i - , iInterfaceSignals = [] -- TODO - , iInterfaceProperties = [] -- TODO + , iInterfaceSignals = + introspectSignal <$> interfaceSignals i + , iInterfaceProperties = + introspectProperty + <$> interfaceProperties i , iInterfaceAnnotations = [] -- TODO } @@ -227,12 +257,15 @@ introspectMethod :: Object -> Method introspectMethod object = Method (repMethod $ introspect object) "Introspect" - (Result "xml_data") + Result + ("xml_data" :> ResultDone) introspectable :: Object -> Interface introspectable o = Interface{ interfaceName = "org.freedesktop.DBus.Introspectable" , interfaceMethods = [introspectMethod o] + , interfaceSignals = [] , interfaceAnnotations = [] + , interfaceProperties = [] } addIntrospectable :: Object -> Object diff --git a/src/DBus/MainLoop.hs b/src/DBus/MainLoop.hs --- a/src/DBus/MainLoop.hs +++ b/src/DBus/MainLoop.hs @@ -54,26 +54,23 @@ import DBus.Wire handleMessage handleCall handleSignals answerSlots (header, body) = - case messageType header of - MethodCall -> handleCall header body - MethodReturn -> handleReturn True - Error -> handleError - Signal -> handleSignals header body - _ -> return () + case messageType header of + MessageTypeMethodCall -> handleCall header body + MessageTypeMethodReturn -> handleReturn True + MessageTypeError -> handleError + MessageTypeSignal -> handleSignals header body + _ -> return () where handleReturn nonError = case hFReplySerial $ fields header of Nothing -> return () Just s -> atomically $ do slots <- readTVar answerSlots - let ret = case body of - [] -> DBV DBVUnit - (x:_) -> x case Map.lookup s slots of Nothing -> return () Just putSlot -> do writeTVar answerSlots (Map.delete s slots) putSlot $ if nonError - then Right ret + then Right body else Left body handleError = case hFReplySerial $ fields header of Nothing -> return () -- TODO: handle non-response errors @@ -91,20 +88,27 @@ = Ex.handle (\e -> hPutStrLn stderr (show ( e:: Ex.SomeException))) $ do let errToErrMessage s e = errorMessage s (Just ser) sender (errorName e) (errorText e) (errorBody e) - mkReturnMethod s arg = methodReturn s ser sender (filter notUnit [arg]) - serial <- atomically $ dBusCreateSerial conn + mkReturnMethod s args = methodReturn s ser sender args ret <- case callAtPath o path iface member args of Left e -> return $ Left e Right f -> do - ret <- withAsync (Ex.catch (Right <$> f) (return . Left)) waitCatch + ret <- withAsync (Ex.catch (Right <$> runSignalT f) + (return . Left)) waitCatch case ret of Left e -> return $ Left (MsgError "org.freedesktop.DBus.Error.Failed" (Just $ "Method threw exception: " `Text.append` Text.pack (show e)) []) - Right r -> return $ r - let bs = either (errToErrMessage serial) (mkReturnMethod serial) ret - sendBS conn bs + Right r -> return $ r + serial <- atomically $ dBusCreateSerial conn + case ret of + Left err -> sendBS conn $ errToErrMessage serial err + Right (r, sigs) -> do + sendBS conn $ mkReturnMethod serial r + forM_ sigs $ \sig -> do + sid <- atomically $ dBusCreateSerial conn + sendBS conn $ mkSignal sid [] sig + where notUnit (DBV DBVUnit) = False notUnit _ = True objectRoot _ _ _ _ = return () diff --git a/src/DBus/Message.hs b/src/DBus/Message.hs --- a/src/DBus/Message.hs +++ b/src/DBus/Message.hs @@ -6,6 +6,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} module DBus.Message where @@ -24,39 +25,42 @@ import Data.Maybe import Data.Monoid import Data.Singletons +import Data.Singletons.Decide import qualified Data.Text as Text import Data.Word import System.Mem.Weak import Control.Monad.Catch (MonadThrow, throwM) +import Data.Singletons.Prelude.List import DBus.Error import DBus.Representable import DBus.TH import DBus.Types import DBus.Wire +import DBus.Object -data MessageType = Invalid - | MethodCall - | MethodReturn - | Error - | Signal - | Other Word8 +data MessageType = MessageTypeInvalid + | MessageTypeMethodCall + | MessageTypeMethodReturn + | MessageTypeError + | MessageTypeSignal + | MessageTypeOther Word8 deriving (Eq, Show) instance Representable MessageType where type RepType MessageType = 'DBusSimpleType TypeByte - toRep Invalid = DBVByte $ 0 - toRep MethodCall = DBVByte $ 1 - toRep MethodReturn = DBVByte $ 2 - toRep Error = DBVByte $ 3 - toRep Signal = DBVByte $ 4 - toRep (Other i) = DBVByte $ fromIntegral i - fromRep (DBVByte 0) = Just $ Invalid - fromRep (DBVByte 1) = Just $ MethodCall - fromRep (DBVByte 2) = Just $ MethodReturn - fromRep (DBVByte 3) = Just $ Error - fromRep (DBVByte 4) = Just $ Signal - fromRep (DBVByte i) = Just $ Other $ fromIntegral i + toRep MessageTypeInvalid = DBVByte $ 0 + toRep MessageTypeMethodCall = DBVByte $ 1 + toRep MessageTypeMethodReturn = DBVByte $ 2 + toRep MessageTypeError = DBVByte $ 3 + toRep MessageTypeSignal = DBVByte $ 4 + toRep (MessageTypeOther i) = DBVByte $ fromIntegral i + fromRep (DBVByte 0) = Just $ MessageTypeInvalid + fromRep (DBVByte 1) = Just $ MessageTypeMethodCall + fromRep (DBVByte 2) = Just $ MessageTypeMethodReturn + fromRep (DBVByte 3) = Just $ MessageTypeError + fromRep (DBVByte 4) = Just $ MessageTypeSignal + fromRep (DBVByte i) = Just $ MessageTypeOther $ fromIntegral i data Flag = NoReplyExpected | NoAutoStart @@ -180,7 +184,7 @@ } header = MessageHeader { endianessFlag = Little - , messageType = MethodCall + , messageType = MessageTypeMethodCall , flags = Flags flags , version = 1 , messageLength = 0 @@ -189,10 +193,28 @@ } in serializeMessage header args +mkSignal sid flags sig = + let hFields = emptyHeaderFields { hFPath = Just $ signalPath sig + , hFInterface = Just $ signalInterface sig + , hFMember = Just $ signalMember sig + } + header = MessageHeader + { endianessFlag = Little + , messageType = MessageTypeSignal + , flags = Flags flags + , version = 1 + , messageLength = 0 + , serial = sid + , fields = hFields + } + in serializeMessage header (signalBody sig) + + + methodReturn :: Word32 -> Word32 -> Text.Text - -> [SomeDBusValue] + -> SomeDBusArguments -> BS.Builder methodReturn sid rsid dest args = let hFields = emptyHeaderFields{ hFDestination = Just dest @@ -200,14 +222,14 @@ } header = MessageHeader { endianessFlag = Little - , messageType = MethodReturn + , messageType = MessageTypeMethodReturn , flags = Flags [] , version = 1 , messageLength = 0 , serial = sid , fields = hFields } - in serializeMessage header args + in serializeMessage header (argsToValues args) errorMessage :: Word32 -> Maybe Word32 @@ -223,7 +245,7 @@ } header = MessageHeader { endianessFlag = Little - , messageType = Error + , messageType = MessageTypeError , flags = Flags [] , version = 1 , messageLength = 0 @@ -273,17 +295,18 @@ atomically $ putTMVar (dBusWriteLock conn) write --- | Asychronously call a method. Returns an STM action that waits for the --- returned value. -callMethod :: Text.Text -- ^ Entity to send the message to +-- | Asychronously call a method. +-- +-- This is the "raw" version of 'callMethod'. It doesn't do argument conversion. +callMethod' :: Text.Text -- ^ Entity to send the message to -> ObjectPath -- ^ Object -> Text.Text -- ^ Interface -> Text.Text -- ^ Member (method) name -> [SomeDBusValue] -- ^ Arguments -> [Flag] -- ^ Method call flags -> DBusConnection -- ^ Connection to send the call over - -> IO (STM (Either [SomeDBusValue] SomeDBusValue)) -callMethod dest path interface member args flags conn = do + -> IO (STM (Either [SomeDBusValue] [SomeDBusValue] )) +callMethod' dest path interface member args flags conn = do serial <- atomically $ dBusCreateSerial conn ref <- newEmptyTMVarIO rSlot <- newTVarIO () @@ -304,23 +327,69 @@ getAnswer :: IO (STM b) -> IO b getAnswer = (atomically =<<) --- | Synchronously call a method. Returned errors are thrown as 'MethodError's. +-- | Synchronously call a method. +-- +-- This is the "cooked" version of callMethod\''. It automatically converts +-- arguments and returns values and throws conversion errors as exceptions +-- -- If the returned value's type doesn't match the expected type a -- 'MethodSignatureMissmatch' is thrown. -callMethod' :: (SingI (RepType a), Representable a, MonadThrow m, MonadIO m) => +-- +-- You can pass in and extract multiple arguments and return values with types +-- that are represented by DBus Structs (e.g. tuples). More specifically, +-- multiple arguments/return values are handled in the following way: +-- +-- * If the method returns multiple values and the RepType of the expected +-- return value is a struct it tries to match up the arguments with the struct +-- fields +-- +-- * If the method returns /a single struct/ and the RepType is a struct it will +-- try to match up those two +-- +-- * If the RepType of the expected return value is not a struct it will only +-- match if the method returned exactly one value and those two match up (as per +-- normal) +-- +-- This means that if the RepType of the expected return value is a struct it +-- might be matched in two ways: Either by the method returning multiple values +-- or the method returning a single struct. At the moment there is no way to +-- exclude either +callMethod :: ( Representable args + , Representable ret + ) => Text.Text -- ^ Entity to send the message to -> ObjectPath -- ^ Object -> Text.Text -- ^ Interface -> Text.Text -- ^ Member (method) to call - -> [SomeDBusValue] -- ^ Arguments + -> args -- ^ Arguments -> [Flag] -- ^ Method call flags -> DBusConnection -- ^ Connection to send the call over - -> m a -callMethod' dest path interface member args flags conn = do - ret <- liftIO . getAnswer - $ callMethod dest path interface member args flags conn - case ret of - Left e -> throwM $ MethodErrorMessage e - Right r -> case fromRep =<< dbusValue r of - Nothing -> throwM $ MethodSignatureMissmatch r - Just x -> return x + -> IO (Either MethodError ret) +callMethod dest path interface member (arg :: args) flags conn = do + let sng = sing :: Sing (RepType args) + flsng = flattenRepS sng + args' = withSingI flsng $ argsToValues $ SDBA (flattenRep arg) + ret <- getAnswer $ callMethod' dest path interface member args' flags conn + return $ case ret of + Left e -> Left $ MethodErrorMessage e + Right rvs -> case listToSomeArguments rvs of + sr@(SDBA (r :: DBusArguments ats)) -> + maybe (Left $ MethodSignatureMissmatch rvs) Right + $ fix $ \(_ :: Maybe ret) -> + case sing :: Sing (RepType ret) of + STypeStruct ts -> case (r, sing :: Sing ats) of + (ArgsNil, SNil) -> Nothing + (ArgsCons r' ArgsNil, SCons a SNil) -> + case a %~ (sing :: Sing (RepType ret)) of + Proved Refl -> fromRep r' + Disproved _ -> Nothing + _ -> withSingI ts + $ fromRep . DBVStruct =<< maybeArgsToStruct r + STypeUnit -> case r of + ArgsNil -> fromRep DBVUnit + _ -> Nothing + _ -> case (sing :: Sing ats, r) of + (SCons at SNil, ArgsCons r' ArgsNil) -> + case at %~ (sing :: Sing (RepType ret)) of + Proved Refl -> fromRep r' + Disproved _ -> Nothing diff --git a/src/DBus/MessageBus.hs b/src/DBus/MessageBus.hs --- a/src/DBus/MessageBus.hs +++ b/src/DBus/MessageBus.hs @@ -3,42 +3,52 @@ {-# LANGUAGE OverloadedStrings #-} module DBus.MessageBus where +import qualified Control.Exception as Ex +import Control.Monad.Catch (MonadThrow, throwM) +import Control.Monad.IO.Class import Control.Monad.Trans (MonadIO) import DBus.Message import DBus.Object import DBus.Types -import Control.Monad.Catch (MonadThrow, throwM) import Data.Default import Data.Singletons import qualified Data.Text as Text import Data.Word -import DBus.Error +import DBus.Error messageBusMethod :: ( MonadIO m , MonadThrow m - , Representable a - , SingI (RepType a) + , Representable args + , SingI (RepType args) + , SingI (FlattenRepType (RepType args)) + , Representable ret + , SingI (RepType ret) ) => Text.Text - -> [SomeDBusValue] + -> args -> DBusConnection - -> m a -messageBusMethod name args = callMethod' "org.freedesktop.DBus" - (objectPath "/org/freedesktop/DBus") - "org.freedesktop.DBus" name args [] + -> m ret +messageBusMethod name args con = do + res <- liftIO $ callMethod "org.freedesktop.DBus" + (objectPath "/org/freedesktop/DBus") + "org.freedesktop.DBus" name args [] con + case res of + Left e -> liftIO $ Ex.throwIO e + Right r -> return r hello :: (MonadIO m, MonadThrow m) => DBusConnection -> m Text.Text -hello = messageBusMethod "Hello" [] +hello = messageBusMethod "Hello" () data RequestNameFlag = RequestNameFlag { allowReplacement - , replaceExisting - , doNotQueue :: Bool - } + , replaceExisting + , doNotQueue :: Bool + } instance Default RequestNameFlag where def = RequestNameFlag False False False +fromRequestNameFlags :: RequestNameFlag -> Word32 fromRequestNameFlags flags = sum [ fromFlag allowReplacement 0x01 , fromFlag replaceExisting 0x02 , fromFlag doNotQueue 0x04 @@ -57,9 +67,7 @@ -> DBusConnection -> m RequestNameReply requestName name flags con = do - reply <- messageBusMethod "RequestName" [ DBV $ DBVString name - , DBV . DBVUInt32 $ - fromRequestNameFlags flags] + reply <- messageBusMethod "RequestName" (name, fromRequestNameFlags flags) con case reply :: Word32 of 1 -> return PrimaryOwner @@ -77,7 +85,7 @@ -> DBusConnection -> m ReleaseNameReply releaseName name con = do - reply <- messageBusMethod "RequestName" [DBV $ DBVString name] con + reply <- messageBusMethod "RequestName" name con case reply :: Word32 of 1 -> return Released 2 -> return NonExistent @@ -88,19 +96,19 @@ Text.Text -> DBusConnection -> m [Text.Text] -listQueuedOwners name = messageBusMethod "ListQueuedOwners" [DBV $ DBVString name] +listQueuedOwners name = messageBusMethod "ListQueuedOwners" name listNames :: (MonadIO m, MonadThrow m) => DBusConnection -> m [Text.Text] -listNames = messageBusMethod "ListNames" [] +listNames = messageBusMethod "ListNames" () listActivatableNames :: (MonadIO m, MonadThrow m) => DBusConnection -> m [Text.Text] -listActivatableNames = messageBusMethod "ListActivatableNames" [] +listActivatableNames = messageBusMethod "ListActivatableNames" () nameHasOwner :: (MonadIO m, MonadThrow m) => Text.Text -> DBusConnection -> m Bool -nameHasOwner name = messageBusMethod "NameHasOwner" [DBV $ toRep name] +nameHasOwner name = messageBusMethod "NameHasOwner" name data StartServiceResult = StartServiceSuccess | StartServiceAlreadyRunning @@ -111,9 +119,7 @@ -> DBusConnection -> m StartServiceResult startServiceByName name con = do - res <- messageBusMethod "StartServiceByName" - [DBV $ toRep name, DBV $ DBVUInt32 0] - con + res <- messageBusMethod "StartServiceByName" (name, 0 :: Word32) con return $ case (res :: Word32) of 1 -> StartServiceSuccess 2 -> StartServiceAlreadyRunning @@ -122,23 +128,21 @@ Text.Text -> DBusConnection -> m Text.Text -getNameOwner txt = messageBusMethod "GetNameOwner" [DBV $ DBVString txt] +getNameOwner txt = messageBusMethod "GetNameOwner" txt getConnectionUnixUser :: (MonadIO m, MonadThrow m) => Text.Text -> DBusConnection -> m Word32 -getConnectionUnixUser txt = messageBusMethod "GetConnectionUnixUser" - [DBV $ DBVString txt] +getConnectionUnixUser txt = messageBusMethod "GetConnectionUnixUser" txt getConnectionProcessID :: (MonadIO m, MonadThrow m) => Text.Text -> DBusConnection -> m Word32 -getConnectionProcessID txt = messageBusMethod "GetConnectionUnixProcessID" - [DBV $ DBVString txt] +getConnectionProcessID txt = messageBusMethod "GetConnectionUnixProcessID" txt getID :: (MonadIO m, MonadThrow m) => DBusConnection -> m Text.Text -getID = messageBusMethod "GetId" [] +getID = messageBusMethod "GetId" () diff --git a/src/DBus/Object.hs b/src/DBus/Object.hs --- a/src/DBus/Object.hs +++ b/src/DBus/Object.hs @@ -10,28 +10,45 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PatternGuards #-} module DBus.Object where import Control.Applicative ((<$>)) +import Control.Concurrent.STM +import qualified Control.Exception as Ex import Control.Monad +import Control.Monad.Trans import Data.List (intercalate, find) +import Data.Map (Map) +import qualified Data.Map as Map import Data.Maybe import Data.Singletons import Data.Singletons.Prelude.List 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 +-- | IsMethod is a Helper class to create MethodWrappers without having to +-- explicitly unwrap all the function arguments. class IsMethod f where type ArgTypes f :: [DBusType] - type ResultType f :: DBusType + type ResultType f :: [DBusType] 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 +instance SingI t => IsMethod (IO (DBusArguments t)) where + type ArgTypes (IO (DBusArguments ts)) = '[] + type ResultType (IO (DBusArguments ts)) = ts + toMethod = MReturn. lift + +instance SingI t => IsMethod (SignalT IO (DBusArguments t)) where + type ArgTypes (SignalT IO (DBusArguments ts)) = '[] + type ResultType (SignalT IO (DBusArguments ts)) = ts toMethod = MReturn instance (IsMethod f, SingI t) => IsMethod (DBusValue t -> f) where @@ -41,15 +58,54 @@ class RepMethod f where type RepMethodArgs f :: [DBusType] - type RepMethodValue f :: DBusType + type RepMethodValue f :: [DBusType] repMethod :: f -> MethodWrapper (RepMethodArgs f) (RepMethodValue f) -instance (Representable t, SingI (RepType t)) => RepMethod (IO t) where +type family FlattenRepType r where + FlattenRepType TypeUnit = '[] + FlattenRepType (TypeStruct ts) = ts + FlattenRepType t = '[t] + +-- TODO: Figure out how to convice GHC that the flattenRepType function and the +-- FlattenRepType type function coincide +flattenRepS :: Sing a -> Sing (FlattenRepType a) +flattenRepS s = case flattenRepS' s of + SomeSing s' -> unsafeCoerce s' + where + flattenRepS' STypeUnit = SomeSing SNil + flattenRepS' (STypeStruct ts) = SomeSing ts + flattenRepS' t = SomeSing (SCons t SNil) + +flattenRep :: ( Representable a ) => + a + -> DBusArguments (FlattenRepType (RepType a)) +flattenRep (x :: t) = + let rts = sing :: Sing (RepType t) + frts :: Sing (FlattenRepType (RepType t)) + frts = flattenRepS rts + in case (rts, frts) of + (STypeUnit, SNil) -> ArgsNil + (STypeStruct ts, ts') -> case toRep x of DBVStruct str -> structToArgs str + (t, SCons t' SNil) -> case t %~ t' of + Proved Refl -> ArgsCons (toRep x) ArgsNil + Disproved _ -> error "flattenRep: this shouldn't happen" + +instance (Representable t) => RepMethod (IO t) where type RepMethodArgs (IO t) = '[] - type RepMethodValue (IO t) = RepType t - repMethod f = MReturn $ toRep `liftM` f + type RepMethodValue (IO t) = FlattenRepType (RepType t) + repMethod (f :: IO t) + = let sng = flattenRepS (sing :: Sing (RepType t)) + in withSingI sng $ MReturn $ flattenRep . toRep <$> lift f -instance (RepMethod b, Representable a, SingI (RepType a) ) +instance (Representable t) => RepMethod (SignalT IO t) where + type RepMethodArgs (SignalT IO t) = '[] + type RepMethodValue (SignalT IO t) = FlattenRepType (RepType t) + repMethod (f :: SignalT IO t) + = let sng = flattenRepS (sing :: Sing (RepType t)) + in withSingI sng $ MReturn $ flattenRep . toRep <$> f + + +instance (RepMethod b, Representable a) => RepMethod (a -> b) where type RepMethodArgs (a -> b) = (RepType a ': RepMethodArgs b) type RepMethodValue (a -> b) = RepMethodValue b @@ -57,52 +113,93 @@ Nothing -> error "marshalling error" -- TODO Just x -> repMethod $ f x +-- | Create a property from a getter and a setter. It will emit a +-- PropertyChanged signal when the setter is called (not only then). To change +-- this behaviour modify the propertyEmitsChangedSignal field +mkProperty :: Representable a => + Text + -> Maybe (IO a) + -> Maybe (a -> IO Bool) + -> Property +mkProperty name get set = + let pw = PropertyWrapper { setProperty = doSet <$> set + , getProperty = lift . fmap toRep <$> get + } + in Property { propertyName = name + , propertyAccessors = pw + , propertyEmitsChangedSignal = PECSTrue + } + where + doSet f v = lift $ f =<< fromRepHelper v + fromRepHelper x = case fromRep x of + Nothing -> Ex.throwIO argTypeMismatch + Just r -> return r + +-- | Make a property out of a TVar. The property is considered changed on every +-- get, no matter if the updated value is actually different from the old one +mkTVarProperty :: Representable a => + Text + -> TVar a + -> Property +mkTVarProperty name tv = mkProperty + name + (Just (atomically $ readTVar tv)) + (Just (\v -> atomically (writeTVar tv v) + >> return True)) + runMethodW :: SingI at => MethodWrapper at rt -> [SomeDBusValue] - -> Maybe (IO (DBusValue rt)) + -> Maybe (SignalT IO (DBusArguments rt)) runMethodW m args = runMethodW' sing args m runMethodW' :: Sing at -> [SomeDBusValue] -> MethodWrapper at rt - -> Maybe (IO (DBusValue rt)) + -> Maybe (SignalT IO (DBusArguments 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) + MethodWrapper (at :: [DBusType]) (rt :: [DBusType]) + -> ([DBusType], [DBusType]) +methodWSignature (_ :: MethodWrapper at rt) = + ( fromSing (sing :: Sing at) + , fromSing (sing :: Sing rt) + ) -runMethod :: Method -> [SomeDBusValue] -> Maybe (IO SomeDBusValue) -runMethod (Method m _ _) args = liftM DBV <$> runMethodW m args +runMethod :: Method -> [SomeDBusValue] -> Maybe (SignalT IO SomeDBusArguments) +runMethod (Method m _ _ _) args = liftM SDBA <$> runMethodW m args -methodSignature :: Method -> ([DBusType], Maybe DBusType) -methodSignature (Method m _ _) = methodWSignature m +methodSignature :: Method -> ([DBusType], [DBusType]) +methodSignature (Method m _ _ _) = methodWSignature m methodName :: Method -> Text.Text -methodName (Method _ n _) = n +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) +argDescToList :: ArgumentDescription ts + -> [Text.Text] +argDescToList (t :-> ts) = t : argDescToList ts +argDescToList Result = [] +resultDescToList :: ResultDescription t -> [Text.Text] +resultDescToList ResultDone = [] +resultDescToList (t :> ts) = t : resultDescToList ts + +argDescriptions args ress = (argDescToList args, resultDescToList ress) + instance Show Method where - show m@(Method _ n desc) = - let (args, res) = argDescriptions desc + show m@(Method _ n argDs resDs) = + let (args, res) = argDescriptions argDs resDs (argst, rest) = methodSignature m components = zipWith (\name tp -> (Text.unpack name ++ ":" ++ ppType tp)) - (args ++ [res]) - (argst ++ [fromMaybe TypeUnit rest]) + (args ++ res) + (argst ++ rest) in Text.unpack n ++ " :: " ++ intercalate " -> " components instance Show Interface where @@ -121,27 +218,105 @@ else listToMaybe . catMaybes $ (findObject suff <$> objectSubObjects o) +errorFailed msg = (MsgError "org.freedesktop.DBus.Error.Failed" + (Just msg) + []) + +-- noSuchInterface, noSuchProperty, propertyNotReadable, propertyNotReadable +noSuchInterface = errorFailed "No such interface" +noSuchProperty = errorFailed "No such property" +propertyNotReadable = errorFailed "Property is not readable" +propertyNotWriteable = errorFailed "Property is not writeable" +argTypeMismatch = errorFailed "Argument type missmatch" + +findProperty o ifaceName prop + = case find ((== ifaceName) . interfaceName) $ objectInterfaces o of + Nothing -> Left noSuchInterface + Just iface -> case find ((== prop) . propertyName) + $ interfaceProperties iface of + Nothing -> Left noSuchProperty + Just p -> Right p + +propertyInterface = "org.freedesktop.DBus.Properties" + +handleProperty :: Object + -> ObjectPath + -> MemberName + -> [SomeDBusValue] + -> Either MsgError (SignalT IO SomeDBusArguments) +handleProperty o _ "Get" [mbIface, mbProp] + | Just ifaceName <- fromRep =<< dbusValue mbIface + , Just propName <- fromRep =<< dbusValue mbProp + = findProperty o ifaceName propName + >>= (\Property{ propertyAccessors = accs} -> + case getProperty accs of + Nothing -> Left propertyNotReadable + Just rd -> Right $ SDBA . singletonArg <$> rd) +handleProperty o path "Set" [mbIface , mbProp, mbVal] + | Just ifaceName <- fromRep =<< dbusValue mbIface + , Just propName <- fromRep =<< dbusValue mbProp + = findProperty o ifaceName propName + >>= (\prop@Property{ propertyAccessors = accs} -> do + rd <- maybe (Left propertyNotWriteable) Right (setProperty accs) + v <- maybe (Left argTypeMismatch) Right (dbusValue mbVal) + Right $ do + invalidated <- rd v + when invalidated $ case propertyEmitsChangedSignal prop of + PECSTrue -> + signal + Signal + { signalPath = path + , signalInterface = propertyInterface + , signalMember = "PropertiesChanged" + , signalBody = + [ DBV $ + toRep ( ifaceName + , Map.fromList [(propName , DBVVariant v)] + , [] :: [Text] + ) + ] + } + PECSInvalidates -> + signal + Signal + { signalPath = path + , signalInterface = propertyInterface + , signalMember = "PropertiesChanged" + , signalBody = + [ DBV $ toRep + ( ifaceName + , Map.empty :: Map.Map Text + (DBusValue (TypeVariant)) + , [propName] + ) + ] + } + PECSFalse -> return () + return (SDBA ArgsNil)) +handleProperty _ _ _ _ = Left argTypeMismatch + callAtPath :: Object -> ObjectPath -> Text.Text -> Text.Text -> [SomeDBusValue] - -> Either MsgError (IO SomeDBusValue) + -> Either MsgError (SignalT IO SomeDBusArguments) 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 + Just o -> case interface of + "org.freedesktop.DBus.Properties" -> handleProperty o path member args + _ -> case find ((== interface) . interfaceName) $ objectInterfaces 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 diff --git a/src/DBus/Representable.hs b/src/DBus/Representable.hs --- a/src/DBus/Representable.hs +++ b/src/DBus/Representable.hs @@ -6,6 +6,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} + +{-# OPTIONS_GHC -fcontext-stack=21 #-} + module DBus.Representable where import DBus.Types @@ -83,6 +87,11 @@ toRep x = DBVObjectPath x fromRep (DBVObjectPath x) = Just x +instance SingI t => Representable (DBusValue t) where + type RepType (DBusValue t) = t + toRep = id + fromRep = Just + instance ( Representable a , SingI (RepType a)) => Representable [a] where type RepType [a] = TypeArray (RepType a) @@ -96,33 +105,16 @@ fromRep (DBVByteArray bs) = Just bs fromRep (DBVArray bs) = BS.pack <$> mapM fromRep bs -type family FromSimpleType (t :: DBusType) :: DBusSimpleType -type instance FromSimpleType ('DBusSimpleType k) = k +type family FromSimpleType (t :: DBusType) :: DBusSimpleType where + FromSimpleType ('DBusSimpleType k) = k instance ( Ord k , Representable k , RepType k ~ 'DBusSimpleType r + , SingI r , Representable v ) => Representable (Map.Map k v) where type RepType (Map.Map k v) = TypeDict (FromSimpleType (RepType k)) (RepType v) toRep m = DBVDict $ map (\(l,r) -> (toRep l, toRep r)) (Map.toList m) fromRep (DBVDict xs) = Map.fromList <$> sequence (map (\(l,r) -> (,) <$> fromRep l <*> fromRep r) xs) - -instance ( Representable l - , Representable r - , SingI (RepType l) - , SingI (RepType r)) - => Representable (Either l r) where - type RepType (Either l r) = TypeStruct '[ 'DBusSimpleType TypeBoolean - , TypeVariant] - toRep (Left l) = DBVStruct ( StructCons (DBVBool False) $ - StructSingleton (DBVVariant (toRep l))) - toRep (Right r) = DBVStruct ( StructCons (DBVBool True) $ - StructSingleton (DBVVariant (toRep r))) - fromRep (DBVStruct ((StructCons (DBVBool False) - (StructSingleton r)))) - = Left <$> (fromRep =<< fromVariant r) - fromRep (DBVStruct ((StructCons (DBVBool True) - (StructSingleton r)))) - = Right <$> (fromRep =<< fromVariant r) diff --git a/src/DBus/Signal.hs b/src/DBus/Signal.hs --- a/src/DBus/Signal.hs +++ b/src/DBus/Signal.hs @@ -56,10 +56,10 @@ <> TB.singleton '\'' boolToText True = "true" boolToText False = "false" - fromMessageType MethodCall = "method_call" - fromMessageType MethodReturn = "method_return" - fromMessageType Signal = "signal" - fromMessageType Error = "error" + fromMessageType MessageTypeMethodCall = "method_call" + fromMessageType MessageTypeMethodReturn = "method_return" + fromMessageType MessageTypeSignal = "signal" + fromMessageType MessageTypeError = "error" ft = TB.fromText num i = TB.fromText . Text.pack $ show i @@ -69,7 +69,7 @@ matchSignal header rule = let fs = fields header in and $ catMaybes - [ Just $ messageType header == Signal + [ Just $ messageType header == MessageTypeSignal , (\x -> hFMember fs == Just x ) <$> mrMember rule , (\x -> hFInterface fs == Just x ) <$> mrInterface rule , (\(ns, x) -> case hFPath fs of @@ -83,11 +83,10 @@ MatchRule -> DBusConnection -> m () -addMatch rule = messageBusMethod "AddMatch" [DBV . DBVString $ renderRule rule] +addMatch rule = messageBusMethod "AddMatch" (renderRule rule) removeMatch :: (MonadIO m, MonadThrow m ) => MatchRule -> DBusConnection -> m () -removeMatch rule = messageBusMethod "RemoveMatch" - [DBV . DBVString $ renderRule rule] +removeMatch rule = messageBusMethod "RemoveMatch" (renderRule rule) diff --git a/src/DBus/Signature.hs b/src/DBus/Signature.hs --- a/src/DBus/Signature.hs +++ b/src/DBus/Signature.hs @@ -3,8 +3,8 @@ import Control.Applicative ((<$>)) import Control.Monad -import qualified Data.Attoparsec as AP -import qualified Data.Attoparsec.Char8 as AP +import qualified Data.Attoparsec.ByteString as AP +import qualified Data.Attoparsec.ByteString.Char8 as AP import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Builder as BS diff --git a/src/DBus/Transport.hs b/src/DBus/Transport.hs --- a/src/DBus/Transport.hs +++ b/src/DBus/Transport.hs @@ -7,8 +7,8 @@ import Control.Concurrent import qualified Control.Exception as Ex import Control.Monad -import Data.Attoparsec as AP -import Data.Attoparsec.Char8 as AP8 +import Data.Attoparsec.ByteString as AP +import Data.Attoparsec.ByteString.Char8 as AP8 import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy.Builder as BS @@ -174,6 +174,6 @@ go ((_, t) : ts) = do mbS <- Ex.try $ connectTransport t case mbS of - Left (e :: DBusError) -> print e >> go ts + Left (e :: DBusError) -> go ts Right s -> return $ Just s go [] = return Nothing diff --git a/src/DBus/Types.hs b/src/DBus/Types.hs --- a/src/DBus/Types.hs +++ b/src/DBus/Types.hs @@ -10,18 +10,24 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module DBus.Types where +import Control.Applicative import Control.Applicative ((<$>), (<*>)) import Control.Concurrent import Control.Concurrent.STM import qualified Control.Exception as Ex import Control.Monad +import Control.Monad.Trans import Control.Monad.Trans.Error +import Control.Monad.Writer.Strict import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Builder as BS -import Data.Data(Data) +import Data.Data (Data) import Data.Function (fix, on) import Data.Int import Data.List @@ -32,7 +38,7 @@ import Data.Singletons.Prelude.List import Data.Singletons.TH hiding (Error) import qualified Data.Text as Text -import Data.Typeable(Typeable) +import Data.Typeable (Typeable) import Data.Word import Unsafe.Coerce (unsafeCoerce) @@ -45,7 +51,10 @@ } deriving (Eq, Data, Typeable) +type InterfaceName = Text.Text +type MemberName = Text.Text + newtype Signature = Signature {fromSignature :: [DBusType]} deriving (Show, Eq) @@ -77,6 +86,7 @@ isEmpty (ObjectPath False p) = null p isEmpty _ = False +-- | Types that are not composite. These can be the keys of a Dict data DBusSimpleType = TypeByte | TypeBoolean @@ -133,19 +143,109 @@ | Arg Parity deriving (Eq, Show, Data, Typeable) -type family ArgsOf x :: Parity -type instance ArgsOf (IO x) = 'Null -type instance ArgsOf (a -> b) = 'Arg (ArgsOf b) -infixr 0 :-> -data MethodDescription parity where - (:->) :: Text.Text -> MethodDescription n -> MethodDescription (Arg n) - Result :: Text.Text -> MethodDescription 'Null - genSingletons [''DBusSimpleType, ''DBusType, ''Parity] singEqInstances [''DBusSimpleType, ''DBusType, ''Parity] --- singDecideInstances [''DBusSimpleType] +singDecideInstances [''DBusSimpleType, ''DBusType] +-- | A Transformer for (IO) actions that might want to send a signal. +newtype SignalT m a = SignalT { unSignal :: WriterT [Signal] m a} + deriving ( Functor + , Applicative + , Monad + , MonadTrans ) + +data Signal = Signal { signalPath :: ObjectPath + , signalInterface :: InterfaceName + , signalMember :: MemberName + , signalBody :: [SomeDBusValue] + } + +runSignalT :: SignalT m a -> m (a, [Signal]) +runSignalT (SignalT w) = runWriterT w + +signal :: Monad m => Signal -> SignalT m () +signal sig = SignalT $ tell [sig] + + + +type family ArgsOf x :: Parity where + ArgsOf (IO x) = 'Null + ArgsOf (SignalT IO x) = 'Null + ArgsOf (a -> b) = 'Arg (ArgsOf b) + +infixr 0 :> +data ResultDescription parity where + (:>) :: Text.Text -> ResultDescription n -> ResultDescription (Arg n) + ResultDone :: ResultDescription 'Null + +infixr 0 :-> +data ArgumentDescription parity where + (:->) :: Text.Text -> ArgumentDescription n -> ArgumentDescription (Arg n) + Result :: ArgumentDescription 'Null + + +data DBusArguments :: [DBusType] -> * where + ArgsNil :: DBusArguments '[] + ArgsCons :: DBusValue a -> DBusArguments as -> DBusArguments (a ': as) + +data SomeDBusArguments where + SDBA :: SingI ts => DBusArguments ts -> SomeDBusArguments + +deriving instance Show SomeDBusArguments + +listToSomeArguments :: [SomeDBusValue] -> SomeDBusArguments +listToSomeArguments [] = SDBA ArgsNil +listToSomeArguments (DBV v : xs) = + case listToSomeArguments xs of + SDBA sdba -> SDBA (ArgsCons v sdba) + +argsToValues :: SomeDBusArguments -> [SomeDBusValue] +argsToValues (SDBA (a :: DBusArguments t)) = argsToValues' (sing :: Sing t) a + where + argsToValues' :: Sing ts -> DBusArguments ts -> [SomeDBusValue] + argsToValues' (SNil) ArgsNil = [] + argsToValues' (SCons t ts) (ArgsCons a as) = + withSingI t $ (DBV a) : argsToValues' ts as + +argsToStruct :: DBusArguments (t ': ts) -> DBusStruct (t ': ts) +argsToStruct (ArgsCons x ArgsNil) = StructSingleton x +argsToStruct (ArgsCons x xs@(ArgsCons _ _)) = StructCons x (argsToStruct xs) + +structToArgs :: DBusStruct ts -> DBusArguments ts +structToArgs (StructSingleton v) = ArgsCons v ArgsNil +structToArgs (StructCons v vs) = ArgsCons v (structToArgs vs) + +maybeArgsToStruct :: (SingI ts, SingI ss) => + DBusArguments ts + -> Maybe (DBusStruct ss) +maybeArgsToStruct (args :: DBusArguments (ts :: [DBusType])) = + fix $ \(_ :: Maybe (DBusStruct (ss :: [DBusType]))) -> + let singt = sing :: Sing ts + sings = sing :: Sing ss + in case singt of + SNil -> Nothing + SCons t' ts' -> case singt %~ sings of + Proved Refl -> withSingI ts' (Just $ argsToStruct args) + Disproved _ -> Nothing + + +singletonArg :: DBusValue a -> DBusArguments '[a] +singletonArg x = ArgsCons x ArgsNil + +instance Eq (DBusArguments t) where + ArgsNil == ArgsNil = True + ArgsCons x xs == ArgsCons y ys = + x == y && xs == ys + +instance SingI a => Show (DBusArguments a) where + show xs = showArgs sing xs + +showArgs :: Sing a -> DBusArguments a -> String +showArgs (SNil) ArgsNil = "ArgsNil" +showArgs (SCons t ts) (ArgsCons x xs) = + withSingI t $ "ArgsCons (" ++ show x ++ ") (" ++ showArgs ts xs ++ ")" + data DBusStruct :: [DBusType] -> * where StructSingleton :: DBusValue a -> DBusStruct '[a] StructCons :: DBusValue a -> DBusStruct as -> DBusStruct (a ': as) @@ -189,8 +289,8 @@ -> DBusValue (TypeDict k v) -- TODO: Remove - -- Unit isn't an actual DBus type and is included only for use with methods - -- that don't return a value + -- | Unit isn't an actual DBus type and is included only for use with methods + -- that don't return a value. DBVUnit :: DBusValue TypeUnit @@ -301,38 +401,129 @@ typeOf :: SingI t => DBusValue t -> DBusType typeOf (_ :: DBusValue a) = fromSing (sing :: SDBusType a) -class Representable a where +-- | Class of types that can be represented in the D-Bus type system. +-- +-- The toRep and fromRep functions form a Prism and should follow the "obvious" +-- laws: +-- +-- * @fromRep (toRep x) == Just x@ +-- +-- * @fmap toRep (fromRep x) =<= Just x @ +-- +-- (where @x =<= y@ iff @x@ is @Nothing@ or @x == y@) +-- +-- All 'DBusValues' represent themselves and instances for +-- the following "canonical" pairs are provided +-- +-- Haskell type => D-Bus type +-- +-- * Word/X/ and Int/X/ => UInt/X/ and Int/X/ respectively +-- (for /X/ in {16, 32, 64}) +-- +-- * 'Bool' => Boolean +-- +-- * 'Word8' => Byte +-- +-- * 'Double' => Double +-- +-- * 'Text' => String +-- +-- * 'ObjectPath' => ObjectPath +-- +-- * 'DBusType' => Signature +-- +-- * [a] => Array of a (for Representable a) +-- +-- * 'ByteString' => Array of Byte +-- +-- * Tuples up to length 20 => Structs of equal length where each of the members +-- is itself Representable +-- +-- * 'Map' => Dict where the keys can be represented by a 'DBusSimpleType' +-- +-- An instance for 'String' is impossible because it conflicts with the instance +-- for lists (use Text instead) +-- +-- Also note that no Representable instances are provided for 'Int', 'Integer' +-- and 'Float'. +-- +-- You can automatically derive an instance for your own Types with +-- 'makeRepresentable' +class SingI (RepType a) => Representable a where + -- | The 'DBusType' that represents this type type RepType a :: DBusType + -- | Conversion from Haskell to D-Bus types toRep :: a -> DBusValue (RepType a) + -- | Conversion from D-Bus to Haskell types. fromRep :: DBusValue (RepType a) -> Maybe a + ------------------------------------------------ -- Objects ------------------------------------------------ + + + data MethodWrapper av rv where - MReturn :: SingI t => IO (DBusValue t) -> MethodWrapper '[] t + MReturn :: SingI ts => SignalT IO (DBusArguments ts) -> MethodWrapper '[] ts MAsk :: SingI t => (DBusValue t -> MethodWrapper avs rv ) -> MethodWrapper (t ': avs) rv -type family ArgParity (x :: [DBusType]) :: Parity -type instance ArgParity '[] = 'Null -type instance ArgParity (x ': xs) = Arg (ArgParity xs) +type family ArgParity (x :: [DBusType]) :: Parity where + ArgParity '[] = 'Null + ArgParity (x ': xs) = Arg (ArgParity xs) data Method where - Method :: (SingI avs, SingI t) => - MethodWrapper avs t + Method :: (SingI avs, SingI ts) => + MethodWrapper avs ts -> Text.Text - -> MethodDescription (ArgParity avs) + -> ArgumentDescription (ArgParity avs) + -> ResultDescription (ArgParity ts) -> Method +data PropertyEmitsChangedSignal = PECSTrue + | PECSInvalidates + | PECSFalse + +data PropertyWrapper t where + PropertyWrapper :: forall t. SingI t => + { setProperty :: Maybe (DBusValue t -> SignalT IO Bool) + -- | ^ setter for the property. Returns + , getProperty :: Maybe (SignalT IO (DBusValue t)) + } -> PropertyWrapper t + +data Property where + Property :: forall t . (SingI t) => + { propertyName :: Text.Text + , propertyAccessors :: PropertyWrapper t + , propertyEmitsChangedSignal :: PropertyEmitsChangedSignal + } -> Property + +propertyType :: Property -> DBusType +propertyType Property{propertyAccessors = accs :: PropertyWrapper t} + = fromSing (sing :: Sing t) + data Annotation = Annotation { annotationName :: Text.Text , annotationValue :: Text.Text } deriving (Eq, Show, Data, Typeable) + +data SignalArgument = + SignalArgument { signalArgumentName :: Text.Text + , signalArgumentType :: DBusType + } + +data SignalInterface = SignalI { signalName :: Text.Text + , signalArguments :: [SignalArgument] + , signalAnnotations :: [Annotation] + } + data Interface = Interface { interfaceName :: Text.Text , interfaceMethods :: [Method] , interfaceAnnotations :: [Annotation] + , interfaceSignals :: [SignalInterface] + , interfaceProperties :: [Property] } instance Eq Interface where @@ -373,13 +564,13 @@ } data MethodError = MethodErrorMessage [SomeDBusValue] - | MethodSignatureMissmatch SomeDBusValue + | MethodSignatureMissmatch [SomeDBusValue] deriving (Show, Typeable) instance Ex.Exception MethodError type Serial = Word32 -type Slot = Either [SomeDBusValue] SomeDBusValue -> STM () +type Slot = Either [SomeDBusValue] [SomeDBusValue] -> STM () type AnswerSlots = Map.Map Serial Slot data DBusConnection = diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import Control.Applicative ((<$>), (<*>)) +import Control.Monad +import Control.Monad.Reader +import DBus.Signature +import Data.Binary.Get +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Builder as BS +import Data.Char +import Data.Either +import Data.Int +import Data.List (intercalate) +import Data.Singletons +import Data.Singletons.Prelude.List +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Word + +import DBus.Types +import DBus.Wire + +-- import DBus.Introspect +import Test.QuickCheck +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Tasty.TH + +import Numeric +import Debug.Trace + +instance Arbitrary DBusSimpleType where + arbitrary = oneof [ return TypeByte + , return TypeBoolean + , return TypeInt16 + , return TypeUInt16 + , return TypeInt32 + , return TypeUInt32 + , return TypeInt64 + , return TypeUInt64 + , return TypeDouble + , return TypeUnixFD + , return TypeString + , return TypeObjectPath + , return TypeSignature + ] + shrink _ = [TypeByte] + +resized :: Gen a -> Gen a +resized g = sized (\i -> resize (i `div` 2) g) + +maxsized :: Int -> Gen a -> Gen a +maxsized s g = sized (\i -> resize (min s i) g) + +instance Arbitrary DBusType where + arbitrary = oneof [ DBusSimpleType <$> resized arbitrary + , TypeArray <$> resized arbitrary + , TypeStruct <$> resized (listOf1 arbitrary) + , TypeDict <$> resized arbitrary <*> resized arbitrary + , return TypeVariant + ] + shrink (TypeStruct ts) = TypeStruct <$> (filter (not.null) $ shrink ts) + shrink (TypeDict kt vt) = (TypeDict kt <$> (shrink vt)) + ++ (TypeDict <$> (shrink kt) <*> [vt]) + shrink (TypeDictEntry kt vt) = (TypeDictEntry kt <$> (shrink vt)) + ++ (TypeDictEntry <$> (shrink kt) <*> [vt]) + shrink (TypeArray t) = TypeArray <$> shrink t + shrink t = [] + +prop_signatureInverse = \s -> eitherParseSig (toSignature s) == Right s + +nodeXml = Text.encodeUtf8 $ Text.concat + [ "" + , " " + , " " + , " " + , " " + , " " + , " " + , " " + , " " + , " " + , " " + , " " + , " " + , " " + , " " + , " " + , " " + , " " + , " " + , " " + , " " + , " " + , " " + , "" + ] + +isRight :: Either a b -> Bool +isRight (Right _) = True +isRight (Left _) = False + +-- testing_pickler1 = isRight $ xmlToNode nodeXml +-- testing_pickler2 = let Right node = xmlToNode nodeXml +-- reXml = nodeToXml node +-- Right reNode = xmlToNode reXml +-- in node == reNode + + +genText = Text.pack <$> arbitrary +genOP = objectPath . Text.pack <$> arbitrary + + +shrinkTypes [x] = (:[]) <$> shrinkType x +shrinkTypes xs = if BS.length (toSignatures xs) > 255 + then shrinkTypes (tail xs) + else return xs + +genDBV :: Sing t -> Gen (DBusValue t) +genDBV (SDBusSimpleType STypeByte) = DBVByte <$> arbitrary +genDBV (SDBusSimpleType STypeBoolean) = DBVBool <$> arbitrary +genDBV (SDBusSimpleType STypeInt16) = DBVInt16 <$> arbitrary +genDBV (SDBusSimpleType STypeUInt16) = DBVUInt16 <$> arbitrary +genDBV (SDBusSimpleType STypeInt32) = DBVInt32 <$> arbitrary +genDBV (SDBusSimpleType STypeUInt32) = DBVUInt32 <$> arbitrary +genDBV (SDBusSimpleType STypeInt64) = DBVInt64 <$> arbitrary +genDBV (SDBusSimpleType STypeUInt64) = DBVUInt64 <$> arbitrary +genDBV (SDBusSimpleType STypeDouble) = DBVDouble <$> arbitrary +genDBV (SDBusSimpleType STypeUnixFD) = DBVUnixFD <$> arbitrary +genDBV (SDBusSimpleType STypeString) = DBVString <$> genText +genDBV (SDBusSimpleType STypeObjectPath) = DBVObjectPath <$> genOP +genDBV (SDBusSimpleType STypeSignature) = maxsized 10 $ + DBVSignature <$> (shrinkTypes =<< arbitrary) +genDBV STypeVariant = resized $ do + t <- maxsized 10 $ shrinkType =<< arbitrary :: Gen DBusType + case toSing t of + SomeSing (st :: Sing t) -> withSingI st $ DBVVariant <$> genDBV st +genDBV (STypeArray t) = resized $ DBVArray + <$> listOf (genDBV t) +genDBV (STypeStruct ts) = resized $ DBVStruct <$> genStruct ts +genDBV (STypeDict kt vt) = resized $ + DBVDict <$> listOf ((,) <$> genDBV (SDBusSimpleType kt) + <*> genDBV vt) + + +genStruct :: Sing ts -> Gen (DBusStruct ts) +genStruct (SCons t SNil) = StructSingleton <$> genDBV t +genStruct (SCons t ts) = StructCons <$> genDBV t <*> genStruct ts + +for = flip map + +shrinkType t = if BS.length (toSignature t) > 255 + then shrinkType =<< elements (shrink t) + else return t + +instance Arbitrary SomeDBusValue where + arbitrary = do + t <- shrinkType =<< arbitrary :: Gen DBusType + case toSing t of + SomeSing st -> withSingI st $ DBV <$> genDBV st + shrink (DBV x) = case x of + DBVVariant y -> (DBV y) + : ((\(DBV x) -> DBV (DBVVariant x)) <$> shrink (DBV y)) + (DBVArray (a:as) :: DBusValue t) -> case (sing :: Sing t) of + STypeArray ts -> withSingI ts $ + ( case shrink (fromSing (sing :: Sing t)) of + tss -> for tss $ \tshrink -> case toSing tshrink of + (SomeSing (ss :: Sing tt)) -> withSingI ss $ + DBV (DBVArray ([] :: [DBusValue tt])) + ) ++ + [ DBV ( DBVArray [] :: DBusValue t) + , DBV ( DBVArray as :: DBusValue t) + , DBV ( DBVArray (init (a:as)) :: DBusValue t) + , case (sing :: Sing t) of + STypeArray st + -> withSingI st $ DBV a + ] ++ map (\(DBV b) -> DBV (DBVArray [b])) (shrink (DBV a)) + + (DBVDict ((k,v):as) :: DBusValue t) + -> [ DBV ( DBVDict [] :: DBusValue t) + , DBV ( DBVDict as :: DBusValue t) + , case (sing :: Sing t) of + STypeDict kt vt -> withSingI kt $ DBV k + , case (sing :: Sing t) of + STypeDict kt vt -> withSingI vt $ DBV v + ] + + (DBVStruct fs :: DBusValue t) -> + case (sing :: Sing t) of + STypeStruct ts -> shrinkStruct ts fs + _ -> [] + +shrinkStruct :: Sing ts -> DBusStruct ts -> [SomeDBusValue] +shrinkStruct (SCons t SNil) (StructSingleton x) = withSingI t [DBV x] +shrinkStruct (SCons t ts) (StructCons x xs) = + withSingI t $ withSingI ts $ + (DBV $ DBVStruct xs) + : (DBV x) + : (shrinkStruct ts xs) + +hexifyChar c = case showHex c "" of + [x] -> ['0',x] + x -> x + +hexifyBS bs = intercalate " " $ hexifyChar <$> BSL.unpack bs + +showifyChar c = if ord 'a' <= c && c <= ord 'z' + then chr c : " " + else " " + +showifyBS bs = intercalate " " $ showifyChar . fromIntegral <$> BSL.unpack bs + +-- sho bs = "============\n" ++ show bs ++ "\n -------------- \n" ++ hexifyBS bs +sho bs = show bs + +to :: SingI t => DBusValue t -> BSL.ByteString +to x = (BS.toLazyByteString $ runDBusPut Big (putDBV x)) + + +wire_inverse (x :: DBusValue t) = + let from = runGet (runReaderT getDBV Big) (to x) + in (DBV from, x == from) + +prop_wire_inverse (DBV x) = snd $ wire_inverse x + + +main = $defaultMainGenerator + +ppv (x :: DBusValue t) = do + print x + let bs = to x + return $! bs + forM_ [1..32] $ \i -> (putStr $ hexifyChar i) >> putStr " " + putStrLn "" + putStrLn (hexifyBS bs) + putStrLn (showifyBS bs) + putStrLn (" ## " ++ show (BSL.length bs)) + let from = runGet (runReaderT getDBV Big) bs + print from + print x + print $ x == from + +foo = sample' arbitrary >>= (mapM_ $ \(DBV x) -> ppv x) + +test1 = DBVVariant (DBVArray [DBVUInt16 2]) +test2 = DBVArray [DBVByte 0 , DBVByte 3, DBVByte 0] +test3 = DBVVariant (DBVVariant (DBVStruct (StructSingleton (DBVStruct (StructSingleton (DBVUInt16 9)))))) + +test4 = DBVArray [DBVVariant $ DBVUInt32 7 ] +test5 = DBVArray [DBVVariant $ DBVUInt64 7 ] + +test6 = DBVArray [DBVStruct (StructSingleton (DBVVariant (DBVUInt32 0)))] +test7 = DBVArray [DBVStruct (StructSingleton (DBVUInt64 (maxBound :: Word64)))] + +test8o = DBVVariant (DBVVariant (DBVArray [DBVVariant (DBVVariant (DBVInt16 (-1)))])) + +test8 = DBVVariant (DBVVariant (DBVArray [DBVVariant (DBVVariant (DBVInt16 (-1)))])) diff --git a/tests/Runtest.hs b/tests/Runtest.hs new file mode 100644 --- /dev/null +++ b/tests/Runtest.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import qualified Control.Exception as Ex +import DBus +import DBus.Types +import DBus.Object +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Word + + +testFunction1 txt num b = + if b then Right $ (fromIntegral $ Text.length txt) * num + else Left txt + +testAction1 :: Text -> Word32 -> Bool -> IO Word32 +testAction1 txt num doError = do + case testFunction1 txt num doError of + Right num -> return num + Left e -> Ex.throwIO $ errorFailed txt + +testMethod = Method (repMethod testAction1) + "testMethod1" + ("text" :-> "number" :-> "error?" :-> Result) + ("another number" :> ResultDone) + +testInterface = Interface "dbus.test" [testMethod] [] [] [] + +testObject = Object { objectObjectPath = objectPath "dbus/test" + , objectInterfaces = [testInterface] + , objectSubObjects = [] + } + +root = Object { objectObjectPath = objectPath "/" + , objectInterfaces = [] + , objectSubObjects = [testObject] + } + +server = do + con <- connectBus Session + (\con header bdy -> do + print header + objectRoot (addIntrospectable root) + con header bdy + ) ignore + requestName "dbus.test" def con + return con + + + + +client = connectBus Session ignore ignore + + +main = do + srvCon <- server + cl <- client + res <- callMethod + "dbus.test" (objectPath "/dbus/test") "dbus.test" "testMethod1" + ("test" :: Text, 13 :: Word32, True) + [] cl + print (res :: (Either MethodError Word32)) + checkAlive srvCon + return ()