diff options
| -rw-r--r-- | Assistant/Threads/MountWatcher.hs | 4 | ||||
| -rw-r--r-- | Assistant/Threads/NetWatcher.hs | 4 | ||||
| -rw-r--r-- | Utility/DBus.hs | 57 |
3 files changed, 61 insertions, 4 deletions
diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index 462f5843c..294f9a972 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -51,7 +51,7 @@ mountWatcherThread st handle scanremotes = thread $ #if WITH_DBUS dbusThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> IO () -dbusThread st dstatus scanremotes = E.catch (go =<< connectSession) onerr +dbusThread st dstatus scanremotes = E.catch (runClient getSessionAddress go) onerr where go client = ifM (checkMountMonitor client) ( do @@ -73,7 +73,7 @@ dbusThread st dstatus scanremotes = E.catch (go =<< connectSession) onerr onerr :: E.SomeException -> IO () onerr e = do runThreadState st $ - warning $ "Failed to use dbus; falling back to mtab polling (" ++ show e ++ ")" + warning $ "dbus failed; falling back to mtab polling (" ++ show e ++ ")" pollinstead pollinstead = pollingThread st dstatus scanremotes diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs index a8daa9435..f9ca5641d 100644 --- a/Assistant/Threads/NetWatcher.hs +++ b/Assistant/Threads/NetWatcher.hs @@ -57,7 +57,7 @@ netWatcherFallbackThread st dstatus scanremotes = thread $ #if WITH_DBUS dbusThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> IO () -dbusThread st dstatus scanremotes = E.catch (go =<< connectSystem) onerr +dbusThread st dstatus scanremotes = E.catch (runClient getSystemAddress go) onerr where go client = ifM (checkNetMonitor client) ( do @@ -69,7 +69,7 @@ dbusThread st dstatus scanremotes = E.catch (go =<< connectSystem) onerr ) onerr :: E.SomeException -> IO () onerr e = runThreadState st $ - warning $ "Failed to use dbus; falling back to polling (" ++ show e ++ ")" + warning $ "dbus failed; falling back to polling (" ++ show e ++ ")" handle = do debug thisThread ["detected network connection"] handleConnection st dstatus scanremotes 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 ())) |