webapp: remind user when using repositories that lack consistency checks

When starting up the assistant, it'll remind about the current
repository, if it doesn't have checks. And when a removable drive
is plugged in, it will remind if a repository on it lacks checks.

Since that might be annoying, the reminders can be turned off.

This commit was sponsored by Nedialko Andreev.

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.Fsck
-import Assistant.Repair
 import qualified Git
+import qualified Git.Fsck
+import Assistant.Fsck
+import Assistant.Repair
 
 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)

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.

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

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. -}