diff options
Diffstat (limited to 'Assistant/Threads')
-rw-r--r-- | Assistant/Threads/Cronner.hs | 6 | ||||
-rw-r--r-- | Assistant/Threads/MountWatcher.hs | 37 | ||||
-rw-r--r-- | Assistant/Threads/ProblemFixer.hs | 4 | ||||
-rw-r--r-- | Assistant/Threads/SanityChecker.hs | 2 |
4 files changed, 28 insertions, 21 deletions
diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs index df5264d7f..55b3ca2f1 100644 --- a/Assistant/Threads/Cronner.hs +++ b/Assistant/Threads/Cronner.hs @@ -29,9 +29,10 @@ import Assistant.Types.UrlRenderer import Assistant.Alert import Remote import qualified Types.Remote as Remote +import qualified Git import qualified Git.Fsck +import Assistant.Fsck import Assistant.Repair -import qualified Git import Control.Concurrent.Async import Control.Concurrent.MVar @@ -55,6 +56,7 @@ import qualified Data.Set as S - ones, and kill the threads for deleted ones. -} cronnerThread :: UrlRenderer -> NamedThread cronnerThread urlrenderer = namedThreadUnchecked "Cronner" $ do + fsckNudge urlrenderer Nothing dstatus <- getDaemonStatus h <- liftIO $ newNotificationHandle False (scheduleLogNotifier dstatus) go h M.empty M.empty @@ -208,7 +210,7 @@ runActivity' urlrenderer (ScheduledRemoteFsck u s d) = handle =<< liftAnnex (rem - Annex monad. -} go rmt =<< liftAnnex (mkfscker (annexFsckParams d)) go rmt annexfscker = do - fsckresults <- showFscking urlrenderer (Just $ Remote.name rmt) $ tryNonAsync $ do + fsckresults <- showFscking urlrenderer (Just rmt) $ tryNonAsync $ do void annexfscker let r = Remote.repo rmt if Git.repoIsLocal r && not (Git.repoIsLocalUnknown r) diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index c18bfb5bd..39ae67537 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -19,6 +19,8 @@ import Utility.ThreadScheduler import Utility.Mounts import Remote.List import qualified Types.Remote as Remote +import Assistant.Types.UrlRenderer +import Assistant.Fsck import qualified Data.Set as S @@ -33,18 +35,18 @@ import qualified Control.Exception as E #warning Building without dbus support; will use mtab polling #endif -mountWatcherThread :: NamedThread -mountWatcherThread = namedThread "MountWatcher" +mountWatcherThread :: UrlRenderer -> NamedThread +mountWatcherThread urlrenderer = namedThread "MountWatcher" $ #if WITH_DBUS - dbusThread + dbusThread urlrenderer #else - pollingThread + pollingThread urlrenderer #endif #if WITH_DBUS -dbusThread :: Assistant () -dbusThread = do +dbusThread :: UrlRenderer -> Assistant () +dbusThread urlrenderer = do runclient <- asIO1 go r <- liftIO $ E.try $ runClient getSessionAddress runclient either onerr (const noop) r @@ -59,13 +61,13 @@ dbusThread = do handleevent <- asIO1 $ \_event -> do nowmounted <- liftIO $ currentMountPoints wasmounted <- liftIO $ swapMVar mvar nowmounted - handleMounts wasmounted nowmounted + handleMounts urlrenderer 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 + pollingThread urlrenderer ) onerr :: E.SomeException -> Assistant () onerr e = do @@ -76,7 +78,7 @@ dbusThread = do - done in this situation. -} liftAnnex $ warning $ "dbus failed; falling back to mtab polling (" ++ show e ++ ")" - pollingThread + pollingThread urlrenderer {- 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. -} @@ -139,24 +141,25 @@ mountChanged = [gvfs True, gvfs False, kde, kdefallback] #endif -pollingThread :: Assistant () -pollingThread = go =<< liftIO currentMountPoints +pollingThread :: UrlRenderer -> Assistant () +pollingThread urlrenderer = go =<< liftIO currentMountPoints where go wasmounted = do liftIO $ threadDelaySeconds (Seconds 10) nowmounted <- liftIO currentMountPoints - handleMounts wasmounted nowmounted + handleMounts urlrenderer wasmounted nowmounted go nowmounted -handleMounts :: MountPoints -> MountPoints -> Assistant () -handleMounts wasmounted nowmounted = - mapM_ (handleMount . mnt_dir) $ +handleMounts :: UrlRenderer -> MountPoints -> MountPoints -> Assistant () +handleMounts urlrenderer wasmounted nowmounted = + mapM_ (handleMount urlrenderer . mnt_dir) $ S.toList $ newMountPoints wasmounted nowmounted -handleMount :: FilePath -> Assistant () -handleMount dir = do +handleMount :: UrlRenderer -> FilePath -> Assistant () +handleMount urlrenderer dir = do debug ["detected mount of", dir] rs <- filter (Git.repoIsLocal . Remote.repo) <$> remotesUnder dir + mapM_ (fsckNudge urlrenderer . Just) rs reconnectRemotes True rs {- Finds remotes located underneath the mount point. diff --git a/Assistant/Threads/ProblemFixer.hs b/Assistant/Threads/ProblemFixer.hs index f9774e0f0..8095581a6 100644 --- a/Assistant/Threads/ProblemFixer.hs +++ b/Assistant/Threads/ProblemFixer.hs @@ -54,7 +54,7 @@ handleRemoteProblem urlrenderer rmt ifM (liftIO $ checkAvailable True rmt) ( do fixedlocks <- repairStaleGitLocks r - fsckresults <- showFscking urlrenderer (Just $ Remote.name rmt) $ tryNonAsync $ + fsckresults <- showFscking urlrenderer (Just rmt) $ tryNonAsync $ Git.Fsck.findBroken True r repaired <- repairWhenNecessary urlrenderer (Remote.uuid rmt) (Just rmt) fsckresults return $ fixedlocks || repaired @@ -66,5 +66,5 @@ handleRemoteProblem urlrenderer rmt {- This is not yet used, and should probably do a fsck. -} handleLocalRepoProblem :: UrlRenderer -> Assistant Bool -handleLocalRepoProblem urlrenderer = do +handleLocalRepoProblem _urlrenderer = do repairStaleGitLocks =<< liftAnnex gitRepo diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index 4f5eeda50..b03298510 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -33,8 +33,10 @@ import Data.Time.Clock.POSIX - being nonresponsive.) -} sanityCheckerStartupThread :: Maybe Duration -> NamedThread sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerStartup" $ do + {- Stale git locks can prevent commits from happening, etc. -} void $ repairStaleGitLocks =<< liftAnnex gitRepo + {- If there's a startup delay, it's done here. -} liftIO $ maybe noop (threadDelaySeconds . Seconds . fromIntegral . durationSeconds) startupdelay {- Notify other threads that the startup sanity check is done. -} |