pushed Assistant monad down into DaemonStatus code

Currently have three old versions of functions that more reworking is
needed to remove: getDaemonStatusOld, modifyDaemonStatusOld_, and
modifyDaemonStatusOld

Assistant/DaemonStatus.hs

@@ -31,11 +31,16 @@ getDaemonStatusOld = atomically . readTMVar
 getDaemonStatus :: Assistant DaemonStatus
 getDaemonStatus = (atomically . readTMVar) <<~ daemonStatusHandle
 
-modifyDaemonStatus_ :: DaemonStatusHandle -> (DaemonStatus -> DaemonStatus) -> IO ()
+-- TODO remove this
-modifyDaemonStatus_ dstatus a = modifyDaemonStatus dstatus $ \s -> (a s, ())
+modifyDaemonStatusOld_ :: DaemonStatusHandle -> (DaemonStatus -> DaemonStatus) -> IO ()
+modifyDaemonStatusOld_ dstatus a = modifyDaemonStatusOld dstatus $ \s -> (a s, ())
 
-modifyDaemonStatus :: DaemonStatusHandle -> (DaemonStatus -> (DaemonStatus, b)) -> IO b
+modifyDaemonStatus_ :: (DaemonStatus -> DaemonStatus) -> Assistant ()
-modifyDaemonStatus dstatus a = do
+modifyDaemonStatus_ a = modifyDaemonStatus $ \s -> (a s, ())
+
+-- TODO remove this
+modifyDaemonStatusOld :: DaemonStatusHandle -> (DaemonStatus -> (DaemonStatus, b)) -> IO b
+modifyDaemonStatusOld dstatus a = do
 	(s, b) <- atomically $ do
 		r@(s, _) <- a <$> takeTMVar dstatus
 		putTMVar dstatus s
@@ -43,6 +48,17 @@ modifyDaemonStatus dstatus a = do
 	sendNotification $ changeNotifier s
 	return b
 
+modifyDaemonStatus :: (DaemonStatus -> (DaemonStatus, b)) -> Assistant b
+modifyDaemonStatus a = do
+	dstatus <- getAssistant daemonStatusHandle
+	liftIO $ do
+		(s, b) <- atomically $ do
+			r@(s, _) <- a <$> takeTMVar dstatus
+			putTMVar dstatus s
+			return r
+		sendNotification $ changeNotifier s
+		return b
+
 {- Syncable remotes ordered by cost. -}
 calcSyncRemotes :: Annex [Remote]
 calcSyncRemotes = do
@@ -53,11 +69,10 @@ calcSyncRemotes = do
 	return $ filter good rs
 
 {- Updates the sycRemotes list from the list of all remotes in Annex state. -}
-updateSyncRemotes :: DaemonStatusHandle -> Annex ()
+updateSyncRemotes :: Assistant ()
-updateSyncRemotes dstatus = do
+updateSyncRemotes = do
-	remotes <- calcSyncRemotes
+	remotes <- liftAnnex calcSyncRemotes
-	liftIO $ modifyDaemonStatus_ dstatus $
+	modifyDaemonStatus_ $ \s -> s { syncRemotes = remotes }
-		\s -> s { syncRemotes = remotes }
 
 {- Load any previous daemon status file, and store it in a MVar for this
  - process to use as its DaemonStatus. Also gets current transfer status. -}
