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

@@ -132,7 +132,7 @@ startDaemon assistant foreground startdelay listenhost startbrowser = do
 			, assist $ sanityCheckerHourlyThread
 			, assist $ problemFixerThread urlrenderer
 #ifdef WITH_CLIBS
-			, assist $ mountWatcherThread
+			, assist $ mountWatcherThread urlrenderer
 #endif
 			, assist $ netWatcherThread
 			, assist $ netWatcherFallbackThread

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!"
 

Assistant/Fsck.hs

@@ -0,0 +1,50 @@
+{- git-annex assistant fscking
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Assistant.Fsck where
+
+import Assistant.Common
+import Types.ScheduledActivity
+import qualified Types.Remote as Remote
+import Annex.UUID
+import Assistant.Alert
+import Assistant.Types.UrlRenderer
+import Logs.Schedule
+import qualified Annex
+
+import qualified Data.Set as S
+
+{- Displays a nudge in the webapp if a fsck is not configured for
+ - the specified remote, or for the local repository. -}
+fsckNudge :: UrlRenderer -> Maybe Remote -> Assistant ()
+fsckNudge urlrenderer mr
+	| maybe True fsckableRemote mr =
+		whenM (liftAnnex $ annexFsckNudge <$> Annex.getGitConfig) $
+			unlessM (liftAnnex $ checkFscked mr) $
+				notFsckedNudge urlrenderer mr
+	| otherwise = noop
+
+fsckableRemote :: Remote -> Bool
+fsckableRemote = isJust . Remote.remoteFsck
+
+{- Checks if the remote, or the local repository, has a fsck scheduled.
+ - Only looks at fscks configured to run via the local repository, not
+ - other repositories. -}
+checkFscked :: Maybe Remote -> Annex Bool
+checkFscked mr = any wanted . S.toList <$> (scheduleGet =<< getUUID)
+  where
+	wanted = case mr of
+		Nothing -> isSelfFsck
+		Just r -> flip isFsckOf (Remote.uuid r)
+
+isSelfFsck :: ScheduledActivity -> Bool
+isSelfFsck (ScheduledSelfFsck _ _) = True
+isSelfFsck _ = False
+
+isFsckOf :: ScheduledActivity -> UUID -> Bool
+isFsckOf (ScheduledRemoteFsck u _ _) u' = u == u'
+isFsckOf _ _ = False

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

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.

Assistant/WebApp/Configurators/Fsck.hs

@@ -22,6 +22,10 @@ import Annex.UUID
 import qualified Remote
 import Assistant.DaemonStatus
 import qualified Annex.Branch
+import Assistant.Fsck
+import Config
+import Git.Config
+import qualified Annex
 
 {- This adds a form to the page. It does not handle posting of the form,
  - because unlike a typical yesod form that posts using the same url
@@ -41,7 +45,7 @@ showFsckForm new activity = do
  - some Annex action on it. -}
 withFsckForm :: (ScheduledActivity -> Annex ()) -> Handler ()
 withFsckForm a = do
-	((res, _form), _enctype) <- runFsckForm False defaultFsck
+	((res, _form), _enctype) <- runFsckForm False $ defaultFsck Nothing
 	case res of
 		FormSuccess activity -> liftAnnex $ a activity
 		_ -> noop
@@ -109,8 +113,9 @@ runFsckForm new activity = case activity of
 		liftAnnex $ 
 			zip <$> (map T.pack <$> Remote.prettyListUUIDs us) <*> pure us
 
-defaultFsck :: ScheduledActivity
-defaultFsck = ScheduledSelfFsck (Schedule Daily AnyTime) (Duration $ 60*60)
+defaultFsck :: Maybe Remote -> ScheduledActivity
+defaultFsck Nothing = ScheduledSelfFsck (Schedule Daily AnyTime) (Duration $ 60*60)
+defaultFsck (Just r) = ScheduledRemoteFsck (Remote.uuid r) (Schedule Daily AnyTime) (Duration $ 60*60)
 
 showFsckStatus :: ScheduledActivity -> Widget
 showFsckStatus activity = do
@@ -122,7 +127,12 @@ getConfigFsckR :: Handler Html
 getConfigFsckR = postConfigFsckR
 postConfigFsckR :: Handler Html
 postConfigFsckR = page "Consistency checks" (Just Configuration) $ do
-	checks <- liftAnnex $ S.toList <$> (scheduleGet =<< getUUID)
+	scheduledchecks <- liftAnnex $
+		S.toList <$> (scheduleGet =<< getUUID)
+	rs <- liftAssistant $
+		filter fsckableRemote . syncRemotes <$> getDaemonStatus
+	recommendedchecks <- liftAnnex $ map defaultFsck
+		<$> filterM (not <$$> checkFscked) (Nothing : map Just rs)
 	$(widgetFile "configurators/fsck")
 
 changeSchedule :: Handler () -> Handler Html
@@ -147,3 +157,39 @@ postChangeActivityR :: UUID -> ScheduledActivity -> Handler Html
 postChangeActivityR u oldactivity = changeSchedule $
 	withFsckForm $ \newactivity -> scheduleChange u $
 			S.insert newactivity . S.delete oldactivity
+
+data FsckPreferences = FsckPreferences
+	{ enableFsckNudge :: Bool
+	}
+
+getFsckPreferences :: Annex FsckPreferences
+getFsckPreferences = FsckPreferences
+	<$> (annexFsckNudge <$> Annex.getGitConfig)
+
+fsckPreferencesAForm :: FsckPreferences -> MkAForm FsckPreferences
+fsckPreferencesAForm def = FsckPreferences
+	<$> areq (checkBoxField `withNote` nudgenote) "Reminders" (Just $ enableFsckNudge def)
+  where
+	nudgenote = [whamlet|Remind me when using repositories that lack consistency checks.|]
+
+runFsckPreferencesForm :: Handler ((FormResult FsckPreferences, Widget), Enctype)
+runFsckPreferencesForm = do
+	prefs <- liftAnnex getFsckPreferences
+	runFormPostNoToken $ renderBootstrap $ fsckPreferencesAForm prefs
+
+showFsckPreferencesForm :: Widget
+showFsckPreferencesForm = do
+	((res, form), enctype) <- liftH $ runFsckPreferencesForm
+	case res of
+		FormSuccess _ -> noop
+		_ -> $(widgetFile "configurators/fsck/preferencesform")
+
+postConfigFsckPreferencesR :: Handler Html
+postConfigFsckPreferencesR = do
+	((res, _form), _enctype) <- runFsckPreferencesForm
+	case res of
+		FormSuccess prefs ->
+			liftAnnex $ setConfig (annexConfig "fscknudge")
+				(boolConfig $ enableFsckNudge prefs)
+		_ -> noop
+	redirect ConfigFsckR

Assistant/WebApp/routes

@@ -20,6 +20,7 @@
 /config/xmpp/for/frield XMPPConfigForPairFriendR GET POST
 /config/xmpp/needcloudrepo/#UUID NeedCloudRepoR GET
 /config/fsck ConfigFsckR GET POST
+/config/fsck/preferences ConfigFsckPreferencesR POST
 
 /config/addrepository AddRepositoryR GET
 /config/repository/new NewRepositoryR GET POST

Types/GitConfig.hs

@@ -41,6 +41,7 @@ data GitConfig = GitConfig
 	, annexWebDownloadCommand :: Maybe String
 	, annexCrippledFileSystem :: Bool
 	, annexLargeFiles :: Maybe String
+	, annexFsckNudge :: Bool
 	, coreSymlinks :: Bool
 	, gcryptId :: Maybe String
 	}
