diff options
| -rw-r--r-- | Assistant/Alert.hs | 34 | ||||
| -rw-r--r-- | Assistant/DaemonStatus.hs | 27 | ||||
| -rw-r--r-- | Assistant/Threads/MountWatcher.hs | 2 | ||||
| -rw-r--r-- | Assistant/Threads/Pusher.hs | 17 | ||||
| -rw-r--r-- | Assistant/Threads/SanityChecker.hs | 13 | ||||
| -rw-r--r-- | Assistant/Threads/TransferScanner.hs | 5 | ||||
| -rw-r--r-- | Assistant/Threads/Watcher.hs | 13 | ||||
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 2 |
8 files changed, 84 insertions, 29 deletions
diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index 49ad515ad..23a93b1c1 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -20,8 +20,8 @@ type Widget = forall sub master. GWidget sub master () data AlertClass = Success | Message | Activity | Warning | Error deriving (Eq, Ord) -{- An alert can be a simple message, or an arbitrary Yesod Widget -} -data AlertMessage = StringAlert String | WidgetAlert Widget +{- An alert can be a simple message, or an arbitrary Yesod Widget. -} +data AlertMessage = StringAlert String | WidgetAlert (Alert -> Widget) data Alert = Alert { alertClass :: AlertClass @@ -37,7 +37,7 @@ type AlertId = Integer type AlertPair = (AlertId, Alert) -data AlertPriority = Low | Medium | High | Pinned +data AlertPriority = Filler | Low | Medium | High | Pinned deriving (Eq, Ord) {- The desired order is the reverse of: @@ -45,7 +45,8 @@ data AlertPriority = Low | Medium | High | Pinned - - Pinned alerts - - High priority alerts, newest first - - Medium priority Activity, newest first (mostly used for Activity) - - - Low priority alwerts, newest first + - - Low priority alerts, newest first + - - Filler priorty alerts, newest first - - Ties are broken by the AlertClass, with Errors etc coming first. -} compareAlertPairs :: AlertPair -> AlertPair -> Ordering @@ -56,6 +57,31 @@ compareAlertPairs `thenOrd` compare aid bid `thenOrd` compare aclass bclass +makeAlertFiller :: Bool -> Alert -> Alert +makeAlertFiller success alert + | alertPriority alert == Filler = alert + | otherwise = alert + { alertClass = if c == Activity then c' else c + , alertPriority = Filler + , alertHeader = finished <$> h + , alertMessage = massage m + } + where + h = alertHeader alert + m = alertMessage alert + c = alertClass alert + c' + | success = Success + | otherwise = Error + + massage (WidgetAlert w) = WidgetAlert w -- renders old on its own + massage (StringAlert s) = StringAlert $ + maybe (finished s) (const s) h + + finished s + | success = s ++ ": Succeeded" + | otherwise = s ++ ": Failed" + sortAlertPairs :: [AlertPair] -> [AlertPair] sortAlertPairs = reverse . sortBy compareAlertPairs diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index f1b3bdb9f..6d05c6152 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -223,12 +223,29 @@ addAlert dstatus alert = notifyAlert dstatus `after` modifyDaemonStatus dstatus m = M.insertWith' const i alert (alertMap s) removeAlert :: DaemonStatusHandle -> AlertId -> IO () -removeAlert dstatus i = notifyAlert dstatus `after` modifyDaemonStatus_ dstatus go +removeAlert dstatus i = updateAlert dstatus i (const Nothing) + +updateAlert :: DaemonStatusHandle -> AlertId -> (Alert -> Maybe Alert) -> IO () +updateAlert dstatus i a = updateAlertMap dstatus $ \m -> M.update a i m + +updateAlertMap :: DaemonStatusHandle -> (AlertMap -> AlertMap) -> IO () +updateAlertMap dstatus a = notifyAlert dstatus `after` modifyDaemonStatus_ dstatus go where - go s = s { alertMap = M.delete i (alertMap s) } + go s = s { alertMap = a (alertMap s) } -{- Displays an alert while performing an activity, then removes it. -} -alertWhile :: DaemonStatusHandle -> Alert -> IO a -> IO a +{- Displays an alert while performing an activity. + - + - The alert is left visible afterwards, as filler. + - Old filler is pruned, to prevent the map growing too large. -} +alertWhile :: DaemonStatusHandle -> Alert -> IO Bool -> IO Bool alertWhile dstatus alert a = do let alert' = alert { alertClass = Activity } - bracket (addAlert dstatus alert') (removeAlert dstatus) (const a) + i <- addAlert dstatus alert' + r <- bracket_ noop noop a + updateAlertMap dstatus $ makeold i (makeAlertFiller r) + return r + where + -- TODO prune old filler + makeold i filler m + | M.size m < 20 = M.adjust filler i m + | otherwise = M.adjust filler i m diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index 20862dac1..4baef1d11 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -165,7 +165,7 @@ handleMount st dstatus scanremotes mntent = do branch <- runThreadState st $ Command.Sync.currentBranch let nonspecial = filter (Git.repoIsLocal . Remote.repo) rs unless (null nonspecial) $ - alertWhile dstatus (syncMountAlert dir nonspecial) $ do + void $ alertWhile dstatus (syncMountAlert dir nonspecial) $ do debug thisThread ["syncing with", show nonspecial] runThreadState st $ manualPull branch nonspecial now <- getCurrentTime diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs index 1b0420b9b..0a0edf1d0 100644 --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -37,7 +37,7 @@ pushRetryThread st dstatus pushmap = runEvery (Seconds halfhour) $ do , "failed pushes" ] now <- getCurrentTime - alertWhile dstatus (pushRetryAlert topush) $ + void $ alertWhile dstatus (pushRetryAlert topush) $ pushToRemotes thisThread now st (Just pushmap) topush where halfhour = 1800 @@ -54,7 +54,7 @@ pushThread st dstatus commitchan pushmap = do if shouldPush now commits then do remotes <- knownRemotes <$> getDaemonStatus dstatus - alertWhile dstatus (pushAlert remotes) $ + void $ alertWhile dstatus (pushAlert remotes) $ pushToRemotes thisThread now st (Just pushmap) remotes else do debug thisThread @@ -80,7 +80,7 @@ shouldPush _now commits - - Avoids running possibly long-duration commands in the Annex monad, so - as not to block other threads. -} -pushToRemotes :: ThreadName -> UTCTime -> ThreadState -> (Maybe FailedPushMap) -> [Remote] -> IO () +pushToRemotes :: ThreadName -> UTCTime -> ThreadState -> (Maybe FailedPushMap) -> [Remote] -> IO Bool pushToRemotes threadname now st mpushmap remotes = do (g, branch) <- runThreadState st $ (,) <$> fromRepo id <*> Command.Sync.currentBranch @@ -92,6 +92,11 @@ pushToRemotes threadname now st mpushmap remotes = do , show rs ] Command.Sync.updateBranch (Command.Sync.syncBranch branch) g + {- TODO git push exits nonzero if the remote + - is already up-to-date. This code does not tell + - the difference between the two. Could perhaps + - be check the refs when it seemed to fail? + - Note bewloe -} (succeeded, failed) <- inParallel (push g branch) rs case mpushmap of Nothing -> noop @@ -104,8 +109,10 @@ pushToRemotes threadname now st mpushmap remotes = do [ "failed to push to" , show failed ] - unless (null failed || not shouldretry) $ - retry branch g failed + if (null failed || not shouldretry) + {- TODO see above TODO item -} + then return True -- return $ null failed + else retry branch g failed makemap l = M.fromList $ zip l (repeat now) diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index cd5dc0644..a7c2189d8 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -31,7 +31,7 @@ sanityCheckerThread st dstatus transferqueue changechan = forever $ do debug thisThread ["starting sanity check"] - alertWhile dstatus sanityCheckAlert go + void $ alertWhile dstatus sanityCheckAlert go debug thisThread ["sanity check complete"] where @@ -40,14 +40,18 @@ sanityCheckerThread st dstatus transferqueue changechan = forever $ do { sanityCheckRunning = True } now <- getPOSIXTime -- before check started - catchIO (check st dstatus transferqueue changechan) - (runThreadState st . warning . show) + r <- catchIO (check st dstatus transferqueue changechan) + $ \e -> do + runThreadState st $ warning $ show e + return False modifyDaemonStatus_ dstatus $ \s -> s { sanityCheckRunning = False , lastSanityCheck = Just now } + return r + {- Only run one check per day, from the time of the last check. -} waitForNextCheck :: DaemonStatusHandle -> IO () waitForNextCheck dstatus = do @@ -67,7 +71,7 @@ oneDay = 24 * 60 * 60 {- It's important to stay out of the Annex monad as much as possible while - running potentially expensive parts of this check, since remaining in it - will block the watcher. -} -check :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO () +check :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO Bool check st dstatus transferqueue changechan = do g <- runThreadState st $ fromRepo id -- Find old unstaged symlinks, and add them to git. @@ -80,6 +84,7 @@ check st dstatus transferqueue changechan = do | isSymbolicLink s -> addsymlink file ms _ -> noop + return True where toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime) slop = fromIntegral tenMinutes diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs index 1d91a65d4..2cba0b2a7 100644 --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -32,18 +32,19 @@ transferScannerThread st dstatus scanremotes transferqueue = do runEvery (Seconds 2) $ do r <- getScanRemote scanremotes liftIO $ debug thisThread ["starting scan of", show r] - alertWhile dstatus (scanAlert r) $ + void $ alertWhile dstatus (scanAlert r) $ scan st dstatus transferqueue r liftIO $ debug thisThread ["finished scan of", show r] {- This is a naive scan through the git work tree. - - The scan is blocked when the transfer queue gets too large. -} -scan :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Remote -> IO () +scan :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Remote -> IO Bool scan st dstatus transferqueue r = do g <- runThreadState st $ fromRepo id files <- LsFiles.inRepo [] g go files + return True where go [] = return () go (f:fs) = do diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index ddbd51655..bfeec7630 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -72,24 +72,23 @@ watchThread st dstatus transferqueue changechan = do } {- Initial scartup scan. The action should return once the scan is complete. -} -startupScan :: ThreadState -> DaemonStatusHandle -> IO a -> IO a +startupScan :: ThreadState -> DaemonStatusHandle -> IO a -> IO () startupScan st dstatus scanner = do runThreadState st $ showAction "scanning" - r <- alertWhile dstatus startupScanAlert $ do - r <- scanner - modifyDaemonStatus_ dstatus $ \s -> s { scanComplete = True } + void $ alertWhile dstatus startupScanAlert $ do + void $ scanner -- Notice any files that were deleted before -- watching was started. runThreadState st $ do inRepo $ Git.Command.run "add" [Param "--update"] showAction "started" - return r + + modifyDaemonStatus_ dstatus $ \s -> s { scanComplete = True } + return True void $ addAlert dstatus runningAlert - return r - ignored :: FilePath -> Bool ignored = ig . takeFileName where diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 7ad40c307..d26855910 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -232,7 +232,7 @@ sideBarDisplay noScript = do (alertHeader alert) $ case alertMessage alert of StringAlert s -> [whamlet|#{s}|] - WidgetAlert w -> w + WidgetAlert w -> w alert rendermessage msg = addalert "yesodmessage" True False "alert-info" Nothing [whamlet|#{msg}|] |