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

This commit is contained in:
Joey Hess 2013-10-22 16:02:52 -04:00
parent 44bb9a808f
commit d345e5b52f
12 changed files with 163 additions and 18 deletions

View file

@ -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" ]

View file

@ -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
]

View file

@ -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

View file

@ -0,0 +1,26 @@
{- git-annex assistant repository repair
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
module Assistant.WebApp.Repair where
import Assistant.WebApp.Common
import Remote (prettyUUID)
getRepairRepositoryR :: UUID -> Handler Html
getRepairRepositoryR = postRepairRepositoryR
postRepairRepositoryR :: UUID -> Handler Html
postRepairRepositoryR u = page "Repair repository" Nothing $ do
repodesc <- liftAnnex $ prettyUUID u
$(widgetFile "control/repairrepository")
getRepairRepositoryRunR :: UUID -> Handler Html
getRepairRepositoryRunR = postRepairRepositoryR
postRepairRepositoryRunR :: UUID -> Handler Html
postRepairRepositoryRunR u = page "Repair repository" Nothing $ do
$(widgetFile "control/repairrepository/run")

View file

@ -216,4 +216,3 @@ instance PathPiece ThreadName where
instance PathPiece ScheduledActivity where
toPathPiece = pack . show
fromPathPiece = readish . unpack

View file

@ -108,4 +108,7 @@
/transfer/start/#Transfer StartTransferR GET POST
/transfer/cancel/#Transfer CancelTransferR GET POST
/repair/#UUID RepairRepositoryR GET POST
/repair/run/#UUID RepairRepositoryRunR GET POST
/static StaticR Static getStatic