diff --git a/DBus/TH/Introspection.hs b/DBus/TH/Introspection.hs new file mode 100644 --- /dev/null +++ b/DBus/TH/Introspection.hs @@ -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 + diff --git a/DBus/TH/Introspection/Output.hs b/DBus/TH/Introspection/Output.hs new file mode 100644 --- /dev/null +++ b/DBus/TH/Introspection/Output.hs @@ -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" + diff --git a/DBus/TH/Introspection/Types.hs b/DBus/TH/Introspection/Types.hs new file mode 100644 --- /dev/null +++ b/DBus/TH/Introspection/Types.hs @@ -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 + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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. + 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/dbus-introspect-hs.hs b/dbus-introspect-hs.hs new file mode 100644 --- /dev/null +++ b/dbus-introspect-hs.hs @@ -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) + diff --git a/dbus-th-introspection.cabal b/dbus-th-introspection.cabal new file mode 100644 --- /dev/null +++ b/dbus-th-introspection.cabal @@ -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 +