add NetWatcher thread

This deals with interruptions in network connectevity, by listening
for a new network interface coming up (using dbus to see when
network-manager or wicd do it), and forcing a rescan of

2 files changed, 152 insertions, 15 deletions

diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs
index 83f582a91..82de186cc 100644
--- a/Assistant/Threads/MountWatcher.hs
+++ b/Assistant/Threads/MountWatcher.hs
@@ -31,6 +31,7 @@ import qualified Data.Set as S
 import Data.Time.Clock
 
 #if WITH_DBUS
+import Utility.DBus
 import DBus.Client
 import DBus
 import Data.Word (Word32)
@@ -78,20 +79,6 @@ dbusThread st dstatus scanremotes = E.catch (go =<< connectSession) onerr
 			pollinstead
 		pollinstead = pollingThread st dstatus scanremotes
 
-type ServiceName = String
-
-listServiceNames :: Client -> IO [ServiceName]
-listServiceNames client = do
-	reply <- callDBus client "ListNames" []
-	return $ fromMaybe [] $ fromVariant (methodReturnBody reply !! 0)
-
-callDBus :: Client -> MemberName -> [Variant] -> IO MethodReturn
-callDBus client name params = call_ client $
-	(methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" name)
-		{ methodCallDestination = Just "org.freedesktop.DBus"
-		, methodCallBody = params
-		}
-
 {- Examine the list of services connected to dbus, to see if there
  - are any we can use to monitor mounts. If not, will attempt to start one. -}
 checkMountMonitor :: Client -> IO Bool
@@ -164,7 +151,7 @@ handleMount st dstatus scanremotes dir = do
 		let nonspecial = filter (Git.repoIsLocal . Remote.repo) rs
 		unless (null nonspecial) $ do
 			void $ alertWhile dstatus (syncAlert nonspecial) $ do
-				debug thisThread ["syncing with", show rs]
+				debug thisThread ["syncing with", show nonspecial]
 				sync nonspecial =<< runThreadState st (inRepo Git.Branch.current)
 			addScanRemotes scanremotes nonspecial
 	where
diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs
new file mode 100644
index 000000000..d871a4791
--- /dev/null
+++ b/Assistant/Threads/NetWatcher.hs
@@ -0,0 +1,150 @@
+{- git-annex assistant network connection watcher, using dbus
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Assistant.Threads.NetWatcher where
+
+import Assistant.Common
+import Assistant.ThreadedMonad
+import Assistant.DaemonStatus
+import Assistant.ScanRemotes
+import Assistant.Threads.Pusher (pushToRemotes)
+import Assistant.Alert
+import qualified Git
+import Utility.ThreadScheduler
+import Remote.List
+import qualified Types.Remote as Remote
+import Assistant.Threads.Merger
+import qualified Git.Branch
+
+import qualified Control.Exception as E
+import Data.Time.Clock
+
+#if WITH_DBUS
+import Utility.DBus
+import DBus.Client
+import DBus
+import Data.Word (Word32)
+#else
+#warning Building without dbus support; will poll for network connection changes
+#endif
+
+thisThread :: ThreadName
+thisThread = "NetWatcher"
+
+netWatcherThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> IO ()
+netWatcherThread st handle scanremotes =
+#if WITH_DBUS
+	dbusThread st handle scanremotes
+#else
+	pollingThread st handle scanremotes
+#endif
+
+#if WITH_DBUS
+
+dbusThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> IO ()
+dbusThread st dstatus scanremotes = E.catch (go =<< connectSystem) onerr
+	where
+		go client = ifM (checkNetMonitor client)
+			( do
+				listenNMConnections client handle
+				listenWicdConnections client handle
+			, do
+				runThreadState st $
+					warning "No known network monitor available through dbus; falling back to polling"
+				pollinstead
+			)
+		onerr :: E.SomeException -> IO ()
+		onerr e = do
+			runThreadState st $
+				warning $ "Failed to use dbus; falling back to polling (" ++ show e ++ ")"
+			pollinstead
+		pollinstead = pollingThread st dstatus scanremotes
+		handle = do
+			debug thisThread ["detected network connection"]
+			handleConnection st dstatus scanremotes
+
+{- Examine the list of services connected to dbus, to see if there
+ - are any we can use to monitor network connections. -}
+checkNetMonitor :: Client -> IO Bool
+checkNetMonitor client = do
+	running <- filter (`elem` [networkmanager, wicd])
+		<$> listServiceNames client
+	case running of
+		[] -> return False
+		(service:_) -> do
+			debug thisThread [ "Using running DBUS service"
+				, service
+				, "to monitor network connection events."
+				]
+			return True
+	where
+		networkmanager = "org.freedesktop.NetworkManager"
+		wicd = "org.wicd.daemon"
+
+{- Listens for new NetworkManager connections. -}
+listenNMConnections :: Client -> IO () -> IO ()
+listenNMConnections client callback =
+	listen client matcher $ \event ->
+		when (Just True == anyM activeconnection (signalBody event)) $
+			callback
+	where
+		matcher = matchAny
+			{ matchInterface = Just "org.freedesktop.NetworkManager.Connection.Active"
+			, matchMember = Just "PropertiesChanged"
+			}
+		nm_connection_activated = toVariant (2 :: Word32)
+		nm_state_key = toVariant ("State" :: String)
+		activeconnection v = do
+			m <- fromVariant v
+			vstate <- lookup nm_state_key $ dictionaryItems m
+			state <- fromVariant vstate
+			return $ state == nm_connection_activated
+
+{- Listens for new Wicd connections. -}
+listenWicdConnections :: Client -> IO () -> IO ()
+listenWicdConnections client callback =
+	listen client matcher $ \event ->
+		when (any (== wicd_success) (signalBody event)) $
+			callback
+	where
+		matcher = matchAny
+			{ matchInterface = Just "org.wicd.daemon"
+			, matchMember = Just "ConnectResultsSent"
+			}
+		wicd_success = toVariant ("success" :: String)
+
+#endif
+
+pollingThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> IO ()
+pollingThread st dstatus scanremotes = runEvery (Seconds 3600) $
+	handleConnection st dstatus scanremotes
+
+handleConnection :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> IO ()
+handleConnection st dstatus scanremotes = do
+	rs <- networkRemotes st
+	unless (null rs) $ do
+		let nonspecial = filter (Git.repoIsUrl . Remote.repo) rs
+		unless (null nonspecial) $ do
+			void $ alertWhile dstatus (syncAlert nonspecial) $ do
+				debug thisThread ["syncing with", show nonspecial]
+				sync nonspecial =<< runThreadState st (inRepo Git.Branch.current)
+			addScanRemotes scanremotes nonspecial
+	where
+		sync rs (Just branch) = do
+			runThreadState st $ manualPull (Just branch) rs
+			now <- getCurrentTime
+			pushToRemotes thisThread now st Nothing rs
+		sync _ _ = return True
+
+{- Finds network remotes. -}
+networkRemotes :: ThreadState -> IO [Remote]
+networkRemotes st = runThreadState st $ do
+	rs <- remoteList
+	return $ filter (isNothing . Remote.path) rs