dbus-0.10.13: 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']]