4dbdc2b666
Converted several threads to run in the monad. Added a lot of useful combinators for working with the monad. Now the monad includes the name of the thread. Some debugging messages are disabled pending converting other threads.
135 lines
3.9 KiB
Haskell
135 lines
3.9 KiB
Haskell
{- 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 Assistant.Pushes
|
|
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)
|
|
#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 <- asIO 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"]
|
|
notifyRestart <<~ pushNotifier
|
|
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 = do
|
|
d <- getAssistant id
|
|
liftIO . reconnectRemotes (threadName d) (threadState d)
|
|
(daemonStatusHandle d) (scanRemoteMap d) (Just $ pushNotifier d)
|
|
=<< networkRemotes
|
|
|
|
{- Finds network remotes. -}
|
|
networkRemotes :: Assistant [Remote]
|
|
networkRemotes = liftAnnex $
|
|
filter (isNothing . Remote.localpath) <$> remoteList
|