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.1.5 +version: 0.1.6 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 @@ -9,7 +9,7 @@ license-file: LICENSE author: Philipp Balzarek maintainer: p.balzarek@googlemail.com -copyright: 2013 Philipp Balzarek +copyright: 2013-2017 Philipp Balzarek category: Network, Desktop build-type: Simple cabal-version: >=1.10 @@ -41,7 +41,7 @@ build-depends: async >= 2.0 , attoparsec >= 0.12 , base >= 4 && <5 - , binary >= 0.7 + , binary >= 0.8.1.0 , blaze-builder >= 0.3 , bytestring >= 0.10 , conduit >= 1.1 diff --git a/src/DBus/Introspect.hs b/src/DBus/Introspect.hs --- a/src/DBus/Introspect.hs +++ b/src/DBus/Introspect.hs @@ -65,7 +65,7 @@ propertyAccessToText Write = "write" propertyAccessToText ReadWrite = "readwrite" -data IArgument = IArgument { iArgumentName :: Text +data IArgument = IArgument { iArgumentName :: Maybe Text , iArgumentType :: DBusType , iArgumentDirection :: Maybe IDirection } deriving (Eq, Show, Data, Typeable) @@ -118,7 +118,7 @@ xpArgument = xpWrap (\(name, tp, dir) -> IArgument name tp dir) (\(IArgument name tp dir) -> (name, tp, dir)) $ xpElemAttrs "arg" - (xp3Tuple (xpAttribute "name" xpText) + (xp3Tuple (xpAttribute' "name" xpText) (xpAttribute "type" xpSignature) (xpAttribute' "direction" xpDirection) ) @@ -207,13 +207,13 @@ toArgs m@(Method _ _ argDs resDs) = let (args, res) = methodSignature m (ts, rs) = argDescriptions argDs resDs - in zipWith (\n t -> IArgument n t (Just In)) ts args - ++ zipWith ((\r t -> IArgument r t (Just Out))) rs res + in zipWith (\n t -> IArgument (Just n) t (Just In)) ts args + ++ zipWith ((\r t -> IArgument (Just r) t (Just Out))) rs res introspectSignalArgument :: DBusType -> Text -> IArgument introspectSignalArgument tp name = - IArgument { iArgumentName = name + IArgument { iArgumentName = Just name , iArgumentType = tp , iArgumentDirection = Nothing } @@ -288,31 +288,31 @@ iMethodName = "Get" , iMethodArguments = [ IArgument { - iArgumentName = "interface_name" + iArgumentName = Just "interface_name" , iArgumentType = DBusSimpleType TypeString , iArgumentDirection = Just In} , IArgument { - iArgumentName = "property_name" + iArgumentName = Just "property_name" , iArgumentType = DBusSimpleType TypeString , iArgumentDirection = Just In} - , IArgument { - iArgumentName = "value" - , iArgumentType = TypeVariant - , iArgumentDirection = Just Out }] - , iMethodAnnotations = []} + , IArgument { + iArgumentName = Just "value" + , iArgumentType = TypeVariant + , iArgumentDirection = Just Out }] + , iMethodAnnotations = []} , IMethod{ iMethodName = "Set" , iMethodArguments = [ IArgument { - iArgumentName = "interface_name" + iArgumentName = Just "interface_name" , iArgumentType = DBusSimpleType TypeString , iArgumentDirection = Just In } , IArgument { - iArgumentName = "property_name" + iArgumentName = Just "property_name" , iArgumentType = DBusSimpleType TypeString , iArgumentDirection = Just In } , IArgument { - iArgumentName = "value" + iArgumentName = Just "value" , iArgumentType = TypeVariant , iArgumentDirection = Just In}] , iMethodAnnotations = [] } @@ -320,11 +320,11 @@ iMethodName = "GetAll" , iMethodArguments = [ IArgument { - iArgumentName = "interface_name" + iArgumentName = Just "interface_name" , iArgumentType = DBusSimpleType TypeString , iArgumentDirection = Just In } , IArgument { - iArgumentName = "props" + iArgumentName = Just "props" , iArgumentType = TypeDict TypeString TypeVariant , iArgumentDirection = Just Out }] , iMethodAnnotations = [] }] @@ -332,15 +332,15 @@ [ ISignal { iSignalName = "PropertiesChanged" , iSignalArguments = [ IArgument { - iArgumentName = "interface_name" + iArgumentName = Just "interface_name" , iArgumentType = DBusSimpleType TypeString , iArgumentDirection = Nothing} , IArgument { - iArgumentName = "changed_properties" + iArgumentName = Just "changed_properties" , iArgumentType = TypeDict TypeString TypeVariant , iArgumentDirection = Nothing} , IArgument { - iArgumentName = "invalidated_properties" + iArgumentName = Just "invalidated_properties" , iArgumentType = TypeArray (DBusSimpleType TypeString) , iArgumentDirection = Nothing}] diff --git a/src/DBus/Property.hs b/src/DBus/Property.hs --- a/src/DBus/Property.hs +++ b/src/DBus/Property.hs @@ -47,13 +47,16 @@ let prop = Property { propertyPath = path , propertyInterface = iface , propertyName = name - , propertySet = doSet <$> set + , propertySet = doSet prop <$> set , propertyGet = fmap toRep <$> get , propertyEmitsChangedSignal = pecs } in prop where - doSet f v = f =<< fromRepHelper v + doSet prop f v = do + x <- fromRepHelper v + propertyChanged prop x + f x fromRepHelper x = case fromRep x of Nothing -> methodError argTypeMismatch Just r -> return r diff --git a/src/DBus/Scaffold.hs b/src/DBus/Scaffold.hs --- a/src/DBus/Scaffold.hs +++ b/src/DBus/Scaffold.hs @@ -64,9 +64,9 @@ makeDbusEndpoints :: DBusEndpointOptions -> ObjectPath -> FilePath -> Q [Dec] makeDbusEndpoints conf root xmlFile = do -- @TODO: root node <- readIntrospectXml xmlFile - let methods = nodeMethodDescriptions "" node - propDs = nodePropertyDescriptions "" node - sigDs = nodeSignals "" node + let methods = nodeMethodDescriptions node + propDs = nodePropertyDescriptions node + sigDs = nodeSignals node downcase [] = [] downcase (x:xs) = toLower x : xs mfs <- fmap catMaybes . forM methods $ \smd -> @@ -125,8 +125,9 @@ in mapIInterfaces f subPath n in ifaceMembers ++ subNodeMembers -nodeMethodDescriptions :: Text -> INode -> [SomeMethodDescription] -nodeMethodDescriptions = mapIInterfaces interfacMethodDescriptions +nodeMethodDescriptions :: INode -> [SomeMethodDescription] +nodeMethodDescriptions node = + mapIInterfaces interfacMethodDescriptions (fromMaybe "" $ nodeName node) node interfacPropertyDescriptions :: Text -> IInterface -> [PropertyDescription] interfacPropertyDescriptions path iface = @@ -146,9 +147,10 @@ , pdType :: DBusType } -nodePropertyDescriptions :: Text -> INode -> [PropertyDescription] -nodePropertyDescriptions = mapIInterfaces interfacPropertyDescriptions - +nodePropertyDescriptions :: INode -> [PropertyDescription] +nodePropertyDescriptions node = + mapIInterfaces interfacPropertyDescriptions (fromMaybe "" $ nodeName node) + node liftText t = [|Text.pack $(liftString (Text.unpack t))|] @@ -191,6 +193,8 @@ -> Q [Dec] liftMethodDescription name smd = case smd of (SMD (md :: MethodDescription args rets)) -> do + when (isEmpty $ methodObjectPath md) + . fail $ "empty method path: " ++ show md let ats = promotedListT . map promoteDBusType $ fromSing (sing :: Sing args) rts = promotedListT . map promoteDBusType $ @@ -232,9 +236,11 @@ Just e -> valD (varP name) (normalB . rp $ liftText e) [] return [tp, cl] -nodeSignals :: Text -> INode -> [SomeSignalDescription] -nodeSignals = mapIInterfaces interfaceSignalDs +nodeSignals :: INode -> [SomeSignalDescription] +nodeSignals node = + mapIInterfaces interfaceSignalDs (fromMaybe "" $ nodeName node) node + interfaceSignalDs :: Text -> IInterface -> [SomeSignalDescription] interfaceSignalDs ndName iface = signalDs (objectPath ndName) (iInterfaceName iface) @@ -260,7 +266,7 @@ toSings [] = SSAD SNil Done toSings (iarg : iargs) = let t = iArgumentType iarg - desc = iArgumentName iarg + desc = fromMaybe "" $ iArgumentName iarg in case (toSing t, toSings iargs) of (SomeSing s, SSAD ss descs) -> SSAD (SCons s ss) (desc :> descs) diff --git a/src/DBus/Types.hs b/src/DBus/Types.hs --- a/src/DBus/Types.hs +++ b/src/DBus/Types.hs @@ -437,6 +437,7 @@ DBVUnit == DBVUnit = True DBVArray x == DBVByteArray y = BS.pack (map (\(DBVByte w) -> w) x) == y DBVByteArray x == DBVArray y = BS.pack (map (\(DBVByte w) -> w) y) == x + _ == _ = False castDBV :: (SingI s, SingI t) => DBusValue s -> Maybe (DBusValue t) castDBV (v :: DBusValue s) diff --git a/src/DBus/Wire.hs b/src/DBus/Wire.hs --- a/src/DBus/Wire.hs +++ b/src/DBus/Wire.hs @@ -240,13 +240,13 @@ getWord64 = getting B.getWord64le B.getWord64be 8 getInt16 :: DBusGet Int16 -getInt16 = fromIntegral <$> getWord16 +getInt16 = getting B.getInt16le B.getInt16be 2 getInt32 :: DBusGet Int32 -getInt32 = fromIntegral <$> getWord32 +getInt32 = getting B.getInt32le B.getInt32be 4 getInt64 :: DBusGet Int64 -getInt64 = fromIntegral <$> getWord64 +getInt64 = getting B.getInt64le B.getInt64be 8 getDouble :: DBusGet Double getDouble = getting B.getFloat64le B.getFloat64be 8 @@ -355,10 +355,14 @@ EQ -> return [] GT -> mzero - +-- | Run a Binary Getter as a Sink sinkGet :: MonadThrow m => B.Get b -> C.ConduitM BS.ByteString o m b sinkGet f = sink (B.runGetIncremental f) where sink (B.Done bs _ v) = C.leftover bs >> return v - sink (B.Fail u o e) = throwM $ DBusParseError e - sink (B.Partial next) = C.await >>= sink . next + sink (B.Fail u o e) = throwM $ DBusParseError $ e + ++ " (" ++ show o ++ "; " + ++ show u ++ ")" + sink (B.Partial next) = do + bs <- C.await + sink $ next bs