reconnect XMPP when NetWatcher notices a change

4 files changed, 38 insertions, 13 deletions

diff --git a/Assistant/Pushes.hs b/Assistant/Pushes.hs
index 7842c1884..49772d56a 100644
--- a/Assistant/Pushes.hs
+++ b/Assistant/Pushes.hs
@@ -11,6 +11,7 @@ import Common.Annex
 import Utility.TSet
 
 import Control.Concurrent.STM
+import Control.Concurrent.MSampleVar
 import Data.Time.Clock
 import qualified Data.Map as M
 
@@ -18,8 +19,13 @@ import qualified Data.Map as M
 type PushMap = M.Map Remote UTCTime
 type FailedPushMap = TMVar PushMap
 
-{- Used to notify about successful pushes. -}
-newtype PushNotifier = PushNotifier (TSet UUID)
+{- The TSet is recent, successful pushes that other remotes should be
+ - notified about.
+ -
+ - The MSampleVar is written to when the PushNotifier thread should be
+ - restarted for some reason.
+ -}
+data PushNotifier = PushNotifier (TSet UUID) (MSampleVar ())
 
 {- The TMVar starts empty, and is left empty when there are no
  - failed pushes. This way we can block until there are some failed pushes.
@@ -50,10 +56,18 @@ changeFailedPushMap v a = atomically $
 			| otherwise = putTMVar v $! m
 
 newPushNotifier :: IO PushNotifier
-newPushNotifier = PushNotifier <$> newTSet
+newPushNotifier = PushNotifier
+	<$> newTSet
+	<*> newEmptySV
 
 notifyPush :: [UUID] -> PushNotifier -> IO ()
-notifyPush us (PushNotifier s) = putTSet s us
+notifyPush us (PushNotifier s _) = putTSet s us
 
 waitPush :: PushNotifier -> IO [UUID]
-waitPush (PushNotifier s) = getTSet s
+waitPush (PushNotifier s _) = getTSet s
+
+notifyRestart :: PushNotifier -> IO ()
+notifyRestart (PushNotifier _ sv) = writeSV sv ()
+
+waitRestart :: PushNotifier -> IO ()
+waitRestart (PushNotifier _ sv) = readSV sv
diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs
index 883a7bef5..ed64541c3 100644
--- a/Assistant/Threads/NetWatcher.hs
+++ b/Assistant/Threads/NetWatcher.hs
@@ -70,6 +70,7 @@ dbusThread st dstatus scanremotes pushnotifier =
 			)
 		handleconn = do
 			debug thisThread ["detected network connection"]
+			notifyRestart pushnotifier
 			handleConnection st dstatus scanremotes pushnotifier
 		onerr e _ = do
 			runThreadState st $
diff --git a/Assistant/Threads/PushNotifier.hs b/Assistant/Threads/PushNotifier.hs
index 46a1d3ebf..f6058b465 100644
--- a/Assistant/Threads/PushNotifier.hs
+++ b/Assistant/Threads/PushNotifier.hs
@@ -28,12 +28,19 @@ import Data.Time.Clock
 thisThread :: ThreadName
 thisThread = "PushNotifier"
 
+controllerThread :: PushNotifier -> IO () -> IO ()
+controllerThread pushnotifier a = forever $ do
+	tid <- forkIO a
+	waitRestart pushnotifier
+	killThread tid
+
 pushNotifierThread :: ThreadState -> DaemonStatusHandle -> PushNotifier -> NamedThread
-pushNotifierThread st dstatus pushnotifier = NamedThread thisThread $ do
-	v <- runThreadState st $ getXMPPCreds
-	case v of
-		Nothing -> return () -- no creds? exit thread
-		Just c -> loop c =<< getCurrentTime
+pushNotifierThread st dstatus pushnotifier = NamedThread thisThread $
+	controllerThread pushnotifier $ do
+		v <- runThreadState st $ getXMPPCreds
+		case v of
+			Nothing -> noop
+			Just c -> loop c =<< getCurrentTime
 	where
 		loop c starttime = do
 			void $ connectXMPP c $ \jid -> do
@@ -53,7 +60,6 @@ pushNotifierThread st dstatus pushnotifier = NamedThread thisThread $ do
 					threadDelaySeconds (Seconds 300)
 					loop c =<< getCurrentTime
 
-		
 		sendnotifications = forever $ do
 			us <- liftIO $ waitPush pushnotifier
 			let payload = [extendedAway, encodePushNotification us]
diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs
index 75d948cbd..2e38189ea 100644
--- a/Assistant/XMPP.hs
+++ b/Assistant/XMPP.hs
@@ -16,7 +16,7 @@ import Network
 import Control.Concurrent
 import qualified Data.Text as T
 import Data.XML.Types
-import Control.Exception as E
+import Control.Exception (SomeException)
 
 {- Everything we need to know to connect to an XMPP server. -}
 data XMPPCreds = XMPPCreds
@@ -53,7 +53,11 @@ connectXMPP' jid c a = go =<< lookupSRV srvrecord
 				a jid
 			ifM (isEmptyMVar mv) (go rest, return r)
 
-		run h p a' = E.try (runClientError (Server serverjid h p) jid (xmppUsername c) (xmppPassword c) (void a')) :: IO (Either SomeException ())
+		{- Async exceptions are let through so the XMPP thread can
+		 - be killed. -}
+		run h p a' = tryNonAsync $
+			runClientError (Server serverjid h p) jid
+				(xmppUsername c) (xmppPassword c) (void a')
 
 {- XMPP runClient, that throws errors rather than returning an Either -}
 runClientError :: Server -> JID -> T.Text -> T.Text -> XMPP a -> IO a