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

Git/Fsck.hs

@@ -6,9 +6,11 @@
  -}
 
 module Git.Fsck (
+	FsckResults,
+	MissingObjects,
 	findBroken,
+	foundBroken,
 	findMissing,
-	MissingObjects
 ) where
 
 import Common
@@ -22,17 +24,20 @@ import qualified Data.Set as S
 
 type MissingObjects = S.Set Sha
 
+{- If fsck succeeded, Just a set of missing objects it found.
+ - If it failed, Nothing. -}
+type FsckResults = Maybe MissingObjects
+
 {- Runs fsck to find some of the broken objects in the repository.
  - May not find all broken objects, if fsck fails on bad data in some of
- - the broken objects it does find. If the fsck fails generally without
- - finding any broken objects, returns Nothing.
+ - the broken objects it does find.
  -
  - Strategy: Rather than parsing fsck's current specific output,
  - look for anything in its output (both stdout and stderr) that appears
  - to be a git sha. Not all such shas are of broken objects, so ask git
  - to try to cat the object, and see if it fails.
  -}
-findBroken :: Bool -> Repo -> IO (Maybe MissingObjects)
+findBroken :: Bool -> Repo -> IO FsckResults
 findBroken batchmode r = do
 	(output, fsckok) <- processTranscript command' (toCommand params') Nothing
 	let objs = parseFsckOutput output
@@ -46,6 +51,10 @@ findBroken batchmode r = do
 		| batchmode = toBatchCommand (command, params)
 		| otherwise = (command, params)
 
+foundBroken :: FsckResults -> Bool
+foundBroken Nothing = True
+foundBroken (Just s) = not (S.null s)
+
 {- Finds objects that are missing from the git repsitory, or are corrupt.
  -
  - Note that catting a corrupt object will cause cat-file to crash;

Git/RecoverRepository.hs

@@ -48,7 +48,7 @@ import Data.Tuple.Utils
  - To remove corrupt objects, unpack all packs, and remove the packs
  - (to handle corrupt packs), and remove loose object files.
  -}
-cleanCorruptObjects :: Maybe MissingObjects -> Repo -> IO MissingObjects
+cleanCorruptObjects :: FsckResults -> Repo -> IO MissingObjects
 cleanCorruptObjects mmissing r = check mmissing
   where
 	check Nothing = do

Locations.hs

@@ -28,6 +28,7 @@ module Locations (
 	gitAnnexBadLocation,
 	gitAnnexUnusedLog,
 	gitAnnexFsckState,
+	gitAnnexFsckResultsLog,
 	gitAnnexScheduleState,
 	gitAnnexTransferDir,
 	gitAnnexCredsDir,
@@ -66,6 +67,7 @@ import Data.Char
 import Common
 import Types
 import Types.Key
+import Types.UUID
 import qualified Git
 
 {- Conventions:
@@ -193,6 +195,10 @@ gitAnnexUnusedLog prefix r = gitAnnexDir r </> (prefix ++ "unused")
 gitAnnexFsckState :: Git.Repo -> FilePath
 gitAnnexFsckState r = gitAnnexDir r </> "fsckstate"
 
+{- .git/annex/fsckresults/uuid is used to store results of git fscks -}
+gitAnnexFsckResultsLog :: UUID -> Git.Repo -> FilePath
+gitAnnexFsckResultsLog u r = gitAnnexDir r </> "fsckresults" </> fromUUID u
+
 {- .git/annex/schedulestate is used to store information about when
  - scheduled jobs were last run. -}
 gitAnnexScheduleState :: Git.Repo -> FilePath

Logs/FsckResults.hs

@@ -0,0 +1,43 @@
+{- git-annex fsck results log files
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Logs.FsckResults (
+	writeFsckResults,
+	readFsckResults
+) where
+
+import Common.Annex
+import Utility.Tmp
+import Git.Fsck
+import Git.Types
+
+import qualified Data.Set as S
+
+writeFsckResults :: UUID -> FsckResults -> Annex ()
+writeFsckResults u fsckresults = do
+	logfile <- fromRepo $ gitAnnexFsckResultsLog u
+	liftIO $ 
+		case fsckresults of
+			Nothing -> store S.empty logfile
+			Just s
+				| S.null s -> nukeFile logfile
+				| otherwise -> store s logfile
+  where
+  	store s logfile = do 
+		createDirectoryIfMissing True (parentDir logfile)
+		liftIO $ viaTmp writeFile logfile $ serialize s
+	serialize = unlines . map show . S.toList
+
+readFsckResults :: UUID -> Annex FsckResults
+readFsckResults u = do
+	logfile <- fromRepo $ gitAnnexFsckResultsLog u
+	liftIO $ catchDefaultIO (Just S.empty) $
+		deserialize <$> readFile logfile
+  where
+	deserialize l = 
+		let s = S.fromList $ map Ref $ lines l
+		in if S.null s then Nothing else Just s

templates/control/repairrepository.hamlet

@@ -0,0 +1,25 @@
+<div .span9 .hero-unit>
+  <p>
+    A periodic #
+    <a href="@{ConfigFsckR}">
+      consistency check #
+    found corrupt data in the git repository #{repodesc}.
+  <p>
+    While this is not good, this problem can be automatically repaired,
+    often without data loss.
+  <p>
+    When possible, the corrupt data will be recovered from other #
+    repositories. You should make sure any other repositories #
+    are available before continuing. Ie, plug in any removable drive #
+    that contains a repository, or make sure your network connection #
+    to other repositories is active.
+  <p>
+    <a .btn .btn-primary href="@{RepairRepositoryRunR u}" onclick="$('#workingmodal').modal('show');">
+      Start Repair Process
+<div .modal .fade #workingmodal>
+  <div .modal-header>
+    <h3>
+      Repairing #{repodesc} ...
+  <div .modal-body>
+    <p>
+      This may take some time.

templates/control/repairrepository/run.hamlet

@@ -0,0 +1,3 @@
+<div .span9 .hero-unit>
+  <p>
+    TODO