module DBus.Introspection
( Object (..)
, Interface (..)
, Method (..)
, Signal (..)
, Parameter (..)
, Property (..)
, PropertyAccess (..)
, toXML
, fromXML
) where
import Control.Monad ((>=>))
import Control.Monad.ST (runST)
import Data.Maybe (fromMaybe)
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 qualified DBus.Types as T
data Object = Object T.ObjectPath [Interface] [Object]
deriving (Show, Eq)
data Interface = Interface T.InterfaceName [Method] [Signal] [Property]
deriving (Show, Eq)
data Method = Method T.MemberName [Parameter] [Parameter]
deriving (Show, Eq)
data Signal = Signal T.MemberName [Parameter]
deriving (Show, Eq)
data Parameter = Parameter Text T.Signature
deriving (Show, Eq)
data Property = Property Text T.Signature [PropertyAccess]
deriving (Show, Eq)
data PropertyAccess = Read | Write
deriving (Show, Eq)
fromXML :: T.ObjectPath -> Text -> Maybe Object
fromXML path text = do
root <- parseElement text
parseRoot path root
parseElement :: Text -> Maybe X.Element
parseElement text = 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 text)
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.objectPath x
parseObject path e
parseChild :: T.ObjectPath -> X.Element -> Maybe Object
parseChild parentPath e = do
let parentPath' = case T.objectPathText parentPath of
"/" -> "/"
x -> Data.Text.append x "/"
pathSegment <- X.attributeText "name" e
path <- T.objectPath $ Data.Text.append parentPath' 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.interfaceName =<< X.attributeText "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.memberName =<< X.attributeText "name" e
paramsIn <- children parseParameter (isParam ["in", ""]) e
paramsOut <- children parseParameter (isParam ["out"]) e
return $ Method name paramsIn paramsOut
parseSignal :: X.Element -> Maybe Signal
parseSignal e = do
name <- T.memberName =<< X.attributeText "name" e
params <- children parseParameter (isParam ["out", ""]) e
return $ Signal name params
parseType :: X.Element -> Maybe T.Signature
parseType e = X.attributeText "type" e >>= T.signature
parseParameter :: X.Element -> Maybe Parameter
parseParameter e = do
let name = getattr "name" e
sig <- parseType e
case T.signatureTypes sig of
[_] -> Just (Parameter name sig)
_ -> Nothing
parseProperty :: X.Element -> Maybe Property
parseProperty e = do
let name = getattr "name" e
sig <- parseType e
access <- case getattr "access" e of
"" -> Just []
"read" -> Just [Read]
"write" -> Just [Write]
"readwrite" -> Just [Read, Write]
_ -> Nothing
return $ Property name sig access
getattr :: X.Name -> X.Element -> Text
getattr = (fromMaybe "" .) . X.attributeText
isParam :: [Text] -> X.Element -> [X.Element]
isParam dirs = X.isNamed "arg" >=> checkDir where
checkDir e = [e | getattr "direction" e `elem` dirs]
children :: Monad m => (X.Element -> m b) -> (X.Element -> [X.Element]) -> X.Element -> m [b]
children f p = mapM f . concatMap p . X.elementChildren
newtype XmlWriter a = XmlWriter { runXmlWriter :: Maybe (a, Text) }
instance Monad XmlWriter where
return a = XmlWriter $ Just (a, Data.Text.empty)
m >>= f = XmlWriter $ do
(a, w) <- runXmlWriter m
(b, w') <- runXmlWriter (f a)
return (b, Data.Text.append w w')
tell :: Text -> XmlWriter ()
tell t = XmlWriter $ Just ((), t)
toXML :: Object -> Maybe Text
toXML obj = do
(_, text) <- runXmlWriter (writeRoot obj)
return text
writeRoot :: Object -> XmlWriter ()
writeRoot obj@(Object path _ _) = do
tell "<!DOCTYPE node PUBLIC '-//freedesktop//DTD D-BUS Object Introspection 1.0//EN'"
tell " 'http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd'>\n"
writeObject (T.objectPathText path) obj
writeChild :: T.ObjectPath -> Object -> XmlWriter ()
writeChild parentPath obj@(Object path _ _) = write where
path' = T.objectPathText path
parent' = T.objectPathText parentPath
relpathM = if Data.Text.isPrefixOf parent' path'
then Just $ if parent' == "/"
then Data.Text.drop 1 path'
else Data.Text.drop (Data.Text.length parent' + 1) path'
else Nothing
write = case relpathM of
Just relpath -> writeObject relpath obj
Nothing -> XmlWriter Nothing
writeObject :: Text -> Object -> XmlWriter ()
writeObject path (Object fullPath interfaces children') = writeElement "node"
[("name", path)] $ do
mapM_ writeInterface interfaces
mapM_ (writeChild fullPath) children'
writeInterface :: Interface -> XmlWriter ()
writeInterface (Interface name methods signals properties) = writeElement "interface"
[("name", T.interfaceNameText name)] $ do
mapM_ writeMethod methods
mapM_ writeSignal signals
mapM_ writeProperty properties
writeMethod :: Method -> XmlWriter ()
writeMethod (Method name inParams outParams) = writeElement "method"
[("name", T.memberNameText name)] $ do
mapM_ (writeParameter "in") inParams
mapM_ (writeParameter "out") outParams
writeSignal :: Signal -> XmlWriter ()
writeSignal (Signal name params) = writeElement "signal"
[("name", T.memberNameText name)] $ do
mapM_ (writeParameter "out") params
writeParameter :: Text -> Parameter -> XmlWriter ()
writeParameter direction (Parameter name sig) = writeEmptyElement "arg"
[ ("name", name)
, ("type", T.signatureText sig)
, ("direction", direction)
]
writeProperty :: Property -> XmlWriter ()
writeProperty (Property name sig access) = writeEmptyElement "property"
[ ("name", name)
, ("type", T.signatureText sig)
, ("access", strAccess access)
]
strAccess :: [PropertyAccess] -> Text
strAccess access = Data.Text.append readS writeS where
readS = if elem Read access then "read" else ""
writeS = if elem Write access then "write" else ""
writeElement :: Text -> [(Text, Text)] -> XmlWriter () -> XmlWriter ()
writeElement name attrs content = do
tell "<"
tell name
mapM_ writeAttribute attrs
tell ">"
content
tell "</"
tell name
tell ">"
writeEmptyElement :: Text -> [(Text, Text)] -> XmlWriter ()
writeEmptyElement name attrs = do
tell "<"
tell name
mapM_ writeAttribute attrs
tell "/>"
writeAttribute :: (Text, Text) -> XmlWriter ()
writeAttribute (name, content) = do
tell " "
tell name
tell "='"
tell (escape content)
tell "'"
escape :: Text -> Text
escape = Data.Text.concatMap escapeChar where
escapeChar c = case c of
'&' -> "&"
'<' -> "<"
'>' -> ">"
'"' -> """
'\'' -> "'"
_ -> Data.Text.singleton c