add git fsck to cronner, and UI for repository repair (not yet wired up)
This commit is contained in:
parent
44bb9a808f
commit
d345e5b52f
12 changed files with 163 additions and 18 deletions
|
@ -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" ]
|
||||
|
|
|
@ -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
|
||||
]
|
||||
|
|
|
@ -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
|
||||
|
|
26
Assistant/WebApp/Repair.hs
Normal file
26
Assistant/WebApp/Repair.hs
Normal 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")
|
|
@ -216,4 +216,3 @@ instance PathPiece ThreadName where
|
|||
instance PathPiece ScheduledActivity where
|
||||
toPathPiece = pack . show
|
||||
fromPathPiece = readish . unpack
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue