add config page for fsck, and alert with button when a fsck is running

This commit is contained in:
Joey Hess 2013-10-10 18:02:33 -04:00
parent 18f4d1b400
commit e9745f2da2
12 changed files with 74 additions and 23 deletions

View file

@ -5,7 +5,7 @@
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveDataTypeable, CPP #-}
module Assistant.Threads.Cronner (
cronnerThread
@ -25,6 +25,11 @@ import qualified Build.SysConfig
import Assistant.TransferQueue
import Annex.Content
import Logs.Transfer
import Assistant.Types.UrlRenderer
import Assistant.Alert
#ifdef WITH_WEBAPP
import Assistant.WebApp.Types
#endif
import Control.Concurrent.Async
import Data.Time.LocalTime
@ -32,6 +37,7 @@ import Data.Time.Clock
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Control.Exception as E
import qualified Data.Text as T
{- Loads schedules for this repository, and fires off one thread for each
- scheduled event. These threads sleep until the next time the event
@ -41,8 +47,8 @@ import qualified Control.Exception as E
- schedules. When there's a change, compare the old and new list of
- schedules to find deleted and added ones. Start new threads for added
- ones, and kill the threads for deleted ones. -}
cronnerThread :: NamedThread
cronnerThread = namedThreadUnchecked "Cronner" $ do
cronnerThread :: UrlRenderer -> NamedThread
cronnerThread urlrenderer = namedThreadUnchecked "Cronner" $ do
dstatus <- getDaemonStatus
h <- liftIO $ newNotificationHandle False (scheduleLogNotifier dstatus)
go h M.empty
@ -70,7 +76,7 @@ cronnerThread = namedThreadUnchecked "Cronner" $ do
(M.filterWithKey (\k _ -> S.member k removedactivities) m)
go h m'
startactivities as lastruntimes = forM as $ \activity -> do
runner <- asIO2 activityThread
runner <- asIO2 (activityThread urlrenderer)
a <- liftIO $ async $
runner activity (M.lookup activity lastruntimes)
return (activity, a)
@ -79,8 +85,8 @@ cronnerThread = namedThreadUnchecked "Cronner" $ do
- sleep until that time, and run it. Then call setLastRunTime, and
- loop.
-}
activityThread :: ScheduledActivity -> Maybe LocalTime -> Assistant ()
activityThread activity lasttime = go lasttime =<< getnexttime lasttime
activityThread :: UrlRenderer -> ScheduledActivity -> Maybe LocalTime -> Assistant ()
activityThread urlrenderer activity lasttime = go lasttime =<< getnexttime lasttime
where
getnexttime = liftIO . nextTime schedule
go _ Nothing = debug ["no scheduled events left for", desc]
@ -111,7 +117,7 @@ activityThread activity lasttime = go lasttime =<< getnexttime lasttime
(localTimeToUTC tz t) > 600
run nowt = do
debug ["starting", desc]
runActivity activity
runActivity urlrenderer activity
debug ["finished", desc]
liftAnnex $ setLastRunTime activity nowt
go (Just nowt) =<< getnexttime (Just nowt)
@ -125,13 +131,23 @@ secondsUntilLocalTime t = do
then Seconds secs
else Seconds 0
runActivity :: ScheduledActivity -> Assistant ()
runActivity (ScheduledSelfFsck _ d) = do
runActivity :: UrlRenderer -> ScheduledActivity -> Assistant ()
runActivity urlrenderer (ScheduledSelfFsck _ d) = do
program <- liftIO $ readProgramFile
void $ liftIO $ niceShell $
program ++ " fsck --incremental-schedule=1d --time-limit=" ++ fromDuration d
#ifdef WITH_WEBAPP
button <- mkAlertButton False (T.pack "Configure") urlrenderer ConfigFsckR
r <- alertDuring (fsckAlert button) $ liftIO $ do
E.try (runfsck program) :: IO (Either E.SomeException ExitCode)
either (liftIO . E.throwIO) (const noop) r
#else
runfsck program
#endif
queueBad
runActivity (ScheduledRemoteFsck _ _ _) =
where
runfsck program = niceShell $
program ++ " fsck --incremental-schedule=1d --time-limit=" ++ fromDuration d
runActivity _ (ScheduledRemoteFsck _ _ _) =
debug ["remote fsck not implemented yet"]
queueBad :: Assistant ()

View file

@ -102,7 +102,7 @@ pairListenerThread urlrenderer = namedThread "PairListener" $ do
pairReqReceived :: Bool -> UrlRenderer -> PairMsg -> Assistant ()
pairReqReceived True _ _ = noop -- ignore our own PairReq
pairReqReceived False urlrenderer msg = do
button <- mkAlertButton (T.pack "Respond") urlrenderer (FinishLocalPairR msg)
button <- mkAlertButton True (T.pack "Respond") urlrenderer (FinishLocalPairR msg)
void $ addAlert $ pairRequestReceivedAlert repo button
where
repo = pairRepo msg

View file

@ -29,6 +29,7 @@ import Assistant.WebApp.Configurators.XMPP
import Assistant.WebApp.Configurators.Preferences
import Assistant.WebApp.Configurators.Edit
import Assistant.WebApp.Configurators.Delete
import Assistant.WebApp.Configurators.Fsck
import Assistant.WebApp.Documentation
import Assistant.WebApp.Control
import Assistant.WebApp.OtherRepos

View file

@ -336,7 +336,7 @@ pairMsgReceived urlrenderer PairReq theiruuid selfjid theirjid
finishXMPPPairing theirjid theiruuid
-- Show an alert to let the user decide if they want to pair.
showalert = do
button <- mkAlertButton (T.pack "Respond") urlrenderer $
button <- mkAlertButton True (T.pack "Respond") urlrenderer $
ConfirmXMPPPairFriendR $
PairKey theiruuid $ formatJID theirjid
void $ addAlert $ pairRequestReceivedAlert