@@ -136,15 +151,14 @@ adjustTransfersSTM dstatus a = do
 	putTMVar dstatus $ s { currentTransfers = a (currentTransfers s) }
 
 {- Alters a transfer's info, if the transfer is in the map. -}
-alterTransferInfo :: DaemonStatusHandle -> Transfer -> (TransferInfo -> TransferInfo) -> IO ()
+alterTransferInfo :: Transfer -> (TransferInfo -> TransferInfo) -> Assistant ()
-alterTransferInfo dstatus t a = updateTransferInfo' dstatus $ M.adjust a t
+alterTransferInfo t a = updateTransferInfo' $ M.adjust a t
 
 {- Updates a transfer's info. Adds the transfer to the map if necessary,
  - or if already present, updates it while preserving the old transferTid,
  - transferPaused, and bytesComplete values, which are not written to disk. -}
-updateTransferInfo :: DaemonStatusHandle -> Transfer -> TransferInfo -> IO ()
+updateTransferInfo :: Transfer -> TransferInfo -> Assistant ()
-updateTransferInfo dstatus t info = updateTransferInfo' dstatus $
+updateTransferInfo t info = updateTransferInfo' $ M.insertWith' merge t info
-	M.insertWith' merge t info
 	where
 		merge new old = new
 			{ transferTid = maybe (transferTid new) Just (transferTid old)
@@ -152,52 +166,59 @@ updateTransferInfo dstatus t info = updateTransferInfo' dstatus $
 			, bytesComplete = maybe (bytesComplete new) Just (bytesComplete old)
 			}
 
-updateTransferInfo' :: DaemonStatusHandle -> (TransferMap -> TransferMap) -> IO ()
+updateTransferInfo' :: (TransferMap -> TransferMap) -> Assistant ()
-updateTransferInfo' dstatus a =
+updateTransferInfo' a = notifyTransfer `after` modifyDaemonStatus_ update
-	notifyTransfer dstatus `after` modifyDaemonStatus_ dstatus go
 	where
-		go s = s { currentTransfers = a (currentTransfers s) }
+		update s = s { currentTransfers = a (currentTransfers s) }
 
 {- Removes a transfer from the map, and returns its info. -}
-removeTransfer :: DaemonStatusHandle -> Transfer -> IO (Maybe TransferInfo)
+removeTransfer :: Transfer -> Assistant (Maybe TransferInfo)
-removeTransfer dstatus t = 
+removeTransfer t = notifyTransfer `after` modifyDaemonStatus remove
-	notifyTransfer dstatus `after` modifyDaemonStatus dstatus go
 	where
-		go s =
+		remove s =
 			let (info, ts) = M.updateLookupWithKey
 				(\_k _v -> Nothing)
 				t (currentTransfers s)
 			in (s { currentTransfers = ts }, info)
 
 {- Send a notification when a transfer is changed. -}
-notifyTransfer :: DaemonStatusHandle -> IO ()
+notifyTransfer :: Assistant ()
-notifyTransfer dstatus = sendNotification
+notifyTransfer = do
+	dstatus <- getAssistant daemonStatusHandle
+	liftIO $ sendNotification
+		=<< transferNotifier <$> atomically (readTMVar dstatus)
+
+-- TODO remove
+notifyTransferOld :: DaemonStatusHandle -> IO ()
+notifyTransferOld dstatus = sendNotification
 	=<< transferNotifier <$> atomically (readTMVar dstatus)
 
 {- Send a notification when alerts are changed. -}
-notifyAlert :: DaemonStatusHandle -> IO ()
+notifyAlert :: Assistant ()
-notifyAlert dstatus = sendNotification
+notifyAlert = do
-	=<< alertNotifier <$> atomically (readTMVar dstatus)
+	dstatus <- getAssistant daemonStatusHandle
+	liftIO $ sendNotification
+		=<< alertNotifier <$> atomically (readTMVar dstatus)
 
 {- Returns the alert's identifier, which can be used to remove it. -}
-addAlert :: DaemonStatusHandle -> Alert -> IO AlertId
+addAlert :: Alert -> Assistant AlertId
-addAlert dstatus alert = notifyAlert dstatus `after` modifyDaemonStatus dstatus go
+addAlert alert = notifyAlert `after` modifyDaemonStatus add
 	where
-		go s = (s { lastAlertId = i, alertMap = m }, i)
+		add s = (s { lastAlertId = i, alertMap = m }, i)
 			where
 				i = nextAlertId $ lastAlertId s
 				m = mergeAlert i alert (alertMap s)
 
-removeAlert :: DaemonStatusHandle -> AlertId -> IO ()
+removeAlert :: AlertId -> Assistant ()
-removeAlert dstatus i = updateAlert dstatus i (const Nothing)
+removeAlert i = updateAlert i (const Nothing)
 
-updateAlert :: DaemonStatusHandle -> AlertId -> (Alert -> Maybe Alert) -> IO ()
+updateAlert :: AlertId -> (Alert -> Maybe Alert) -> Assistant ()
-updateAlert dstatus i a = updateAlertMap dstatus $ \m -> M.update a i m
+updateAlert i a = updateAlertMap $ \m -> M.update a i m
 
-updateAlertMap :: DaemonStatusHandle -> (AlertMap -> AlertMap) -> IO ()
+updateAlertMap :: (AlertMap -> AlertMap) -> Assistant ()
-updateAlertMap dstatus a = notifyAlert dstatus `after` modifyDaemonStatus_ dstatus go
+updateAlertMap a = notifyAlert `after` modifyDaemonStatus_ update
 	where
-		go s = s { alertMap = a (alertMap s) }
+		update s = s { alertMap = a (alertMap s) }
 
 {- Displays an alert while performing an activity that returns True on
  - success.
@@ -213,17 +234,13 @@ alertWhile alert a = alertWhile' alert $ do
 alertWhile' :: Alert -> Assistant (Bool, a) -> Assistant a
 alertWhile' alert a = do
 	let alert' = alert { alertClass = Activity }
-	dstatus <- getAssistant daemonStatusHandle
+	i <- addAlert alert'
-	i <- liftIO $ addAlert dstatus alert'
 	(ok, r) <- a
-	liftIO $ updateAlertMap dstatus $
+	updateAlertMap $ mergeAlert i $ makeAlertFiller ok alert'
-		mergeAlert i $ makeAlertFiller ok alert'
 	return r
 
 {- Displays an alert while performing an activity, then removes it. -}
 alertDuring :: Alert -> Assistant a -> Assistant a
 alertDuring alert a = do
-	let alert' = alert { alertClass = Activity }
+	i <- addAlert $ alert { alertClass = Activity }
-	dstatus <- getAssistant daemonStatusHandle
+	removeAlert  i `after` a
-	i <- liftIO $ addAlert dstatus alert'
-	liftIO (removeAlert dstatus i) `after` a

Assistant/Monad.hs

@@ -13,7 +13,6 @@ module Assistant.Monad (
 	newAssistantData,
 	runAssistant,
 	getAssistant,
-	withAssistant,
 	liftAnnex,
 	(<~>),
 	(<<~),
@@ -110,6 +109,3 @@ asIO2 a = do
 {- Runs an IO action on a selected field of the AssistantData. -}
 (<<~) :: (a -> IO b) -> (AssistantData -> a) -> Assistant b
 io <<~ v = reader v >>= liftIO . io
-
-withAssistant :: (AssistantData -> a) -> (a -> IO b) -> Assistant b
-withAssistant v io = io <<~ v

Assistant/NamedThread.hs

@@ -26,5 +26,5 @@ runNamedThread (NamedThread name a) = do
 				let msg = unwords [name, "crashed:", show e]
 				hPutStrLn stderr msg
 				-- TODO click to restart
-				void $ addAlert (daemonStatusHandle d) $
+				flip runAssistant d $ void $
-					warningAlert name msg
+					addAlert $ warningAlert name msg

Assistant/Pairing/Network.hs

@@ -80,7 +80,7 @@ startSending :: DaemonStatusHandle -> PairingInProgress -> PairStage -> (PairSta
 startSending dstatus pip stage sender = void $ forkIO $ do
 	tid <- myThreadId
 	let pip' = pip { inProgressPairStage = stage, inProgressThreadId = Just tid }
-	oldpip <- modifyDaemonStatus dstatus $
+	oldpip <- modifyDaemonStatusOld dstatus $
 		\s -> (s { pairingInProgress = Just pip' }, pairingInProgress s)
 	maybe noop stopold oldpip
 	sender stage
@@ -90,7 +90,7 @@ startSending dstatus pip stage sender = void $ forkIO $ do
 stopSending :: PairingInProgress -> DaemonStatusHandle -> IO ()
 stopSending pip dstatus = do
 	maybe noop killThread $ inProgressThreadId pip
-	modifyDaemonStatus_ dstatus $ \s -> s { pairingInProgress = Nothing }
+	modifyDaemonStatusOld_ dstatus $ \s -> s { pairingInProgress = Nothing }
 
 class ToSomeAddr a where
 	toSomeAddr :: a -> SomeAddr

Assistant/Sync.hs

@@ -154,6 +154,6 @@ manualPull currentbranch remotes = do
 {- Start syncing a newly added remote, using a background thread. -}
 syncNewRemote :: Remote -> Assistant ()
 syncNewRemote remote = do
-	liftAnnex . updateSyncRemotes =<< getAssistant daemonStatusHandle
+	updateSyncRemotes
 	thread <- asIO2 reconnectRemotes
 	void $ liftIO $ forkIO $ thread False [remote]

Assistant/Threads/ConfigMonitor.hs

@@ -74,7 +74,7 @@ reloadConfigs changedconfigs = do
 	{- Changes to the remote log, or the trust log, can affect the
 	 - syncRemotes list -}
 	when (Logs.Remote.remoteLog `elem` fs || Logs.Trust.trustLog `elem` fs) $
-		liftAnnex . updateSyncRemotes =<< getAssistant daemonStatusHandle
+		updateSyncRemotes
   where
 	(fs, as) = unzip $ filter (flip S.member changedfiles . fst)
 		configFilesActions

Assistant/Threads/MountWatcher.hs

@@ -177,7 +177,7 @@ remotesUnder dir = do
 	let (waschanged, rs') = unzip pairs
 	when (any id waschanged) $ do
 		liftAnnex $ Annex.changeState $ \s -> s { Annex.remotes = rs' }
-		liftAnnex . updateSyncRemotes =<< getAssistant daemonStatusHandle
+		updateSyncRemotes
 	return $ map snd $ filter fst pairs
 	where
 		checkremote repotop r = case Remote.localpath r of

Assistant/Threads/PairListener.hs

@@ -104,12 +104,12 @@ pairReqReceived :: Bool -> UrlRenderer -> PairMsg -> Assistant ()
 pairReqReceived True _ _ = noop -- ignore our own PairReq
 pairReqReceived False urlrenderer msg = do
 	url <- liftIO $ renderUrl urlrenderer (FinishPairR msg) []
-	dstatus <- getAssistant daemonStatusHandle
+	close <- asIO removeAlert
-	liftIO $ void $ addAlert dstatus $ pairRequestReceivedAlert repo
+	void $ addAlert $ pairRequestReceivedAlert repo
 		AlertButton
 			{ buttonUrl = url
 			, buttonLabel = T.pack "Respond"
-			, buttonAction = Just $ removeAlert dstatus
+			, buttonAction = Just close
 			}
   where
 	repo = pairRepo msg

Assistant/Threads/SanityChecker.hs

@@ -28,14 +28,12 @@ sanityCheckerThread = NamedThread "SanityChecker" $ forever $ do
 	debug ["sanity check complete"]
   where
 	go = do
-		dstatus <- getAssistant daemonStatusHandle
+		modifyDaemonStatus_ $ \s -> s { sanityCheckRunning = True }
-		liftIO $ modifyDaemonStatus_ dstatus $ \s -> s
-			{ sanityCheckRunning = True }
 
 		now <- liftIO $ getPOSIXTime -- before check started
 		r <- either showerr return =<< tryIO <~> check
 
-		liftIO $ modifyDaemonStatus_ dstatus $ \s -> s
+		modifyDaemonStatus_ $ \s -> s
 			{ sanityCheckRunning = False
 			, lastSanityCheck = Just now
 			}
@@ -84,8 +82,7 @@ check = do
 	slop = fromIntegral tenMinutes
 	insanity msg = do
 		liftAnnex $ warning msg
-		dstatus <- getAssistant daemonStatusHandle
+		void $ addAlert $ sanityCheckFixAlert msg
-		liftIO $ void $ addAlert dstatus $ sanityCheckFixAlert msg
 	addsymlink file s = do
 		Watcher.runHandler Watcher.onAddSymlink file s
 		insanity $ "found unstaged symlink: " ++ file

Assistant/Threads/TransferPoller.hs

@@ -52,7 +52,5 @@ transferPollerThread = NamedThread "TransferPoller" $ do
 
 	newsize t info sz
 		| bytesComplete info /= sz && isJust sz =
-			withAssistant daemonStatusHandle $ \h ->
+			alterTransferInfo t $ \i -> i { bytesComplete = sz }
-				alterTransferInfo h t $
-					\i -> i { bytesComplete = sz }
 		| otherwise = noop

Assistant/Threads/TransferWatcher.hs

@@ -64,8 +64,7 @@ onAdd file = case parseTransferFile file of
 		debug [ "transfer starting:", show t]
 		r <- headMaybe . filter (sameuuid t)
 			<$> liftAnnex Remote.remoteList
-		dstatus <- getAssistant daemonStatusHandle
+		updateTransferInfo t info { transferRemote = r }
-		liftIO $ updateTransferInfo dstatus t info { transferRemote = r }
 	sameuuid t r = Remote.uuid r == transferUUID t
 
 {- Called when a transfer information file is updated.
@@ -79,9 +78,8 @@ onModify file = do
 		Just t -> go t =<< liftIO (readTransferInfoFile Nothing file)
 	where
 		go _ Nothing = noop
-		go t (Just newinfo) = withAssistant daemonStatusHandle $ \h ->
+		go t (Just newinfo) = alterTransferInfo t $
-			alterTransferInfo h t $
+			\i -> i { bytesComplete = bytesComplete newinfo }
-				\i -> i { bytesComplete = bytesComplete newinfo }
 
 {- This thread can only watch transfer sizes when the DirWatcher supports
  - tracking modificatons to files. -}
@@ -94,7 +92,7 @@ onDel file = case parseTransferFile file of
 	Nothing -> noop
 	Just t -> do
 		debug [ "transfer finishing:", show t]
-		minfo <- flip removeTransfer t <<~ daemonStatusHandle
+		minfo <- removeTransfer t
 
 		finished <- asIO2 finishedTransfer
 		void $ liftIO $ forkIO $ do

Assistant/Threads/Transferrer.hs

@@ -32,9 +32,8 @@ transfererThread = NamedThread "Transferr" $ do
 	program <- liftIO readProgramFile
 	transferqueue <- getAssistant transferQueue
 	dstatus <- getAssistant daemonStatusHandle
-	slots <- getAssistant transferSlots
 	starter <- asIO2 $ startTransfer program
-	liftIO $ forever $ inTransferSlot dstatus slots $
+	forever $ inTransferSlot $ liftIO $
 		maybe (return Nothing) (uncurry starter)
 			=<< getNextTransfer transferqueue dstatus notrunning
   where
@@ -48,12 +47,12 @@ startTransfer program t info = case (transferRemote info, associatedFile info) o
 	(Just remote, Just file) -> ifM (liftAnnex $ shouldTransfer t info)
 		( do
 			debug [ "Transferring:" , show t ]
-			notifyTransfer <<~ daemonStatusHandle
+			notifyTransfer
 			tp <- asIO2 transferprocess
 			return $ Just (t, info, tp remote file)
 		, do
 			debug [ "Skipping unnecessary transfer:" , show t ]
-			void $ flip removeTransfer t <<~ daemonStatusHandle
+			void $ removeTransfer t
 			return Nothing
 		)
 	_ -> return Nothing
@@ -77,10 +76,8 @@ startTransfer program t info = case (transferRemote info, associatedFile info) o
 		 - in the transfer.
 		 -}
 		whenM (liftIO $ (==) ExitSuccess <$> waitForProcess pid) $ do
-			dstatus <- getAssistant daemonStatusHandle
+			void $ addAlert $ makeAlertFiller True $
-			liftIO $ void $ addAlert dstatus $
+				transferFileAlert direction True file
-				makeAlertFiller True $
-					transferFileAlert direction True file
 			recordCommit
 	  where
 		params =

Assistant/Threads/Watcher.hs

@@ -85,9 +85,7 @@ startupScan scanner = do
 			inRepo $ Git.Command.run "add" [Param "--update"]
 			showAction "started"
 		
-		dstatus <- getAssistant daemonStatusHandle
+		modifyDaemonStatus_ $ \s -> s { scanComplete = True }
-		liftIO $ modifyDaemonStatus_ dstatus $
-			\s -> s { scanComplete = True }
 
 		return (True, r)
 
@@ -218,8 +216,7 @@ onDelDir dir _ = do
 onErr :: Handler
 onErr msg _ = do
 	liftAnnex $ warning msg
-	dstatus <- getAssistant daemonStatusHandle
+	void $ addAlert $ warningAlert "watcher" msg
-	void $ liftIO $ addAlert dstatus $ warningAlert "watcher" msg
 	noChange
 
 {- Adds a symlink to the index, without ever accessing the actual symlink

Assistant/TransferQueue.hs

@@ -123,7 +123,7 @@ enqueue schedule q dstatus t info
 			atomically $ do
 				void $ modifyTVar' (queuesize q) succ
 				void $ modifyTVar' (queuelist q) modlist
-			void $ notifyTransfer dstatus
+			void $ notifyTransferOld dstatus
 
 {- Adds a transfer to the queue. -}
 queueTransfer :: Schedule -> TransferQueue -> DaemonStatusHandle -> AssociatedFile -> Transfer -> Remote -> IO ()
@@ -182,7 +182,7 @@ dequeueTransfers :: TransferQueue -> DaemonStatusHandle -> (Transfer -> Bool) ->
 dequeueTransfers q dstatus c = do
 	removed <- atomically $ dequeueTransfersSTM q c
 	unless (null removed) $
-		notifyTransfer dstatus
+		notifyTransferOld dstatus
 	return removed
 
 dequeueTransfersSTM :: TransferQueue -> (Transfer -> Bool) -> STM [(Transfer, TransferInfo)]

Assistant/TransferSlots.hs

@@ -17,20 +17,22 @@ import qualified Control.Exception as E
 import Control.Concurrent
 import qualified Control.Concurrent.MSemN as MSemN
 
+type TransferGenerator = Assistant (Maybe (Transfer, TransferInfo, IO ()))
+
 {- Waits until a transfer slot becomes available, then runs a
  - TransferGenerator, and then runs the transfer action in its own thread. 
  -}
-inTransferSlot :: TransferSlotRunner
+inTransferSlot :: TransferGenerator -> Assistant ()
-inTransferSlot dstatus s gen = do
+inTransferSlot gen = do
-	MSemN.wait s 1
+	flip MSemN.wait 1 <<~ transferSlots
-	runTransferThread dstatus s =<< gen
+	runTransferThread =<< gen
 
 {- Runs a TransferGenerator, and its transfer action,
  - without waiting for a slot to become available. -}
-inImmediateTransferSlot :: TransferSlotRunner
+inImmediateTransferSlot :: TransferGenerator -> Assistant ()
-inImmediateTransferSlot dstatus s gen = do
+inImmediateTransferSlot gen = do
-	MSemN.signal s (-1)
+	flip MSemN.signal (-1) <<~ transferSlots
-	runTransferThread dstatus s =<< gen
+	runTransferThread =<< gen
 
 {- Runs a transfer action, in an already allocated transfer slot.
  - Once it finishes, frees the transfer slot.
@@ -42,24 +44,26 @@ inImmediateTransferSlot dstatus s gen = do
  - then pausing the thread until a ResumeTransfer exception is raised,
  - then rerunning the action.
  -}
-runTransferThread :: DaemonStatusHandle -> TransferSlots -> Maybe (Transfer, TransferInfo, IO ()) -> IO ()
+runTransferThread :: Maybe (Transfer, TransferInfo, IO ()) -> Assistant ()
-runTransferThread _ s  Nothing = MSemN.signal s 1
+runTransferThread Nothing = flip MSemN.signal 1 <<~ transferSlots
-runTransferThread dstatus s (Just (t, info, a)) = do
+runTransferThread (Just (t, info, a)) = do
-	tid <- forkIO go
+	d <- getAssistant id
-	updateTransferInfo dstatus t $ info { transferTid = Just tid }
+	tid <- liftIO $ forkIO $ go d
+	updateTransferInfo t $ info { transferTid = Just tid }
 	where
-		go = catchPauseResume a
+		go d = catchPauseResume d a
-		pause = catchPauseResume $ runEvery (Seconds 86400) noop
+		pause d = catchPauseResume d $ runEvery (Seconds 86400) noop
 		{- Note: This must use E.try, rather than E.catch.
 		 - When E.catch is used, and has called go in its exception
 		 - handler, Control.Concurrent.throwTo will block sometimes
 		 - when signaling. Using E.try avoids the problem. -}
-		catchPauseResume a' = do
+		catchPauseResume d a' = do
 			r <- E.try a' :: IO (Either E.SomeException ())
 			case r of
 				Left e -> case E.fromException e of
-					Just PauseTransfer -> pause
+					Just PauseTransfer -> pause d
-					Just ResumeTransfer -> go
+					Just ResumeTransfer -> go d
-					_ -> done
+					_ -> done d
-				_ -> done
+				_ -> done d
-		done = MSemN.signal s 1
+		done d = flip runAssistant d $ 
+			flip MSemN.signal 1 <<~ transferSlots

Assistant/Types/TransferSlots.hs

@@ -9,9 +9,6 @@
 
 module Assistant.Types.TransferSlots where
 
-import Assistant.Types.DaemonStatus
-import Logs.Transfer
-
 import qualified Control.Exception as E
 import qualified Control.Concurrent.MSemN as MSemN
 import Data.Typeable
@@ -25,9 +22,6 @@ data TransferException = PauseTransfer | ResumeTransfer
 
 instance E.Exception TransferException
 
-type TransferSlotRunner = DaemonStatusHandle -> TransferSlots -> TransferGenerator -> IO ()
-type TransferGenerator = IO (Maybe (Transfer, TransferInfo, IO ()))
-
 {- Number of concurrent transfers allowed to be run from the assistant.
  -
  - Transfers launched by other means, including by remote assistants,

Assistant/WebApp/Configurators/Edit.hs

@@ -69,7 +69,6 @@ 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 daemonStatusHandle
 		runAnnex undefined $ do
 			name <- fromRepo $ uniqueRemoteName (T.unpack $ repoName newc) 0
 			inRepo $ Git.Command.run "remote"
@@ -78,7 +77,7 @@ setRepoConfig uuid mremote oldc newc = do
 				, Param name
 				]
 			void $ Remote.remoteListRefresh
-			updateSyncRemotes dstatus
+		runAssistantY updateSyncRemotes
 
 editRepositoryAForm :: RepoConfig -> AForm WebApp WebApp RepoConfig
 editRepositoryAForm def = RepoConfig

Assistant/WebApp/Configurators/XMPP.hs

@@ -34,13 +34,14 @@ 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 daemonStatusHandle
 	urlrender <- getUrlRender
-	void $ liftIO $ addAlert dstatus $ xmppNeededAlert $ AlertButton
+	void $ runAssistantY $ do
-		{ buttonLabel = "Configure a Jabber account"
+		close <- asIO removeAlert
-		, buttonUrl = urlrender XMPPR
+		addAlert $ xmppNeededAlert $ AlertButton
-		, buttonAction = Just $ removeAlert dstatus
+			{ buttonLabel = "Configure a Jabber account"
-		}
+			, buttonUrl = urlrender XMPPR
+			, buttonAction = Just close
+			}
 
 getXMPPR :: Handler RepHtml
 #ifdef WITH_XMPP

Assistant/WebApp/SideBar.hs

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

Assistant/WebApp/Utility.hs

@@ -38,7 +38,7 @@ changeSyncable (Just r) False = do
 	changeSyncFlag r False
 	d <- getAssistantY id
 	let dstatus = daemonStatusHandle d
-	runAssistantY $ liftAnnex $ updateSyncRemotes dstatus
+	runAssistantY $ updateSyncRemotes
 	{- Stop all transfers to or from this remote.
 	 - XXX Can't stop any ongoing scan, or git syncs. -}
 	void $ liftIO $ dequeueTransfers (transferQueue d) dstatus tofrom
@@ -67,30 +67,27 @@ pauseTransfer = cancelTransfer True
 
 cancelTransfer :: Bool -> Transfer -> Handler ()
 cancelTransfer pause t = do
-	dstatus <- getAssistantY daemonStatusHandle
 	tq <- getAssistantY transferQueue
 	m <- getCurrentTransfers
-	liftIO $ do
+	dstatus <- getAssistantY daemonStatusHandle
-		unless pause $
+	unless pause $ liftIO $
-			{- remove queued transfer -}
+		{- remove queued transfer -}
-			void $ dequeueTransfers tq dstatus $
+		void $ dequeueTransfers tq dstatus $
-				equivilantTransfer t
+			equivilantTransfer t
-		{- stop running transfer -}
+	{- stop running transfer -}
-		maybe noop (stop dstatus) (M.lookup t m)
+	maybe noop stop (M.lookup t m)
 	where
-		stop dstatus info = do
+		stop info = runAssistantY $ do
 			{- When there's a thread associated with the
 			 - transfer, it's signaled first, to avoid it
 			 - displaying any alert about the transfer having
 			 - failed when the transfer process is killed. -}
-			maybe noop signalthread $ transferTid info
+			liftIO $ maybe noop signalthread $ transferTid info
-			maybe noop killproc $ transferPid info
+			liftIO $ maybe noop killproc $ transferPid info
 			if pause
-				then void $
+				then void $ alterTransferInfo t $
-					alterTransferInfo dstatus t $
+					\i -> i { transferPaused = True }
-						\i -> i { transferPaused = True }
+				else void $ removeTransfer t
-				else void $
-					removeTransfer dstatus t
 		signalthread tid
 			| pause = throwTo tid PauseTransfer
 			| otherwise = killThread tid
@@ -115,16 +112,12 @@ startTransfer t = do
 			is <- liftIO $ map snd <$> getMatchingTransfers q dstatus (== t)
 			maybe noop start $ headMaybe is
 		resume tid = do
-			dstatus <- getAssistantY daemonStatusHandle
+			runAssistantY $ alterTransferInfo t $
-			liftIO $ do
+				\i -> i { transferPaused = False }
-				alterTransferInfo dstatus t $
+			liftIO $ throwTo tid ResumeTransfer
-					\i -> i { transferPaused = False }
-				throwTo tid ResumeTransfer
 		start info = runAssistantY $ do
 			program <- liftIO readProgramFile
-			dstatus <- getAssistant daemonStatusHandle
+			inImmediateTransferSlot $
-			slots <- getAssistant transferSlots
-			inImmediateTransferSlot dstatus slots <~>
 				Transferrer.startTransfer program t info
 
 getCurrentTransfers :: Handler TransferMap