67e46229a5
This is groundwork for letting a repo be instantiated the first time it's actually used, instead of at startup. The only behavior change is that some old special cases for xmpp remotes were removed. Where before git-annex silently did nothing with those no-longer supported remotes, it may now fail in some way. The additional IO action should have no performance impact as long as it's simply return. This commit was sponsored by Boyd Stephen Smith Jr. on Patreon
73 lines
2.5 KiB
Haskell
73 lines
2.5 KiB
Haskell
{- git-annex assistant thread to handle fixing problems with repositories
|
|
-
|
|
- Copyright 2013 Joey Hess <id@joeyh.name>
|
|
-
|
|
- 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 = do
|
|
repo <- liftAnnex $ Remote.getRepo rmt
|
|
handleRemoteProblem' repo urlrenderer rmt
|
|
|
|
handleRemoteProblem' :: Git.Repo -> UrlRenderer -> Remote -> Assistant Bool
|
|
handleRemoteProblem' repo urlrenderer rmt
|
|
| Git.repoIsLocal repo && not (Git.repoIsLocalUnknown repo) =
|
|
ifM (liftIO $ checkAvailable True rmt)
|
|
( do
|
|
fixedlocks <- repairStaleGitLocks repo
|
|
fsckresults <- showFscking urlrenderer (Just rmt) $ tryNonAsync $
|
|
Git.Fsck.findBroken True repo
|
|
repaired <- repairWhenNecessary urlrenderer (Remote.uuid rmt) (Just rmt) fsckresults
|
|
return $ fixedlocks || repaired
|
|
, return False
|
|
)
|
|
| otherwise = return False
|
|
|
|
{- This is not yet used, and should probably do a fsck. -}
|
|
handleLocalRepoProblem :: UrlRenderer -> Assistant Bool
|
|
handleLocalRepoProblem _urlrenderer = do
|
|
repairStaleGitLocks =<< liftAnnex gitRepo
|