40ecf58d4b
This does not change the overall license of the git-annex program, which was already AGPL due to a number of sources files being AGPL already. Legally speaking, I'm adding a new license under which these files are now available; I already released their current contents under the GPL license. Now they're dual licensed GPL and AGPL. However, I intend for all my future changes to these files to only be released under the AGPL license, and I won't be tracking the dual licensing status, so I'm simply changing the license statement to say it's AGPL. (In some cases, others wrote parts of the code of a file and released it under the GPL; but in all cases I have contributed a significant portion of the code in each file and it's that code that is getting the AGPL license; the GPL license of other contributors allows combining with AGPL code.)
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 AGPL 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
|