diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2010-2013 Vincent Hanquez + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Network/DBus/Model.hs b/Network/DBus/Model.hs new file mode 100644 --- /dev/null +++ b/Network/DBus/Model.hs @@ -0,0 +1,16 @@ +-- | +-- Module : Network.DBus.Model +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Model parsing for introspections and definition +-- of DBus interfaces. +module Network.DBus.Model + ( module Network.DBus.Model.Types + , fromXML + ) where + +import Network.DBus.Model.Types +import Network.DBus.Model.Parse diff --git a/Network/DBus/Model/Parse.hs b/Network/DBus/Model/Parse.hs new file mode 100644 --- /dev/null +++ b/Network/DBus/Model/Parse.hs @@ -0,0 +1,144 @@ +-- | +-- Module : Network.DBus.Model.Parse +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Network.DBus.Model.Parse + ( fromXML + ) where + +import Control.Applicative + +import qualified Text.XML.HaXml as X +--import Text.XML.HaXml (o) +--import qualified Network.DBus as DBus +import qualified Network.DBus.Actions as DBus (unserializeSignature) +import Network.DBus.Model.Types + +import qualified Data.ByteString.Char8 as BC +import Data.List (partition) +import Data.Maybe (catMaybes) + +fromXML :: String -> Maybe Model +fromXML s = Model <$> mapM parseInterface (childElems "interface" root) + where X.Document _ _ root _ = X.xmlParse "" s + +parseInterface :: X.Element i -> Maybe Interface +parseInterface e = + Interface <$> parseName e + <*> mapM parseMethod (childElems "method" e) + <*> mapM parseSignal (childElems "signal" e) + <*> mapM parseProperty (childElems "property" e) + <*> mapM parseEnumeration (childElems "tp:enum" e) + <*> mapM parseFlags (childElems "tp:flags" e) + <*> mapM parseStruct (childElems "tp:struct" e) + +parseStruct e = + Struct <$> parseName e + <*> mapM parseMember (childElems "tp:member" e) + +parseMember e = + Member <$> parseName e + <*> parseType e + <*> pure (parseRawType e) + <*> parseDoc e + +parseEnumeration e = + Enumeration <$> parseName e + <*> parseType e + <*> mapM parseEnumValue (childElems "tp:enumvalue" e) + +parseEnumValue e = + EnumValue <$> attr "suffix" e + <*> attr "value" e + +parseFlags e = + Flags <$> parseName e + <*> attr "value-prefix" e + <*> parseType e + <*> mapM parseFlag (childElems "flag" e) + <*> parseDoc e + +parseFlag e = + Flag <$> attr "suffix" e + <*> attr "value" e + <*> parseDoc e + +parseProperty e = + Property <$> parseName e + <*> parseType e + <*> parseAccess e + <*> pure (parseRawType e) + +parseMethod e = + Method <$> parseName e + <*> mapM parseAnnotation (childElems "annotation" e) + <*> mapM parseArg inElems + <*> mapM parseArg outElems + <*> parseDoc e + where argElems = childElems "arg" e + (inElems,outElems) = partition inOrOut argElems + inOrOut a = case attr "direction" a of + Nothing -> True + Just "in" -> True + Just "out" -> False + Just z -> error ("unexpected direction string: " ++ z) + +parseSignal e = + Signal <$> parseName e + <*> mapM parseArg (childElems "arg" e) + <*> parseDoc e + +parseAnnotation e = + Annotation <$> parseName e + <*> attr "value" e + +parseArg e = + Arg <$> parseName e + <*> parseType e + <*> parseDoc e + +parseType e = attr "type" e >>= parseSignature + where parseSignature s = do + typsig <- either (const Nothing) Just $ DBus.unserializeSignature (BC.pack s) + case typsig of + [t] -> Just t + _ -> Nothing + +parseAccess e = attr "access" e >>= parse + where parse "read" = Just Read + parse "write" = Just Write + parse "readwrite" = Just ReadWrite + parse _ = Nothing + +parseRawType e = attrFQ (Just $ X.Namespace "tp" "") "type" e + +parseName e = attr "name" e + +parseDoc :: X.Element i -> Maybe (Maybe Doc) +parseDoc e = pure $ case childElems "tp:docstring" e of + [(X.Elem _ _ [X.CString _ cd _])] -> Just cd + _ -> Nothing + +------------------------------------------------------ +-- XML helpers + +childElemsWith :: X.CFilter i -> X.Element i -> [X.Element i] +childElemsWith elemFilter (X.Elem _ _ contents) = + catMaybes . map select . concatMap elemFilter $ contents + where + select (X.CElem e _) = Just e + select _ = Nothing + +childElems :: String -> X.Element i -> [X.Element i] +childElems name = childElemsWith (X.tag name) + +attrFQ :: Maybe X.Namespace -> String -> X.Element i -> Maybe String +attrFQ ns name (X.Elem _ attrs _) = show <$> lookup el attrs + where el = maybe (X.N name) (\n -> X.QN n name) ns + +attr :: String -> X.Element i -> Maybe String +attr = attrFQ Nothing + diff --git a/Network/DBus/Model/Types.hs b/Network/DBus/Model/Types.hs new file mode 100644 --- /dev/null +++ b/Network/DBus/Model/Types.hs @@ -0,0 +1,130 @@ +-- | +-- Module : Network.DBus.Model.Types +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Basic 1-to-1 mapping of XML types defined for +-- XML introspection and definition of DBus interfaces. +-- +module Network.DBus.Model.Types + ( Model(..) + , Interface(..) + , Enumeration(..) + , EnumValue(..) + , Flags(..) + , Flag(..) + , Struct(..) + , Member(..) + , Method(..) + , Annotation(..) + , Signal(..) + , Property(..) + , Arg(..) + , Access(..) + , Doc + ) where + +import qualified Network.DBus as DBus + +-- | The whole XML model +data Model = Model + { interfaces :: [Interface] + } deriving (Show,Eq) + +-- | An DBus XML interface containing methods, signals and properties +data Interface = Interface + { interfaceName :: String + , interfaceMethods :: [Method] + , interfaceSignals :: [Signal] + , interfaceProperties :: [Property] + , interfaceEnums :: [Enumeration] + , interfaceFlagss :: [Flags] -- ^ List of list of flag + , interfaceStructs :: [Struct] + } deriving (Show,Eq) + +-- | DBus Enumeration (Telepathy extension) +data Enumeration = Enumeration + { enumName :: String + , enumType :: DBus.Type + , enumValues :: [EnumValue] + } deriving (Show,Eq) + +-- | DBus Enumeration value +data EnumValue = EnumValue + { enumSuffix :: String + , enumValue :: String + } deriving (Show,Eq) + +-- | DBus Flags (Telepathy extension) +data Flags = Flags + { flagsName :: String + , flagsValuePrefix :: String + , flagsType :: DBus.Type + , flagsFlags :: [Flag] + , flagsDoc :: Maybe Doc + } deriving (Show,Eq) + +data Flag = Flag + { flagSuffix :: String + , flagValue :: String + , flagDoc :: Maybe Doc + } deriving (Show,Eq) + +-- | DBus Struct (Telepathy extension) +data Struct = Struct + { structName :: String + , structMembers :: [Member] + } deriving (Show,Eq) + +-- | DBus Struct Member +data Member = Member + { memberName :: String + , memberType :: DBus.Type + , memberRawType :: Maybe String + , memberDoc :: Maybe Doc + } deriving (Show,Eq) + +-- | Represent a DBus Method +data Method = Method + { methodName :: String + , methodAnnotations :: [Annotation] + , methodParamsIn :: [Arg] + , methodParamsOut :: [Arg] + , methodDoc :: Maybe Doc + } deriving (Show,Eq) + +-- | Represent a DBus Method's Annotation +data Annotation = Annotation + { annotationName :: String + , annotationValue :: String + } deriving (Show,Eq) + +-- | Represent a DBus Signal +data Signal = Signal + { signalName :: String + , signalParams :: [Arg] + , signalDoc :: Maybe Doc + } deriving (Show,Eq) + +-- | Represent a DBus Property +data Property = Property + { propertyName :: String + , propertyType :: DBus.Type + , propertyAccess :: Access + , propertyRawType :: Maybe String + } deriving (Show,Eq) + +-- | Represent a DBus Arg (Parameter) +data Arg = Arg + { argName :: String + , argType :: DBus.Type + , argDoc :: Maybe Doc + } deriving (Show,Eq) + +-- | Property access type +data Access = Read | Write | ReadWrite + deriving (Show,Eq) + +type Doc = String diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Test/Test.hs b/Test/Test.hs new file mode 100644 --- /dev/null +++ b/Test/Test.hs @@ -0,0 +1,18 @@ +module Main where + +import Control.Applicative + +import qualified Network.DBus as DBus +import qualified Network.DBus.Actions as DBus + +import qualified Network.DBus.Model as Model + +import Text.Groom +import System.Environment + +main = do + args <- getArgs + model <- Model.fromXML <$> readFile (args !! 0) + case model of + Nothing -> putStrLn "parse failed" + Just m -> putStrLn $ groom m diff --git a/udbus-model.cabal b/udbus-model.cabal new file mode 100644 --- /dev/null +++ b/udbus-model.cabal @@ -0,0 +1,45 @@ +Name: udbus-model +Version: 0.2.0 +Description: Model API for udbus introspection and definitions +License: BSD3 +License-file: LICENSE +Copyright: Vincent Hanquez +Author: Vincent Hanquez +Maintainer: Vincent Hanquez +Synopsis: Model API for udbus introspection and definitions +Build-Type: Simple +Category: Network +stability: experimental +Cabal-Version: >=1.8 +Homepage: http://github.com/vincenthz/hs-udbus + +Flag executable + Description: Build the executable + Default: False + +Library + Build-Depends: base >= 3 && < 5 + , bytestring + , HaXml + , udbus >= 0.2.0 + Exposed-modules: Network.DBus.Model + Other-modules: Network.DBus.Model.Types + Network.DBus.Model.Parse + ghc-options: -Wall -fno-warn-missing-signatures + +Executable dbus-model-parse + hs-source-dirs: Test + Main-is: Test.hs + if flag(executable) + Buildable: True + Build-Depends: base + , groom + , udbus + , udbus-model + else + Buildable: False + + +source-repository head + type: git + location: git://github.com/vincenthz/hs-udbus