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

7 files changed, 106 insertions, 17 deletions

diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs
index 3455d0563..4e6dab033 100644
--- a/Assistant/Alert.hs
+++ b/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" ]
diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs
index 8eb3d472e..786044b20 100644
--- a/Assistant/Threads/Cronner.hs
+++ b/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
 	]
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index 2c5b1dbd2..a5f4f4201 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/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
diff --git a/Git/Fsck.hs b/Git/Fsck.hs
index 3872c6b04..2c9423005 100644
--- a/Git/Fsck.hs
+++ b/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;
diff --git a/Git/RecoverRepository.hs b/Git/RecoverRepository.hs
index 0563c636b..f591bd6b2 100644
--- a/Git/RecoverRepository.hs
+++ b/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
diff --git a/Locations.hs b/Locations.hs
index b96f58d5f..47a009590 100644
--- a/Locations.hs
+++ b/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
diff --git a/Logs/FsckResults.hs b/Logs/FsckResults.hs
new file mode 100644
index 000000000..75ed7389c
--- /dev/null
+++ b/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