improved dbus error handling

Now when the dbus connection is dropped, it'll fall back to polling.

I could make it try to reconnect, but there's a FD leak in the dbus
library, so not yet.

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
 

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

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 ()))