d-bus 0.0.3 → 0.1.0
raw patch · 15 files changed
+1044/−217 lines, 15 filesdep +QuickCheckdep +d-busdep +tastydep ~binarydep ~bytestringdep ~mtl
Dependencies added: QuickCheck, d-bus, tasty, tasty-quickcheck, tasty-th, xml-hamlet
Dependency ranges changed: binary, bytestring, mtl, singletons, text
Files
- d-bus.cabal +30/−14
- src/DBus.hs +20/−9
- src/DBus/Auth.hs +2/−2
- src/DBus/Introspect.hs +40/−7
- src/DBus/MainLoop.hs +20/−16
- src/DBus/Message.hs +109/−40
- src/DBus/MessageBus.hs +34/−30
- src/DBus/Object.hs +218/−43
- src/DBus/Representable.hs +12/−20
- src/DBus/Signal.hs +7/−8
- src/DBus/Signature.hs +2/−2
- src/DBus/Transport.hs +3/−3
- src/DBus/Types.hs +214/−23
- tests/Main.hs +268/−0
- tests/Runtest.hs +65/−0
d-bus.cabal view
@@ -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
src/DBus.hs view
@@ -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 ()
src/DBus/Auth.hs view
@@ -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
src/DBus/Introspect.hs view
@@ -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
src/DBus/MainLoop.hs view
@@ -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 ()
src/DBus/Message.hs view
@@ -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
src/DBus/MessageBus.hs view
@@ -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" ()
src/DBus/Object.hs view
@@ -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
src/DBus/Representable.hs view
@@ -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)
src/DBus/Signal.hs view
@@ -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)
src/DBus/Signature.hs view
@@ -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
src/DBus/Transport.hs view
@@ -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
src/DBus/Types.hs view
@@ -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 =
+ tests/Main.hs view
@@ -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+ [ "<!DOCTYPE node PUBLIC \"-//freedesktop//DTD D-BUS Object Introspection \+ \1.0//EN\""+ , " \"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd\">"+ , " <node name=\"/com/example/sample_object\">"+ , " <interface name=\"com.example.SampleInterface\">"+ , " <method name=\"Frobate\">"+ , " <arg name=\"foo\" type=\"i\" direction=\"in\"/>"+ , " <arg name=\"bar\" type=\"s\" direction=\"out\"/>"+ , " <arg name=\"baz\" type=\"a{us}\" direction=\"out\"/>"+ , " <annotation name=\"org.freedesktop.DBus.Deprecated\" value=\"true\"/>"+ , " </method>"+ , " <method name=\"Bazify\">"+ , " <arg name=\"bar\" type=\"(iiu)\" direction=\"in\"/>"+ , " <arg name=\"bar\" type=\"v\" direction=\"out\"/>"+ , " </method>"+ , " <method name=\"Mogrify\">"+ , " <arg name=\"bar\" type=\"(iiav)\" direction=\"in\"/>"+ , " </method>"+ , " <signal name=\"Changed\">"+ , " <arg name=\"new_value\" type=\"b\"/>"+ , " </signal>"+ , " <property name=\"Bar\" type=\"y\" access=\"readwrite\"/>"+ , " </interface>"+ , " <node name=\"child_of_sample_object\"/>"+ , " <node name=\"another_child_of_sample_object\"/>"+ , "</node>"+ ]++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)))]))
+ tests/Runtest.hs view
@@ -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 ()