module DBus.Connection (
Connection,
BusType(..),
busGet, busConnectionUnref,
send, sendWithReplyAndBlock,
flush, close,
withConnection,
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
| System
| Starter
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
busConnectionUnref :: Connection -> IO ()
busConnectionUnref = finalizeForeignPtr
foreign import ccall unsafe "dbus_bus_get"
bus_get :: CInt -> ErrorP -> IO ConnectionP
busGet :: BusType -> IO Connection
busGet bt = withErrorP (bus_get (toInt bt)) >>= connectionPTOConnection where
toInt Session = 0
toInt System = 1
toInt Starter = 2
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 1 = PrimaryOwner
fromInt 2 = InQueue
fromInt 3 = Exists
fromInt 4 = AlreadyOwner
foreign import ccall unsafe "dbus_connection_close"
connection_close :: ConnectionP -> IO ()
close :: Connection -> IO ()
close conn = withForeignPtr conn connection_close
withConnection :: BusType -> (Connection -> IO a) -> IO a
withConnection bt = bracket (busGet bt) busConnectionUnref
foreign import ccall unsafe "dbus_connection_send"
connection_send :: ConnectionP -> MessageP -> Ptr Word32 -> IO Bool
send :: Connection -> Message
-> Word32
-> IO Word32
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
-> IO PendingCall
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
-> 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 ()
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
readWriteDispatch :: Connection
-> Int
-> IO Bool
readWriteDispatch conn timeout = do
withForeignPtr conn $ \conn ->
connection_read_write_dispatch conn timeout
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
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)
-> 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 0
else return 1
foreign import ccall "dbus_bus_add_match"
bus_add_match :: ConnectionP -> CString -> ErrorP -> IO ()
addMatch :: Connection
-> Bool
-> 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