dbus-1.4.3: examples/dbus-monitor.hs
{-# LANGUAGE OverloadedStrings #-}
-- Copyright (C) 2009-2011 John Millikin <john@john-millikin.com>
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
-- http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.
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
-- exercise 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']]