diff options
author | 2012-10-26 00:10:41 -0400 | |
---|---|---|
committer | 2012-10-26 00:10:41 -0400 | |
commit | 89a33e4ce1219dff81f6c5fd296b6e6ba6866ea3 (patch) | |
tree | d5d88ff78f40fd9e4fc932a5ccfadcf9b17fdd31 /Utility/DBus.hs | |
parent | b4f43466b1100b158d2a69c01e646896ba34494f (diff) | |
parent | 0a87d90900949e6f7e75ab2ac83b4135746d7602 (diff) |
Merge branch 'master' into xmpp
Conflicts:
Assistant/Threads/MountWatcher.hs
Assistant/Threads/NetWatcher.hs
Diffstat (limited to 'Utility/DBus.hs')
-rw-r--r-- | Utility/DBus.hs | 57 |
1 files changed, 57 insertions, 0 deletions
diff --git a/Utility/DBus.hs b/Utility/DBus.hs index cfd06f762..3b34e00ac 100644 --- a/Utility/DBus.hs +++ b/Utility/DBus.hs @@ -12,6 +12,8 @@ module Utility.DBus where import DBus.Client import DBus import Data.Maybe +import Control.Concurrent +import Control.Exception as E type ServiceName = String @@ -26,3 +28,58 @@ callDBus client name params = call_ client $ { methodCallDestination = Just "org.freedesktop.DBus" , methodCallBody = params } + +{- Connects to the bus, and runs the client action. + - + - Throws a ClientError, and closes the connection if it fails to + - process an incoming message, or if the connection is lost. + - Unlike DBus's usual interface, this error is thrown at the top level, + - rather than inside the clientThreadRunner, so it can be caught, and + - runClient re-run as needed. -} +runClient :: IO (Maybe Address) -> (Client -> IO ()) -> IO () +runClient getaddr clientaction = do + env <- getaddr + case env of + Nothing -> throwIO (clientError "runClient: unable to determine DBUS address") + Just addr -> do + {- The clientaction will set up listeners, which + - run in a different thread. We block while + - they're running, until our threadrunner catches + - a ClientError, which it will put into the MVar + - to be rethrown here. -} + mv <- newEmptyMVar + let tr = threadrunner (putMVar mv) + let opts = defaultClientOptions { clientThreadRunner = tr } + client <- connectWith opts addr + clientaction client + e <- takeMVar mv + disconnect client + throw e + where + threadrunner storeerr io = loop + where + loop = catchClientError (io >> loop) storeerr + +{- Connects to the bus, and runs the client action. + - + - If the connection is lost, runs onretry, which can do something like + - a delay, or printing a warning, and has a state value (useful for + - exponential backoff). Once onretry returns, the connection is retried. + - + - Warning: Currently connectWith can throw a SocketError and leave behind + - an open FD. So each retry leaks one FD. -} +persistentClient :: IO (Maybe Address) -> v -> (SomeException -> v -> IO v) -> (Client -> IO ()) -> IO () +persistentClient getaddr v onretry clientaction = do + {- runClient can fail with not just ClientError, but also other + - things, if dbus is not running. -} + r <- E.try (runClient getaddr clientaction) :: IO (Either SomeException ()) + either retry return r + where + retry e = do + v' <- onretry e v + persistentClient getaddr v' onretry clientaction + +{- Catches only ClientError -} +catchClientError :: IO () -> (ClientError -> IO ()) -> IO () +catchClientError io handler = do + either handler return =<< (E.try io :: IO (Either ClientError ())) |