dbus-th-introspection (empty) → 0.1.0.0
raw patch · 8 files changed
+404/−0 lines, 8 filesdep +basedep +cmdargsdep +containerssetup-changed
Dependencies added: base, cmdargs, containers, dbus, dbus-th, template-haskell
Files
- DBus/TH/Introspection.hs +98/−0
- DBus/TH/Introspection/Output.hs +45/−0
- DBus/TH/Introspection/Types.hs +19/−0
- LICENSE +30/−0
- README +71/−0
- Setup.hs +2/−0
- dbus-introspect-hs.hs +89/−0
- dbus-th-introspection.cabal +50/−0
+ DBus/TH/Introspection.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}+module DBus.TH.Introspection+ (+ module DBus.TH.Introspection.Types,+ module DBus.TH.Introspection.Output,+ listNames,+ introspect,+ getServiceObjects,+ dbusType2haskell,+ method2function+ ) where++import Control.Monad+import Data.List+import Language.Haskell.TH++import DBus+import DBus.Client+import qualified DBus.Introspection as I+import DBus.TH as TH++import DBus.TH.Introspection.Types+import DBus.TH.Introspection.Output++interface "org.freedesktop.DBus" "/" "org.freedesktop.DBus" Nothing [+ "ListNames" =:: Return ''ListStr+ ]++-- | Run DBus introspection on specified object+introspect :: Client -> BusName -> ObjectPath -> IO I.Object+introspect client service path = do+ reply <- call_ client (methodCall path "org.freedesktop.DBus.Introspectable" "Introspect")+ { methodCallDestination = Just service+ }+ let Just xml = fromVariant (methodReturnBody reply !! 0)+ case I.parseXML path xml of+ Just info -> return info+ Nothing -> error ("Invalid introspection XML: " ++ show xml)++-- | Obtain list of all objects exported by given interface, starting+-- with specified path.+getServiceObjects :: Client -- ^ DBus connection+ -> BusName -- ^ Service name+ -> ObjectPath -- ^ Object path to start with. For example, \"/\".+ -> IO [I.Object]+getServiceObjects dbus service path = do+ ob <- introspect dbus service path+ children <- forM (I.objectChildren ob) $ \child ->+ getServiceObjects dbus service (I.objectPath child)+ return $ ob : concat children+++-- | Try to convert DBus type to Haskell type.+-- Only some relatively simple types are supported as for now.+dbusType2haskell :: DBus.Type -> Either String Name+dbusType2haskell TypeBoolean = return ''Bool+dbusType2haskell TypeWord8 = return ''Word8+dbusType2haskell TypeWord16 = return ''Word16+dbusType2haskell TypeWord32 = return ''Word32+dbusType2haskell TypeInt16 = return ''Int16+dbusType2haskell TypeInt32 = return ''Int32+dbusType2haskell TypeDouble = return ''Double+dbusType2haskell TypeString = return ''String+dbusType2haskell (TypeArray TypeWord8) = return ''ListWord8+dbusType2haskell (TypeArray TypeWord16) = return ''ListWord16+dbusType2haskell (TypeArray TypeWord32) = return ''ListWord32+dbusType2haskell (TypeArray TypeInt16) = return ''ListInt16+dbusType2haskell (TypeArray TypeInt32) = return ''ListInt32+dbusType2haskell (TypeArray TypeString) = return ''ListStr+dbusType2haskell (TypeDictionary TypeString TypeString) = return ''DictStrStr+dbusType2haskell t = Left $ "Unsupported type " ++ show t++-- | Try to convert DBus.Introspection method description into DBus.TH description.+method2function :: I.Method -> Either String TH.Function+method2function m = do+ signature <- toSignature (I.methodArgs m)+ return $ name =:: signature+ where+ name = formatMemberName (I.methodName m)++ toSignature :: [I.MethodArg] -> Either String TH.Signature+ toSignature args = do+ let (inArgs, outArgs) = partition (\a -> I.methodArgDirection a == I.directionIn) args+ if length outArgs > 1+ then Left $ "Method " ++ name ++ " has more than one out parameter"+ else do+ outArgName <- if null outArgs+ then return ''()+ else dbusType2haskell $ I.methodArgType $ head outArgs+ transformInArgs outArgName inArgs++ transformInArgs :: Name -> [I.MethodArg] -> Either String TH.Signature+ transformInArgs retType [] = return $ Return retType+ transformInArgs retType (a:as) = do+ argName <- dbusType2haskell (I.methodArgType a)+ rest <- transformInArgs retType as+ return $ argName :-> rest+
+ DBus/TH/Introspection/Output.hs view
@@ -0,0 +1,45 @@++module DBus.TH.Introspection.Output where++import Control.Monad+import Data.List+import Language.Haskell.TH++import DBus+import DBus.Client+import qualified DBus.Introspection as I+import DBus.TH as TH++import DBus.TH.Introspection.Types++-- | Gernerate DBus function declaration+pprintFunc :: TH.Function -> String+pprintFunc fn = "\"" ++ fnName fn ++ "\" =:: " ++ formatSignature (fnSignature fn)+ where+ formatSignature (Return name) = "Return ''" ++ nameBase name+ formatSignature (name :-> sig) = "''" ++ nameBase name ++ " :-> " ++ formatSignature sig++-- | Generate DBus interface declaration+pprintInterface :: String -- ^ Service name+ -> Maybe String -- ^ Just name for static object name; Nothing for dynamic object name+ -> String -- ^ Interface name+ -> [String] -- ^ Rendered function declarations+ -> String+pprintInterface serviceName (Just objectPath) ifaceName funcs =+ "interface \"" ++ serviceName ++ "\" \"" ++ objectPath ++ "\" \"" ++ ifaceName ++ "\" Nothing [\n" +++ (intercalate ",\n" $ map (\s -> " " ++ s) funcs) +++ "\n ]\n"+pprintInterface serviceName Nothing ifaceName funcs =+ "interface' \"" ++ serviceName ++ "\" Nothing \"" ++ ifaceName ++ "\" Nothing [\n" +++ (intercalate ",\n" $ map (\s -> " " ++ s) funcs) +++ "\n ]\n"++-- | Module header+header :: String -> String+header modName =+ "{-# LANGUAGE TemplateHaskell #-}\n" +++ "module " ++ modName ++ " where\n" +++ "\n" +++ "import DBus.TH\n" +++ "import DBus.TH.Introspection\n"+
+ DBus/TH/Introspection/Types.hs view
@@ -0,0 +1,19 @@++module DBus.TH.Introspection.Types where++import Data.Word+import Data.Int+import qualified Data.Map as M++type ListInt8 = [Int8]+type ListInt16 = [Int16]+type ListInt32 = [Int32]++type ListWord8 = [Word8]+type ListWord16 = [Word16]+type ListWord32 = [Word32]++type ListStr = [String]++type DictStrStr = M.Map String String+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Ilya Portnov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Ilya Portnov nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT+OWNER 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.
+ README view
@@ -0,0 +1,71 @@++This package is aimed to simplify writing bindings for DBus interfaces by using+DBus introspection and dbus-th package.++The synopsis is:++dbus-introspect-hs [OPTIONS] [SERVICE.NAME] [/PATH/TO/OBJECT] [INTERFACE.NAME]+ Introspect specified DBus object/interface and generate TemplateHaskell+ source for calling all functions from Haskell++Common flags:+ -m --module=NAME --modulename Haskell module name+ -o --output=FILE --outputfile Output file+ -s --system Use system bus instead of sesion bus+ -d --dynamic --dynamicobject If specified - generated functions will get+ object path as 2nd argument++If service name is not provided, the program will generate bindings for all+services available (Warning: you can receive a very large file). If object +path is not provided, the program will generate bindings for all objects+provided by specified service. Similarly, if interface name is not proviced,+the program will generate bindings for all interfaces provided by speciifed+object.++If -d option is specified, the program will generate bindings by using+"interface'" instead of "interface"; so, all generated functions will get+object path as their second argument.++For example, one may run++ $ dbus-introspect-hs --dynamic --session -m Session \+ org.freedesktop.login1 /org/freedesktop/login1/session/self \+ org.freedesktop.login1.Session++and receive:++ {-# LANGUAGE TemplateHaskell #-}+ module Session where++ import DBus.TH+ import DBus.TH.Introspection++ -- Service BusName "org.freedesktop.login1"+ -- Interface org.freedesktop.login1.Session+ interface' "org.freedesktop.login1" Nothing "org.freedesktop.login1.Session" Nothing [+ "Terminate" =:: Return ''(),+ "Activate" =:: Return ''(),+ "Lock" =:: Return ''(),+ "Unlock" =:: Return ''(),+ "SetIdleHint" =:: ''Bool :-> Return ''(),+ "Kill" =:: ''String :-> ''Int32 :-> Return ''(),+ "TakeControl" =:: ''Bool :-> Return ''(),+ "ReleaseControl" =:: Return ''(),+ -- Error: method TakeDevice: Method TakeDevice has more than one out parameter,+ "ReleaseDevice" =:: ''Word32 :-> ''Word32 :-> Return ''(),+ "PauseDeviceComplete" =:: ''Word32 :-> ''Word32 :-> Return ''()+ ]++After "import Session", the functions like activate :: Client -> String -> IO ()+will be available.++Note that many DBus services provide one interface for many objects; and +in one interface, there could be several functions with the same name (but+with different signatures). In this case, the source generated by this+program would not compile due to duplicated declaration names.++So, the sources generated by this program are primarily intended for +hand inspection and editing (change declaration names, remove unneded or+duplicated declarations); not for automatic compilation during some+package build process.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ dbus-introspect-hs.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell, DeriveDataTypeable #-}++import Control.Monad+import Data.List+import Language.Haskell.TH++import DBus+import DBus.Client+import qualified DBus.Introspection as I+import DBus.TH as TH++import DBus.TH.Introspection++import System.Console.CmdArgs+import System.IO++data Options = Options {+ moduleName :: String,+ outputFile :: String,+ system :: Bool,+ serviceName :: String,+ objectPath :: String,+ interfaceName :: String,+ dynamicObject :: Bool+ }+ deriving (Data, Typeable, Show, Eq)++options = Options {+ moduleName = "Interface" &= typ "NAME" &= name "module" &= help "Haskell module name",+ outputFile = "-" &= typFile &= name "output" &= help "Output file",+ system = False &= help "Use system bus instead of sesion bus",+ serviceName = def &= typ "SERVICE.NAME" &= argPos 0 &= opt ("" :: String),+ objectPath = def &= typ "/PATH/TO/OBJECT" &= argPos 1 &= opt ("" :: String),+ interfaceName = def &= typ "INTERFACE.NAME" &= argPos 2 &= opt ("" :: String),+ dynamicObject = def &= name "dynamic" &= help "If specified - generated functions will get object path as 2nd argument"+ } &=+ help "Introspect specified DBus object/interface and generate TemplateHaskell source for calling all functions from Haskell" &=+ program "dbus-introspect-hs" &= + summary "dbus-introspect-hs program"++withOutFile :: FilePath -> (Handle -> IO a) -> IO a+withOutFile "-" fn = fn stdout+withOutFile path fn = withFile path WriteMode fn++main :: IO ()+main = do+ opts <- cmdArgs options+ dbus <- if system opts+ then connectSystem+ else connectSession+ services <- if serviceName opts == ""+ then do+ ss <- listNames dbus+ case ss of+ Nothing -> fail $ "Can't obtain list of services"+ Just list -> return $ map busName_ list+ else return [busName_ $ serviceName opts]++ withOutFile (outputFile opts) $ \h -> do+ hPutStrLn h $ header (moduleName opts)++ forM_ services $ \service -> do+ hPutStrLn h $ "-- Service " ++ formatBusName service+ objects <- if objectPath opts == ""+ then do+ obs <- getServiceObjects dbus service "/"+ return $ map I.objectPath obs+ else return [objectPath_ $ objectPath opts]+ forM_ objects $ \object -> do+ ob <- introspect dbus service object+ forM_ (I.objectInterfaces ob) $ \iface -> do+ let ifaceName = formatInterfaceName (I.interfaceName iface)+ useIface = case interfaceName opts of+ "" -> True+ name -> name == ifaceName+ when useIface $ do+ hPutStrLn h $ "-- Interface " ++ ifaceName+ funcs <- forM (I.interfaceMethods iface) $ \m -> do+ -- hPutStrLn h $ " -- Method: " ++ + let methodName = formatMemberName (I.methodName m)+ case method2function m of+ Left err -> do+ return [ "-- Error: method " ++ methodName ++ ": " ++ err ]+ Right fn -> return [ pprintFunc fn ]+ let path = if dynamicObject opts + then Nothing+ else Just (formatObjectPath object)+ hPutStrLn h $ pprintInterface (formatBusName service) path ifaceName (concat funcs)+
+ dbus-th-introspection.cabal view
@@ -0,0 +1,50 @@+-- Initial dbus-th-introspection.cabal generated by cabal init. For +-- further documentation, see http://haskell.org/cabal/users-guide/++name: dbus-th-introspection+version: 0.1.0.0+synopsis: Generate bindings for DBus calls by using DBus introspection and dbus-th+description: This package is aimed to simplify writing bindings for DBus interfaces by using+ DBus introspection and dbus-th package.+extra-doc-files: README+license: BSD3+license-file: LICENSE+author: Ilya Portnov+maintainer: portnov84@rambler.ru+-- copyright: +category: Development+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10++library+ exposed-modules: DBus.TH.Introspection,+ DBus.TH.Introspection.Output,+ DBus.TH.Introspection.Types+ -- other-modules: + other-extensions: TemplateHaskell, OverloadedStrings+ build-depends: base >=4.7 && <4.8,+ dbus-th >=0.1.2.0,+ template-haskell >=2.9 && <2.10,+ dbus >=0.10 && <0.11,+ containers >=0.5 && <0.6+ ghc-options: -fwarn-unused-imports+ default-language: Haskell2010++executable dbus-introspect-hs+ Main-Is: dbus-introspect-hs.hs+ other-modules: DBus.TH.Introspection,+ DBus.TH.Introspection.Output,+ DBus.TH.Introspection.Types+ build-depends: base >=4.7 && <4.8,+ dbus-th >=0.1.2.0,+ template-haskell >=2.9 && <2.10,+ dbus >=0.10 && <0.11,+ containers >=0.5 && <0.6,+ cmdargs+ default-language: Haskell2010++Source-repository head+ type: git+ location: https://github.com/portnov/dbus-th-introspection.git+