add post-repair actions

Assistant/Threads/ProblemChecker.hs

@@ -1,55 +0,0 @@
-{- git-annex assistant thread to handle reported problems with repositories
- -
- - Copyright 2013 Joey Hess <joey@kitenet.net>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-module Assistant.Threads.ProblemChecker (
-	problemCheckerThread
-) where
-
-import Assistant.Common
-import Utility.ThreadScheduler
-import Assistant.Types.UrlRenderer
-import Assistant.Alert
-import Remote
-import qualified Types.Remote as Remote
-import qualified Git.Fsck
-import Assistant.Repair
-import qualified Git
-import Assistant.RepoProblem
-import Assistant.Sync
-import Annex.UUID
-
-{- Waits for problems with a repo, and tries to fsck the repo and repair
- - the problem. -}
-problemCheckerThread :: UrlRenderer -> NamedThread
-problemCheckerThread urlrenderer = namedThread "ProblemChecker" $ forever $ do
-	mapM_ (handleProblem urlrenderer)
-		=<< nub <$> getRepoProblems
-	liftIO $ threadDelaySeconds (Seconds 60)
-
-handleProblem :: UrlRenderer -> UUID -> Assistant ()
-handleProblem urlrenderer u = ifM ((==) u <$> liftAnnex getUUID)
-	( handleLocalRepoProblem urlrenderer
-	, maybe noop (handleRemoteProblem urlrenderer)
-		=<< liftAnnex (remoteFromUUID u)
-	)
-
-handleRemoteProblem :: UrlRenderer -> Remote -> Assistant ()
-handleRemoteProblem urlrenderer rmt
-	| Git.repoIsLocal r && not (Git.repoIsLocalUnknown r) =
-		whenM (liftIO $ checkAvailable True rmt) $ do
-			repairStaleGitLocks r
-			fsckresults <- showFscking urlrenderer (Just $ Remote.name rmt) $ tryNonAsync $
-				Git.Fsck.findBroken True r
-			whenM (repairWhenNecessary urlrenderer (Remote.uuid rmt) (Just rmt) fsckresults) $
-				syncRemote rmt
-	| otherwise = noop
-  where
-	r = Remote.repo rmt
-
-handleLocalRepoProblem :: UrlRenderer -> Assistant ()
-handleLocalRepoProblem urlrenderer = do
-	repairStaleGitLocks =<< liftAnnex gitRepo

Assistant/Threads/ProblemFixer.hs

@@ -0,0 +1,70 @@
+{- git-annex assistant thread to handle fixing problems with repositories
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Threads.ProblemFixer (
+	problemFixerThread
+) where
+
+import Assistant.Common
+import Assistant.Types.RepoProblem
+import Assistant.RepoProblem
+import Assistant.Types.UrlRenderer
+import Assistant.Alert
+import Remote
+import qualified Types.Remote as Remote
+import qualified Git.Fsck
+import Assistant.Repair
+import qualified Git
+import Annex.UUID
+import Utility.ThreadScheduler
+
+{- Waits for problems with a repo, and tries to fsck the repo and repair
+ - the problem. -}
+problemFixerThread :: UrlRenderer -> NamedThread
+problemFixerThread urlrenderer = namedThread "ProblemFixer" $
+	go =<< getRepoProblems
+  where
+	go problems = do
+		mapM_ (handleProblem urlrenderer) problems
+		liftIO $ threadDelaySeconds (Seconds 60)
+		-- Problems may have been re-reported while they were being
+		-- fixed, so ignore those. If a new unique problem happened
+		-- 60 seconds after the last was fixed, we're unlikely
+		-- to do much good anyway.
+		go =<< filter (\p -> not (any (sameRepoProblem p) problems))
+			<$> getRepoProblems
+
+handleProblem :: UrlRenderer -> RepoProblem -> Assistant ()
+handleProblem urlrenderer repoproblem = do
+	fixed <- ifM ((==) (problemUUID repoproblem) <$> liftAnnex getUUID)
+		( handleLocalRepoProblem urlrenderer
+		, maybe (return False) (handleRemoteProblem urlrenderer)
+			=<< liftAnnex (remoteFromUUID $ problemUUID repoproblem)
+		)
+	when fixed $
+		liftIO $ afterFix repoproblem
+
+handleRemoteProblem :: UrlRenderer -> Remote -> Assistant Bool
+handleRemoteProblem urlrenderer rmt
+	| Git.repoIsLocal r && not (Git.repoIsLocalUnknown r) =
+		ifM (liftIO $ checkAvailable True rmt)
+			( do
+				fixedlocks <- repairStaleGitLocks r
+				fsckresults <- showFscking urlrenderer (Just $ Remote.name rmt) $ tryNonAsync $
+					Git.Fsck.findBroken True r
+				repaired <- repairWhenNecessary urlrenderer (Remote.uuid rmt) (Just rmt) fsckresults
+				return $ fixedlocks || repaired
+			, return False
+			)
+	| otherwise = return False
+  where
+	r = Remote.repo rmt
+
+{- This is not yet used, and should probably do a fsck. -}
+handleLocalRepoProblem :: UrlRenderer -> Assistant Bool
+handleLocalRepoProblem urlrenderer = do
+	repairStaleGitLocks =<< liftAnnex gitRepo

Assistant/Threads/SanityChecker.hs

@@ -33,7 +33,7 @@ import Data.Time.Clock.POSIX
  - being nonresponsive.) -}
 sanityCheckerStartupThread :: Maybe Duration -> NamedThread
 sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerStartup" $ do
-	repairStaleGitLocks =<< liftAnnex gitRepo
+	void $ repairStaleGitLocks =<< liftAnnex gitRepo
 
 	liftIO $ maybe noop (threadDelaySeconds . Seconds . fromIntegral . durationSeconds) startupdelay