summaryrefslogtreecommitdiff
path: root/Assistant/Threads/NetWatcher.hs
blob: 09cddd3245ce87ac399a752ccf7a2ef63f09d04c (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
{- 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.Sync
import Utility.ThreadScheduler
import qualified Types.Remote as Remote
import Assistant.DaemonStatus
import Assistant.RemoteControl
import Utility.NotificationBroadcaster

#if WITH_DBUS
import Utility.DBus
import DBus.Client
import DBus
import Assistant.NetMessager
#else
#ifdef linux_HOST_OS
#warning Building without dbus support; will poll for network connection changes
#endif
#endif

netWatcherThread :: NamedThread
#if WITH_DBUS
netWatcherThread = thread dbusThread
#else
netWatcherThread = thread noop
#endif
  where
	thread = namedThread "NetWatcher"

{- This is a fallback for when dbus cannot be used to detect
 - network connection changes, but it also ensures that
 - any networked remotes that may have not been routable for a
 - while (despite the local network staying up), are synced with
 - periodically.
 -
 - Note that it does not call notifyNetMessagerRestart, or
 - signal the RemoteControl, because it doesn't know that the
 - network has changed.
 -}
netWatcherFallbackThread :: NamedThread
netWatcherFallbackThread = namedThread "NetWatcherFallback" $
	runEvery (Seconds 3600) <~> handleConnection

#if WITH_DBUS

dbusThread :: Assistant ()
dbusThread = do
	handleerr <- asIO2 onerr
	runclient <- asIO1 go
	liftIO $ persistentClient getSystemAddress () handleerr runclient
  where
	go client = ifM (checkNetMonitor client)
		( do
			callback <- asIO1 connchange
			liftIO $ do
				listenNMConnections client callback
				listenWicdConnections client callback
		, do
			liftAnnex $
				warning "No known network monitor available through dbus; falling back to polling"
		)
	connchange False = do
		debug ["detected network disconnection"]
		sendRemoteControl LOSTNET
	connchange True = do
		debug ["detected network connection"]
		notifyNetMessagerRestart
		handleConnection
		sendRemoteControl RESUME
	onerr e _ = do
		liftAnnex $
			warning $ "lost dbus connection; falling back to polling (" ++ show e ++ ")"
		{- Wait, in hope that dbus will come back -}
		liftIO $ threadDelaySeconds (Seconds 60)

{- Examine the list of services connected to dbus, to see if there
 - are any we can use to monitor network connections. -}
checkNetMonitor :: Client -> Assistant Bool
checkNetMonitor client = do
	running <- liftIO $ filter (`elem` [networkmanager, wicd])
		<$> listServiceNames client
	case running of
		[] -> return False
		(service:_) -> do
			debug [ "Using running DBUS service"
				, service
				, "to monitor network connection events."
				]
			return True
  where
	networkmanager = "org.freedesktop.NetworkManager"
	wicd = "org.wicd.daemon"

{- Listens for NetworkManager connections and diconnections.
 -
 - Connection example (once fully connected):
 - [Variant {"ActivatingConnection": Variant (ObjectPath "/"), "PrimaryConnection": Variant (ObjectPath "/org/freedesktop/NetworkManager/ActiveConnection/34"), "State": Variant 70}]
 -
 - Disconnection example:
 - [Variant {"ActiveConnections": Variant []}]
 -}
listenNMConnections :: Client -> (Bool -> IO ()) -> IO ()
listenNMConnections client setconnected =
#if MIN_VERSION_dbus(0,10,7)
	void $ addMatch client matcher
#else
	listen client matcher
#endif
		$ \event -> mapM_ handleevent
			(map dictionaryItems $ mapMaybe fromVariant $ signalBody event)
  where
	matcher = matchAny
		{ matchInterface = Just "org.freedesktop.NetworkManager"
		, matchMember = Just "PropertiesChanged"
		}
	nm_active_connections_key = toVariant ("ActiveConnections" :: String)
	nm_activatingconnection_key = toVariant ("ActivatingConnection" :: String)
	noconnections = Just $ toVariant $ toVariant ([] :: [ObjectPath])
	rootconnection = Just $ toVariant $ toVariant $ objectPath_ "/"
	handleevent m
		| lookup nm_active_connections_key m == noconnections =
			setconnected False
		| lookup nm_activatingconnection_key m == rootconnection =
			setconnected True
		| otherwise = noop

{- Listens for Wicd connections and disconnections.
 -
 - Connection example:
 -   ConnectResultsSent:
 -     Variant "success"
 -
 - Diconnection example:
 -   StatusChanged
 -     [Variant 0, Variant [Varient ""]]
 -}
listenWicdConnections :: Client -> (Bool -> IO ()) -> IO ()
listenWicdConnections client setconnected = do
	match connmatcher $ \event ->
		when (any (== wicd_success) (signalBody event)) $
			setconnected True
	match statusmatcher $ \event -> handleevent (signalBody event)
  where
	connmatcher = matchAny
		{ matchInterface = Just "org.wicd.daemon"
		, matchMember = Just "ConnectResultsSent"
		}
	statusmatcher = matchAny
		{ matchInterface = Just "org.wicd.daemon"
		, matchMember = Just "StatusChanged"
		}
	wicd_success = toVariant ("success" :: String)
	wicd_disconnected = toVariant [toVariant ("" :: String)]
	handleevent status
		| any (== wicd_disconnected) status = setconnected False
		| otherwise = noop
	match matcher a = 
#if MIN_VERSION_dbus(0,10,7)
		void $ addMatch client matcher a
#else
		listen client matcher a
#endif
#endif

handleConnection :: Assistant ()
handleConnection = do
	liftIO . sendNotification . networkConnectedNotifier =<< getDaemonStatus
	reconnectRemotes True =<< networkRemotes

{- Network remotes to sync with. -}
networkRemotes :: Assistant [Remote]
networkRemotes = filter (isNothing . Remote.localpath) . syncRemotes
	<$> getDaemonStatus