{-# LANGUAGE OverloadedStrings #-} -- Copyright (C) 2009-2011 John Millikin -- -- 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 -- 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']]