@@ -68,6 +69,7 @@ extractGitConfig r = GitConfig
 	, annexWebDownloadCommand = getmaybe (annex "web-download-command")
 	, annexCrippledFileSystem = getbool (annex "crippledfilesystem") False
 	, annexLargeFiles = getmaybe (annex "largefiles")
+	, annexFsckNudge = getbool (annex "fscknudge") True
 	, coreSymlinks = getbool "core.symlinks" True
 	, gcryptId = getmaybe "core.gcrypt-id"
 	}

doc/design/assistant/disaster_recovery.mdwn

@@ -14,8 +14,9 @@ check that nothing else is using it, fix the problem, and redo the commit.
 * What about local remotes, eg removable drives? git-annex does attempt
   to commit to the git-annex branch of those. It will use the automatic
   fix if any are dangling. It does not commit to the master branch; indeed
-  a removable drive typically has a bare repository. So I think nothing to
-  do here.
+  a removable drive typically has a bare repository.
+  However, it does a scan for broken locks anyway if there's a problem
+  syncing. **done**
 * What about git-annex-shell? If the ssh remote has the assistant running,
   it can take care of it, and if not, it's a server, and perhaps the user
   should be required to fix up if it crashes during a commit. This should
@@ -95,10 +96,10 @@ quite a lot of state.
 
 Or: Display a message whenever a removable drive is detected to have been
 connected. I like this, but what about nudging the main repo? Could do it
-every webapp startup, perhaps?
+every webapp startup, perhaps? **done**
 
 There should be a "No thanks" button that prevents it nudging again for a
-repo.
+repo. **done**
 
 ## git repository repair
 

doc/git-annex.mdwn

@@ -1118,6 +1118,11 @@ Here are all the supported configuration settings.
   to close it. On Mac OSX, when not using direct mode this defaults to
   1 second, to work around a bad interaction with software there.
 
+* `annex.fscknudge`
+
+  When set to false, prevents the webapp from reminding you when using
+  repositories that lack consistency checks.
+
 * `annex.autocommit`
 
   Set to false to prevent the git-annex assistant from automatically

templates/configurators/fsck.hamlet

@@ -9,13 +9,23 @@
     Running the consistency check involves reading all the files in the #
     repository, which can take a long time if it's large. Running just a #
     little at a time will eventually check the whole repository.
-  $if (not (null checks))
+  $if (not (null scheduledchecks))
     <p>
       Currently scheduled checks:
-      $forall c <- checks
+      $forall c <- scheduledchecks
         ^{showFsckForm False c}
         <div style="margin-left: 5em">
           ^{showFsckStatus c}
   <p>
-    Add a check:
-    ^{showFsckForm True defaultFsck}
+    $if null (recommendedchecks)
+      Add a check:
+      ^{showFsckForm True (defaultFsck Nothing)}
+    $else
+      <i .icon-warning-sign></i> #
+      Some repositories are not yet checked. #
+      Please consider adding these checks:
+      $forall c <- recommendedchecks
+        ^{showFsckForm True c}
+  <h3>
+    Configuration
+  ^{showFsckPreferencesForm}

templates/configurators/fsck/preferencesform.hamlet

@@ -0,0 +1,6 @@
+<div .well>
+  <form method="post" .form-horizontal action=@{ConfigFsckPreferencesR} enctype=#{enctype}>
+    ^{form}
+    <div .form-actions>
+      <button .btn .btn-primary type=submit>
+        Save