#line 19 "src/bus.anansi"
#line 30 "src/introduction.anansi"
#line 20 "src/bus.anansi"
#line 52 "src/introduction.anansi"
#line 21 "src/bus.anansi"
module DBus.Bus
( getBus
, getFirstBus
, getSystemBus
, getSessionBus
, getStarterBus
) where
#line 56 "src/introduction.anansi"
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as TL
#line 29 "src/bus.anansi"
import qualified Control.Exception as E
import Control.Monad (when)
import Data.Maybe (fromJust, isNothing)
import qualified Data.Set as Set
import System.Environment (getEnv)
import qualified DBus.Address as A
import qualified DBus.Authentication as Auth
import qualified DBus.Connection as C
import DBus.Constants (dbusName, dbusPath, dbusInterface)
import qualified DBus.Message as M
import qualified DBus.Types as T
import DBus.Util (fromRight)
#line 50 "src/bus.anansi"
busForConnection :: C.Connection -> IO (C.Connection, T.BusName)
busForConnection c = fmap ((,) c) $ sendHello c
#line 99 "src/api-docs.anansi"
#line 54 "src/bus.anansi"
getBus :: Auth.Mechanism -> A.Address -> IO (C.Connection, T.BusName)
getBus = ((busForConnection =<<) .) . C.connect
#line 62 "src/bus.anansi"
#line 104 "src/api-docs.anansi"
#line 63 "src/bus.anansi"
getFirstBus :: [(Auth.Mechanism, A.Address)] -> IO (C.Connection, T.BusName)
getFirstBus = (busForConnection =<<) . C.connectFirst
#line 74 "src/bus.anansi"
#line 109 "src/api-docs.anansi"
#line 75 "src/bus.anansi"
getSystemBus :: IO (C.Connection, T.BusName)
getSystemBus = getBus' $ fromEnv `E.catch` noEnv where
defaultAddr = "unix:path=/var/run/dbus/system_bus_socket"
fromEnv = getEnv "DBUS_SYSTEM_BUS_ADDRESS"
noEnv (E.SomeException _) = return defaultAddr
#line 116 "src/api-docs.anansi"
#line 82 "src/bus.anansi"
getSessionBus :: IO (C.Connection, T.BusName)
getSessionBus = getBus' $ getEnv "DBUS_SESSION_BUS_ADDRESS"
#line 121 "src/api-docs.anansi"
#line 86 "src/bus.anansi"
getStarterBus :: IO (C.Connection, T.BusName)
getStarterBus = getBus' $ getEnv "DBUS_STARTER_ADDRESS"
#line 91 "src/bus.anansi"
getBus' :: IO String -> IO (C.Connection, T.BusName)
getBus' io = do
addr <- fmap TL.pack io
case A.mkAddresses addr of
Just [x] -> getBus Auth.realUserID x
Just xs -> getFirstBus [(Auth.realUserID,x) | x <- xs]
_ -> E.throwIO $ C.InvalidAddress addr
#line 103 "src/bus.anansi"
hello :: M.MethodCall
hello = M.MethodCall dbusPath
"Hello"
(Just dbusInterface)
(Just dbusName)
Set.empty
[]
#line 113 "src/bus.anansi"
sendHello :: C.Connection -> IO T.BusName
sendHello c = do
serial <- fromRight `fmap` C.send c return hello
reply <- waitForReply c serial
let name = case M.methodReturnBody reply of
(x:_) -> T.fromVariant x
_ -> Nothing
when (isNothing name) $
E.throwIO $ E.AssertionFailed "Invalid response to Hello()"
return . fromJust $ name
#line 128 "src/bus.anansi"
waitForReply :: C.Connection -> M.Serial -> IO M.MethodReturn
waitForReply c serial = do
received <- C.receive c
msg <- case received of
Right x -> return x
Left _ -> E.throwIO $ E.AssertionFailed "Invalid response to Hello()"
case msg of
(M.ReceivedMethodReturn _ _ reply) ->
if M.methodReturnSerial reply == serial
then return reply
else waitForReply c serial
_ -> waitForReply c serial