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

1 files changed, 150 insertions, 0 deletions

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