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
parent
4e765327ca
commit
4dbdc2b666
29 changed files with 299 additions and 280 deletions
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue