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 Text.XML.HaXml as H
import Text.XML.HaXml.Parse (xmlParse')
import DBus.Util (eitherToMaybe)
import Data.Char (chr)
import Data.Maybe (fromMaybe)
import Text.XML.HaXml.Pretty (document)
import Text.PrettyPrint.HughesPJ (render)
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
doc <- eitherToMaybe . xmlParse' "" . TL.unpack $ text
let (H.Document _ _ root _) = doc
parseRoot path root
parseRoot :: T.ObjectPath -> H.Element a -> Maybe Object
parseRoot defaultPath e = do
path <- case getAttr "name" e of
Nothing -> Just defaultPath
Just x -> T.mkObjectPath x
parseObject' path e
parseChild :: T.ObjectPath -> H.Element a -> Maybe Object
parseChild parentPath e = do
let parentPath' = case T.strObjectPath parentPath of
"/" -> "/"
x -> TL.append x "/"
pathSegment <- getAttr "name" e
path <- T.mkObjectPath $ TL.append parentPath' pathSegment
parseObject' path e
parseObject' :: T.ObjectPath -> H.Element a -> Maybe Object
parseObject' path e@(H.Elem "node" _ _) = do
interfaces <- children parseInterface (H.tag "interface") e
children' <- children (parseChild path) (H.tag "node") e
return $ Object path interfaces children'
parseObject' _ _ = Nothing
parseInterface :: H.Element a -> Maybe Interface
parseInterface e = do
name <- T.mkInterfaceName =<< getAttr "name" e
methods <- children parseMethod (H.tag "method") e
signals <- children parseSignal (H.tag "signal") e
properties <- children parseProperty (H.tag "property") e
return $ Interface name methods signals properties
parseMethod :: H.Element a -> Maybe Method
parseMethod e = do
name <- T.mkMemberName =<< getAttr "name" e
paramsIn <- children parseParameter (isParam ["in", ""]) e
paramsOut <- children parseParameter (isParam ["out"]) e
return $ Method name paramsIn paramsOut
parseSignal :: H.Element a -> Maybe Signal
parseSignal e = do
name <- T.mkMemberName =<< getAttr "name" e
params <- children parseParameter (isParam ["out", ""]) e
return $ Signal name params
parseParameter :: H.Element a -> Maybe Parameter
parseParameter e = do
let name = getAttr' "name" e
sig <- parseType e
return $ Parameter name sig
parseType :: H.Element a -> Maybe T.Signature
parseType e = do
sig <- T.mkSignature =<< getAttr "type" e
case T.signatureTypes sig of
[_] -> Just sig
_ -> Nothing
parseProperty :: H.Element a -> 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
attrValue :: H.AttValue -> Maybe Text
attrValue attr = fmap (TL.pack . concat) $ mapM unescape parts where
(H.AttValue parts) = attr
unescape (Left x) = Just x
unescape (Right (H.RefEntity x)) = lookup x namedRefs
unescape (Right (H.RefChar x)) = Just [chr x]
namedRefs =
[ ("lt", "<")
, ("gt", ">")
, ("amp", "&")
, ("apos", "'")
, ("quot", "\"")
]
getAttr :: String -> H.Element a -> Maybe Text
getAttr name (H.Elem _ attrs _) = lookup name attrs >>= attrValue
getAttr' :: String -> H.Element a -> Text
getAttr' = (fromMaybe "" .) . getAttr
isParam :: [Text] -> H.CFilter a
isParam dirs content = do
arg@(H.CElem e _) <- H.tag "arg" content
let direction = getAttr' "direction" e
[arg | direction `elem` dirs]
children :: Monad m => (H.Element a -> m b) -> H.CFilter a -> H.Element a -> m [b]
children f filt (H.Elem _ _ contents) =
mapM f [x | (H.CElem x _) <- concatMap filt contents]
dtdPublicID, dtdSystemID :: String
dtdPublicID = "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"
dtdSystemID = "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd"
toXML :: Object -> Maybe Text
toXML obj = fmap (TL.pack . render . document) doc where
prolog = H.Prolog Nothing [] (Just doctype) []
doctype = H.DTD "node" (Just (H.PUBLIC
(H.PubidLiteral dtdPublicID)
(H.SystemLiteral dtdSystemID))) []
doc = do
root <- xmlRoot obj
return $ H.Document prolog H.emptyST root []
xmlRoot :: Object -> Maybe (H.Element a)
xmlRoot obj@(Object path _ _) = do
(H.CElem root _) <- xmlObject' (T.strObjectPath path) obj
return root
xmlObject :: T.ObjectPath -> Object -> Maybe (H.Content a)
xmlObject parentPath obj@(Object path _ _) = do
let path' = T.strObjectPath path
parent' = T.strObjectPath parentPath
relpath <- if TL.isPrefixOf parent' path'
then Just $ if parent' == "/"
then TL.drop 1 path'
else TL.drop (TL.length parent' + 1) path'
else Nothing
xmlObject' relpath obj
xmlObject' :: Text -> Object -> Maybe (H.Content a)
xmlObject' path (Object fullPath interfaces children') = do
children'' <- mapM (xmlObject fullPath) children'
return $ mkElement "node"
[mkAttr "name" $ TL.unpack path]
$ concat
[ map xmlInterface interfaces
, children''
]
xmlInterface :: Interface -> H.Content a
xmlInterface (Interface name methods signals properties) =
mkElement "interface"
[mkAttr "name" . TL.unpack . T.strInterfaceName $ name]
$ concat
[ map xmlMethod methods
, map xmlSignal signals
, map xmlProperty properties
]
xmlMethod :: Method -> H.Content a
xmlMethod (Method name inParams outParams) = mkElement "method"
[mkAttr "name" . TL.unpack . T.strMemberName $ name]
$ concat
[ map (xmlParameter "in") inParams
, map (xmlParameter "out") outParams
]
xmlSignal :: Signal -> H.Content a
xmlSignal (Signal name params) = mkElement "signal"
[mkAttr "name" . TL.unpack . T.strMemberName $ name]
$ map (xmlParameter "out") params
xmlParameter :: String -> Parameter -> H.Content a
xmlParameter direction (Parameter name sig) = mkElement "arg"
[ mkAttr "name" . TL.unpack $ name
, mkAttr "type" . TL.unpack . T.strSignature $ sig
, mkAttr "direction" direction
] []
xmlProperty :: Property -> H.Content a
xmlProperty (Property name sig access) = mkElement "property"
[ mkAttr "name" . TL.unpack $ name
, mkAttr "type" . TL.unpack . T.strSignature $ sig
, mkAttr "access" $ xmlAccess access
] []
xmlAccess :: [PropertyAccess] -> String
xmlAccess access = readS ++ writeS where
readS = if elem Read access then "read" else ""
writeS = if elem Write access then "write" else ""
mkElement :: String -> [H.Attribute] -> [H.Content a] -> H.Content a
mkElement name attrs contents = H.CElem (H.Elem name attrs contents) undefined
mkAttr :: String -> String -> H.Attribute
mkAttr name value = (name, H.AttValue [Left escaped]) where
raw = H.CString True value ()
escaped = H.verbatim $ H.xmlEscapeContent H.stdXmlEscaper [raw]