git-annex/Assistant/Threads/NetWatcher.hs

{- 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