diff options
Diffstat (limited to 'Assistant/Threads/MountWatcher.hs')
-rw-r--r-- | Assistant/Threads/MountWatcher.hs | 142 |
1 files changed, 71 insertions, 71 deletions
diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index f36bb8874..cb08071f5 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -11,11 +11,8 @@ module Assistant.Threads.MountWatcher where import Assistant.Common -import Assistant.ThreadedMonad import Assistant.DaemonStatus -import Assistant.ScanRemotes import Assistant.Sync -import Assistant.Pushes import qualified Annex import qualified Git import Utility.ThreadScheduler @@ -39,70 +36,70 @@ import qualified Control.Exception as E thisThread :: ThreadName thisThread = "MountWatcher" -mountWatcherThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> NamedThread -mountWatcherThread st handle scanremotes pushnotifier = thread $ liftIO $ +mountWatcherThread :: NamedThread +mountWatcherThread = NamedThread "MountWatcher" $ #if WITH_DBUS - dbusThread st handle scanremotes pushnotifier + dbusThread #else - pollingThread st handle scanremotes pushnotifier + pollingThread #endif - where - thread = NamedThread thisThread #if WITH_DBUS -dbusThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> IO () -dbusThread st dstatus scanremotes pushnotifier = - E.catch (runClient getSessionAddress go) onerr - where - go client = ifM (checkMountMonitor client) - ( do - {- Store the current mount points in an mvar, - - to be compared later. We could in theory - - work out the mount point from the dbus - - message, but this is easier. -} - mvar <- newMVar =<< currentMountPoints - forM_ mountChanged $ \matcher -> - listen client matcher $ \_event -> do - nowmounted <- currentMountPoints - wasmounted <- swapMVar mvar nowmounted - handleMounts st dstatus scanremotes pushnotifier wasmounted nowmounted - , do - runThreadState st $ - warning "No known volume monitor available through dbus; falling back to mtab polling" - pollinstead - ) - onerr :: E.SomeException -> IO () - onerr e = do - {- If the session dbus fails, the user probably - - logged out of their desktop. Even if they log - - back in, we won't have access to the dbus - - session key, so polling is the best that can be - - done in this situation. -} - runThreadState st $ - warning $ "dbus failed; falling back to mtab polling (" ++ show e ++ ")" - pollinstead - pollinstead = pollingThread st dstatus scanremotes pushnotifier +dbusThread :: Assistant () +dbusThread = do + runclient <- asIO go + r <- liftIO $ E.try $ runClient getSessionAddress runclient + either onerr (const noop) r + where + go client = ifM (checkMountMonitor client) + ( do + {- Store the current mount points in an MVar, to be + - compared later. We could in theory work out the + - mount point from the dbus message, but this is + - easier. -} + mvar <- liftIO $ newMVar =<< currentMountPoints + handleevent <- asIO $ \_event -> do + nowmounted <- liftIO $ currentMountPoints + wasmounted <- liftIO $ swapMVar mvar nowmounted + handleMounts wasmounted nowmounted + liftIO $ forM_ mountChanged $ \matcher -> + listen client matcher handleevent + , do + liftAnnex $ + warning "No known volume monitor available through dbus; falling back to mtab polling" + pollingThread + ) + onerr :: E.SomeException -> Assistant () + onerr e = do + {- If the session dbus fails, the user probably + - logged out of their desktop. Even if they log + - back in, we won't have access to the dbus + - session key, so polling is the best that can be + - done in this situation. -} + liftAnnex $ + warning $ "dbus failed; falling back to mtab polling (" ++ show e ++ ")" + pollingThread {- Examine the list of services connected to dbus, to see if there - are any we can use to monitor mounts. If not, will attempt to start one. -} -checkMountMonitor :: Client -> IO Bool +checkMountMonitor :: Client -> Assistant Bool checkMountMonitor client = do running <- filter (`elem` usableservices) - <$> listServiceNames client + <$> liftIO (listServiceNames client) case running of - [] -> startOneService client startableservices + [] -> liftIO $ startOneService client startableservices (service:_) -> do - brokendebug thisThread [ "Using running DBUS service" + debug [ "Using running DBUS service" , service , "to monitor mount events." ] return True - where - startableservices = [gvfs] - usableservices = startableservices ++ [kde] - gvfs = "org.gtk.Private.GduVolumeMonitor" - kde = "org.kde.DeviceNotifications" + where + startableservices = [gvfs] + usableservices = startableservices ++ [kde] + gvfs = "org.gtk.Private.GduVolumeMonitor" + kde = "org.kde.DeviceNotifications" startOneService :: Client -> [ServiceName] -> IO Bool startOneService _ [] = return False @@ -144,26 +141,29 @@ mountChanged = [gvfs True, gvfs False, kde, kdefallback] #endif -pollingThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> IO () -pollingThread st dstatus scanremotes pushnotifier = go =<< currentMountPoints +pollingThread :: Assistant () +pollingThread = go =<< liftIO currentMountPoints where go wasmounted = do - threadDelaySeconds (Seconds 10) - nowmounted <- currentMountPoints - handleMounts st dstatus scanremotes pushnotifier wasmounted nowmounted + liftIO $ threadDelaySeconds (Seconds 10) + nowmounted <- liftIO currentMountPoints + handleMounts wasmounted nowmounted go nowmounted -handleMounts :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> MountPoints -> MountPoints -> IO () -handleMounts st dstatus scanremotes pushnotifier wasmounted nowmounted = - mapM_ (handleMount st dstatus scanremotes pushnotifier . mnt_dir) $ +handleMounts :: MountPoints -> MountPoints -> Assistant () +handleMounts wasmounted nowmounted = + mapM_ (handleMount . mnt_dir) $ S.toList $ newMountPoints wasmounted nowmounted -handleMount :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> FilePath -> IO () -handleMount st dstatus scanremotes pushnotifier dir = do - brokendebug thisThread ["detected mount of", dir] - reconnectRemotes thisThread st dstatus scanremotes (Just pushnotifier) - =<< filter (Git.repoIsLocal . Remote.repo) - <$> remotesUnder st dstatus dir +handleMount :: FilePath -> Assistant () +handleMount dir = do + debug ["detected mount of", dir] + rs <- filter (Git.repoIsLocal . Remote.repo) <$> remotesUnder dir + d <- getAssistant id + liftIO $ + reconnectRemotes (threadName d) (threadState d) + (daemonStatusHandle d) (scanRemoteMap d) + (Just $ pushNotifier d) rs {- Finds remotes located underneath the mount point. - @@ -173,15 +173,15 @@ handleMount st dstatus scanremotes pushnotifier dir = do - at startup time, or may have changed (it could even be a different - repository at the same remote location..) -} -remotesUnder :: ThreadState -> DaemonStatusHandle -> FilePath -> IO [Remote] -remotesUnder st dstatus dir = runThreadState st $ do - repotop <- fromRepo Git.repoPath - rs <- remoteList - pairs <- mapM (checkremote repotop) rs +remotesUnder :: FilePath -> Assistant [Remote] +remotesUnder dir = do + repotop <- liftAnnex $ fromRepo Git.repoPath + rs <- liftAnnex remoteList + pairs <- liftAnnex $ mapM (checkremote repotop) rs let (waschanged, rs') = unzip pairs when (any id waschanged) $ do - Annex.changeState $ \s -> s { Annex.remotes = rs' } - updateSyncRemotes dstatus + liftAnnex $ Annex.changeState $ \s -> s { Annex.remotes = rs' } + liftAnnex . updateSyncRemotes =<< getAssistant daemonStatusHandle return $ map snd $ filter fst pairs where checkremote repotop r = case Remote.localpath r of |