add config page for fsck, and alert with button when a fsck is running

Assistant.hs

@@ -134,7 +134,7 @@ startDaemon assistant foreground listenhost startbrowser = do
 			, assist $ netWatcherThread
 			, assist $ netWatcherFallbackThread
 			, assist $ transferScannerThread urlrenderer
-			, assist $ cronnerThread
+			, assist $ cronnerThread urlrenderer
 			, assist $ configMonitorThread
 			, assist $ glacierThread
 			, watch $ watchThread

Assistant/Alert.hs

@@ -27,17 +27,19 @@ import Assistant.WebApp
 import Yesod
 #endif
 
-{- Makes a button for an alert that opens a Route. The button will
- - close the alert it's attached to when clicked. -}
+{- Makes a button for an alert that opens a Route. 
+ -
+ - If autoclose is set, the button will close the alert it's
+ - attached to when clicked. -}
 #ifdef WITH_WEBAPP
-mkAlertButton :: T.Text -> UrlRenderer -> Route WebApp -> Assistant AlertButton
-mkAlertButton label urlrenderer route = do
+mkAlertButton :: Bool -> T.Text -> UrlRenderer -> Route WebApp -> Assistant AlertButton
+mkAlertButton autoclose label urlrenderer route = do
 	close <- asIO1 removeAlert
 	url <- liftIO $ renderUrl urlrenderer route []
 	return $ AlertButton
 		{ buttonLabel = label
 		, buttonUrl = url
-		, buttonAction = Just close
+		, buttonAction = if autoclose then Just close else Nothing
 		}
 #endif
 
@@ -147,6 +149,12 @@ 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 -> Alert
+fsckAlert button = baseActivityAlert
+	{ alertData = [ UnTensed "Consistency check in progress" ]
+	, alertButton = Just button
+	}
+
 pairingAlert :: AlertButton -> Alert
 pairingAlert button = baseActivityAlert
 	{ alertData = [ UnTensed "Pairing in progress" ]

Assistant/DeleteRemote.hs

@@ -81,7 +81,7 @@ finishRemovingRemote :: UrlRenderer -> UUID -> Assistant ()
 #ifdef WITH_WEBAPP
 finishRemovingRemote urlrenderer uuid = do
 	desc <- liftAnnex $ Remote.prettyUUID uuid
-	button <- mkAlertButton (T.pack "Finish deletion process") urlrenderer $
+	button <- mkAlertButton True (T.pack "Finish deletion process") urlrenderer $
 		FinishDeleteRepositoryR uuid
 	void $ addAlert $ remoteRemovalAlert desc button
 #else

Assistant/NamedThread.hs

@@ -76,7 +76,7 @@ startNamedThread urlrenderer (NamedThread afterstartupsanitycheck name a) = do
 					]
 				hPutStrLn stderr msg
 #ifdef WITH_WEBAPP
-				button <- runAssistant d $ mkAlertButton
+				button <- runAssistant d $ mkAlertButton True
 					(T.pack "Restart Thread")
 					urlrenderer 
 					(RestartThreadR name)

Assistant/Threads/Cronner.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable, CPP #-}
 
 module Assistant.Threads.Cronner (
 	cronnerThread
@@ -25,6 +25,11 @@ import qualified Build.SysConfig
 import Assistant.TransferQueue
 import Annex.Content
 import Logs.Transfer
+import Assistant.Types.UrlRenderer
+import Assistant.Alert
+#ifdef WITH_WEBAPP
+import Assistant.WebApp.Types
+#endif
 
 import Control.Concurrent.Async
 import Data.Time.LocalTime
@@ -32,6 +37,7 @@ import Data.Time.Clock
 import qualified Data.Map as M
 import qualified Data.Set as S
 import qualified Control.Exception as E
+import qualified Data.Text as T
 
 {- Loads schedules for this repository, and fires off one thread for each 
  - scheduled event. These threads sleep until the next time the event
@@ -41,8 +47,8 @@ import qualified Control.Exception as E
  - schedules. When there's a change, compare the old and new list of
  - schedules to find deleted and added ones. Start new threads for added
  - ones, and kill the threads for deleted ones. -}
-cronnerThread :: NamedThread
-cronnerThread = namedThreadUnchecked "Cronner" $ do
+cronnerThread :: UrlRenderer -> NamedThread
+cronnerThread urlrenderer = namedThreadUnchecked "Cronner" $ do
 	dstatus <- getDaemonStatus
 	h <- liftIO $ newNotificationHandle False (scheduleLogNotifier dstatus)
 	go h M.empty
@@ -70,7 +76,7 @@ cronnerThread = namedThreadUnchecked "Cronner" $ do
 			(M.filterWithKey (\k _ -> S.member k removedactivities) m)
 		go h m'
   	startactivities as lastruntimes = forM as $ \activity -> do
-		runner <- asIO2 activityThread
+		runner <- asIO2 (activityThread urlrenderer)
 		a <- liftIO $ async $
 			runner activity (M.lookup activity lastruntimes)
 		return (activity, a)
@@ -79,8 +85,8 @@ cronnerThread = namedThreadUnchecked "Cronner" $ do
  - sleep until that time, and run it. Then call setLastRunTime, and
  - loop.
  -}
-activityThread :: ScheduledActivity -> Maybe LocalTime -> Assistant ()
-activityThread activity lasttime = go lasttime =<< getnexttime lasttime
+activityThread :: UrlRenderer -> ScheduledActivity -> Maybe LocalTime -> Assistant ()
+activityThread urlrenderer activity lasttime = go lasttime =<< getnexttime lasttime
   where
   	getnexttime = liftIO . nextTime schedule
   	go _ Nothing = debug ["no scheduled events left for", desc]
@@ -111,7 +117,7 @@ activityThread activity lasttime = go lasttime =<< getnexttime lasttime
 				(localTimeToUTC tz t) > 600
 	run nowt = do
 		debug ["starting", desc]
-		runActivity activity
+		runActivity urlrenderer activity
 		debug ["finished", desc]
 		liftAnnex $ setLastRunTime activity nowt
 		go (Just nowt) =<< getnexttime (Just nowt)
@@ -125,13 +131,23 @@ secondsUntilLocalTime t = do
 		then Seconds secs
 		else Seconds 0
 
-runActivity :: ScheduledActivity -> Assistant ()
-runActivity (ScheduledSelfFsck _ d) = do
+runActivity :: UrlRenderer -> ScheduledActivity -> Assistant ()
+runActivity urlrenderer (ScheduledSelfFsck _ d) = do
 	program <- liftIO $ readProgramFile
-	void $ liftIO $ niceShell $
-		program ++ " fsck --incremental-schedule=1d --time-limit=" ++ fromDuration d
+#ifdef WITH_WEBAPP
+	button <- mkAlertButton False (T.pack "Configure") urlrenderer ConfigFsckR
+	r <- alertDuring (fsckAlert button) $ liftIO $ do
+		E.try (runfsck program) :: IO (Either E.SomeException ExitCode)
+	either (liftIO . E.throwIO) (const noop) r
+#else
+	runfsck program
+#endif
 	queueBad
-runActivity (ScheduledRemoteFsck _ _ _) =
+  where
+  	runfsck program = niceShell $
+		program ++ " fsck --incremental-schedule=1d --time-limit=" ++ fromDuration d
+
+runActivity _ (ScheduledRemoteFsck _ _ _) =
 	debug ["remote fsck not implemented yet"]
 
 queueBad :: Assistant ()

Assistant/Threads/PairListener.hs

@@ -102,7 +102,7 @@ pairListenerThread urlrenderer = namedThread "PairListener" $ do
 pairReqReceived :: Bool -> UrlRenderer -> PairMsg -> Assistant ()
 pairReqReceived True _ _ = noop -- ignore our own PairReq
 pairReqReceived False urlrenderer msg = do
-	button <- mkAlertButton (T.pack "Respond") urlrenderer (FinishLocalPairR msg)
+	button <- mkAlertButton True (T.pack "Respond") urlrenderer (FinishLocalPairR msg)
 	void $ addAlert $ pairRequestReceivedAlert repo button
   where
 	repo = pairRepo msg

Assistant/Threads/WebApp.hs

@@ -29,6 +29,7 @@ import Assistant.WebApp.Configurators.XMPP
 import Assistant.WebApp.Configurators.Preferences
 import Assistant.WebApp.Configurators.Edit
 import Assistant.WebApp.Configurators.Delete
+import Assistant.WebApp.Configurators.Fsck
 import Assistant.WebApp.Documentation
 import Assistant.WebApp.Control
 import Assistant.WebApp.OtherRepos

Assistant/Threads/XMPPClient.hs

@@ -336,7 +336,7 @@ pairMsgReceived urlrenderer PairReq theiruuid selfjid theirjid
 		finishXMPPPairing theirjid theiruuid
 	-- Show an alert to let the user decide if they want to pair.
 	showalert = do
-		button <- mkAlertButton (T.pack "Respond") urlrenderer $
+		button <- mkAlertButton True (T.pack "Respond") urlrenderer $
 			ConfirmXMPPPairFriendR $
 				PairKey theiruuid $ formatJID theirjid
 		void $ addAlert $ pairRequestReceivedAlert

Assistant/WebApp/Configurators/Fsck.hs

@@ -0,0 +1,17 @@
+{- git-annex assistant fsck configuration
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, OverloadedStrings, FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
+
+module Assistant.WebApp.Configurators.Fsck where
+
+import Assistant.WebApp.Common
+
+getConfigFsckR :: Handler Html
+getConfigFsckR = page "Consistency checks" (Just Configuration) $ do
+	error "TODO"

Assistant/WebApp/Configurators/XMPP.hs

@@ -55,7 +55,7 @@ checkCloudRepos :: UrlRenderer -> Remote -> Assistant ()
 checkCloudRepos urlrenderer r =
 	unlessM (syncingToCloudRemote <$> getDaemonStatus) $ do
 		buddyname <- getBuddyName $ Remote.uuid r
-		button <- mkAlertButton "Add a cloud repository" urlrenderer $
+		button <- mkAlertButton True "Add a cloud repository" urlrenderer $
 			NeedCloudRepoR $ Remote.uuid r
 		void $ addAlert $ cloudRepoNeededAlert buddyname button
 #else

Assistant/WebApp/routes

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

templates/configurators/main.hamlet

@@ -13,6 +13,7 @@
       <p>
         Tune the behavior of git-annex, including how many copies #
         to retain of each file, and how much disk space it can use.
+  <div .row-fluid>
     <div .span4>
       $if xmppconfigured
         <h3>
@@ -28,3 +29,10 @@
        <p>
          Keep in touch with remote devices, and with your friends, #
          by configuring a jabber account.
+    <div .span4>
+      <h3>
+        <a href="@{ConfigFsckR}">
+          Configure consistency checks
+      <p>
+        Set up periodic checks of your data to detect and recover from #
+        disk problems.