dbus-client-0.4: Examples/introspect.hs

-- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com>
-- 
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- any later version.
-- 
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE OverloadedStrings #-}
module Main (main) where
import Prelude hiding (replicate)
import qualified Prelude as Prelude
import qualified Data.Text.Lazy as TL
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent (forkIO)
import Data.Maybe

import DBus.Client
import qualified DBus.Introspection as I
import System (getArgs)

main :: IO ()
main = do
	[service, path] <- getArgs
	c <- newClient =<< getSessionBus
	let introspect' p = runDBus c $ introspect (mkBusName_ $ TL.pack service) p
	forkIO $ runDBus c mainLoop
	printObj introspect' 0 (mkObjectPath_ $ TL.pack path)

introspect :: BusName -> ObjectPath -> DBus I.Object
introspect service path = do
	let proxy = Proxy service path "org.freedesktop.DBus.Introspectable"
	
	reply <- callProxyBlocking_ proxy "Introspect" [] []
	let text = fromJust $ fromVariant (methodReturnBody reply !! 0)
	return . fromJust $ I.fromXML path text

-- most of this stuff is just boring text formatting

printObj :: (ObjectPath -> IO I.Object) -> Integer -> ObjectPath -> IO ()
printObj get depth path = do
	let strPath = strObjectPath path
	putStr $ replicate (depth * 4) ' '
	putStrLn $ TL.unpack strPath
	
	(I.Object _ interfaces children) <- get path
	
	putStr $ replicate (depth * 4) ' '
	putStrLn $ replicate (fromIntegral $ TL.length strPath) '='
	
	mapM_ (printIface (depth + 1)) interfaces
	
	mapM_ (printObj get (depth + 1)) [x | (I.Object x _ _) <- children]

printIface :: Integer -> I.Interface -> IO ()
printIface depth (I.Interface name methods signals properties) = do
	let strName = strInterfaceName name
	putStr $ replicate (depth * 4) ' '
	putStrLn . TL.unpack $ strName
	putStr $ replicate (depth * 4) ' '
	putStrLn $ replicate (fromIntegral $ TL.length strName) '-'
	
	mapM_ (printMethod (depth + 1)) methods
	mapM_ (printSignal (depth + 1)) signals
	mapM_ (printProperty (depth + 1)) properties

printMethod :: Integer -> I.Method -> IO ()
printMethod depth (I.Method name inParams outParams) = do
	putStr $ replicate (depth * 4) ' '
	putStr "M "
	putStrLn . TL.unpack . strMemberName $ name
	
	mapM_ (printParam "IN" (depth + 1)) inParams
	mapM_ (printParam "OUT" (depth + 1)) outParams

printSignal :: Integer -> I.Signal -> IO ()
printSignal depth (I.Signal name params) = do
	putStr $ replicate (depth * 4) ' '
	putStr "S "
	putStrLn . TL.unpack . strMemberName $ name
	
	mapM_ (printParam "OUT" (depth + 1)) params

printProperty :: Integer -> I.Property -> IO ()
printProperty depth (I.Property name sig access) = do
	putStr $ replicate (depth * 4) ' '
	putStr $ "P " ++ show (strSignature sig) ++ " "
	putStrLn $ TL.unpack name
	putStr $ replicate ((depth + 1) * 4) ' '
	putStrLn $ show access
	
printParam :: String -> Integer -> I.Parameter -> IO ()
printParam label depth (I.Parameter name sig) = do
	putStr $ replicate (depth * 4) ' '
	putStr $ "[" ++ label ++ " "
	putStr $ show (strSignature sig) ++ " ] "
	putStrLn $ TL.unpack name

replicate :: Integer -> a -> [a]
replicate = Prelude.replicate . fromInteger