module DBus.Introspection
( Object (..)
, Interface (..)
, Method (..)
, Signal (..)
, Parameter (..)
, Property (..)
, PropertyAccess (..)
, toXML
, fromXML
) where
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as TL
import qualified Data.XML.Types as X
import qualified Text.XML.LibXML.SAX as SAX
import Control.Monad.ST (runST)
import qualified Data.STRef as ST
import Control.Monad ((>=>))
import Data.Maybe (fromMaybe, listToMaybe)
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 _ = ST.writeSTRef stackRef []
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 onError Nothing
SAX.setCallback p SAX.parsedBeginElement onBegin
SAX.setCallback p SAX.parsedEndElement onEnd
SAX.parseLazyText p 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 getattrM "name" e of
Nothing -> Just defaultPath
Just x -> T.mkObjectPath x
parseObject path e
parseChild :: T.ObjectPath -> X.Element -> Maybe Object
parseChild parentPath e = do
let parentPath' = case T.strObjectPath parentPath of
"/" -> "/"
x -> TL.append x "/"
pathSegment <- getattrM "name" e
path <- T.mkObjectPath $ TL.append parentPath' pathSegment
parseObject path e
parseObject :: T.ObjectPath -> X.Element -> Maybe Object
parseObject path e | X.elementName e == toName "node" = do
interfaces <- children parseInterface (named "interface") e
children' <- children (parseChild path) (named "node") e
return $ Object path interfaces children'
parseObject _ _ = Nothing
parseInterface :: X.Element -> Maybe Interface
parseInterface e = do
name <- T.mkInterfaceName =<< getattrM "name" e
methods <- children parseMethod (named "method") e
signals <- children parseSignal (named "signal") e
properties <- children parseProperty (named "property") e
return $ Interface name methods signals properties
parseMethod :: X.Element -> Maybe Method
parseMethod e = do
name <- T.mkMemberName =<< getattrM "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.mkMemberName =<< getattrM "name" e
params <- children parseParameter (isParam ["out", ""]) e
return $ Signal name params
parseParameter :: X.Element -> Maybe Parameter
parseParameter e = do
let name = getattr "name" e
sig <- parseType e
return $ Parameter name sig
parseType :: X.Element -> Maybe T.Signature
parseType e = do
sig <- T.mkSignature =<< getattrM "type" e
case T.signatureTypes sig of
[_] -> Just 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
getattrM :: Text -> X.Element -> Maybe Text
getattrM name = fmap attrText . listToMaybe . attrs where
attrText = textContent . X.attributeContent
attrs = X.elementAttributes >=> X.isNamed (toName name)
textContent cs = TL.concat [t | X.ContentText t <- cs]
getattr :: Text -> X.Element -> Text
getattr = (fromMaybe "" .) . getattrM
isParam :: [Text] -> X.Element -> [X.Element]
isParam dirs = named "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
named :: X.Named a => Text -> a -> [a]
named = X.isNamed . toName
toName :: Text -> X.Name
toName t = X.Name t Nothing Nothing
newtype XmlWriter a = XmlWriter { runXmlWriter :: Maybe (a, Text) }
instance Monad XmlWriter where
return a = XmlWriter $ Just (a, TL.empty)
m >>= f = XmlWriter $ do
(a, w) <- runXmlWriter m
(b, w') <- runXmlWriter (f a)
return (b, TL.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.strObjectPath path) obj
writeChild :: T.ObjectPath -> Object -> XmlWriter ()
writeChild parentPath obj@(Object path _ _) = write where
path' = T.strObjectPath path
parent' = T.strObjectPath parentPath
relpathM = if TL.isPrefixOf parent' path'
then Just $ if parent' == "/"
then TL.drop 1 path'
else TL.drop (TL.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.strInterfaceName name)] $ do
mapM_ writeMethod methods
mapM_ writeSignal signals
mapM_ writeProperty properties
writeMethod :: Method -> XmlWriter ()
writeMethod (Method name inParams outParams) = writeElement "method"
[("name", T.strMemberName name)] $ do
mapM_ (writeParameter "in") inParams
mapM_ (writeParameter "out") outParams
writeSignal :: Signal -> XmlWriter ()
writeSignal (Signal name params) = writeElement "signal"
[("name", T.strMemberName name)] $ do
mapM_ (writeParameter "out") params
writeParameter :: Text -> Parameter -> XmlWriter ()
writeParameter direction (Parameter name sig) = writeEmptyElement "arg"
[ ("name", name)
, ("type", T.strSignature sig)
, ("direction", direction)
]
writeProperty :: Property -> XmlWriter ()
writeProperty (Property name sig access) = writeEmptyElement "property"
[ ("name", name)
, ("type", T.strSignature sig)
, ("access", strAccess access)
]
strAccess :: [PropertyAccess] -> Text
strAccess access = TL.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 = TL.concatMap escapeChar where
escapeChar c = case c of
'&' -> "&"
'<' -> "<"
'>' -> ">"
'"' -> """
'\'' -> "'"
_ -> TL.singleton c