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.

6 files changed, 65 insertions, 29 deletions

diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs
index ff378a7b0..b10a724ed 100644
--- a/Assistant/Alert.hs
+++ b/Assistant/Alert.hs
@@ -15,7 +15,6 @@ import Assistant.Alert.Utility
 import qualified Remote
 import Utility.Tense
 import Logs.Transfer
-import Git.Remote (RemoteName)
 
 import Data.String
 import qualified Data.Text as T
@@ -168,25 +167,54 @@ sanityCheckFixAlert msg = Alert
 	alerthead = "The daily sanity check found and fixed a problem:"
 	alertfoot = "If these problems persist, consider filing a bug report."
 
-fsckAlert :: AlertButton -> Maybe RemoteName -> Alert
-fsckAlert button n = baseActivityAlert
-	{ alertData = case n of
+fsckingAlert :: AlertButton -> Maybe Remote -> Alert
+fsckingAlert button mr = baseActivityAlert
+	{ alertData = case mr of
 		Nothing -> [ UnTensed $ T.pack $ "Consistency check in progress" ]
-		Just remotename -> [ UnTensed $ T.pack $ "Consistency check of " ++ remotename ++ " in progress"]
+		Just r -> [ UnTensed $ T.pack $ "Consistency check of " ++ Remote.name r ++ " in progress"]
 	, alertButton = Just button
 	}
 
-showFscking :: UrlRenderer -> Maybe RemoteName -> IO (Either E.SomeException a) -> Assistant a
-showFscking urlrenderer remotename a = do
+showFscking :: UrlRenderer -> Maybe Remote -> IO (Either E.SomeException a) -> Assistant a
+showFscking urlrenderer mr a = do
 #ifdef WITH_WEBAPP
 	button <- mkAlertButton False (T.pack "Configure") urlrenderer ConfigFsckR
-	r <- alertDuring (fsckAlert button remotename) $
+	r <- alertDuring (fsckingAlert button mr) $
 		liftIO a
 #else
 	r <- liftIO a
 #endif
 	either (liftIO . E.throwIO) return r
 
+notFsckedNudge :: UrlRenderer -> Maybe Remote -> Assistant ()
+#ifdef WITH_WEBAPP
+notFsckedNudge urlrenderer mr = do
+	button <- mkAlertButton True (T.pack "Configure") urlrenderer ConfigFsckR
+	void $ addAlert (notFsckedAlert mr button)
+#else
+notFsckedNudge _ = noop
+#endif
+
+notFsckedAlert :: Maybe Remote -> AlertButton -> Alert
+notFsckedAlert mr button = Alert
+	{ alertHeader = Just $ fromString $ concat
+		[ "You should enable consistency checking to protect your data"
+		, maybe "" (\r -> " in " ++ Remote.name r) mr
+		, "."
+		]
+	, alertIcon = Just InfoIcon
+	, alertPriority = High
+	, alertButton = Just button
+	, alertClosable = True
+	, alertClass = Message
+	, alertMessageRender = renderData
+	, alertCounter = 0
+	, alertBlockDisplay = True
+	, alertName = Just NotFsckedAlert
+	, alertCombiner = Just $ dataCombiner $ \_old new -> new
+	, alertData = []
+	}
+
 brokenRepositoryAlert :: AlertButton -> Alert
 brokenRepositoryAlert = errorAlert "Serious problems have been detected with your repository. This needs your immediate attention!"
 
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. -}
diff --git a/Assistant/Types/Alert.hs b/Assistant/Types/Alert.hs
index 290733b66..2e52ca7ef 100644
--- a/Assistant/Types/Alert.hs
+++ b/Assistant/Types/Alert.hs
@@ -30,6 +30,7 @@ data AlertName
 	| RemoteRemovalAlert String
 	| CloudRepoNeededAlert
 	| SyncAlert
+	| NotFsckedAlert
 	deriving (Eq)
 
 {- The first alert is the new alert, the second is an old alert.