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

7 files changed, 46 insertions, 21 deletions

diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs
index df5ee2910..e7b731a8c 100644
--- a/Assistant/Alert.hs
+++ b/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" ]
diff --git a/Assistant/DeleteRemote.hs b/Assistant/DeleteRemote.hs
index 6a77eedc6..cc05786e4 100644
--- a/Assistant/DeleteRemote.hs
+++ b/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
diff --git a/Assistant/NamedThread.hs b/Assistant/NamedThread.hs
index f29f0cf36..2440c45bf 100644
--- a/Assistant/NamedThread.hs
+++ b/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)
diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs
index 1a27e3c1b..baec094fc 100644
--- a/Assistant/Threads/Cronner.hs
+++ b/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 ()
diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs
index 882c95cc2..482b0923c 100644
--- a/Assistant/Threads/PairListener.hs
+++ b/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
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index 4620b0387..2c5b1dbd2 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/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
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index ffd487ae1..8eb469939 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/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