add git fsck to cronner, and UI for repository repair (not yet wired up)

Assistant/Alert.hs

@@ -79,6 +79,22 @@ warningAlert name msg = Alert
 	, alertButton = Nothing
 	}
 
+errorAlert :: String -> AlertButton -> Alert
+errorAlert msg button = Alert
+	{ alertClass = Error
+	, alertHeader = Just $ tenseWords ["error"]
+	, alertMessageRender = renderData
+	, alertData = [UnTensed $ T.pack msg]
+	, alertCounter = 0
+	, alertBlockDisplay = True
+	, alertClosable = True
+	, alertPriority = Pinned
+	, alertIcon = Just ErrorIcon
+	, alertCombiner = Nothing
+	, alertName = Nothing
+	, alertButton = Just button
+	}
+
 activityAlert :: Maybe TenseText -> [TenseChunk] -> Alert
 activityAlert header dat = baseActivityAlert
 	{ alertHeader = header
@@ -158,6 +174,9 @@ fsckAlert button n = baseActivityAlert
 	, alertButton = Just button
 	}
 
+brokenRepositoryAlert :: AlertButton -> Alert
+brokenRepositoryAlert = errorAlert "Your repository needs repairs."
+
 pairingAlert :: AlertButton -> Alert
 pairingAlert button = baseActivityAlert
 	{ alertData = [ UnTensed "Pairing in progress" ]

Assistant/Threads/Cronner.hs

@@ -32,6 +32,8 @@ import Remote
 import Assistant.WebApp.Types
 #endif
 import Git.Remote (RemoteName)
+import qualified Git.Fsck
+import Logs.FsckResults
 
 import Control.Concurrent.Async
 import Control.Concurrent.MVar
@@ -182,15 +184,24 @@ runActivity urlrenderer activity nowt = do
 runActivity' :: UrlRenderer -> ScheduledActivity -> Assistant ()
 runActivity' urlrenderer (ScheduledSelfFsck _ d) = do
 	program <- liftIO $ readProgramFile
-	void $ runFsck urlrenderer Nothing $
-  		batchCommand program (Param "fsck" : fsckParams d)
+	g <- liftAnnex gitRepo
+	fsckresults <- showFscking urlrenderer Nothing $ tryNonAsync $ do
+		r <- Git.Fsck.findBroken True g
+		void $ batchCommand program (Param "fsck" : annexFsckParams d)
+		return r
+	when (Git.Fsck.foundBroken fsckresults) $ do
+		u <- liftAnnex getUUID
+		liftAnnex $ writeFsckResults u fsckresults
+		button <- mkAlertButton True (T.pack "Repair") urlrenderer $
+			RepairRepositoryR u
+		void $ addAlert $ brokenRepositoryAlert button
 	mapM_ reget =<< liftAnnex (dirKeys gitAnnexBadDir)
   where
 	reget k = queueTransfers "fsck found bad file; redownloading" Next k Nothing Download
 runActivity' urlrenderer (ScheduledRemoteFsck u s d) = go =<< liftAnnex (remoteFromUUID u)
   where
 	go (Just r) = void $ case Remote.remoteFsck r of
-		Nothing -> void $ runFsck urlrenderer (Just $ Remote.name r) $ do
+		Nothing -> void $ showFscking urlrenderer (Just $ Remote.name r) $ tryNonAsync $ do
 			program <- readProgramFile
 			batchCommand program $ 
 				[ Param "fsck"
@@ -198,28 +209,28 @@ runActivity' urlrenderer (ScheduledRemoteFsck u s d) = go =<< liftAnnex (remoteF
 				, Param "--fast"
 				, Param "--from"
 				, Param $ Remote.name r
-				] ++ fsckParams d
+				] ++ annexFsckParams d
 		Just mkfscker ->
 			{- Note that having mkfsker return an IO action
 			 - avoids running a long duration fsck in the
 			 - Annex monad. -}
-			void . runFsck urlrenderer (Just $ Remote.name r)
-				=<< liftAnnex (mkfscker (fsckParams d))
+			void . showFscking urlrenderer (Just $ Remote.name r) . tryNonAsync
+				=<< liftAnnex (mkfscker (annexFsckParams d))
 	go Nothing = debug ["skipping remote fsck of uuid without a configured remote", fromUUID u, fromSchedule s]
 
-runFsck :: UrlRenderer -> Maybe RemoteName -> IO Bool -> Assistant Bool
-runFsck urlrenderer remotename a = do
+showFscking :: UrlRenderer -> Maybe RemoteName -> IO (Either E.SomeException a) -> Assistant a
+showFscking urlrenderer remotename a = do
 #ifdef WITH_WEBAPP
 	button <- mkAlertButton False (T.pack "Configure") urlrenderer ConfigFsckR
-	r <- alertDuring (fsckAlert button remotename) $ liftIO $ do
-		E.try a :: IO (Either E.SomeException Bool)
+	r <- alertDuring (fsckAlert button remotename) $
+		liftIO a
 	either (liftIO . E.throwIO) return r
 #else
 	a
 #endif
 
-fsckParams :: Duration -> [CommandParam]
-fsckParams d =
+annexFsckParams :: Duration -> [CommandParam]
+annexFsckParams d =
 	[ Param "--incremental-schedule=1d"
 	, Param $ "--time-limit=" ++ fromDuration d
 	]

Assistant/Threads/WebApp.hs

@@ -33,6 +33,7 @@ import Assistant.WebApp.Configurators.Fsck
 import Assistant.WebApp.Documentation
 import Assistant.WebApp.Control
 import Assistant.WebApp.OtherRepos
+import Assistant.WebApp.Repair
 import Assistant.Types.ThreadedMonad
 import Utility.WebApp
 import Utility.Tmp

Assistant/WebApp/Repair.hs

@@ -0,0 +1,26 @@
+{- git-annex assistant repository repair
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
+
+module Assistant.WebApp.Repair where
+
+import Assistant.WebApp.Common
+import Remote (prettyUUID)
+
+getRepairRepositoryR :: UUID -> Handler Html
+getRepairRepositoryR = postRepairRepositoryR
+postRepairRepositoryR :: UUID -> Handler Html
+postRepairRepositoryR u = page "Repair repository" Nothing $ do
+	repodesc <- liftAnnex $ prettyUUID u
+	$(widgetFile "control/repairrepository")
+
+getRepairRepositoryRunR :: UUID -> Handler Html
+getRepairRepositoryRunR = postRepairRepositoryR
+postRepairRepositoryRunR :: UUID -> Handler Html
+postRepairRepositoryRunR u = page "Repair repository" Nothing $ do
+	$(widgetFile "control/repairrepository/run")

Assistant/WebApp/Types.hs

@@ -216,4 +216,3 @@ instance PathPiece ThreadName where
 instance PathPiece ScheduledActivity where
 	toPathPiece = pack . show
 	fromPathPiece = readish . unpack
-

Assistant/WebApp/routes

@@ -108,4 +108,7 @@
 /transfer/start/#Transfer StartTransferR GET POST
 /transfer/cancel/#Transfer CancelTransferR GET POST
 
+/repair/#UUID RepairRepositoryR GET POST
+/repair/run/#UUID RepairRepositoryRunR GET POST
+
 /static StaticR Static getStatic