Hello community, here is the log from the commit of package ghc-dbus for openSUSE:Factory checked in at 2018-12-06 12:16:49 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-dbus (Old) and /work/SRC/openSUSE:Factory/.ghc-dbus.new.19453 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-dbus" Thu Dec 6 12:16:49 2018 rev:3 rq:653441 version:1.1.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-dbus/ghc-dbus.changes 2018-10-25 08:17:03.976051722 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-dbus.new.19453/ghc-dbus.changes 2018-12-06 12:16:53.489547209 +0100 @@ -1,0 +2,12 @@ +Mon Nov 26 03:01:51 UTC 2018 - [email protected] + +- Update dbus to version 1.1.1. + Upstream does not provide a change log file. + +------------------------------------------------------------------- +Sat Nov 24 03:01:52 UTC 2018 - [email protected] + +- Update dbus to version 1.1.0. + Upstream does not provide a change log file. + +------------------------------------------------------------------- Old: ---- dbus-1.0.1.tar.gz New: ---- dbus-1.1.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-dbus.spec ++++++ --- /var/tmp/diff_new_pack.0ejOV8/_old 2018-12-06 12:16:54.049546608 +0100 +++ /var/tmp/diff_new_pack.0ejOV8/_new 2018-12-06 12:16:54.053546603 +0100 @@ -19,7 +19,7 @@ %global pkg_name dbus %bcond_with tests Name: ghc-%{pkg_name} -Version: 1.0.1 +Version: 1.1.1 Release: 0 Summary: A client library for the D-Bus IPC system License: Apache-2.0 @@ -29,11 +29,12 @@ BuildRequires: ghc-Cabal-devel BuildRequires: ghc-bytestring-devel BuildRequires: ghc-cereal-devel +BuildRequires: ghc-conduit-devel BuildRequires: ghc-containers-devel BuildRequires: ghc-deepseq-devel +BuildRequires: ghc-exceptions-devel BuildRequires: ghc-filepath-devel BuildRequires: ghc-lens-devel -BuildRequires: ghc-libxml-sax-devel BuildRequires: ghc-network-devel BuildRequires: ghc-parsec-devel BuildRequires: ghc-random-devel @@ -45,6 +46,7 @@ BuildRequires: ghc-transformers-devel BuildRequires: ghc-unix-devel BuildRequires: ghc-vector-devel +BuildRequires: ghc-xml-conduit-devel BuildRequires: ghc-xml-types-devel %if %{with tests} BuildRequires: ghc-QuickCheck-devel ++++++ dbus-1.0.1.tar.gz -> dbus-1.1.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/dbus-1.0.1/benchmarks/DBusBenchmarks.hs new/dbus-1.1.1/benchmarks/DBusBenchmarks.hs --- old/dbus-1.0.1/benchmarks/DBusBenchmarks.hs 2018-03-29 02:52:31.000000000 +0200 +++ new/dbus-1.1.1/benchmarks/DBusBenchmarks.hs 2018-11-23 05:51:25.000000000 +0100 @@ -40,13 +40,16 @@ benchUnmarshal name msg = bench name (whnf unmarshal bytes) where Right bytes = marshal LittleEndian (serial 0) msg +parseSig :: String -> Maybe Signature +parseSig = parseSignature + benchmarks :: [Benchmark] benchmarks = [ bgroup "Types" [ bgroup "Signature" - [ bench "parseSignature/small" (nf parseSignature "y") - , bench "parseSignature/medium" (nf parseSignature "yyyyuua(yv)") - , bench "parseSignature/large" (nf parseSignature "a{s(asiiiiasa(siiia{s(iiiiv)}))}") + [ bench "parseSignature/small" (nf parseSig "y") + , bench "parseSignature/medium" (nf parseSig "yyyyuua(yv)") + , bench "parseSignature/large" (nf parseSig "a{s(asiiiiasa(siiia{s(iiiiv)}))}") ] , bgroup "ObjectPath" [ bench "objectPath_/small" (nf objectPath_ "/") diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/dbus-1.0.1/dbus.cabal new/dbus-1.1.1/dbus.cabal --- old/dbus-1.0.1/dbus.cabal 2018-03-29 03:00:22.000000000 +0200 +++ new/dbus-1.1.1/dbus.cabal 2018-11-25 04:17:02.000000000 +0100 @@ -1,5 +1,5 @@ name: dbus -version: 1.0.1 +version: 1.1.1 license: Apache-2.0 license-file: license.txt author: John Millikin <[email protected]> @@ -83,11 +83,12 @@ base >=4 && <5 , bytestring , cereal + , conduit >= 1.3.0 , containers , deepseq + , exceptions , filepath , lens - , libxml-sax , network , parsec , random @@ -98,6 +99,7 @@ , transformers , unix , vector + , xml-conduit , xml-types exposed-modules: @@ -128,7 +130,6 @@ , directory , extra , filepath - , libxml-sax , network , parsec , process @@ -142,7 +143,6 @@ , transformers , unix , vector - , xml-types other-modules: DBusTests.Address diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/dbus-1.0.1/lib/DBus/Generation.hs new/dbus-1.1.1/lib/DBus/Generation.hs --- old/dbus-1.0.1/lib/DBus/Generation.hs 2018-03-29 00:22:00.000000000 +0200 +++ new/dbus-1.1.1/lib/DBus/Generation.hs 2018-11-23 06:10:28.000000000 +0100 @@ -356,7 +356,7 @@ buildSignature $ AppT (ConT ''IO) $ AppT (AppT (ConT ''Either) (ConT ''M.MethodError)) $ getArgType propType - setterSigType = buildSignature $ + setterSigType = buildSignature $ addTypeArg (getArgType propType) $ AppT (ConT ''IO) $ AppT (ConT ''Maybe) (ConT ''M.MethodError) buildArgs rest = clientN:addArgIf takeBusArg busN (addArgIf takeObjectPathArg objectPathN rest) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/dbus-1.0.1/lib/DBus/Internal/Types.hs new/dbus-1.1.1/lib/DBus/Internal/Types.hs --- old/dbus-1.0.1/lib/DBus/Internal/Types.hs 2018-03-29 00:22:00.000000000 +0200 +++ new/dbus-1.1.1/lib/DBus/Internal/Types.hs 2018-11-23 05:51:25.000000000 +0100 @@ -1,15 +1,11 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} -- Copyright (C) 2009-2012 John Millikin <[email protected]> --- --- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- any later version. @@ -25,13 +21,11 @@ module DBus.Internal.Types where import Control.DeepSeq -import Control.Exception (Exception, handle, throwIO) import Control.Monad (liftM, when, (>=>)) -import qualified Data.ByteString -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as Char8 -import qualified Data.ByteString.Lazy -import qualified Data.ByteString.Unsafe +import Control.Monad.Catch +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BL import Data.Char (ord) import Data.Coerce import Data.Int @@ -47,10 +41,8 @@ import qualified Data.Vector import Data.Vector (Vector) import Data.Word -import qualified Foreign import GHC.Generics import qualified Language.Haskell.TH.Lift as THL -import System.IO.Unsafe (unsafePerformIO) import System.Posix.Types (Fd) import Text.ParserCombinators.Parsec ((<|>), oneOf) import qualified Text.ParserCombinators.Parsec as Parsec @@ -188,29 +180,29 @@ -- | Parse a signature string into a valid signature. -- --- Returns @Nothing@ if the given string is not a valid signature. -parseSignature :: String -> Maybe Signature +-- Throws if the given string is not a valid signature. +parseSignature :: MonadThrow m => String -> m Signature parseSignature s = do - when (length s > 255) Nothing - when (any (\c -> ord c > 0x7F) s) Nothing - parseSignatureBytes (Char8.pack s) + when (length s > 255) $ throwM $ userError "string too long" + when (any (\c -> ord c > 0x7F) s) $ throwM $ userError "invalid signature" + parseSignatureBytes (BS8.pack s) -parseSignatureBytes :: ByteString -> Maybe Signature +parseSignatureBytes :: MonadThrow m => BS.ByteString -> m Signature parseSignatureBytes bytes = - case Data.ByteString.length bytes of - 0 -> Just (Signature []) + case BS.length bytes of + 0 -> pure (Signature []) 1 -> parseSigFast bytes len | len <= 255 -> parseSigFull bytes - _ -> Nothing + _ -> throwM $ userError "string too long" -parseSigFast :: ByteString -> Maybe Signature +parseSigFast :: MonadThrow m => BS.ByteString -> m Signature parseSigFast bytes = - let byte = Data.ByteString.Unsafe.unsafeHead bytes in - parseAtom (fromIntegral byte) - (\t -> Just (Signature [t])) - (case byte of - 0x76 -> Just (Signature [TypeVariant]) - _ -> Nothing) + let byte = BS.head bytes + in parseAtom (fromIntegral byte) + (\t -> pure (Signature [t])) + (case byte of + 0x76 -> pure (Signature [TypeVariant]) + _ -> throwM $ userError "invalid signature") parseAtom :: Int -> (Type -> a) -> a -> a parseAtom byte yes no = case byte of @@ -235,94 +227,82 @@ instance Exception SigParseError -peekWord8AsInt :: Foreign.Ptr Word8 -> Int -> IO Int -peekWord8AsInt ptr off = do - w <- Foreign.peekElemOff ptr off - return (fromIntegral w) - -parseSigFull :: ByteString -> Maybe Signature -parseSigFull bytes = unsafePerformIO io where - io = handle - (\SigParseError -> return Nothing) - $ Data.ByteString.Unsafe.unsafeUseAsCStringLen bytes - $ \(ptr, len) -> do - ts <- parseSigBuf (Foreign.castPtr ptr, len) - return (Just (Signature ts)) - - parseSigBuf (buf, len) = mainLoop [] 0 where - - mainLoop acc ii | ii >= len = return (reverse acc) - mainLoop acc ii = do - c <- peekWord8AsInt buf ii - let next t = mainLoop (t : acc) (ii + 1) - parseAtom c next $ case c of - 0x76 -> next TypeVariant - 0x28 -> do -- '(' - (ii', t) <- structure (ii + 1) - mainLoop (t : acc) ii' - 0x61 -> do -- 'a' - (ii', t) <- array (ii + 1) - mainLoop (t : acc) ii' - _ -> throwIO SigParseError +peekWord8AsInt :: BS.ByteString -> Int -> Int +peekWord8AsInt str i = fromIntegral $ BS.index str i - structure :: Int -> IO (Int, Type) - structure = loop [] where - loop _ ii | ii >= len = throwIO SigParseError - loop acc ii = do - c <- peekWord8AsInt buf ii - let next t = loop (t : acc) (ii + 1) - parseAtom c next $ case c of - 0x76 -> next TypeVariant - 0x28 -> do -- '(' - (ii', t) <- structure (ii + 1) - loop (t : acc) ii' - 0x61 -> do -- 'a' - (ii', t) <- array (ii + 1) - loop (t : acc) ii' - -- ')' - 0x29 -> case acc of - [] -> throwIO SigParseError - _ -> return (ii + 1, TypeStructure (reverse acc)) - _ -> throwIO SigParseError - - array :: Int -> IO (Int, Type) - array ii | ii >= len = throwIO SigParseError - array ii = do - c <- peekWord8AsInt buf ii - let next t = return (ii + 1, TypeArray t) +parseSigFull :: MonadThrow m => BS.ByteString -> m Signature +parseSigFull bytes = Signature <$> mainLoop [] 0 + where + len = BS.length bytes + mainLoop acc ii | ii >= len = pure (reverse acc) + mainLoop acc ii = do + let c = peekWord8AsInt bytes ii + let next t = mainLoop (t : acc) (ii + 1) + parseAtom c next $ case c of + 0x76 -> next TypeVariant + 0x28 -> do -- '(' + (ii', t) <- structure (ii + 1) + mainLoop (t : acc) ii' + 0x61 -> do -- 'a' + (ii', t) <- array (ii + 1) + mainLoop (t : acc) ii' + _ -> throwM SigParseError + + structure = loop [] where + loop _ ii | ii >= len = throwM SigParseError + loop acc ii = do + let c = peekWord8AsInt bytes ii + let next t = loop (t : acc) (ii + 1) parseAtom c next $ case c of 0x76 -> next TypeVariant - 0x7B -> dict (ii + 1) -- '{' 0x28 -> do -- '(' (ii', t) <- structure (ii + 1) - return (ii', TypeArray t) + loop (t : acc) ii' 0x61 -> do -- 'a' (ii', t) <- array (ii + 1) - return (ii', TypeArray t) - _ -> throwIO SigParseError - - dict :: Int -> IO (Int, Type) - dict ii | ii + 1 >= len = throwIO SigParseError - dict ii = do - c1 <- peekWord8AsInt buf ii - c2 <- peekWord8AsInt buf (ii + 1) - - let next t = return (ii + 2, t) - (ii', t2) <- parseAtom c2 next $ case c2 of - 0x76 -> next TypeVariant - 0x28 -> structure (ii + 2) -- '(' - 0x61 -> array (ii + 2) -- 'a' - _ -> throwIO SigParseError - - if ii' >= len - then throwIO SigParseError - else do - c3 <- peekWord8AsInt buf ii' - if c3 == 0x7D - then do - t1 <- parseAtom c1 return (throwIO SigParseError) - return (ii' + 1, TypeDictionary t1 t2) - else throwIO SigParseError + loop (t : acc) ii' + -- ')' + 0x29 -> case acc of + [] -> throwM SigParseError + _ -> pure (ii + 1, TypeStructure (reverse acc)) + _ -> throwM SigParseError + + array ii | ii >= len = throwM SigParseError + array ii = do + let c = peekWord8AsInt bytes ii + let next t = pure (ii + 1, TypeArray t) + parseAtom c next $ case c of + 0x76 -> next TypeVariant + 0x7B -> dict (ii + 1) -- '{' + 0x28 -> do -- '(' + (ii', t) <- structure (ii + 1) + pure (ii', TypeArray t) + 0x61 -> do -- 'a' + (ii', t) <- array (ii + 1) + pure (ii', TypeArray t) + _ -> throwM SigParseError + + dict ii | ii + 1 >= len = throwM SigParseError + dict ii = do + let c1 = peekWord8AsInt bytes ii + let c2 = peekWord8AsInt bytes (ii + 1) + + let next t = pure (ii + 2, t) + (ii', t2) <- parseAtom c2 next $ case c2 of + 0x76 -> next TypeVariant + 0x28 -> structure (ii + 2) -- '(' + 0x61 -> array (ii + 2) -- 'a' + _ -> throwM SigParseError + + if ii' >= len + then throwM SigParseError + else do + let c3 = peekWord8AsInt bytes ii' + if c3 == 0x7D + then do + t1 <- parseAtom c1 pure (throwM SigParseError) + pure (ii' + 1, TypeDictionary t1 t2) + else throwM SigParseError extractFromVariant :: IsValue a => Variant -> Maybe a extractFromVariant (Variant (ValueVariant v)) = extractFromVariant v @@ -359,7 +339,7 @@ data Value = ValueAtom Atom | ValueVariant Variant - | ValueBytes ByteString + | ValueBytes BS.ByteString | ValueVector Type (Vector Value) | ValueMap Type Type (Map Atom Value) | ValueStructure [Value] @@ -427,8 +407,8 @@ showThings :: String -> (a -> String) -> String -> [a] -> String showThings a s z xs = a ++ intercalate ", " (map s xs) ++ z -vectorToBytes :: Vector Value -> ByteString -vectorToBytes = Data.ByteString.pack +vectorToBytes :: Vector Value -> BS.ByteString +vectorToBytes = BS.pack . Data.Vector.toList . Data.Vector.map (\(ValueAtom (AtomWord8 x)) -> x) @@ -556,26 +536,26 @@ toVariant = toVariant . Data.Vector.fromList fromVariant = fmap Data.Vector.toList . fromVariant -instance IsValue ByteString where +instance IsValue BS.ByteString where typeOf _ = TypeArray TypeWord8 toValue = ValueBytes fromValue (ValueBytes bs) = Just bs fromValue (ValueVector TypeWord8 v) = Just (vectorToBytes v) fromValue _ = Nothing -instance IsVariant ByteString where +instance IsVariant BS.ByteString where toVariant = Variant . toValue fromVariant (Variant val) = fromValue val -instance IsValue Data.ByteString.Lazy.ByteString where +instance IsValue BL.ByteString where typeOf _ = TypeArray TypeWord8 toValue = toValue - . Data.ByteString.concat - . Data.ByteString.Lazy.toChunks - fromValue = fmap (\bs -> Data.ByteString.Lazy.fromChunks [bs]) + . BS.concat + . BL.toChunks + fromValue = fmap (\bs -> BL.fromChunks [bs]) . fromValue -instance IsVariant Data.ByteString.Lazy.ByteString where +instance IsVariant BL.ByteString where toVariant = Variant . toValue fromVariant (Variant val) = fromValue val @@ -663,7 +643,7 @@ formatObjectPath :: ObjectPath -> String formatObjectPath (ObjectPath s) = s -parseObjectPath :: String -> Maybe ObjectPath +parseObjectPath :: MonadThrow m => String -> m ObjectPath parseObjectPath s = do maybeParseString parserObjectPath s return (ObjectPath s) @@ -706,9 +686,9 @@ formatInterfaceName :: InterfaceName -> String formatInterfaceName (InterfaceName s) = s -parseInterfaceName :: String -> Maybe InterfaceName +parseInterfaceName :: MonadThrow m => String -> m InterfaceName parseInterfaceName s = do - when (length s > 255) Nothing + when (length s > 255) $ throwM $ userError "name too long" maybeParseString parserInterfaceName s return (InterfaceName s) @@ -746,9 +726,9 @@ formatMemberName :: MemberName -> String formatMemberName (MemberName s) = s -parseMemberName :: String -> Maybe MemberName +parseMemberName :: MonadThrow m => String -> m MemberName parseMemberName s = do - when (length s > 255) Nothing + when (length s > 255) $ throwM $ userError "name too long" maybeParseString parserMemberName s return (MemberName s) @@ -783,9 +763,9 @@ formatErrorName :: ErrorName -> String formatErrorName (ErrorName s) = s -parseErrorName :: String -> Maybe ErrorName +parseErrorName :: MonadThrow m => String -> m ErrorName parseErrorName s = do - when (length s > 255) Nothing + when (length s > 255) $ throwM $ userError "name too long" maybeParseString parserInterfaceName s return (ErrorName s) @@ -813,9 +793,9 @@ formatBusName :: BusName -> String formatBusName (BusName s) = s -parseBusName :: String -> Maybe BusName +parseBusName :: MonadThrow m => String -> m BusName parseBusName s = do - when (length s > 255) Nothing + when (length s > 255) $ throwM $ userError "name too long" maybeParseString parserBusName s return (BusName s) @@ -883,7 +863,7 @@ -- 'IsValue'. data Array = Array Type (Vector Value) - | ArrayBytes ByteString + | ArrayBytes BS.ByteString instance Show Array where show (Array t xs) = showValue True (ValueVector t xs) @@ -904,7 +884,7 @@ arrayItems :: Array -> [Variant] arrayItems (Array _ xs) = map Variant (Data.Vector.toList xs) -arrayItems (ArrayBytes bs) = map toVariant (Data.ByteString.unpack bs) +arrayItems (ArrayBytes bs) = map toVariant (BS.unpack bs) -- | A D-Bus Dictionary is a container type similar to Haskell maps, storing -- zero or more associations between keys and values. @@ -1365,9 +1345,9 @@ Just x -> x Nothing -> error ("Invalid " ++ label ++ ": " ++ show str) -maybeParseString :: Parsec.Parser a -> String -> Maybe a +maybeParseString :: MonadThrow m => Parsec.Parser a -> String -> m a maybeParseString parser s = case Parsec.parse parser "" s of - Left _ -> Nothing - Right a -> Just a + Left err -> throwM $ userError $ show err + Right a -> pure a THL.deriveLiftMany [''BusName, ''ObjectPath, ''InterfaceName, ''MemberName] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/dbus-1.0.1/lib/DBus/Introspection.hs new/dbus-1.1.1/lib/DBus/Introspection.hs --- old/dbus-1.0.1/lib/DBus/Introspection.hs 2018-03-29 02:52:31.000000000 +0200 +++ new/dbus-1.1.1/lib/DBus/Introspection.hs 2018-11-25 04:06:48.000000000 +0100 @@ -29,16 +29,15 @@ , Property(..) ) where +import Conduit import qualified Control.Applicative -import Control.Monad ((>=>), ap, liftM) -import Control.Monad.ST (runST) +import Control.Monad (ap, liftM) +import qualified Data.ByteString.Lazy.Char8 as BL8 import Data.List (isPrefixOf) -import qualified Data.STRef as ST -import qualified Data.Text -import Data.Text (Text) -import qualified Data.Text.Encoding -import qualified Data.XML.Types as X -import qualified Text.XML.LibXML.SAX as SAX +import Data.Maybe +import qualified Data.Text as Text +import Data.XML.Types +import qualified Text.XML.Stream.Parse as X import qualified DBus as T @@ -93,124 +92,130 @@ } deriving (Show, Eq) +data ObjectChildren + = InterfaceDefinition Interface + | SubNode Object + +data InterfaceChildren + = MethodDefinition Method + | SignalDefinition Signal + | PropertyDefinition Property + parseXML :: T.ObjectPath -> String -> Maybe Object -parseXML path xml = do - root <- parseElement (Data.Text.pack xml) - parseRoot path root - -parseElement :: Text -> Maybe X.Element -parseElement xml = runST $ do - stackRef <- ST.newSTRef [([], [])] - let onError _ = do - ST.writeSTRef stackRef [] - return False - let onBegin _ attrs = do - ST.modifySTRef stackRef ((attrs, []):) - return True - let onEnd name = do - stack <- ST.readSTRef stackRef - let (attrs, children'):stack' = stack - let e = X.Element name attrs (map X.NodeElement (reverse children')) - let (pAttrs, pChildren):stack'' = stack' - let parent = (pAttrs, e:pChildren) - ST.writeSTRef stackRef (parent:stack'') - return True - - p <- SAX.newParserST Nothing - SAX.setCallback p SAX.parsedBeginElement onBegin - SAX.setCallback p SAX.parsedEndElement onEnd - SAX.setCallback p SAX.reportError onError - SAX.parseBytes p (Data.Text.Encoding.encodeUtf8 xml) - SAX.parseComplete p - stack <- ST.readSTRef stackRef - return $ case stack of - [] -> Nothing - (_, children'):_ -> Just (head children') - -parseRoot :: T.ObjectPath -> X.Element -> Maybe Object -parseRoot defaultPath e = do - path <- case X.attributeText "name" e of - Nothing -> Just defaultPath - Just x -> T.parseObjectPath (Data.Text.unpack x) - parseObject path e +parseXML path xml = + runConduit $ X.parseLBS X.def (BL8.pack xml) .| X.force "parse error" (parseObject $ getRootName path) -parseChild :: T.ObjectPath -> X.Element -> Maybe Object -parseChild parentPath e = do +getRootName :: T.ObjectPath -> X.AttrParser T.ObjectPath +getRootName defaultPath = do + nodeName <- X.attr "name" + pure $ maybe defaultPath (T.objectPath_ . Text.unpack) nodeName + +getChildName :: T.ObjectPath -> X.AttrParser T.ObjectPath +getChildName parentPath = do + nodeName <- X.requireAttr "name" let parentPath' = case T.formatObjectPath parentPath of "/" -> "/" x -> x ++ "/" - pathSegment <- X.attributeText "name" e - path <- T.parseObjectPath (parentPath' ++ Data.Text.unpack pathSegment) - parseObject path e - -parseObject :: T.ObjectPath -> X.Element -> Maybe Object -parseObject path e | X.elementName e == "node" = do - interfaces <- children parseInterface (X.isNamed "interface") e - children' <- children (parseChild path) (X.isNamed "node") e - return (Object path interfaces children') -parseObject _ _ = Nothing - -parseInterface :: X.Element -> Maybe Interface -parseInterface e = do - name <- T.parseInterfaceName =<< attributeString "name" e - methods <- children parseMethod (X.isNamed "method") e - signals <- children parseSignal (X.isNamed "signal") e - properties <- children parseProperty (X.isNamed "property") e - return (Interface name methods signals properties) - -parseMethod :: X.Element -> Maybe Method -parseMethod e = do - name <- T.parseMemberName =<< attributeString "name" e - args <- children parseMethodArg (isArg ["in", "out", ""]) e - return (Method name args) - -parseSignal :: X.Element -> Maybe Signal -parseSignal e = do - name <- T.parseMemberName =<< attributeString "name" e - args <- children parseSignalArg (isArg ["out", ""]) e - return (Signal name args) - -parseType :: X.Element -> Maybe T.Type -parseType e = do - typeStr <- attributeString "type" e - sig <- T.parseSignature typeStr - case T.signatureTypes sig of - [t] -> Just t - _ -> Nothing - -parseMethodArg :: X.Element -> Maybe MethodArg -parseMethodArg e = do - t <- parseType e - let dir = case getattr "direction" e of - "out" -> Out - _ -> In - Just (MethodArg (getattr "name" e) t dir) - -parseSignalArg :: X.Element -> Maybe SignalArg -parseSignalArg e = do - t <- parseType e - Just (SignalArg (getattr "name" e) t) - -isArg :: [String] -> X.Element -> [X.Element] -isArg dirs = X.isNamed "arg" >=> checkDir where - checkDir e = [e | getattr "direction" e `elem` dirs] - -parseProperty :: X.Element -> Maybe Property -parseProperty e = do - t <- parseType e - (canRead, canWrite) <- case getattr "access" e of - "" -> Just (False, False) - "read" -> Just (True, False) - "write" -> Just (False, True) - "readwrite" -> Just (True, True) - _ -> Nothing - Just (Property (getattr "name" e) t canRead canWrite) - -getattr :: X.Name -> X.Element -> String -getattr name e = maybe "" Data.Text.unpack (X.attributeText name e) + pure $ T.objectPath_ (parentPath' ++ Text.unpack nodeName) -children :: Monad m => (X.Element -> m b) -> (X.Element -> [X.Element]) -> X.Element -> m [b] -children f p = mapM f . concatMap p . X.elementChildren +parseObject + :: X.AttrParser T.ObjectPath + -> ConduitT Event o Maybe (Maybe Object) +parseObject getPath = X.tag' "node" getPath parseContent + where + parseContent objPath = do + elems <- X.many $ X.choose + [ fmap SubNode <$> parseObject (getChildName objPath) + , fmap InterfaceDefinition <$> parseInterface + ] + let base = Object objPath [] [] + addElem e (Object p is cs) = case e of + InterfaceDefinition i -> Object p (i:is) cs + SubNode c -> Object p is (c:cs) + pure $ foldr addElem base elems + +parseInterface + :: ConduitT Event o Maybe (Maybe Interface) +parseInterface = X.tag' "interface" getName parseContent + where + getName = do + ifName <- X.requireAttr "name" + pure $ T.interfaceName_ (Text.unpack ifName) + parseContent ifName = do + elems <- X.many $ X.choose + [ parseMethod + , parseSignal + , parseProperty + ] + let base = Interface ifName [] [] [] + addElem e (Interface n ms ss ps) = case e of + MethodDefinition m -> Interface n (m:ms) ss ps + SignalDefinition s -> Interface n ms (s:ss) ps + PropertyDefinition p -> Interface n ms ss (p:ps) + pure $ foldr addElem base elems + +parseMethod :: ConduitT Event o Maybe (Maybe InterfaceChildren) +parseMethod = X.tag' "method" getName parseArgs + where + getName = do + ifName <- X.requireAttr "name" + T.parseMemberName (Text.unpack ifName) + parseArgs name = do + args <- X.many $ + X.tag' "arg" getArg pure + pure $ MethodDefinition $ Method name args + getArg = do + name <- fromMaybe "" <$> X.attr "name" + typeStr <- X.requireAttr "type" + dirStr <- fromMaybe "in" <$> X.attr "direction" + X.ignoreAttrs + typ <- parseType typeStr + let dir = if dirStr == "in" then In else Out + pure $ MethodArg (Text.unpack name) typ dir + +parseSignal :: ConduitT Event o Maybe (Maybe InterfaceChildren) +parseSignal = X.tag' "signal" getName parseArgs + where + getName = do + ifName <- X.requireAttr "name" + T.parseMemberName (Text.unpack ifName) + parseArgs name = do + args <- X.many $ + X.tag' "arg" getArg pure + pure $ SignalDefinition $ Signal name args + getArg = do + name <- fromMaybe "" <$> X.attr "name" + typeStr <- X.requireAttr "type" + X.ignoreAttrs + typ <- parseType typeStr + pure $ SignalArg (Text.unpack name) typ + +parseProperty :: ConduitT Event o Maybe (Maybe InterfaceChildren) +parseProperty = X.tag' "property" getProp $ \p -> do + X.many_ X.ignoreAnyTreeContent + pure p + where + getProp = do + name <- Text.unpack <$> X.requireAttr "name" + typeStr <- X.requireAttr "type" + accessStr <- fromMaybe "" <$> X.attr "access" + X.ignoreAttrs + typ <- parseType typeStr + (canRead, canWrite) <- case accessStr of + "" -> pure (False, False) + "read" -> pure (True, False) + "write" -> pure (False, True) + "readwrite" -> pure (True, True) + _ -> throwM $ userError "invalid access value" + + pure $ PropertyDefinition $ Property name typ canRead canWrite + +parseType :: MonadThrow m => Text.Text -> m T.Type +parseType typeStr = do + typ <- T.parseSignature (Text.unpack typeStr) + case T.signatureTypes typ of + [t] -> pure t + _ -> throwM $ userError "invalid type sig" newtype XmlWriter a = XmlWriter { runXmlWriter :: Maybe (a, String) } @@ -317,8 +322,8 @@ , ("access", readS ++ writeS) ] -attributeString :: X.Name -> X.Element -> Maybe String -attributeString name e = fmap Data.Text.unpack (X.attributeText name e) +--attributeString :: X.Name -> X.Element -> Maybe String +--attributeString name e = fmap Data.Text.unpack (X.attributeText name e) writeElement :: String -> [(String, String)] -> XmlWriter () -> XmlWriter () writeElement name attrs content = do diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/dbus-1.0.1/lib/DBus/TH.hs new/dbus-1.1.1/lib/DBus/TH.hs --- old/dbus-1.0.1/lib/DBus/TH.hs 2018-03-29 00:22:00.000000000 +0200 +++ new/dbus-1.1.1/lib/DBus/TH.hs 2018-05-05 06:09:43.000000000 +0200 @@ -6,7 +6,6 @@ import DBus.Generation import System.FilePath - generateSignalsFromInterface defaultGenerationParams $ buildIntrospectionInterface $ buildPropertiesInterface undefined diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/dbus-1.0.1/tests/DBusTests/Generation.hs new/dbus-1.1.1/tests/DBusTests/Generation.hs --- old/dbus-1.0.1/tests/DBusTests/Generation.hs 2018-03-29 00:22:00.000000000 +0200 +++ new/dbus-1.1.1/tests/DBusTests/Generation.hs 2018-05-05 06:09:43.000000000 +0200 @@ -26,6 +26,11 @@ testInterface = defaultInterface { interfaceMethods = [autoMethod "SampleMethod1" sampleMethod1] + , interfaceProperties = + [autoProperty "SampleWriteProperty" + (Just $ return (1 :: Int32)) + (Just $ const $ return ()) + ] , interfaceName = "org.TestInterface" , interfaceSignals = testSignals } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/dbus-1.0.1/tests/DBusTests/Introspection.hs new/dbus-1.1.1/tests/DBusTests/Introspection.hs --- old/dbus-1.0.1/tests/DBusTests/Introspection.hs 2018-03-29 02:52:31.000000000 +0200 +++ new/dbus-1.1.1/tests/DBusTests/Introspection.hs 2018-11-23 06:15:58.000000000 +0100 @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} -- Copyright (C) 2010-2012 John Millikin <[email protected]> -- -- Licensed under the Apache License, Version 2.0 (the "License");
