Assistant monad, stage 2.5

Converted several threads to run in the monad.

Added a lot of useful combinators for working with the monad.

Now the monad includes the name of the thread.

Some debugging messages are disabled pending converting other threads.

Assistant/WebApp/Configurators/Edit.hs

@@ -69,7 +69,7 @@ setRepoConfig uuid mremote oldc newc = do
 	when (repoSyncable oldc /= repoSyncable newc) $
 		changeSyncable mremote (repoSyncable newc)
 	when (isJust mremote && repoName oldc /= repoName newc) $ do
-		dstatus <- getAssistantY daemonStatus
+		dstatus <- getAssistantY daemonStatusHandle
 		runAnnex undefined $ do
 			name <- fromRepo $ uniqueRemoteName (T.unpack $ repoName newc) 0
 			inRepo $ Git.Command.run "remote"

Assistant/WebApp/Configurators/Pairing.hs

@@ -87,7 +87,7 @@ getInprogressPairR _ = noPairing
  -}
 startPairing :: PairStage -> IO () -> (AlertButton -> Alert) -> Maybe UUID -> Text -> Secret -> Widget
 startPairing stage oncancel alert muuid displaysecret secret = do
-	dstatus <- lift $ getAssistantY daemonStatus
+	dstatus <- lift $ getAssistantY daemonStatusHandle
 	urlrender <- lift getUrlRender
 	reldir <- fromJust . relDir <$> lift getYesod
 

Assistant/WebApp/Configurators/S3.hs

@@ -124,5 +124,5 @@ makeS3Remote (S3Creds ak sk) name setup config = do
 		makeSpecialRemote name S3.remote config
 		return remotename
 	setup r
-	liftIO $ syncNewRemote st (daemonStatus d) (scanRemoteMap d) r
+	liftIO $ syncNewRemote st (daemonStatusHandle d) (scanRemoteMap d) r
 	redirect $ EditNewCloudRepositoryR $ Remote.uuid r

Assistant/WebApp/Configurators/Ssh.hs

@@ -286,7 +286,7 @@ makeSshRepo forcersync setup sshdata = do
 	d <- getAssistantY id
 	r <- liftIO $ makeSshRemote
 		(threadState d)
-		(daemonStatus d)
+		(daemonStatusHandle d)
 		(scanRemoteMap d)
 		forcersync sshdata
 	setup r

Assistant/WebApp/Configurators/XMPP.hs

@@ -34,7 +34,7 @@ import qualified Data.Text as T
 {- Displays an alert suggesting to configure XMPP, with a button. -}
 xmppNeeded :: Handler ()
 xmppNeeded = whenM (isNothing <$> runAnnex Nothing getXMPPCreds) $ do
-	dstatus <- getAssistantY daemonStatus
+	dstatus <- getAssistantY daemonStatusHandle
 	urlrender <- getUrlRender
 	void $ liftIO $ addAlert dstatus $ xmppNeededAlert $ AlertButton
 		{ buttonLabel = "Configure a Jabber account"

Assistant/WebApp/SideBar.hs

@@ -73,7 +73,7 @@ getSideBarR nid = do
 {- Called by the client to close an alert. -}
 getCloseAlert :: AlertId -> Handler ()
 getCloseAlert i = do
-	dstatus <- getAssistantY daemonStatus
+	dstatus <- getAssistantY daemonStatusHandle
 	liftIO $ removeAlert dstatus i
 
 {- When an alert with a button is clicked on, the button takes us here. -}

Assistant/WebApp/Utility.hs

@@ -37,7 +37,7 @@ changeSyncable (Just r) True = do
 changeSyncable (Just r) False = do
 	changeSyncFlag r False
 	d <- getAssistantY id
-	let dstatus = daemonStatus d
+	let dstatus = daemonStatusHandle d
 	let st = threadState d
 	liftIO $ runThreadState st $ updateSyncRemotes dstatus
 	{- Stop all transfers to or from this remote.
@@ -65,7 +65,7 @@ syncRemote remote = do
 	d <- getAssistantY id
 	liftIO $ syncNewRemote
 		(threadState d)
-		(daemonStatus d)
+		(daemonStatusHandle d)
 		(scanRemoteMap d)
 		remote
 
@@ -74,7 +74,7 @@ pauseTransfer = cancelTransfer True
 
 cancelTransfer :: Bool -> Transfer -> Handler ()
 cancelTransfer pause t = do
-	dstatus <- getAssistantY daemonStatus
+	dstatus <- getAssistantY daemonStatusHandle
 	tq <- getAssistantY transferQueue
 	m <- getCurrentTransfers
 	liftIO $ do
@@ -94,8 +94,9 @@ cancelTransfer pause t = do
 			maybe noop killproc $ transferPid info
 			if pause
 				then void $
-					alterTransferInfo dstatus t $ \i -> i
-						{ transferPaused = True }
+					alterTransferInfo t
+						(\i -> i { transferPaused = True })
+						dstatus
 				else void $
 					removeTransfer dstatus t
 		signalthread tid
@@ -117,19 +118,20 @@ startTransfer t = do
 	where
 		go info = maybe (start info) resume $ transferTid info
 		startqueued = do
-			dstatus <- getAssistantY daemonStatus
+			dstatus <- getAssistantY daemonStatusHandle
 			q <- getAssistantY transferQueue
 			is <- liftIO $ map snd <$> getMatchingTransfers q dstatus (== t)
 			maybe noop start $ headMaybe is
 		resume tid = do
-			dstatus <- getAssistantY daemonStatus
+			dstatus <- getAssistantY daemonStatusHandle
 			liftIO $ do
-				alterTransferInfo dstatus t $ \i -> i
-					{ transferPaused = False }
+				alterTransferInfo t
+					(\i -> i { transferPaused = False })
+					dstatus
 				throwTo tid ResumeTransfer
 		start info = do
 			st <- getAssistantY threadState
-			dstatus <- getAssistantY daemonStatus
+			dstatus <- getAssistantY daemonStatusHandle
 			slots <- getAssistantY transferSlots
 			commitchan <- getAssistantY commitChan
 			liftIO $ inImmediateTransferSlot dstatus slots $ do