DBus (empty) → 0.1
raw patch · 14 files changed
+1061/−0 lines, 14 filesdep +basesetup-changed
Dependencies added: base
Files
- DBus.buildinfo.in +2/−0
- DBus.cabal +33/−0
- DBus.hsc +36/−0
- DBus/Connection.hsc +210/−0
- DBus/Internal.hsc +62/−0
- DBus/Message.hsc +398/−0
- DBus/Shared.hsc +36/−0
- LICENSE +23/−0
- README +25/−0
- Setup.lhs +3/−0
- configure.ac +5/−0
- demo/Demo.hs +84/−0
- demo/Monitor.hs +132/−0
- doc-prologue.txt +12/−0
+ DBus.buildinfo.in view
@@ -0,0 +1,2 @@+cc-options: @DBUS_CFLAGS@+ld-options: @DBUS_LIBS@
+ DBus.cabal view
@@ -0,0 +1,33 @@+name: DBus+version: 0.1++license: BSD3+license-file: LICENSE+copyright: Copyright (C) 2006 Evan Martin <martine@danga.com>+author: Evan Martin <martine@danga.com>+maintainer: Unmaintained++stability: Experimental+Category: System+synopsis: DBus bindings+description: Bindings for the D-Bus API.+ For details on D-Bus, see the D-Bus wiki at:+ <http://www.freedesktop.org/wiki/Software/dbus>+ .+ It's worth noting that this binding is not stable or+ even well-tested at all. Use this library at your own risk.+homepage: http://neugierig.org/software/hdbus++build-depends: base+build-type: Simple+tested-with: GHC==6.8.2++exposed-modules: DBus, DBus.Message, DBus.Connection+other-modules: DBus.Internal, DBus.Shared++extensions: ForeignFunctionInterface, OverlappingInstances,+ ExistentialQuantification, PatternSignatures,+ ScopedTypeVariables, FlexibleInstances, TypeSynonymInstances++data-files: README, doc-prologue.txt+extra-source-files: configure.ac, DBus.buildinfo.in, demo/Demo.hs, demo/Monitor.hs
+ DBus.hsc view
@@ -0,0 +1,36 @@+-- HDBus -- Haskell bindings for D-Bus.+-- Copyright (C) 2006 Evan Martin <martine@danga.com>++#define DBUS_API_SUBJECT_TO_CHANGE+#include "dbus/dbus.h"++module DBus (+ module DBus.Shared,++ -- * Error Handling+ -- | Some D-Bus functions can only fail on out-of-memory conditions.+ -- I don't think there is much we can do in those cases.+ --+ -- Other D-Bus functions can fail with other sorts of errors, which are+ -- raised as dynamic exceptions. Errors can be caught with+ -- 'Control.Exception.catchDyn', like this:+ --+ -- > do conn <- DBus.busGet DBus.System+ -- > doSomethingWith conn+ -- > `catchDyn` (\(DBus.Error name msg) -> putStrLn ("D-Bus error! " ++ msg))+ --+ Error(..),+) where++import DBus.Shared+import Data.Typeable (Typeable(..), mkTyConApp, mkTyCon)++-- |'Error's carry a name (like \"org.freedesktop.dbus.Foo\") and a+-- message (like \"connection failed\").+data Error = Error String String+instance Typeable Error where+ typeOf _ = mkTyConApp (mkTyCon "DBus.Error") []+instance Show Error where+ show (Error name message) = "D-Bus Error (" ++ name ++ "): " ++ message++-- vim: set ts=2 sw=2 tw=72 et ft=haskell :
+ DBus/Connection.hsc view
@@ -0,0 +1,210 @@+-- HDBus -- Haskell bindings for D-Bus.+-- Copyright (C) 2006 Evan Martin <martine@danga.com>++#define DBUS_API_SUBJECT_TO_CHANGE+#include "dbus/dbus.h"++module DBus.Connection (+ -- * Connection Basics+ Connection,+ BusType(..),+ busGet,+ send, sendWithReplyAndBlock,+ flush, close,+ withConnection,++ -- * Main Loop Management+ readWriteDispatch, addFilter, addMatch,++ RequestNameReply(..),+ busRequestName,+) where++import Control.Exception (bracket)+import Control.Monad (when)+import Foreign+import Foreign.C.String+import Foreign.C.Types (CInt)++import DBus.Internal+import DBus.Message+import DBus.Shared++type Connection = ForeignPtr ConnectionTag++data BusType = Session -- ^The login session bus.+ | System -- ^The systemwide bus.+ | Starter -- ^The bus that started us, if any.++foreign import ccall unsafe "&dbus_connection_unref"+ connection_unref :: FunPtr (ConnectionP -> IO ())+connectionPTOConnection conn = do+ when (conn == nullPtr) $ fail "null connection"+ newForeignPtr connection_unref conn++foreign import ccall unsafe "dbus_bus_get"+ bus_get :: CInt -> ErrorP -> IO ConnectionP+-- |Connect to a standard bus.+busGet :: BusType -> IO Connection+busGet bt = withErrorP (bus_get (toInt bt)) >>= connectionPTOConnection where+ toInt Session = #{const DBUS_BUS_SESSION}+ toInt System = #{const DBUS_BUS_SYSTEM}+ toInt Starter = #{const DBUS_BUS_STARTER}++data RequestNameReply = PrimaryOwner | InQueue | Exists | AlreadyOwner+foreign import ccall unsafe "dbus_bus_request_name"+ bus_request_name :: ConnectionP -> CString -> CInt -> ErrorP -> IO CInt+busRequestName :: Connection -> String -> [Int] -> IO RequestNameReply+busRequestName conn name flags =+ withForeignPtr conn $ \conn -> do+ withCString name $ \cname -> do+ ret <- withErrorP (bus_request_name conn cname 2)+ return $ fromInt ret where+ fromInt #{const DBUS_REQUEST_NAME_REPLY_PRIMARY_OWNER} = PrimaryOwner+ fromInt #{const DBUS_REQUEST_NAME_REPLY_IN_QUEUE} = InQueue+ fromInt #{const DBUS_REQUEST_NAME_REPLY_EXISTS} = Exists+ fromInt #{const DBUS_REQUEST_NAME_REPLY_ALREADY_OWNER} = AlreadyOwner++-- |Close a connection. A connection must be closed before its last+-- reference disappears.+foreign import ccall unsafe "dbus_connection_close"+ connection_close :: ConnectionP -> IO ()+close :: Connection -> IO ()+close conn = withForeignPtr conn connection_close++-- |Open a connection and run an IO action, ensuring it is properly closed when+-- you're done.+withConnection :: BusType -> (Connection -> IO a) -> IO a+withConnection bt = bracket (busGet bt) close++foreign import ccall unsafe "dbus_connection_send"+ connection_send :: ConnectionP -> MessageP -> Ptr Word32 -> IO Bool++-- |Adds a 'Message' to the outgoing message queue.+send :: Connection -> Message+ -> Word32 -- ^Serial.+ -> IO Word32 -- ^Returned serial.+send conn msg serial =+ withForeignPtr conn $ \conn -> do+ withForeignPtr msg $ \msg -> do+ with serial $ \serial -> do+ catchOom $ connection_send conn msg serial+ peek serial++type PendingCallTag = ()+type PendingCallP = Ptr PendingCallTag+type PendingCall = ForeignPtr PendingCallTag++foreign import ccall unsafe "dbus_connection_send_with_reply"+ connection_send_with_reply :: ConnectionP -> MessageP+ -> Ptr PendingCallP -> IO Bool+foreign import ccall unsafe "&dbus_pending_call_unref"+ pending_call_unref :: FunPtr (PendingCallP -> IO ())++sendWithReply :: Connection -> Message+ -> Maybe Int -- ^Optional timeout in milliseconds.+ -> IO PendingCall+-- XXX a NULL PendingCall lets us track timeout errors+sendWithReply conn msg timeout = do+ withForeignPtr conn $ \conn -> do+ withForeignPtr msg $ \msg -> do+ with (nullPtr :: PendingCallP) $ \ppcp -> do+ catchOom $ connection_send_with_reply conn msg ppcp+ throwIfNull "null PPendingCall" (return ppcp)+ pcp <- peek ppcp+ throwIfNull "null PendingCall" (return pcp)+ newForeignPtr pending_call_unref pcp++foreign import ccall unsafe "dbus_connection_send_with_reply_and_block"+ connection_send_with_reply_and_block :: ConnectionP -> MessageP -> Int -> ErrorP -> IO MessageP++sendWithReplyAndBlock :: Connection -> Message+ -> Int -- ^Timeout in milliseconds.+ -> IO Message+sendWithReplyAndBlock conn msg timeout =+ withForeignPtr conn $ \conn -> do+ withForeignPtr msg $ \msg -> do+ ret <- withErrorP $ connection_send_with_reply_and_block conn msg timeout+ messagePToMessage ret False++foreign import ccall unsafe "dbus_connection_flush"+ connection_flush :: ConnectionP -> IO ()+-- |Block until all pending messages have been sent.+flush :: Connection -> IO ()+flush conn = withForeignPtr conn connection_flush++foreign import ccall "dbus_connection_read_write_dispatch"+ connection_read_write_dispatch :: ConnectionP -> Int -> IO Bool+-- |Block until a message is read or written, then return True unless a+-- disconnect message is received.+readWriteDispatch :: Connection+ -> Int -- ^Timeout, in milliseconds.+ -> IO Bool+readWriteDispatch conn timeout = do+ withForeignPtr conn $ \conn ->+ connection_read_write_dispatch conn timeout++-- "a" here is the type of the callback function.+data FreeClosure a = FreeClosure { fcCallback :: FunPtr a,+ fcFree :: FunPtr (FreeFunction a) }+type FreeFunction a = StablePtr (FreeClosure a) -> IO ()+foreign import ccall "wrapper"+ wrapFreeFunction :: FreeFunction a -> IO (FunPtr (FreeFunction a))++mkFreeClosure :: FunPtr a -> IO (FreeClosure a)+mkFreeClosure callback = do+ freef <- wrapFreeFunction freeFunction+ return $ FreeClosure callback freef+ where+ freeFunction :: FreeFunction a+ freeFunction sptr = do+ (FreeClosure cb freef) <- deRefStablePtr sptr+ freeStablePtr sptr+ freeHaskellFunPtr cb+ freeHaskellFunPtr freef -- XXX we are freeing ourselves.+ -- XXX this is officially not ok,+ -- XXX but it seems like it'll do.++type HandleMessageFunction = ConnectionP -> MessageP -> Ptr () -> IO CInt++foreign import ccall "wrapper"+ wrapHandleMessageFunction :: HandleMessageFunction+ -> IO (FunPtr HandleMessageFunction)++foreign import ccall "dbus_connection_add_filter"+ connection_add_filter :: ConnectionP+ -> FunPtr HandleMessageFunction -> StablePtr a+ -> FunPtr (StablePtr a -> IO ()) -> IO Bool+addFilter :: Connection+ -> (Message -> IO Bool) -- ^A callback that returns True if+ -- the message has been handled.+ -> IO ()+addFilter conn callback = do+ withForeignPtr conn $ \conn -> do+ hmf <- wrapHandleMessageFunction handleMessageFunction+ closure <- mkFreeClosure hmf+ pclosure <- newStablePtr closure+ catchOom $ connection_add_filter conn hmf pclosure (fcFree closure)+ where+ handleMessageFunction :: HandleMessageFunction+ handleMessageFunction connp messagep datap = do+ message <- messagePToMessage messagep True+ res <- callback message+ if res then return #{const DBUS_HANDLER_RESULT_HANDLED}+ else return #{const DBUS_HANDLER_RESULT_NOT_YET_HANDLED}+++foreign import ccall "dbus_bus_add_match"+ bus_add_match :: ConnectionP -> CString -> ErrorP -> IO ()+addMatch :: Connection+ -> Bool -- ^Whether to block waiting for a response, allowing+ -- us to raise an exception if a response never comes.+ -> String -> IO ()+addMatch conn block rule =+ withForeignPtr conn $ \conn ->+ withCString rule $ \rule -> do+ if block+ then withErrorP $ bus_add_match conn rule+ else bus_add_match conn rule nullPtr++-- vim: set ts=2 sw=2 tw=72 et ft=haskell :
+ DBus/Internal.hsc view
@@ -0,0 +1,62 @@+-- HDBus -- Haskell bindings for D-Bus.+-- Copyright (C) 2006 Evan Martin <martine@danga.com>++-- tell Haddock not to doc this module:+-- #hide++#define DBUS_API_SUBJECT_TO_CHANGE+#include "dbus/dbus.h"++module DBus.Internal where++import Control.Exception (throwDyn)+import Control.Monad (when)+import DBus (Error(..))+import Foreign+import Foreign.C.String++type MessageTag = ()+type MessageP = Ptr MessageTag+type ConnectionTag = ()+type ConnectionP = Ptr ConnectionTag++allocInit :: Int -> (Ptr a -> IO ()) -> (Ptr a -> IO b) -> IO b+allocInit size init cont = allocaBytes size $ \obj -> do init obj; cont obj++-- Sometimes functions claim they can only fail in oom conditions.+-- What else can we do but die?+catchOom :: IO Bool -> IO ()+catchOom action = throwIf_ (== False) (const "Out of memory") action++foreign import ccall unsafe "dbus_message_ref"+ message_ref :: MessageP -> IO ()+foreign import ccall unsafe "&dbus_message_unref"+ message_unref :: FunPtr (MessageP -> IO ())+messagePToMessage msg addref = do+ throwIfNull "null message" (return msg)+ when addref $ message_ref msg+ newForeignPtr message_unref msg++type ErrorTag = ()+type ErrorP = Ptr ErrorTag++foreign import ccall unsafe "dbus_error_init"+ error_init :: ErrorP -> IO ()+foreign import ccall unsafe "dbus_error_is_set"+ error_is_set :: ErrorP -> IO Bool+foreign import ccall unsafe "dbus_error_free"+ error_free :: ErrorP -> IO ()++withErrorP :: (ErrorP -> IO a) -> IO a+withErrorP f =+ allocInit #{size DBusError} error_init $ \err -> do+ ret <- f err+ has_err <- error_is_set err+ if not has_err+ then return ret+ else do name <- #{peek DBusError, name} err >>= peekCString+ msg <- #{peek DBusError, message} err >>= peekCString+ error_free err+ throwDyn $ Error name msg++-- vim: set ts=2 sw=2 tw=72 et ft=haskell :
+ DBus/Message.hsc view
@@ -0,0 +1,398 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, TypeSynonymInstances #-}+-- HDBus -- Haskell bindings for D-Bus.+-- Copyright (C) 2006 Evan Martin <martine@danga.com>++#define DBUS_API_SUBJECT_TO_CHANGE+#include "dbus/dbus.h"++module DBus.Message (+ -- * Messages+ Message,+ newSignal, newMethodCall,+ -- * Accessors+ Type(..),+ getType, getSignature,+ getPath, getInterface, getMember, getErrorName,+ getDestination, getSender,++ -- * Arguments+ Arg(..),+ args, addArgs,+ -- ** Dictionaries+ -- | D-Bus functions that expect a dictionary must be passed a 'Dict',+ -- which is trivially constructable from an appropriate list.+ Dict, dict,+ -- ** Variants+ -- | Some D-Bus functions allow variants, which are similar to+ -- 'Data.Dynamic' dynamics but restricted to D-Bus data types.+ Variant, variant+) where++import Control.Monad (when)+import Data.Int+import Data.Word+import Data.Dynamic+import Foreign+import Foreign.C.String+import Foreign.C.Types (CInt)++import DBus.Internal+import DBus.Shared++type Message = ForeignPtr MessageTag++foreign import ccall unsafe "dbus_message_new_signal"+ message_new_signal :: CString -> CString -> CString -> IO MessageP+foreign import ccall unsafe "dbus_message_new_method_call"+ message_new_method_call :: CString -> CString -> CString -> CString -> IO MessageP++newSignal :: PathName -- ^Path.+ -> InterfaceName -- ^Interface.+ -> String -- ^Method name.+ -> IO Message+newSignal path iface name =+ withCString path $ \cpath ->+ withCString iface $ \ciface ->+ withCString name $ \cname -> do+ msg <- message_new_signal cpath ciface cname+ messagePToMessage msg False++newMethodCall :: ServiceName -- ^Bus name.+ -> PathName -- ^Path.+ -> InterfaceName -- ^Interface.+ -> String -- ^Method name.+ -> IO Message+newMethodCall busname path iface method =+ withCString busname $ \cbusname ->+ withCString path $ \cpath ->+ withCString iface $ \ciface ->+ withCString method $ \cmethod -> do+ msg <- message_new_method_call cbusname cpath ciface cmethod+ messagePToMessage msg False++data Type = MethodCall | MethodReturn | Error | Signal+ | Other Int deriving Show+instance Enum Type where+ toEnum #{const DBUS_MESSAGE_TYPE_METHOD_CALL} = MethodCall+ toEnum #{const DBUS_MESSAGE_TYPE_METHOD_RETURN} = MethodReturn+ toEnum #{const DBUS_MESSAGE_TYPE_ERROR} = Error+ toEnum #{const DBUS_MESSAGE_TYPE_SIGNAL} = Signal+ toEnum x = Other x+ fromEnum = error "not implemented"+foreign import ccall unsafe "dbus_message_get_type"+ message_get_type :: MessageP -> IO Int+getType :: Message -> IO Type+getType msg = withForeignPtr msg message_get_type >>= return . toEnum++getOptionalString :: (MessageP -> IO CString) -> Message -> IO (Maybe String)+getOptionalString getter msg =+ withForeignPtr msg getter >>= maybePeek peekCString++foreign import ccall unsafe dbus_message_get_path :: MessageP -> IO CString+foreign import ccall unsafe dbus_message_get_interface :: MessageP -> IO CString+foreign import ccall unsafe dbus_message_get_member :: MessageP -> IO CString+foreign import ccall unsafe dbus_message_get_error_name :: MessageP -> IO CString+foreign import ccall unsafe dbus_message_get_sender :: MessageP -> IO CString+foreign import ccall unsafe dbus_message_get_signature :: MessageP -> IO CString+foreign import ccall unsafe dbus_message_get_destination :: MessageP -> IO CString+getPath, getInterface, getMember, getErrorName, getDestination, getSender+ :: Message -> IO (Maybe String)+getPath = getOptionalString dbus_message_get_path+getInterface = getOptionalString dbus_message_get_interface+getMember = getOptionalString dbus_message_get_member+getErrorName = getOptionalString dbus_message_get_error_name+getDestination = getOptionalString dbus_message_get_destination+getSender = getOptionalString dbus_message_get_sender+getSignature :: Message -> IO String+getSignature msg =+ withForeignPtr msg dbus_message_get_signature >>= peekCString++type IterTag = ()+type Iter = Ptr IterTag++class Show a => Arg a where+ toIter :: a -> Iter -> IO ()+ fromIter :: Iter -> IO a+ signature :: a -> String++ -- for collection types, this does from/to inside the collection's iter+ toIterInternal :: a -> Iter -> IO ()+ toIterInternal = toIter+ fromIterInternal :: Iter -> IO a+ fromIterInternal = fromIter++assertArgType iter expected_type = do+ arg_type <- message_iter_get_arg_type iter+ when (arg_type /= expected_type) $+ fail $ "Expected arg type " ++ show expected_type +++ " but got " ++ show arg_type++putBasic iter typ val = catchOom (message_iter_append_basic iter typ val)+withContainer iter typ sig f =+ withIter $ \sub -> do+ catchOom $ (message_iter_open_container iter typ sig sub)+ f sub+ catchOom $ (message_iter_close_container iter sub)++instance Arg () where+ toIter _ _ = return ()+ fromIter _ = return ()+ signature _ = "()" -- not really correct, but we should never need this.++instance Arg String where+ fromIter iter = do+ assertArgType iter #{const DBUS_TYPE_STRING}+ alloca $ \str -> do+ message_iter_get_basic iter str+ peek str >>= peekCString+ toIter arg iter =+ -- we need a pointer to a CString (which itself is Ptr CChar)+ withCString arg $ \cstr ->+ with cstr $ putBasic iter #{const DBUS_TYPE_STRING}+ signature _ = "s"++instance Arg Int32 where+ fromIter iter = do+ assertArgType iter #{const DBUS_TYPE_INT32}+ alloca $ \int -> do+ message_iter_get_basic iter int+ peek int+ toIter arg iter = with arg $ putBasic iter #{const DBUS_TYPE_INT32}+ signature _ = "i"+instance Arg Word32 where+ fromIter iter = do+ assertArgType iter #{const DBUS_TYPE_UINT32}+ alloca $ \int -> do+ message_iter_get_basic iter int+ peek int+ toIter arg iter = with arg $ putBasic iter #{const DBUS_TYPE_UINT32}+ signature _ = "u"++data Variant = forall a. Arg a => Variant a+variant :: Arg a => a -> Variant+variant = Variant+instance Show Variant where+ show (Variant a) = "[variant]" ++ show a+instance Arg Variant where+ fromIter iter = do+ assertArgType iter #{const DBUS_TYPE_VARIANT}+ elem_type <- message_iter_get_element_type iter+ withIter $ \sub -> do+ message_iter_recurse iter sub+ variantFromIterType sub elem_type where+ -- XXX there ought to be a more clever way to do this.+ variantFromIterType iter #{const DBUS_TYPE_STRING} = do+ (v :: String) <- fromIter iter; return $ Variant v+ variantFromIterType iter #{const DBUS_TYPE_INT32} = do+ (v :: Int32) <- fromIter iter; return $ Variant v+ variantFromIterType iter #{const DBUS_TYPE_UINT32} = do+ (v :: Word32) <- fromIter iter; return $ Variant v+ toIter (Variant arg) iter = do+ withIter $ \sub ->+ withCString (signature arg) $ \sig ->+ withContainer iter #{const DBUS_TYPE_VARIANT} sig $ \sub ->+ toIter arg sub where+ signature _ = "v"++instance Arg a => Arg [a] where+ fromIter iter = do+ assertArgType iter #{const DBUS_TYPE_ARRAY}+ len <- message_iter_get_array_len iter+ if len > 0+ then withIter $ \sub -> do+ message_iter_recurse iter sub+ array <- getArray sub+ return array+ else return [] where+ getArray sub = do x <- fromIter sub+ has_next <- message_iter_next sub+ if has_next+ then do xs <- getArray sub+ return (x:xs)+ else return [x]+ toIter arg iter =+ withIter $ \sub ->+ withCString (signature (undefined :: a)) $ \sig ->+ withContainer iter #{const DBUS_TYPE_ARRAY} sig $ \sub ->+ mapM_ (\v -> toIter v sub) arg+ signature a = "a" ++ signature (undefined :: a)++-- instance (Show a,Show b,Show c,Show d,Show e,Show f,Show g,Show h) => Show (a,b,c,d,e,f,g,h) where+-- show _ = "[show not implemented]"++newtype DictEntry a b = DictEntry (a,b)+instance (Show a, Show b) => Show (DictEntry a b) where+ show (DictEntry pair) = "[DictEntry] " ++ show pair+instance (Arg a, Arg b) => Arg (DictEntry a b) where+ toIter (DictEntry pair) iter =+ withContainer iter #{const DBUS_TYPE_DICT_ENTRY} nullPtr $ \sub -> do+ toIterInternal pair sub+ fromIter iter = do+ pair <- fromIter iter+ return (DictEntry pair)+ signature _ =+ "{" ++ signature (undefined :: a) ++ signature (undefined :: b) ++ "}"++type Dict a b = [DictEntry a b]+dict :: (Arg a, Arg b) => [(a, b)] -> Dict a b+dict = map DictEntry++-- tuple instances generated by codegen/TupleInstances.hs+instance (Arg a,Arg b) => Arg (a,b) where+ toIter arg iter =+ withContainer iter #{const DBUS_TYPE_STRUCT} nullPtr $ \sub -> do+ toIterInternal arg sub+ fromIter iter =+ withIter $ \sub -> do+ message_iter_recurse iter sub+ fromIterInternal sub+ signature _ =+ "{" ++ signature (undefined :: a) ++ signature (undefined :: b) ++ "}"+ toIterInternal (a,b) iter = do+ toIter a iter; toIter b iter+ return ()+ fromIterInternal iter = do+ a <- fromIter iter; next <- message_iter_next iter+ b <- fromIter iter; next <- message_iter_next iter+ return (a,b)++instance (Arg a,Arg b,Arg c,Arg d,Arg e,Arg f,Arg g,Arg h) => Arg (a,b,c,d,e,f,g,h) where+ toIter arg iter =+ withContainer iter #{const DBUS_TYPE_STRUCT} nullPtr $ \sub -> do+ toIterInternal arg sub+ fromIter iter =+ withIter $ \sub -> do+ message_iter_recurse iter sub+ fromIterInternal sub+ signature _ =+ "{" ++ signature (undefined :: a) ++ signature (undefined :: b) ++ signature (undefined :: c) ++ signature (undefined :: d) ++ signature (undefined :: e) ++ signature (undefined :: f) ++ signature (undefined :: g) ++ signature (undefined :: h) ++ "}"+ toIterInternal (a,b,c,d,e,f,g,h) iter = do+ toIter a iter; toIter b iter; toIter c iter; toIter d iter; toIter e iter; toIter f iter; toIter g iter; toIter h iter+ return ()+ fromIterInternal iter = do+ a <- fromIter iter; next <- message_iter_next iter+ b <- fromIter iter; next <- message_iter_next iter+ c <- fromIter iter; next <- message_iter_next iter+ d <- fromIter iter; next <- message_iter_next iter+ e <- fromIter iter; next <- message_iter_next iter+ f <- fromIter iter; next <- message_iter_next iter+ g <- fromIter iter; next <- message_iter_next iter+ h <- fromIter iter; next <- message_iter_next iter+ return (a,b,c,d,e,f,g,h)++dynTag :: Dynamic -> Int32+dynTag x =+ case fromDynamic x of+ Just (i :: Int32) -> #{const DBUS_TYPE_INT32}+ Nothing ->+ case fromDynamic x of+ Just (word :: Word32) -> #{const DBUS_TYPE_UINT32}+ Nothing ->+ case fromDynamic x of+ Just (s :: String) -> #{const DBUS_TYPE_STRING}+ Nothing ->+ case fromDynamic x of+ Just (arr :: [Dynamic]) -> #{const DBUS_TYPE_ARRAY}+ Nothing ->+ case fromDynamic x of+ Just (a :: [Dynamic], b :: [Dynamic]) -> #{const DBUS_TYPE_DICT_ENTRY}+ Nothing ->+ case fromDynamic x of+ Just (b :: Bool) -> #{const DBUS_TYPE_BOOLEAN}+ Nothing -> #{const DBUS_TYPE_INVALID}++instance Arg [Dynamic] where+ fromIter iter =+ let loop list False = return (reverse list)+ loop list True = do+ argt <- message_iter_get_arg_type iter+ let next x = do {+ valid <- message_iter_next iter;+ loop (x:list) valid }+ -- putStr $ "argt is " ++ show argt ++ "\n"+ case argt of+ #{const DBUS_TYPE_INVALID} -> return (reverse list)+ #{const DBUS_TYPE_UINT32} -> do+ (word :: Word32) <- fromIter iter+ next (toDyn word)+ #{const DBUS_TYPE_INT32} -> do+ (i :: Int32) <- fromIter iter+ next (toDyn i)+ #{const DBUS_TYPE_STRING} -> do+ (s :: String) <- fromIter iter+ next (toDyn s)+ #{const DBUS_TYPE_ARRAY} -> do+ (arr :: [[Dynamic]]) <- fromIter iter -- this could be better+ next (toDyn arr)+ #{const DBUS_TYPE_DICT_ENTRY} -> do+ (DictEntry (a :: [Dynamic], b :: [Dynamic])) <- fromIter iter+ next (toDyn (a,b))+ #{const DBUS_TYPE_STRUCT} -> do+ withIter $ \sub -> do+ message_iter_recurse iter sub+ (inner :: [Dynamic]) <- fromIter sub+ next (toDyn inner)+ #{const DBUS_TYPE_BOOLEAN} -> do+ (b :: Bool) <- alloca $ \int -> do {+ message_iter_get_basic iter int;+ peek int }+ next (toDyn b)+ #{const DBUS_TYPE_VARIANT} -> do+ withIter $ \sub -> do+ message_iter_recurse iter sub+ (inner :: [Dynamic]) <- fromIter sub+ next (toDyn inner)+ in loop [] True+ toIter list iter =+ let loop [] iter = return ()+ loop (x:xs) iter = do+ case dynTag x of+ #{const DBUS_TYPE_INVALID} -> fail $ "Unsupported dynamic value: " ++ show x+ #{const DBUS_TYPE_UINT32} -> toIter (fromDyn x (0 :: Word32)) iter+ #{const DBUS_TYPE_INT32} -> toIter (fromDyn x (0 :: Int32)) iter+ #{const DBUS_TYPE_STRING} -> toIter (fromDyn x ("" :: String)) iter+ loop xs iter+ in loop list iter+ signature _ = "d"++foreign import ccall unsafe "dbus_message_iter_init"+ message_iter_init :: MessageP -> Iter -> IO Bool+foreign import ccall unsafe "dbus_message_iter_init_append"+ message_iter_init_append :: MessageP -> Iter -> IO ()+foreign import ccall unsafe "dbus_message_iter_get_arg_type"+ message_iter_get_arg_type :: Iter -> IO Int+foreign import ccall unsafe "dbus_message_iter_get_element_type"+ message_iter_get_element_type :: Iter -> IO Int+foreign import ccall unsafe "dbus_message_iter_get_basic"+ message_iter_get_basic :: Iter -> Ptr a -> IO ()+foreign import ccall unsafe "dbus_message_iter_get_array_len"+ message_iter_get_array_len :: Iter -> IO CInt+foreign import ccall unsafe "dbus_message_iter_recurse"+ message_iter_recurse :: Iter -> Iter -> IO ()+foreign import ccall unsafe "dbus_message_iter_next"+ message_iter_next :: Iter -> IO Bool+foreign import ccall unsafe "dbus_message_iter_append_basic"+ message_iter_append_basic :: Iter -> CInt -> Ptr a -> IO Bool+foreign import ccall unsafe "dbus_message_iter_open_container"+ message_iter_open_container :: Iter -> CInt -> CString -> Iter -> IO Bool+foreign import ccall unsafe "dbus_message_iter_close_container"+ message_iter_close_container :: Iter -> Iter -> IO Bool++withIter = allocaBytes #{size DBusMessageIter}++-- |Retrieve the arguments from a message.+args :: (Arg a) => Message -> IO a+args msg =+ withForeignPtr msg $ \msg -> do+ withIter $ \iter -> do+ has_args <- message_iter_init msg iter+ fromIter iter++-- |Add arguments to a message.+addArgs :: (Arg a) => Message -> a -> IO ()+addArgs msg arg =+ withForeignPtr msg $ \msg ->+ allocInit #{size DBusMessageIter} (message_iter_init_append msg) $ \iter ->+ toIterInternal arg iter++-- vim: set ts=2 sw=2 tw=72 et ft=haskell :
@@ -0,0 +1,36 @@+-- HDBus -- Haskell bindings for D-Bus.+-- Copyright (C) 2006 Evan Martin <martine@danga.com>++-- tell Haddock not to doc this module:+-- #hide++#define DBUS_API_SUBJECT_TO_CHANGE+#include "dbus/dbus.h"++module DBus.Shared (+ -- * Constants+ -- |Well-known service, path, and interface names.+ ServiceName, PathName, InterfaceName,+ serviceDBus,+ pathDBus, pathLocal,+ interfaceDBus, interfaceIntrospectable, interfaceLocal,+ +) where++import Foreign+import Foreign.C.String++type ServiceName = String+type PathName = FilePath+type InterfaceName = String+serviceDBus :: ServiceName+pathDBus, pathLocal :: PathName+interfaceDBus, interfaceIntrospectable, interfaceLocal :: InterfaceName+serviceDBus = #{const_str DBUS_SERVICE_DBUS}+pathDBus = #{const_str DBUS_PATH_DBUS}+pathLocal = #{const_str DBUS_PATH_LOCAL}+interfaceDBus = #{const_str DBUS_INTERFACE_DBUS}+interfaceIntrospectable = #{const_str DBUS_INTERFACE_INTROSPECTABLE}+interfaceLocal = #{const_str DBUS_INTERFACE_LOCAL}++-- vim: set ts=2 sw=2 tw=72 et ft=haskell :
+ LICENSE view
@@ -0,0 +1,23 @@+Copyright (c) 2006 Evan Martin <martine@danga.com>+All rights reserved.+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * The name of the author may not be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE REGENTS AND CONTRIBUTORS BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,25 @@+HDBus -- Haskell bindings for D-Bus.+Copyright (C) 2006 Evan Martin <martine@danga.com>++== About+"D-Bus is a message bus system, a simple way for applications to talk to one+another." It's particularly popular on free software desktops (Gnome, KDE).+See http://www.freedesktop.org/wiki/Software/dbus for details.++== Installation+You must have the D-Bus headers and libraries installed.+Install on Debian-based systems with:+ apt-get install libdbus-1-dev+Check your installation with:+ pkg-config --modversion dbus-1++The module code is in module/, and it's the standard series of cabal steps:+ runhaskell Setup.lhs configure+ runhaskell Setup.lhs build+ runhaskell Setup.lhs install++== How to Use it+See demo/Demo.hs for some example calls.++== License+BSD. See module/LICENSE for details.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/runhaskell+> import Distribution.Simple+> main = defaultMainWithHooks autoconfUserHooks
+ configure.ac view
@@ -0,0 +1,5 @@+AC_INIT([HDBus], [0.1], [martine@danga.com], [HDBus])+AC_CONFIG_SRCDIR([DBus.cabal])+PKG_CHECK_MODULES(DBUS, [dbus-1])+AC_CONFIG_FILES([DBus.buildinfo])+AC_OUTPUT
+ demo/Demo.hs view
@@ -0,0 +1,84 @@+{-# OPTIONS -fglasgow-exts -fallow-overlapping-instances #-}+-- HDBus -- Haskell bindings for DBus.+-- Copyright (C) 2006 Evan Martin <martine@danga.com>++import qualified DBus+import qualified DBus.Connection+import qualified DBus.Message+import Control.Exception+import Data.Int+import Data.Word++main :: IO ()+main = do+ DBus.Connection.withConnection DBus.Connection.Session $ \bus -> do+ (t1 :: [String]) <- testMethodCall bus DBus.serviceDBus DBus.pathDBus+ DBus.interfaceDBus "ListNames" ()+ (t2 :: String) <- testMethodCall bus DBus.serviceDBus DBus.pathDBus+ DBus.interfaceIntrospectable "Introspect" ()++ --testGaim bus+ --testBmp bus+ testNotify bus++ signalTest bus++testGaim bus = do+ accounts <- gaimCall "GaimAccountsGetAll" ()+ let account :: Int32 = head accounts+ username <- gaimCall "GaimAccountGetUsername" account+ putStrLn $ "First account is " ++ username ++ "." where+ gaimCall :: (DBus.Message.Arg a, DBus.Message.Arg b) => String -> a -> IO b+ gaimCall = testMethodCall bus "net.sf.gaim.GaimService"+ "/net/sf/gaim/GaimObject"+ "net.sf.gaim.GaimInterface"++testBmp bus = do+ bmpCall "VolumeGet" []+ bmpCall "VolumeSet" [50 :: Int32] where+ bmpCall = testMethodCall bus "org.beepmediaplayer.bmp" "/SystemControl" "org.beepmediaplayer.bmp"++testNotify bus = do+ -- For details on this API, see the desktop notification spec at+ -- http://www.galago-project.org/specs/notification/+ let args = ("hdbus",+ 0 :: Word32, -- don't replace anybody+ "", -- no icon+ "hdbus calling",+ "This message was sent via hdbus.",+ [] :: [String],+ [] :: DBus.Message.Dict String DBus.Message.Variant,+ 3*1000 :: Int32 -- timeout+ )+ () <- notifyCall "Notify" args+ return () where+ notifyCall = testMethodCall bus "org.freedesktop.Notifications"+ "/org/freedesktop/Notifications"+ "org.freedesktop.Notifications"++showArgs :: DBus.Message.Arg a => a -> String+showArgs args = show args ++ " (sig: " ++ DBus.Message.signature args ++ ")"++testMethodCall :: (DBus.Message.Arg a, DBus.Message.Arg b)+ => DBus.Connection.Connection+ -> DBus.ServiceName -> DBus.PathName -> DBus.InterfaceName+ -> String -> a -> IO b+testMethodCall bus name path iface method args = do+ putStrLn ""+ putStrLn $ "Calling: " ++ show [name, path, iface, method]+ putStrLn $ " with args:" ++ showArgs args+ do+ msg <- DBus.Message.newMethodCall name path iface method+ DBus.Message.addArgs msg args+ reply <- DBus.Connection.sendWithReplyAndBlock bus msg 2000+ replyargs <- DBus.Message.args reply+ putStrLn $ "Result: " ++ showArgs replyargs+ return replyargs+ `catchDyn` (\(e :: DBus.Error) -> do print e; fail "fatal: dbus error")++signalTest bus = do+ msg <- DBus.Message.newSignal "/org/neugierig/HDBusTest" "org.neugierg.HDBus" "Test"+ ret <- DBus.Connection.send bus msg 0+ print ret++-- vim: set ts=2 sw=2 et ft=haskell :
+ demo/Monitor.hs view
@@ -0,0 +1,132 @@+{-# OPTIONS -fglasgow-exts #-}++-- ghc --make -ldbus-1 -o monitor Monitor.hs++import qualified DBus+import qualified DBus.Connection+import qualified DBus.Message+import Control.Exception(catchDyn)+import Data.Int+import Data.Word+import Data.Dynamic+import DBus.Message(Arg, variant)+import DBus.Connection(withConnection, readWriteDispatch, addFilter, addMatch, BusType(Session))+++type Variant = DBus.Message.Variant+type Bus = DBus.Connection.Connection+type NotifyArgs = (String, Word32, String, String, String,+ [String], DBus.Message.Dict String Variant, Int32)+++main :: IO ()+main = do+ let loop bus = (readWriteDispatch bus (-1) >> loop bus)+ withConnection Session $ \bus -> do+ addFilter bus $ \msg -> do+ path <- DBus.Message.getPath msg+ iface <- DBus.Message.getInterface msg+ member <- DBus.Message.getMember msg+ src <- DBus.Message.getSender msg+ dst <- DBus.Message.getDestination msg+ errname <- DBus.Message.getErrorName msg+ sig <- DBus.Message.getSignature msg+ t <- DBus.Message.getType msg+ let cstr (Just s) = s+ cstr (Nothing) = "null"+ let s = "sender="++ cstr src ++ " -> dest="++cstr dst ++ " sig=" ++ sig+ let ms = s ++ " path=" ++ cstr path ++ "; interface="++ cstr iface+ ++ "; member=" ++ cstr member ++ "\n"+ case t of+ DBus.Message.MethodCall -> putStr $ "Call " ++ ms+ DBus.Message.MethodReturn -> putStr $ "Return " ++ s ++ "\n"+ DBus.Message.Error -> putStr $ "Error " ++ s ++ " errname=" ++ cstr errname ++ "\n"+ DBus.Message.Signal -> putStr $ "Signal " ++ ms+ DBus.Message.Other x -> putStr $ "Other: " ++ (show x) ++ ms+ vars <- variantArgs msg+ mapM_ (\var -> do+ putStr "\t"+ print var)+ vars+ return True+ addMatch bus False "type='method_call'"+ addMatch bus False "type='method_return'"+ addMatch bus False "type='error'"+ addMatch bus False "type='signal'"+ loop bus++data Tagged = I32 Int32 | W32 Word32 | S String | A [Dynamic] | B Bool | E [Dynamic] [Dynamic] | Invalid++tag :: Dynamic -> Tagged+tag dyn =+ case fromDynamic dyn of+ Just (i :: Int32) -> I32 i+ Nothing ->+ case fromDynamic dyn of+ Just (word :: Word32) -> W32 word+ Nothing ->+ case fromDynamic dyn of+ Just (s :: String) -> S s + Nothing ->+ case fromDynamic dyn of+ Just (arr :: [Dynamic]) -> A arr+ Nothing ->+ case fromDynamic dyn of+ Just (b :: Bool) -> B b+ Nothing ->+ case fromDynamic dyn of+ Just (a, b) -> E a b+ Nothing -> Invalid++toVariant :: Dynamic -> Variant+toVariant dyn =+ case tag dyn of+ I32 i -> variant i+ W32 w -> variant w+ S s -> variant s+ A arr -> variant (map toVariant arr)+ B b -> variant (if b then (1 :: Int32) else 0)+ E a b -> variant (map toVariant a, map toVariant b)+ Invalid -> variant "<invalid>"++variantArgs msg = do+ (args :: [Dynamic]) <- DBus.Message.args msg+ return $ map toVariant args++{-+variantArgs msg =+ let load msg =+ do args <- DBus.Message.args msg;+ return args+ try cmp els =+ catch (do val <- cmp+ return $ DBus.Message.variant val)+ (\err -> els)+ in try ((load msg) :: IO [Dynamic]) $+ try ((load msg) :: IO Int32) $+ try ((load msg) :: IO Word32) $+ try ((load msg) :: IO String) $+ try ((load msg) :: IO ()) $+ try ((load msg) :: IO [Int32]) $+ try ((load msg) :: IO [Word32]) $+ try ((load msg) :: IO [String]) $+ try ((load msg) :: IO [()]) $+ try ((load msg) :: IO NotifyArgs) $+ try ((load msg) :: IO Variant)+ (putStr "variantArgs failed\n" >> fail "Cannot figure out the type\n")+-}++{-+snoop :: Arg a => DBus.Message.Message -> IO a+snoop msg = do+ args <- DBus.Message.args msg+ print (DBus.Message.variant args)+ return args++eat :: IO a -> IO ()+eat cmp = cmp >> return ()++try :: IO a -> IO () -> IO ()+try cmp els =+ catch (eat cmp) (\err -> els)+-}
+ doc-prologue.txt view
@@ -0,0 +1,12 @@+See the HDBus home page (<http://neugierig.org/software/hdbus/>) for details.++This documentation assumes you already know how the D-Bus API works.++* See the D-Bus wiki+ (<http://www.freedesktop.org/wiki/Software/dbus>) for an overview.++* See the D-Bus low-level API tutorial+ (<http://www.matthew.ath.cx/misc/dbus>) for more detail.++* See the D-Bus API reference+ (<http://dbus.freedesktop.org/doc/api/html/>) for per-function documentation.