diff options
| -rw-r--r-- | Assistant.hs | 2 | ||||
| -rw-r--r-- | Assistant/Threads/Pusher.hs | 23 | ||||
| -rw-r--r-- | Assistant/Threads/SanityChecker.hs | 57 |
3 files changed, 53 insertions, 29 deletions
diff --git a/Assistant.hs b/Assistant.hs index 1f41a9398..22a87fe8c 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -146,7 +146,7 @@ startDaemon assistant foreground webappwaiter mapM_ forkIO [ commitThread st changechan commitchan transferqueue dstatus , pushThread st dstatus commitchan pushmap - , pushRetryThread st pushmap + , pushRetryThread st dstatus pushmap , mergeThread st , transferWatcherThread st dstatus , transfererThread st dstatus transferqueue transferslots diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs index 3762c4836..27e95a734 100644 --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -10,12 +10,14 @@ module Assistant.Threads.Pusher where import Assistant.Common import Assistant.Commits import Assistant.Pushes -import Assistant.DaemonStatus +import Assistant.Alert import Assistant.ThreadedMonad import Assistant.Threads.Merger +import Assistant.DaemonStatus import qualified Command.Sync import Utility.ThreadScheduler import Utility.Parallel +import qualified Remote import Data.Time.Clock import qualified Data.Map as M @@ -24,8 +26,8 @@ thisThread :: ThreadName thisThread = "Pusher" {- This thread retries pushes that failed before. -} -pushRetryThread :: ThreadState -> FailedPushMap -> IO () -pushRetryThread st pushmap = runEvery (Seconds halfhour) $ do +pushRetryThread :: ThreadState -> DaemonStatusHandle -> FailedPushMap -> IO () +pushRetryThread st dstatus pushmap = runEvery (Seconds halfhour) $ do -- We already waited half an hour, now wait until there are failed -- pushes to retry. topush <- getFailedPushesBefore pushmap (fromIntegral halfhour) @@ -36,13 +38,16 @@ pushRetryThread st pushmap = runEvery (Seconds halfhour) $ do , "failed pushes" ] now <- getCurrentTime - pushToRemotes thisThread now st (Just pushmap) topush + alertWhile dstatus (alert topush) $ + pushToRemotes thisThread now st (Just pushmap) topush where halfhour = 1800 + alert rs = activityAlert (Just "Retrying sync") $ + "with " ++ unwords (map Remote.name rs) ++ ", which failed earlier." {- This thread pushes git commits out to remotes soon after they are made. -} pushThread :: ThreadState -> DaemonStatusHandle -> CommitChan -> FailedPushMap -> IO () -pushThread st daemonstatus commitchan pushmap = do +pushThread st dstatus commitchan pushmap = do runEvery (Seconds 2) $ do -- We already waited two seconds as a simple rate limiter. -- Next, wait until at least one commit has been made @@ -51,8 +56,9 @@ pushThread st daemonstatus commitchan pushmap = do now <- getCurrentTime if shouldPush now commits then do - remotes <- knownRemotes <$> getDaemonStatus daemonstatus - pushToRemotes thisThread now st (Just pushmap) remotes + remotes <- knownRemotes <$> getDaemonStatus dstatus + alertWhile dstatus (syncalert remotes) $ + pushToRemotes thisThread now st (Just pushmap) remotes else do debug thisThread [ "delaying push of" @@ -60,6 +66,9 @@ pushThread st daemonstatus commitchan pushmap = do , "commits" ] refillCommits commitchan commits + where + syncalert rs = activityAlert Nothing $ + "Syncing with " ++ unwords (map Remote.name rs) {- Decide if now is a good time to push to remotes. - diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index 5e27246a0..69610c2a7 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -13,6 +13,7 @@ import Assistant.Common import Assistant.DaemonStatus import Assistant.ThreadedMonad import Assistant.Changes +import Assistant.Alert import Assistant.TransferQueue import qualified Git.LsFiles import Utility.ThreadScheduler @@ -25,29 +26,34 @@ thisThread = "SanityChecker" {- This thread wakes up occasionally to make sure the tree is in good shape. -} sanityCheckerThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO () -sanityCheckerThread st status transferqueue changechan = forever $ do - waitForNextCheck status +sanityCheckerThread st dstatus transferqueue changechan = forever $ do + waitForNextCheck dstatus debug thisThread ["starting sanity check"] - modifyDaemonStatus_ status $ \s -> s - { sanityCheckRunning = True } - - now <- getPOSIXTime -- before check started - catchIO (check st status transferqueue changechan) - (runThreadState st . warning . show) - - modifyDaemonStatus_ status $ \s -> s - { sanityCheckRunning = False - , lastSanityCheck = Just now - } + alertWhile dstatus alert go debug thisThread ["sanity check complete"] + where + go = do + modifyDaemonStatus_ dstatus $ \s -> s + { sanityCheckRunning = True } + + now <- getPOSIXTime -- before check started + catchIO (check st dstatus transferqueue changechan) + (runThreadState st . warning . show) + + modifyDaemonStatus_ dstatus $ \s -> s + { sanityCheckRunning = False + , lastSanityCheck = Just now + } + alert = activityAlert (Just "Running daily sanity check") + "to make sure I've not missed anything." {- Only run one check per day, from the time of the last check. -} waitForNextCheck :: DaemonStatusHandle -> IO () -waitForNextCheck status = do - v <- lastSanityCheck <$> getDaemonStatus status +waitForNextCheck dstatus = do + v <- lastSanityCheck <$> getDaemonStatus dstatus now <- getPOSIXTime threadDelaySeconds $ Seconds $ calcdelay now v where @@ -64,10 +70,8 @@ oneDay = 24 * 60 * 60 - running potentially expensive parts of this check, since remaining in it - will block the watcher. -} check :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO () -check st status transferqueue changechan = do - g <- runThreadState st $ do - showSideAction "Running daily check" - fromRepo id +check st dstatus transferqueue changechan = do + g <- runThreadState st $ fromRepo id -- Find old unstaged symlinks, and add them to git. unstaged <- Git.LsFiles.notInRepo False ["."] g now <- getPOSIXTime @@ -81,9 +85,20 @@ check st status transferqueue changechan = do where toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime) slop = fromIntegral tenMinutes - insanity m = runThreadState st $ warning m + insanity msg = do + runThreadState st $ warning msg + void $ addAlert dstatus $ Alert + { alertClass = Warning + , alertHeader = Just "Fixed a problem" + , alertMessage = StringAlert $ unwords + [ "The daily sanity check found and fixed a problem:" + , msg + , "If these problems persist, consider filing a bug report." + ] + , alertBlockDisplay = True + } addsymlink file s = do insanity $ "found unstaged symlink: " ++ file - Watcher.runHandler thisThread st status + Watcher.runHandler thisThread st dstatus transferqueue changechan Watcher.onAddSymlink file s |