lift alertWhile

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 :: Alert -> Assistant Bool -> Assistant Bool
-alertWhile dstatus alert a = alertWhile' dstatus alert $ do
+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' :: Alert -> Assistant (Bool, a) -> Assistant a
-alertWhile' dstatus alert a = do
+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 :: Alert -> Assistant a -> Assistant a
-alertDuring dstatus alert a = do
+alertDuring alert a = do
 	let alert' = alert { alertClass = Activity }
-	i <- addAlert dstatus alert'
+	dstatus <- getAssistant daemonStatusHandle
-	removeAlert dstatus i `after` a
+	i <- liftIO $ addAlert dstatus alert'
+	liftIO (removeAlert dstatus i) `after` a

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 (syncAlert rs) $ do
-	alertWhile dstatus (syncAlert rs) <~> do
 		(ok, diverged) <- sync
 			=<< liftAnnex (inRepo Git.Branch.current)
 		scanremotes <- getAssistant scanRemoteMap

Assistant/Threads/Committer.hs

@@ -58,8 +58,7 @@ commitThread = NamedThread "Committer" $ do
 							, show (length readychanges)
 							, "changes"
 							]
-						dstatus <- getAssistant daemonStatusHandle
+						void $ alertWhile commitAlert $
-						void $ alertWhile dstatus 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' (addFileAlert $ keyFilename ks) $
-		alertWhile' dstatus (addFileAlert $ keyFilename ks) <~> add' change ks
+			liftM ret $ catchMaybeIO <~> do
-	add _ = return Nothing
+				sanitycheck ks $ do
-
+					key <- liftAnnex $ do
-	add' change ks = liftM ret $ catchMaybeIO <~> do
+						showStart "add" $ keyFilename ks
-		sanitycheck ks $ do
+						Command.Add.ingest ks
-			key <- liftAnnex $ do
+					done (finishedChange change) (keyFilename ks) key
-				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

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
+		void $ alertWhile (pushRetryAlert topush) $ do
-		dstatus <- getAssistant daemonStatusHandle
+			now <- liftIO $ getCurrentTime
-		void $ alertWhile dstatus (pushRetryAlert topush) <~>
 			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
+			unless (null remotes) $
-				now <- liftIO $ getCurrentTime
+				void $ alertWhile (pushAlert remotes) $ do
-				dstatus <- getAssistant daemonStatusHandle
+					now <- liftIO $ getCurrentTime
-				void $ alertWhile dstatus (pushAlert remotes) <~>
 					pushToRemotes now True remotes
 		else do
 			debug ["delaying push of", show (length commits), "commits"]

Assistant/Threads/SanityChecker.hs

@@ -24,10 +24,7 @@ sanityCheckerThread = NamedThread "SanityChecker" $ forever $ do
 	waitForNextCheck
 
 	debug ["starting sanity check"]
-
+	void $ alertWhile sanityCheckAlert go
-	dstatus <- getAssistant daemonStatusHandle
-	void $ alertWhile dstatus sanityCheckAlert <~> go
-	
 	debug ["sanity check complete"]
   where
 	go = do

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 (scanAlert visiblers) $ do
-	void $ alertWhile dstatus (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 [])

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' startupScanAlert $ do
-	alertWhile' dstatus 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 }
 

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
+		mksendrequests urlrender sender _stage = do
-			tid <- myThreadId
+			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 ()
 

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