udbus-model (empty) → 0.2.0
raw patch · 7 files changed
+382/−0 lines, 7 filesdep +HaXmldep +basedep +bytestringsetup-changed
Dependencies added: HaXml, base, bytestring, groom, udbus, udbus-model
Files
- LICENSE +27/−0
- Network/DBus/Model.hs +16/−0
- Network/DBus/Model/Parse.hs +144/−0
- Network/DBus/Model/Types.hs +130/−0
- Setup.hs +2/−0
- Test/Test.hs +18/−0
- udbus-model.cabal +45/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2010-2013 Vincent Hanquez <vincent@snarc.org>++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.
+ Network/DBus/Model.hs view
@@ -0,0 +1,16 @@+-- |+-- Module : Network.DBus.Model+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Network/DBus/Model/Parse.hs view
@@ -0,0 +1,144 @@+-- |+-- Module : Network.DBus.Model.Parse+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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+
+ Network/DBus/Model/Types.hs view
@@ -0,0 +1,130 @@+-- |+-- Module : Network.DBus.Model.Types+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Test/Test.hs view
@@ -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
+ udbus-model.cabal view
@@ -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 <vincent@snarc.org>+Author: Vincent Hanquez <vincent@snarc.org>+Maintainer: Vincent Hanquez <vincent@snarc.org>+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