Assistant monad, stage 2.5

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.
This commit is contained in:
Joey Hess 2012-10-29 02:21:04 -04:00
parent 4e765327ca
commit 4dbdc2b666
29 changed files with 299 additions and 280 deletions

View file

@ -11,9 +11,6 @@
module Assistant.Threads.NetWatcher where
import Assistant.Common
import Assistant.ThreadedMonad
import Assistant.DaemonStatus
import Assistant.ScanRemotes
import Assistant.Sync
import Assistant.Pushes
import Utility.ThreadScheduler
@ -29,72 +26,67 @@ import Data.Word (Word32)
#warning Building without dbus support; will poll for network connection changes
#endif
thisThread :: ThreadName
thisThread = "NetWatcher"
netWatcherThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> NamedThread
netWatcherThread :: NamedThread
#if WITH_DBUS
netWatcherThread st dstatus scanremotes pushnotifier = thread $
dbusThread st dstatus scanremotes pushnotifier
netWatcherThread = thread dbusThread
#else
netWatcherThread _ _ _ _ = thread noop
netWatcherThread = thread noop
#endif
where
thread = NamedThread thisThread
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 :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> NamedThread
netWatcherFallbackThread st dstatus scanremotes pushnotifier = thread $
runEvery (Seconds 3600) $
handleConnection st dstatus scanremotes pushnotifier
where
thread = NamedThread thisThread
netWatcherFallbackThread :: NamedThread
netWatcherFallbackThread = NamedThread "NetWatcherFallback" $
runEvery (Seconds 3600) <~> handleConnection
#if WITH_DBUS
dbusThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> IO ()
dbusThread st dstatus scanremotes pushnotifier =
persistentClient getSystemAddress () onerr go
where
go client = ifM (checkNetMonitor client)
( do
listenNMConnections client handleconn
listenWicdConnections client handleconn
, do
runThreadState st $
warning "No known network monitor available through dbus; falling back to polling"
)
handleconn = do
debug thisThread ["detected network connection"]
notifyRestart pushnotifier
handleConnection st dstatus scanremotes pushnotifier
onerr e _ = do
runThreadState st $
warning $ "lost dbus connection; falling back to polling (" ++ show e ++ ")"
{- Wait, in hope that dbus will come back -}
threadDelaySeconds (Seconds 60)
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 -> IO Bool
checkNetMonitor :: Client -> Assistant Bool
checkNetMonitor client = do
running <- filter (`elem` [networkmanager, wicd])
running <- liftIO $ filter (`elem` [networkmanager, wicd])
<$> listServiceNames client
case running of
[] -> return False
(service:_) -> do
debug thisThread [ "Using running DBUS service"
debug [ "Using running DBUS service"
, service
, "to monitor network connection events."
]
return True
where
networkmanager = "org.freedesktop.NetworkManager"
wicd = "org.wicd.daemon"
where
networkmanager = "org.freedesktop.NetworkManager"
wicd = "org.wicd.daemon"
{- Listens for new NetworkManager connections. -}
listenNMConnections :: Client -> IO () -> IO ()
@ -102,18 +94,18 @@ 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
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 ()
@ -121,21 +113,23 @@ 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)
where
matcher = matchAny
{ matchInterface = Just "org.wicd.daemon"
, matchMember = Just "ConnectResultsSent"
}
wicd_success = toVariant ("success" :: String)
#endif
handleConnection :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> IO ()
handleConnection st dstatus scanremotes pushnotifier =
reconnectRemotes thisThread st dstatus scanremotes (Just pushnotifier)
=<< networkRemotes st
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 :: ThreadState -> IO [Remote]
networkRemotes st = runThreadState st $
networkRemotes :: Assistant [Remote]
networkRemotes = liftAnnex $
filter (isNothing . Remote.localpath) <$> remoteList