dbus-0.10.8: examples/dbus-monitor.hs

{-# LANGUAGE OverloadedStrings #-}

-- Copyright (C) 2009-2011 John Millikin <john@john-millikin.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/>.

module Main (main) where

import           Control.Monad
import           Data.List (intercalate)
import           Data.Int
import           Data.Word
import           System.Environment
import           System.Exit
import           System.IO
import           System.Console.GetOpt

import           DBus
import           DBus.Socket

data Bus = Session | System
	deriving (Show)

data Option = BusOption Bus | AddressOption String
	deriving (Show)

optionInfo :: [OptDescr Option]
optionInfo = [
	  Option [] ["session"] (NoArg (BusOption Session))
	         "Monitor the session message bus. (default)"
	, Option [] ["system"] (NoArg (BusOption System))
	         "Monitor the system message bus."
	, Option [] ["address"] (ReqArg AddressOption "ADDRESS")
	         "Connect to a particular bus address."
	]

usage :: String -> String
usage name = "Usage: " ++ name ++ " [OPTION...]"

findSocket :: [Option] -> IO Socket
findSocket opts = getAddress opts >>= open where
	session = do
		got <- getSessionAddress
		case got of
			Just addr -> return addr
			Nothing -> error "DBUS_SESSION_BUS_ADDRESS is not a valid address"
	
	system = do
		got <- getSystemAddress
		case got of
			Just addr -> return addr
			Nothing -> error "DBUS_SYSTEM_BUS_ADDRESS is not a valid address"
	
	getAddress [] = session
	getAddress ((BusOption Session):_) = session
	getAddress ((BusOption System):_) = system
	getAddress ((AddressOption addr):_) = case parseAddress addr of
		Nothing -> error (show addr ++ " is not a valid address")
		Just parsed -> return parsed

addMatch :: Socket -> String -> IO ()
addMatch sock match = send sock (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "AddMatch")
	{ methodCallDestination = Just "org.freedesktop.DBus"
	, methodCallBody = [toVariant match]
	} (\_ -> return ())

defaultFilters :: [String]
defaultFilters =
	[ "type='signal',eavesdrop=true"
	, "type='method_call',eavesdrop=true"
	, "type='method_return',eavesdrop=true"
	, "type='error',eavesdrop=true"
	]

main :: IO ()
main = do
	args <- getArgs
	let (options, userFilters, errors) = getOpt Permute optionInfo args
	unless (null errors) $ do
		name <- getProgName
		hPutStrLn stderr (concat errors)
		hPutStrLn stderr (usageInfo (usage name) optionInfo)
		exitFailure
	
	sock <- findSocket options
	
	send sock (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "Hello")
		{ methodCallDestination = Just "org.freedesktop.DBus"
		} (\_ -> return ())
	
	mapM_ (addMatch sock) (if null userFilters then defaultFilters else userFilters)
	
	forever $ do
		received <- receive sock
		putStrLn (formatMessage received ++ "\n")

-- Message formatting is verbose and mostly uninteresting, except as an
-- excersise in string manipulation.

formatMessage :: ReceivedMessage -> String

-- Method call
formatMessage (ReceivedMethodCall serial msg) = concat
	[ "method call"
	, " sender="
	, maybe "(null)" formatBusName (methodCallSender msg)
	, " -> dest="
	, maybe "(null)" formatBusName (methodCallDestination msg)
	, " serial="
	, show (serialValue serial)
	, " path="
	, formatObjectPath (methodCallPath msg)
	, "; interface="
	, maybe "(null)" formatInterfaceName (methodCallInterface msg)
	, "; member="
	, formatMemberName (methodCallMember msg)
	, formatBody (methodCallBody msg)
	]

-- Method return
formatMessage (ReceivedMethodReturn _ msg) = concat
	[ "method return"
	, " sender="
	, maybe "(null)" formatBusName (methodReturnSender msg)
	, " -> dest="
	, maybe "(null)" formatBusName (methodReturnDestination msg)
	, " reply_serial="
	, show (serialValue (methodReturnSerial msg))
	, formatBody (methodReturnBody msg)
	]

-- Method error
formatMessage (ReceivedMethodError _ msg) = concat
	[ "error"
	, " sender="
	, maybe "(null)" formatBusName (methodErrorSender msg)
	, " -> dest="
	, maybe "(null)" formatBusName (methodErrorDestination msg)
	, " error_name="
	, formatErrorName (methodErrorName msg)
	, " reply_serial="
	, show (serialValue (methodErrorSerial msg))
	, formatBody (methodErrorBody msg)
	]

-- Signal
formatMessage (ReceivedSignal serial msg) = concat
	[ "signal"
	, " sender="
	, maybe "(null)" formatBusName (signalSender msg)
	, " -> dest="
	, maybe "(null)" formatBusName (signalDestination msg)
	, " serial="
	, show (serialValue serial)
	, " path="
	, formatObjectPath (signalPath msg)
	, "; interface="
	, formatInterfaceName (signalInterface msg)
	, "; member="
	, formatMemberName (signalMember msg)
	, formatBody (signalBody msg)
	]

formatMessage msg = concat
	[ "unknown"
	, " sender="
	, maybe "(null)" formatBusName (receivedMessageSender msg)
	, " serial="
	, show (serialValue (receivedMessageSerial msg))
	, formatBody (receivedMessageBody msg)
	]

formatBody :: [Variant] -> String
formatBody body = formatted where
	tree = Children (map formatVariant body)
	formatted = intercalate "\n" ("" : collapseTree 0 tree)

-- A string tree allows easy indentation of nested structures
data StringTree = Line String | MultiLine [StringTree] | Children [StringTree]
	deriving (Show)

collapseTree :: Int -> StringTree -> [String]
collapseTree d (Line x)       = [replicate (d*3) ' ' ++ x]
collapseTree d (MultiLine xs) = concatMap (collapseTree d) xs
collapseTree d (Children xs)  = concatMap (collapseTree (d + 1)) xs

-- Formatting for various kinds of variants, keyed to their signature type.
formatVariant :: Variant -> StringTree
formatVariant x = case variantType x of
	
	TypeBoolean -> Line $ let
		Just x' = fromVariant x
		in "boolean " ++ if x' then "true" else "false"
	
	TypeWord8 -> Line $ let
		Just x' = fromVariant x
		in "byte " ++ show (x' :: Word8)
	
	TypeWord16 -> Line $ let
		Just x' = fromVariant x
		in "uint16 " ++ show (x' :: Word16)
	
	TypeWord32 -> Line $ let
		Just x' = fromVariant x
		in "uint32 " ++ show (x' :: Word32)
	
	TypeWord64 -> Line $ let
		Just x' = fromVariant x
		in "uint64 " ++ show (x' :: Word64)
	
	TypeInt16 -> Line $ let
		Just x' = fromVariant x
		in "int16 " ++ show (x' :: Int16)
	
	TypeInt32 -> Line $ let
		Just x' = fromVariant x
		in "int32 " ++ show (x' :: Int32)
	
	TypeInt64 -> Line $ let
		Just x' = fromVariant x
		in "int64 " ++ show (x' :: Int64)
	
	TypeDouble -> Line $ let
		Just x' = fromVariant x
		in "double " ++ show (x' :: Double)
	
	TypeString -> Line $ let
		Just x' = fromVariant x
		in "string " ++ show (x' :: String)
	
	TypeObjectPath -> Line $ let
		Just x' = fromVariant x
		in "object path " ++ show (formatObjectPath x')
	
	TypeSignature -> Line $ let
		Just x' = fromVariant x
		in "signature " ++ show (formatSignature x')
	
	TypeArray _ -> MultiLine $ let
		Just x' = fromVariant x
		items = arrayItems x'
		lines' = [ Line "array ["
		         , Children (map formatVariant items)
		         , Line "]"
		         ]
		in lines'
	
	TypeDictionary _ _ -> MultiLine $ let
		Just x' = fromVariant x
		items = dictionaryItems x'
		lines' = [ Line "dictionary {"
		         , Children (map formatItem items)
		         , Line "}"
		         ]
		formatItem (k, v) = MultiLine (firstLine : vTail) where
			Line k' = formatVariant k
			v' = collapseTree 0 (formatVariant v)
			vHead = head v'
			vTail = map Line (tail v')
			firstLine = Line (k' ++ " -> " ++ vHead)
		in lines'
	
	TypeStructure _ -> MultiLine $ let
		Just x' = fromVariant x
		items = structureItems x'
		lines' = [ Line "struct ("
		         , Children (map formatVariant items)
		         , Line ")"
		         ]
		in lines'
	
	TypeVariant -> let
		Just x' = fromVariant x
		in MultiLine [Line "variant", Children [formatVariant x']]