blob: 6ac7203b0f9b079494d249a6eb28fd7421416713 (
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
|
{- 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 Remote.List
import qualified Types.Remote as Remote
#if WITH_DBUS
import Utility.DBus
import DBus.Client
import DBus
import Data.Word (Word32)
import Assistant.NetMessager
#else
#warning Building without dbus support; will poll for network connection changes
#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. -}
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
listenNMConnections client <~> handleconn
listenWicdConnections client <~> handleconn
, do
liftAnnex $
warning "No known network monitor available through dbus; falling back to polling"
)
handleconn = do
debug ["detected network connection"]
notifyNetMessagerRestart
handleConnection
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 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
handleConnection :: Assistant ()
handleConnection = reconnectRemotes True =<< networkRemotes
{- Finds network remotes. -}
networkRemotes :: Assistant [Remote]
networkRemotes = liftAnnex $
filter (isNothing . Remote.localpath) <$> remoteList
|
