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.ThreadedMonad
|
|
import Assistant.DaemonStatus
|
|
import Assistant.ScanRemotes
|
|
import Assistant.Sync
|
|
import qualified Git
|
|
import Utility.ThreadScheduler
|
|
import Remote.List
|
|
import qualified Types.Remote as Remote
|
|
|
|
import qualified Control.Exception as E
|
|
|
|
#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
|
|
syncRemotes thisThread st dstatus scanremotes =<<
|
|
filter (Git.repoIsUrl . Remote.repo)
|
|
<$> networkRemotes st
|
|
|
|
{- Finds network remotes. -}
|
|
networkRemotes :: ThreadState -> IO [Remote]
|
|
networkRemotes st = runThreadState st $ do
|
|
rs <- remoteList
|
|
return $ filter (isNothing . Remote.path) rs
|