From 1852eddce6191b2ab3554faafbe38759cbe19623 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 29 Oct 2012 16:49:47 -0400 Subject: [PATCH] lift alertWhile --- Assistant/Common.hs | 23 +++++++++++++---------- Assistant/Sync.hs | 3 +-- Assistant/Threads/Committer.hs | 21 +++++++++------------ Assistant/Threads/Pusher.hs | 12 +++++------- Assistant/Threads/SanityChecker.hs | 5 +---- Assistant/Threads/TransferScanner.hs | 4 ++-- Assistant/Threads/Watcher.hs | 4 ++-- Assistant/WebApp/Configurators/Pairing.hs | 10 ++++++---- Assistant/WebApp/Configurators/XMPP.hs | 1 - 9 files changed, 39 insertions(+), 44 deletions(-) diff --git a/Assistant/Common.hs b/Assistant/Common.hs index fcb6d65c8d..ebef9469a2 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 4d5f8f6257..6a2f5266ed 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 7bcdaa8367..b3a737872c 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 0235e6efc8..95e4e1276a 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 d92c6c394b..46f399dabd 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 8c46a79fa0..3e99b60f59 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 172b7976ef..1c796a521b 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 } diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index f85ff6752e..a33d4c7bdd 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -90,6 +90,8 @@ startPairing stage oncancel alert muuid displaysecret secret = do urlrender <- lift getUrlRender reldir <- fromJust . relDir <$> lift getYesod + sendrequests <- lift $ runAssistantY $ asIO2 $ mksendrequests urlrender + {- Generating a ssh key pair can take a while, so do it in the - background. -} void $ liftIO $ forkIO $ do @@ -102,7 +104,7 @@ startPairing stage oncancel alert muuid displaysecret secret = do <*> (maybe genUUID return muuid) let sender = multicastPairMsg Nothing secret pairdata let pip = PairingInProgress secret Nothing keypair pairdata stage - startSending dstatus pip stage $ sendrequests sender dstatus urlrender + startSending dstatus pip stage $ sendrequests sender lift $ redirect $ InprogressPairR $ toSecretReminder displaysecret where @@ -114,8 +116,8 @@ startPairing stage oncancel alert muuid displaysecret secret = do - have been on a page specific to the in-process pairing - that just stopped, so can't go back there. -} - sendrequests sender dstatus urlrender _stage = do - tid <- myThreadId + mksendrequests urlrender sender _stage = do + tid <- liftIO myThreadId let selfdestruct = AlertButton { buttonLabel = "Cancel" , buttonUrl = urlrender HomeR @@ -123,7 +125,7 @@ startPairing stage oncancel alert muuid displaysecret secret = do oncancel killThread tid } - alertDuring dstatus (alert selfdestruct) $ do + alertDuring (alert selfdestruct) $ liftIO $ do _ <- E.try (sender stage) :: IO (Either E.SomeException ()) return () diff --git a/Assistant/WebApp/Configurators/XMPP.hs b/Assistant/WebApp/Configurators/XMPP.hs index dbc1ab1071..e025c3bb71 100644 --- a/Assistant/WebApp/Configurators/XMPP.hs +++ b/Assistant/WebApp/Configurators/XMPP.hs @@ -14,7 +14,6 @@ import Assistant.WebApp import Assistant.WebApp.Types import Assistant.WebApp.SideBar import Assistant.Alert -import Assistant.DaemonStatus import Utility.Yesod #ifdef WITH_XMPP import Assistant.Common