diff options
| -rw-r--r-- | Assistant/Common.hs | 23 | ||||
| -rw-r--r-- | Assistant/Sync.hs | 3 | ||||
| -rw-r--r-- | Assistant/Threads/Committer.hs | 21 | ||||
| -rw-r--r-- | Assistant/Threads/Pusher.hs | 12 | ||||
| -rw-r--r-- | Assistant/Threads/SanityChecker.hs | 5 | ||||
| -rw-r--r-- | Assistant/Threads/TransferScanner.hs | 4 | ||||
| -rw-r--r-- | Assistant/Threads/Watcher.hs | 4 |
7 files changed, 33 insertions, 39 deletions
diff --git a/Assistant/Common.hs b/Assistant/Common.hs index fcb6d65c8..ebef9469a 100644 --- a/Assistant/Common.hs +++ b/Assistant/Common.hs @@ -76,23 +76,26 @@ updateAlertMap dstatus a = notifyAlert dstatus `after` modifyDaemonStatus_ dstat - - 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 = alertWhile' dstatus alert $ do +alertWhile :: Alert -> Assistant Bool -> Assistant Bool +alertWhile alert a = alertWhile' alert $ do r <- a return (r, r) {- Like alertWhile, but allows the activity to return a value too. -} -alertWhile' :: DaemonStatusHandle -> Alert -> IO (Bool, a) -> IO a -alertWhile' dstatus alert a = do +alertWhile' :: Alert -> Assistant (Bool, a) -> Assistant a +alertWhile' alert a = do let alert' = alert { alertClass = Activity } - i <- addAlert dstatus alert' + dstatus <- getAssistant daemonStatusHandle + i <- liftIO $ addAlert dstatus alert' (ok, r) <- a - updateAlertMap dstatus $ mergeAlert i $ makeAlertFiller ok alert' + liftIO $ updateAlertMap dstatus $ + mergeAlert i $ makeAlertFiller ok alert' return r {- Displays an alert while performing an activity, then removes it. -} -alertDuring :: DaemonStatusHandle -> Alert -> IO a -> IO a -alertDuring dstatus alert a = do +alertDuring :: Alert -> Assistant a -> Assistant a +alertDuring alert a = do let alert' = alert { alertClass = Activity } - i <- addAlert dstatus alert' - removeAlert dstatus i `after` a + dstatus <- getAssistant daemonStatusHandle + i <- liftIO $ addAlert dstatus alert' + liftIO (removeAlert dstatus i) `after` a diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index 4d5f8f625..6a2f5266e 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -38,8 +38,7 @@ import Control.Concurrent reconnectRemotes :: Bool -> [Remote] -> Assistant () reconnectRemotes _ [] = noop reconnectRemotes notifypushes rs = void $ do - dstatus <- getAssistant daemonStatusHandle - alertWhile dstatus (syncAlert rs) <~> do + alertWhile (syncAlert rs) $ do (ok, diverged) <- sync =<< liftAnnex (inRepo Git.Branch.current) scanremotes <- getAssistant scanRemoteMap diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index 7bcdaa836..b3a737872 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -58,8 +58,7 @@ commitThread = NamedThread "Committer" $ do , show (length readychanges) , "changes" ] - dstatus <- getAssistant daemonStatusHandle - void $ alertWhile dstatus commitAlert <~> + void $ alertWhile commitAlert $ liftAnnex commitStaged recordCommit <<~ commitChan else refill readychanges @@ -177,21 +176,19 @@ handleAdds delayadd cs = returnWhen (null incomplete) $ do add :: Change -> Assistant (Maybe Change) add change@(InProcessAddChange { keySource = ks }) = do - dstatus <- getAssistant daemonStatusHandle - alertWhile' dstatus (addFileAlert $ keyFilename ks) <~> add' change ks - add _ = return Nothing - - add' change ks = liftM ret $ catchMaybeIO <~> do - sanitycheck ks $ do - key <- liftAnnex $ do - showStart "add" $ keyFilename ks - Command.Add.ingest ks - done (finishedChange change) (keyFilename ks) key + alertWhile' (addFileAlert $ keyFilename ks) $ + liftM ret $ catchMaybeIO <~> do + sanitycheck ks $ do + key <- liftAnnex $ do + showStart "add" $ keyFilename ks + Command.Add.ingest ks + done (finishedChange change) (keyFilename ks) key where {- Add errors tend to be transient and will be automatically - dealt with, so don't pass to the alert code. -} ret (Just j@(Just _)) = (True, j) ret _ = (True, Nothing) + add _ = return Nothing done _ _ Nothing = do liftAnnex showEndFail diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs index 0235e6efc..95e4e1276 100644 --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -31,9 +31,8 @@ pushRetryThread = NamedThread "PushRetrier" $ runEvery (Seconds halfhour) <~> do topush <- liftIO $ getFailedPushesBefore pushmap (fromIntegral halfhour) unless (null topush) $ do debug ["retrying", show (length topush), "failed pushes"] - now <- liftIO $ getCurrentTime - dstatus <- getAssistant daemonStatusHandle - void $ alertWhile dstatus (pushRetryAlert topush) <~> + void $ alertWhile (pushRetryAlert topush) $ do + now <- liftIO $ getCurrentTime pushToRemotes now True topush where halfhour = 1800 @@ -48,10 +47,9 @@ pushThread = NamedThread "Pusher" $ runEvery (Seconds 2) <~> do if shouldPush commits then do remotes <- filter pushable . syncRemotes <$> daemonStatus - unless (null remotes) $ do - now <- liftIO $ getCurrentTime - dstatus <- getAssistant daemonStatusHandle - void $ alertWhile dstatus (pushAlert remotes) <~> + unless (null remotes) $ + void $ alertWhile (pushAlert remotes) $ do + now <- liftIO $ getCurrentTime pushToRemotes now True remotes else do debug ["delaying push of", show (length commits), "commits"] diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index d92c6c394..46f399dab 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -24,10 +24,7 @@ sanityCheckerThread = NamedThread "SanityChecker" $ forever $ do waitForNextCheck debug ["starting sanity check"] - - dstatus <- getAssistant daemonStatusHandle - void $ alertWhile dstatus sanityCheckAlert <~> go - + void $ alertWhile sanityCheckAlert go debug ["sanity check complete"] where go = do diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs index 8c46a79fa..3e99b60f5 100644 --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -100,10 +100,10 @@ failedTransferScan r = do expensiveScan :: [Remote] -> Assistant () expensiveScan rs = unless onlyweb $ do debug ["starting scan of", show visiblers] - dstatus <- getAssistant daemonStatusHandle - void $ alertWhile dstatus (scanAlert visiblers) <~> do + void $ alertWhile (scanAlert visiblers) $ do g <- liftAnnex gitRepo (files, cleanup) <- liftIO $ LsFiles.inRepo [] g + dstatus <- getAssistant daemonStatusHandle forM_ files $ \f -> do ts <- liftAnnex $ ifAnnexed f (findtransfers dstatus f) (return []) diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index 172b7976e..1c796a521 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -75,8 +75,7 @@ watchThread = NamedThread "Watcher" $ do startupScan :: IO a -> Assistant a startupScan scanner = do liftAnnex $ showAction "scanning" - dstatus <- getAssistant daemonStatusHandle - alertWhile' dstatus startupScanAlert <~> do + alertWhile' startupScanAlert $ do r <- liftIO $ scanner -- Notice any files that were deleted before @@ -85,6 +84,7 @@ startupScan scanner = do inRepo $ Git.Command.run "add" [Param "--update"] showAction "started" + dstatus <- getAssistant daemonStatusHandle liftIO $ modifyDaemonStatus_ dstatus $ \s -> s { scanComplete = True } |