wire git repair into webapp

This commit is contained in:
Joey Hess 2013-10-23 14:43:58 -04:00
parent 1ab2ad86c7
commit 0036139b33
5 changed files with 87 additions and 22 deletions

View file

@ -10,7 +10,17 @@
module Assistant.WebApp.Repair where
import Assistant.WebApp.Common
import Assistant.WebApp.Utility
import Assistant.WebApp.RepoList
import Remote (prettyUUID)
import Command.Repair (repairAnnexBranch)
import Git.Repair (runRepairOf)
import Logs.FsckResults
import Annex.UUID
import Utility.Batch
import Config.Files
import Control.Concurrent.Async
getRepairRepositoryR :: UUID -> Handler Html
getRepairRepositoryR = postRepairRepositoryR
@ -20,7 +30,51 @@ postRepairRepositoryR u = page "Repair repository" Nothing $ do
$(widgetFile "control/repairrepository")
getRepairRepositoryRunR :: UUID -> Handler Html
getRepairRepositoryRunR = postRepairRepositoryR
getRepairRepositoryRunR = postRepairRepositoryRunR
postRepairRepositoryRunR :: UUID -> Handler Html
postRepairRepositoryRunR u = page "Repair repository" Nothing $ do
$(widgetFile "control/repairrepository/run")
postRepairRepositoryRunR u = do
-- Stop the watcher from running while running repairs.
changeSyncable Nothing False
fsckthread <- liftAssistant $ runRepair u
-- Start the watcher running again. This also triggers it to do a
-- startup scan, which is especially important if the git repo
-- repair removed files from the index file. Those files will be
-- seen as new, and re-added to the repository.
changeSyncable Nothing True
liftAnnex $ writeFsckResults u Nothing
page "Repair repository" Nothing $ do
let repolist = repoListDisplay $
mainRepoSelector { nudgeAddMore = True }
$(widgetFile "control/repairrepository/done")
runRepair :: UUID -> Assistant ()
runRepair u = do
fsckresults <- liftAnnex (readFsckResults u)
myu <- liftAnnex getUUID
if u == myu
then localrepair fsckresults
else remoterepair fsckresults
where
localrepair fsckresults = do
-- This intentionally runs the repair inside the Annex
-- monad, which is not stricktly necessary, but keeps
-- other threads that might be trying to use the Annex
-- from running until it completes.
needfsck <- liftAnnex $ do
(ok, stillmissing, modifiedbranches) <- inRepo $
runRepairOf fsckresults True
repairAnnexBranch stillmissing modifiedbranches
return (not ok)
when needfsck $
backgroundfsck [ Param "--fast" ]
remoterepair fsckresults = do
error "TODO: remote repair"
backgroundfsck params = liftIO $ void $ async $ do
program <- readProgramFile
batchCommand program (Param "fsck" : params)