aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Assistant.hs2
-rw-r--r--Assistant/Alert.hs18
-rw-r--r--Assistant/DeleteRemote.hs2
-rw-r--r--Assistant/NamedThread.hs2
-rw-r--r--Assistant/Threads/Cronner.hs40
-rw-r--r--Assistant/Threads/PairListener.hs2
-rw-r--r--Assistant/Threads/WebApp.hs1
-rw-r--r--Assistant/Threads/XMPPClient.hs2
8 files changed, 47 insertions, 22 deletions
diff --git a/Assistant.hs b/Assistant.hs
index ff5165db9..8a0c574ab 100644
--- a/Assistant.hs
+++ b/Assistant.hs
@@ -134,7 +134,7 @@ startDaemon assistant foreground listenhost startbrowser = do
, assist $ netWatcherThread
, assist $ netWatcherFallbackThread
, assist $ transferScannerThread urlrenderer
- , assist $ cronnerThread
+ , assist $ cronnerThread urlrenderer
, assist $ configMonitorThread
, assist $ glacierThread
, watch $ watchThread
diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs
index df5ee2910..e7b731a8c 100644
--- a/Assistant/Alert.hs
+++ b/Assistant/Alert.hs
@@ -27,17 +27,19 @@ import Assistant.WebApp
import Yesod
#endif
-{- Makes a button for an alert that opens a Route. The button will
- - close the alert it's attached to when clicked. -}
+{- Makes a button for an alert that opens a Route.
+ -
+ - If autoclose is set, the button will close the alert it's
+ - attached to when clicked. -}
#ifdef WITH_WEBAPP
-mkAlertButton :: T.Text -> UrlRenderer -> Route WebApp -> Assistant AlertButton
-mkAlertButton label urlrenderer route = do
+mkAlertButton :: Bool -> T.Text -> UrlRenderer -> Route WebApp -> Assistant AlertButton
+mkAlertButton autoclose label urlrenderer route = do
close <- asIO1 removeAlert
url <- liftIO $ renderUrl urlrenderer route []
return $ AlertButton
{ buttonLabel = label
, buttonUrl = url
- , buttonAction = Just close
+ , buttonAction = if autoclose then Just close else Nothing
}
#endif
@@ -147,6 +149,12 @@ sanityCheckFixAlert msg = Alert
alerthead = "The daily sanity check found and fixed a problem:"
alertfoot = "If these problems persist, consider filing a bug report."
+fsckAlert :: AlertButton -> Alert
+fsckAlert button = baseActivityAlert
+ { alertData = [ UnTensed "Consistency check in progress" ]
+ , alertButton = Just button
+ }
+
pairingAlert :: AlertButton -> Alert
pairingAlert button = baseActivityAlert
{ alertData = [ UnTensed "Pairing in progress" ]
diff --git a/Assistant/DeleteRemote.hs b/Assistant/DeleteRemote.hs
index 6a77eedc6..cc05786e4 100644
--- a/Assistant/DeleteRemote.hs
+++ b/Assistant/DeleteRemote.hs
@@ -81,7 +81,7 @@ finishRemovingRemote :: UrlRenderer -> UUID -> Assistant ()
#ifdef WITH_WEBAPP
finishRemovingRemote urlrenderer uuid = do
desc <- liftAnnex $ Remote.prettyUUID uuid
- button <- mkAlertButton (T.pack "Finish deletion process") urlrenderer $
+ button <- mkAlertButton True (T.pack "Finish deletion process") urlrenderer $
FinishDeleteRepositoryR uuid
void $ addAlert $ remoteRemovalAlert desc button
#else
diff --git a/Assistant/NamedThread.hs b/Assistant/NamedThread.hs
index f29f0cf36..2440c45bf 100644
--- a/Assistant/NamedThread.hs
+++ b/Assistant/NamedThread.hs
@@ -76,7 +76,7 @@ startNamedThread urlrenderer (NamedThread afterstartupsanitycheck name a) = do
]
hPutStrLn stderr msg
#ifdef WITH_WEBAPP
- button <- runAssistant d $ mkAlertButton
+ button <- runAssistant d $ mkAlertButton True
(T.pack "Restart Thread")
urlrenderer
(RestartThreadR name)
diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs
index 1a27e3c1b..baec094fc 100644
--- a/Assistant/Threads/Cronner.hs
+++ b/Assistant/Threads/Cronner.hs
@@ -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 ()
diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs
index 882c95cc2..482b0923c 100644
--- a/Assistant/Threads/PairListener.hs
+++ b/Assistant/Threads/PairListener.hs
@@ -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
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index 4620b0387..2c5b1dbd2 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/Assistant/Threads/WebApp.hs
@@ -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
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index ffd487ae1..8eb469939 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/Assistant/Threads/XMPPClient.hs
@@ -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
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-10 17:43:57 +0000