finished pushing Assistant monad into all relevant files

All temporary and old functions are removed.

Assistant/DaemonStatus.hs

@@ -24,30 +24,12 @@ import Data.Time
 import System.Locale
 import qualified Data.Map as M
 
--- TODO remove this
-getDaemonStatusOld :: DaemonStatusHandle -> IO DaemonStatus
-getDaemonStatusOld = atomically . readTMVar
-
 getDaemonStatus :: Assistant DaemonStatus
 getDaemonStatus = (atomically . readTMVar) <<~ daemonStatusHandle
 
--- TODO remove this
-modifyDaemonStatusOld_ :: DaemonStatusHandle -> (DaemonStatus -> DaemonStatus) -> IO ()
-modifyDaemonStatusOld_ dstatus a = modifyDaemonStatusOld dstatus $ \s -> (a s, ())
-
 modifyDaemonStatus_ :: (DaemonStatus -> DaemonStatus) -> Assistant ()
 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
-		return r
-	sendNotification $ changeNotifier s
-	return b
-
 modifyDaemonStatus :: (DaemonStatus -> (DaemonStatus, b)) -> Assistant b
 modifyDaemonStatus a = do
 	dstatus <- getAssistant daemonStatusHandle
@@ -188,11 +170,6 @@ notifyTransfer = do
 	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 :: Assistant ()
 notifyAlert = do

Assistant/Drop.hs

@@ -20,10 +20,11 @@ import Config
 
 {- Drop from local and/or remote when allowed by the preferred content and
  - numcopies settings. -}
-handleDrops :: DaemonStatusHandle -> Bool -> Key -> AssociatedFile -> Annex ()
+handleDrops :: Bool -> Key -> AssociatedFile -> Assistant ()
-handleDrops _ _ _ Nothing = noop
+handleDrops _ _ Nothing = noop
-handleDrops dstatus fromhere key f = do
+handleDrops fromhere key f = do
-	syncrs <- liftIO $ syncRemotes <$> getDaemonStatusOld dstatus
+	syncrs <- syncRemotes <$> getDaemonStatus
+	liftAnnex $ do
 		locs <- loggedLocations key
 		handleDrops' locs syncrs fromhere key f
 

Assistant/Monad.hs

@@ -17,6 +17,7 @@ module Assistant.Monad (
 	(<~>),
 	(<<~),
 	asIO,
+	asIO1,
 	asIO2,
 ) where
 
@@ -95,12 +96,16 @@ io <~> a = do
 	liftIO $ io $ runAssistant a d
 
 {- Creates an IO action that will run an Assistant action when run. -}
-asIO :: (a -> Assistant b) -> Assistant (a -> IO b)
+asIO :: Assistant a -> Assistant (IO a)
 asIO a = do
+	d <- reader id
+	return $ runAssistant a d
+
+asIO1 :: (a -> Assistant b) -> Assistant (a -> IO b)
+asIO1 a = do
 	d <- reader id
 	return $ \v -> runAssistant (a v) d
 
-{- Creates an IO action that will run an Assistant action when run. -}
 asIO2 :: (a -> b -> Assistant c) -> Assistant (a -> b -> IO c)
 asIO2 a = do
 	d <- reader id

Assistant/Pairing/Network.hs

@@ -76,21 +76,24 @@ multicastPairMsg repeats secret pairdata stage = go M.empty repeats
 	mkmsg addr = PairMsg $
 		mkVerifiable (stage, pairdata, addr) secret
 
-startSending :: DaemonStatusHandle -> PairingInProgress -> PairStage -> (PairStage -> IO ()) -> IO ()
+startSending :: PairingInProgress -> PairStage -> (PairStage -> IO ()) -> Assistant ()
-startSending dstatus pip stage sender = void $ forkIO $ do
+startSending pip stage sender = do
-	tid <- myThreadId
+	a <- asIO start
+	void $ liftIO $ forkIO a
+  where
+	start = do
+		tid <- liftIO myThreadId
 		let pip' = pip { inProgressPairStage = stage, inProgressThreadId = Just tid }
-	oldpip <- modifyDaemonStatusOld dstatus $
+		oldpip <- modifyDaemonStatus $
 			\s -> (s { pairingInProgress = Just pip' }, pairingInProgress s)
 		maybe noop stopold oldpip
-	sender stage
+		liftIO $ sender stage
-	where
+	stopold = maybe noop (liftIO . killThread) . inProgressThreadId
-		stopold = maybe noop killThread . inProgressThreadId
 
-stopSending :: PairingInProgress -> DaemonStatusHandle -> IO ()
+stopSending :: PairingInProgress -> Assistant ()
-stopSending pip dstatus = do
+stopSending pip = do
-	maybe noop killThread $ inProgressThreadId pip
+	maybe noop (liftIO . killThread) $ inProgressThreadId pip
-	modifyDaemonStatusOld_ dstatus $ \s -> s { pairingInProgress = Nothing }
+	modifyDaemonStatus_ $ \s -> s { pairingInProgress = Nothing }
 
 class ToSomeAddr a where
 	toSomeAddr :: a -> SomeAddr

Assistant/Threads/Committer.hs

@@ -202,9 +202,7 @@ handleAdds delayadd cs = returnWhen (null incomplete) $ do
 					Git.HashObject.hashObject BlobObject link
 				stageSymlink file sha
 				showEndOk
-		transferqueue <- getAssistant transferQueue
+		queueTransfers Next key (Just file) Upload
-		dstatus <- getAssistant daemonStatusHandle
-		liftAnnex $ queueTransfers Next transferqueue dstatus key (Just file) Upload
 		return $ Just change
 
 	{- Check that the keysource's keyFilename still exists,

Assistant/Threads/Merger.hs

@@ -67,11 +67,8 @@ onAdd file
 	| ".lock" `isSuffixOf` file = noop
 	| isAnnexBranch file = do
 		branchChanged
-		transferqueue <- getAssistant transferQueue
+		whenM (liftAnnex Annex.Branch.forceUpdate) $
-		dstatus <-  getAssistant daemonStatusHandle
+			queueDeferredDownloads Later
-		liftAnnex $
-			whenM Annex.Branch.forceUpdate $
-				queueDeferredDownloads Later transferqueue dstatus
 	| "/synced/" `isInfixOf` file = do
 		mergecurrent =<< liftAnnex (inRepo Git.Branch.current)
 	| otherwise = noop

Assistant/Threads/MountWatcher.hs

@@ -48,7 +48,7 @@ mountWatcherThread = NamedThread "MountWatcher" $
 
 dbusThread :: Assistant ()
 dbusThread = do
-	runclient <- asIO go
+	runclient <- asIO1 go
 	r <- liftIO $ E.try $ runClient getSessionAddress runclient
 	either onerr (const noop) r
   where
@@ -59,7 +59,7 @@ dbusThread = do
 			 - mount point from the dbus message, but this is
 			 - easier. -}
 			mvar <- liftIO $ newMVar =<< currentMountPoints
-			handleevent <- asIO $ \_event -> do
+			handleevent <- asIO1 $ \_event -> do
 				nowmounted <- liftIO $ currentMountPoints
 				wasmounted <- liftIO $ swapMVar mvar nowmounted
 				handleMounts wasmounted nowmounted

Assistant/Threads/NetWatcher.hs

@@ -49,7 +49,7 @@ netWatcherFallbackThread = NamedThread "NetWatcherFallback" $
 dbusThread :: Assistant ()
 dbusThread = do
 	handleerr <- asIO2 onerr
-	runclient <- asIO go
+	runclient <- asIO1 go
 	liftIO $ persistentClient getSystemAddress () handleerr runclient
   where
 	go client = ifM (checkNetMonitor client)

Assistant/Threads/PairListener.hs

@@ -27,7 +27,7 @@ thisThread = "PairListener"
 
 pairListenerThread :: UrlRenderer -> NamedThread
 pairListenerThread urlrenderer = NamedThread "PairListener" $ do
-	listener <- asIO $ go [] []
+	listener <- asIO1 $ go [] []
 	liftIO $ withSocketsDo $
 		runEvery (Seconds 1) $ void $ tryIO $ 
 			listener =<< getsock
@@ -69,7 +69,7 @@ pairListenerThread urlrenderer = NamedThread "PairListener" $ do
 		| not verified && sameuuid = do
 			liftAnnex $ warning
 				"detected possible pairing brute force attempt; disabled pairing"
-			stopSending pip <<~ daemonStatusHandle
+			stopSending pip
 			return (Nothing, False)
 		|otherwise = return (Just pip, verified && sameuuid)
 	  where
@@ -104,7 +104,7 @@ pairReqReceived :: Bool -> UrlRenderer -> PairMsg -> Assistant ()
 pairReqReceived True _ _ = noop -- ignore our own PairReq
 pairReqReceived False urlrenderer msg = do
 	url <- liftIO $ renderUrl urlrenderer (FinishPairR msg) []
-	close <- asIO removeAlert
+	close <- asIO1 removeAlert
 	void $ addAlert $ pairRequestReceivedAlert repo
 		AlertButton
 			{ buttonUrl = url
@@ -119,11 +119,10 @@ pairReqReceived False urlrenderer msg = do
  - and send a single PairDone. -}
 pairAckReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> [PairingInProgress] -> Assistant [PairingInProgress]
 pairAckReceived True (Just pip) msg cache = do
-	stopSending pip <<~ daemonStatusHandle
+	stopSending pip
 	liftIO $ setupAuthorizedKeys msg
 	finishedPairing msg (inProgressSshKeyPair pip)
-	dstatus <- getAssistant daemonStatusHandle
+	startSending pip PairDone $ multicastPairMsg
-	liftIO $ startSending dstatus pip PairDone $ multicastPairMsg
 		(Just 1) (inProgressSecret pip) (inProgressPairData pip)
 	return $ pip : take 10 cache
 {- A stale PairAck might also be seen, after we've finished pairing.
@@ -132,10 +131,9 @@ pairAckReceived True (Just pip) msg cache = do
  - response to stale PairAcks for them. -}
 pairAckReceived _ _ msg cache = do
 	let pips = filter (verifiedPairMsg msg) cache
-	dstatus <- getAssistant daemonStatusHandle
 	unless (null pips) $
-		liftIO $ forM_ pips $ \pip ->
+		forM_ pips $ \pip ->
-			startSending dstatus pip PairDone $ multicastPairMsg
+			startSending pip PairDone $ multicastPairMsg
 				(Just 1) (inProgressSecret pip) (inProgressPairData pip)
 	return cache
 
@@ -152,5 +150,5 @@ pairDoneReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> Assistant ()
 pairDoneReceived False _ _ = noop -- not verified
 pairDoneReceived True Nothing _ = noop -- not in progress
 pairDoneReceived True (Just pip) msg = do
-	stopSending pip <<~ daemonStatusHandle
+	stopSending pip
 	finishedPairing msg (inProgressSshKeyPair pip)

Assistant/Threads/PushNotifier.hs

@@ -26,10 +26,10 @@ import Data.Time.Clock
 
 pushNotifierThread :: NamedThread
 pushNotifierThread = NamedThread "PushNotifier" $ do
-	iodebug <- asIO debug
+	iodebug <- asIO1 debug
-	iopull <- asIO pull
+	iopull <- asIO1 pull
-	iowaitpush <- asIO $ const waitPush
+	iowaitpush <- asIO $ waitPush
-	ioclient <- asIO2 $ xmppClient $ iowaitpush ()
+	ioclient <- asIO2 $ xmppClient $ iowaitpush
 	forever $ do
 		tid <- liftIO $ forkIO $ ioclient iodebug iopull
 		waitRestart

Assistant/Threads/TransferScanner.hs

@@ -21,7 +21,7 @@ import qualified Remote
 import qualified Types.Remote as Remote
 import Utility.ThreadScheduler
 import qualified Git.LsFiles as LsFiles
-import Command
+import qualified Backend
 import Annex.Content
 import Annex.Wanted
 
@@ -78,11 +78,7 @@ failedTransferScan r = do
 			 - that the remote doesn't already have the
 			 - key, so it's not redundantly checked here. -}
 			requeue t info
-	requeue t info = do
+	requeue t info = queueTransferWhenSmall (associatedFile info) t r
-		transferqueue <- getAssistant transferQueue
-		dstatus <- getAssistant daemonStatusHandle
-		liftIO $ queueTransferWhenSmall
-			transferqueue dstatus (associatedFile info) t r
 
 {- This is a expensive scan through the full git work tree, finding
  - files to transfer. The scan is blocked when the transfer queue gets
@@ -101,10 +97,9 @@ expensiveScan rs = unless onlyweb $ do
 	void $ alertWhile (scanAlert visiblers) $ do
 		g <- liftAnnex gitRepo
 		(files, cleanup) <- liftIO $ LsFiles.inRepo [] g
-		dstatus <- getAssistant daemonStatusHandle
 		forM_ files $ \f -> do
-			ts <- liftAnnex $
+			ts <- maybe (return []) (findtransfers f)
-				ifAnnexed f (findtransfers dstatus f) (return [])
+				=<< liftAnnex (Backend.lookupFile f)
 			mapM_ (enqueue f) ts
 		void $ liftIO cleanup
 		return True
@@ -115,14 +110,13 @@ expensiveScan rs = unless onlyweb $ do
 		in if null rs' then rs else rs'
 	enqueue f (r, t) = do
 		debug ["queuing", show t]
-		transferqueue <- getAssistant transferQueue
+		queueTransferWhenSmall (Just f) t r
-		dstatus <- getAssistant daemonStatusHandle
+	findtransfers f (key, _) = do
-		liftIO $ queueTransferWhenSmall transferqueue dstatus (Just f) t r
-	findtransfers dstatus f (key, _) = do
-		locs <- loggedLocations key
 		{- The syncable remotes may have changed since this
 		 - scan began. -}
-		syncrs <- liftIO $ syncRemotes <$> getDaemonStatusOld dstatus
+		syncrs <- syncRemotes <$> getDaemonStatus
+		liftAnnex $ do
+			locs <- loggedLocations key
 			present <- inAnnex key
 
 			handleDrops' locs syncrs present key (Just f)

Assistant/Threads/TransferWatcher.hs

@@ -115,15 +115,9 @@ finishedTransfer :: Transfer -> Maybe TransferInfo -> Assistant ()
 finishedTransfer t (Just info)
 	| transferDirection t == Download =
 		whenM (liftAnnex $ inAnnex $ transferKey t) $ do
-			dstatus <- getAssistant daemonStatusHandle
+			handleDrops False (transferKey t) (associatedFile info)
-			transferqueue <- getAssistant transferQueue
+			queueTransfersMatching (/= transferUUID t) Later
-			liftAnnex $ handleDrops dstatus False
-				(transferKey t) (associatedFile info)
-			liftAnnex $ queueTransfersMatching (/= transferUUID t)
-				Later transferqueue dstatus
 				(transferKey t) (associatedFile info) Upload
-	| otherwise = do
+	| otherwise = handleDrops True (transferKey t) (associatedFile info)
-		dstatus <- getAssistant daemonStatusHandle
-		liftAnnex $ handleDrops dstatus True (transferKey t) (associatedFile info)
 finishedTransfer _ _ = noop
 

Assistant/Threads/Transferrer.hs

@@ -30,26 +30,22 @@ maxTransfers = 1
 transfererThread :: NamedThread
 transfererThread = NamedThread "Transferr" $ do
 	program <- liftIO readProgramFile
-	transferqueue <- getAssistant transferQueue
+	forever $ inTransferSlot $
-	dstatus <- getAssistant daemonStatusHandle
+		maybe (return Nothing) (uncurry $ startTransfer program)
-	starter <- asIO2 $ startTransfer program
+			=<< getNextTransfer notrunning
-	forever $ inTransferSlot $ liftIO $
-		maybe (return Nothing) (uncurry starter)
-			=<< getNextTransfer transferqueue dstatus notrunning
   where
 	{- Skip transfers that are already running. -}
 	notrunning = isNothing . startedTime
 
 {- By the time this is called, the daemonstatus's transfer map should
  - already have been updated to include the transfer. -}
-startTransfer :: FilePath -> Transfer -> TransferInfo -> Assistant (Maybe (Transfer, TransferInfo, IO ()))
+startTransfer :: FilePath -> Transfer -> TransferInfo -> Assistant (Maybe (Transfer, TransferInfo, Assistant ()))
 startTransfer program t info = case (transferRemote info, associatedFile info) of
 	(Just remote, Just file) -> ifM (liftAnnex $ shouldTransfer t info)
 		( do
 			debug [ "Transferring:" , show t ]
 			notifyTransfer
-			tp <- asIO2 transferprocess
+			return $ Just (t, info, transferprocess remote file)
-			return $ Just (t, info, tp remote file)
 		, do
 			debug [ "Skipping unnecessary transfer:" , show t ]
 			void $ removeTransfer t

Assistant/Threads/Watcher.hs

@@ -54,7 +54,7 @@ needLsof = error $ unlines
 
 watchThread :: NamedThread
 watchThread = NamedThread "Watcher" $ do
-	startup <- asIO startupScan
+	startup <- asIO1 startupScan
 	addhook <- hook onAdd
 	delhook <- hook onDel
 	addsymlinkhook <- hook onAddSymlink
@@ -182,12 +182,9 @@ onAddSymlink file filestatus = go =<< liftAnnex (Backend.lookupFile file)
 	checkcontent key daemonstatus
 		| scanComplete daemonstatus = do
 			present <- liftAnnex $ inAnnex key
-			dstatus <- getAssistant daemonStatusHandle
+			unless present $
-			unless present $ do
+				queueTransfers Next key (Just file) Download
-				transferqueue <- getAssistant transferQueue
+			handleDrops present key (Just file)
-				liftAnnex $ queueTransfers Next transferqueue
-					dstatus key (Just file) Download
-			liftAnnex $ handleDrops dstatus present key (Just file)
 		| otherwise = noop
 
 onDel :: Handler

Assistant/TransferQueue.hs

@@ -21,9 +21,8 @@ module Assistant.TransferQueue (
 	dequeueTransfers,
 ) where
 
-import Common.Annex
+import Assistant.Common
 import Assistant.DaemonStatus
-import Assistant.Types.DaemonStatus
 import Assistant.Types.TransferQueue
 import Logs.Transfer
 import Types.Remote
@@ -35,8 +34,8 @@ import Control.Concurrent.STM
 import qualified Data.Map as M
 
 {- Reads the queue's content without blocking or changing it. -}
-getTransferQueue :: TransferQueue -> IO [(Transfer, TransferInfo)]
+getTransferQueue :: Assistant [(Transfer, TransferInfo)]
-getTransferQueue q = atomically $ readTVar $ queuelist q
+getTransferQueue = (atomically . readTVar . queuelist) <<~ transferQueue
 
 stubInfo :: AssociatedFile -> Remote -> TransferInfo
 stubInfo f r = stubTransferInfo
@@ -46,24 +45,24 @@ stubInfo f r = stubTransferInfo
 
 {- Adds transfers to queue for some of the known remotes.
  - Honors preferred content settings, only transferring wanted files. -}
-queueTransfers :: Schedule -> TransferQueue -> DaemonStatusHandle -> Key -> AssociatedFile -> Direction -> Annex ()
+queueTransfers :: Schedule -> Key -> AssociatedFile -> Direction -> Assistant ()
 queueTransfers = queueTransfersMatching (const True)
 
 {- Adds transfers to queue for some of the known remotes, that match a
  - condition. Honors preferred content settings. -}
-queueTransfersMatching :: (UUID -> Bool) -> Schedule -> TransferQueue -> DaemonStatusHandle -> Key -> AssociatedFile -> Direction -> Annex ()
+queueTransfersMatching :: (UUID -> Bool) -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant ()
-queueTransfersMatching matching schedule q dstatus k f direction
+queueTransfersMatching matching schedule k f direction
-	| direction == Download = whenM (wantGet f) go
+	| direction == Download = whenM (liftAnnex $ wantGet f) go
 	| otherwise = go
   where
 	go = do
-			rs <- sufficientremotes
+		rs <- liftAnnex . sufficientremotes
-				=<< syncRemotes <$> liftIO (getDaemonStatusOld dstatus)
+			=<< syncRemotes <$> getDaemonStatus
 		let matchingrs = filter (matching . Remote.uuid) rs
 		if null matchingrs
 			then defer
-				else forM_ matchingrs $ \r -> liftIO $
+			else forM_ matchingrs $ \r ->
-					enqueue schedule q dstatus (gentransfer r) (stubInfo f r)
+				enqueue schedule (gentransfer r) (stubInfo f r)
 	sufficientremotes rs
 		{- Queue downloads from all remotes that
 		 - have the key, with the cheapest ones first.
@@ -82,29 +81,31 @@ queueTransfersMatching matching schedule q dstatus k f direction
 		}
 	defer
 		{- Defer this download, as no known remote has the key. -}
-			| direction == Download = void $ liftIO $ atomically $
+		| direction == Download = do
+			q <- getAssistant transferQueue
+			void $ liftIO $ atomically $
 				modifyTVar' (deferreddownloads q) $
 					\l -> (k, f):l
 		| otherwise = noop
 
 {- Queues any deferred downloads that can now be accomplished, leaving
  - any others in the list to try again later. -}
-queueDeferredDownloads :: Schedule -> TransferQueue -> DaemonStatusHandle -> Annex ()
+queueDeferredDownloads :: Schedule -> Assistant ()
-queueDeferredDownloads schedule q dstatus = do
+queueDeferredDownloads schedule = do
+	q <- getAssistant transferQueue
 	l <- liftIO $ atomically $ swapTVar (deferreddownloads q) []
-	rs <- syncRemotes <$> liftIO (getDaemonStatusOld dstatus)
+	rs <- syncRemotes <$> getDaemonStatus
 	left <- filterM (queue rs) l
 	unless (null left) $
 		liftIO $ atomically $ modifyTVar' (deferreddownloads q) $
 			\new -> new ++ left
   where
 	queue rs (k, f) = do
-			uuids <- Remote.keyLocations k
+		uuids <- liftAnnex $ Remote.keyLocations k
 		let sources = filter (\r -> uuid r `elem` uuids) rs
 		unless (null sources) $
-				forM_ sources $ \r -> liftIO $
+			forM_ sources $ \r ->
-					enqueue schedule q dstatus
+				enqueue schedule (gentransfer r) (stubInfo f r)
-						(gentransfer r) (stubInfo f r)
 		return $ null sources
 	  where
 		gentransfer r = Transfer
@@ -113,34 +114,35 @@ queueDeferredDownloads schedule q dstatus = do
 			, transferUUID = Remote.uuid r
 			}
 
-enqueue :: Schedule -> TransferQueue -> DaemonStatusHandle -> Transfer -> TransferInfo -> IO ()
+enqueue :: Schedule -> Transfer -> TransferInfo -> Assistant ()
-enqueue schedule q dstatus t info
+enqueue schedule t info
 	| schedule == Next = go (new:)
 	| otherwise = go (\l -> l++[new])
   where
 	new = (t, info)
 	go modlist = do
-			atomically $ do
+		q <- getAssistant transferQueue
+		liftIO $ atomically $ do
 			void $ modifyTVar' (queuesize q) succ
 			void $ modifyTVar' (queuelist q) modlist
-			void $ notifyTransferOld dstatus
+		notifyTransfer
 
 {- Adds a transfer to the queue. -}
-queueTransfer :: Schedule -> TransferQueue -> DaemonStatusHandle -> AssociatedFile -> Transfer -> Remote -> IO ()
+queueTransfer :: Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant ()
-queueTransfer schedule q dstatus f t remote =
+queueTransfer schedule f t remote = enqueue schedule t (stubInfo f remote)
-	enqueue schedule q dstatus t (stubInfo f remote)
 
 {- Blocks until the queue is no larger than a given size, and then adds a
  - transfer to the queue. -}
-queueTransferAt :: Int -> Schedule -> TransferQueue -> DaemonStatusHandle -> AssociatedFile -> Transfer -> Remote -> IO ()
+queueTransferAt :: Int -> Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant ()
-queueTransferAt wantsz schedule q dstatus f t remote = do
+queueTransferAt wantsz schedule f t remote = do
-	atomically $ do
+	q <- getAssistant transferQueue
+	liftIO $ atomically $ do
 		sz <- readTVar (queuesize q)
 		unless (sz <= wantsz) $
 			retry -- blocks until queuesize changes
-	enqueue schedule q dstatus t (stubInfo f remote)
+	enqueue schedule t (stubInfo f remote)
 
-queueTransferWhenSmall :: TransferQueue -> DaemonStatusHandle -> AssociatedFile -> Transfer -> Remote -> IO ()
+queueTransferWhenSmall :: AssociatedFile -> Transfer -> Remote -> Assistant ()
 queueTransferWhenSmall = queueTransferAt 10 Later
 
 {- Blocks until a pending transfer is available in the queue,
@@ -151,8 +153,11 @@ queueTransferWhenSmall = queueTransferAt 10 Later
  -
  - This is done in a single STM transaction, so there is no window
  - where an observer sees an inconsistent status. -}
-getNextTransfer :: TransferQueue -> DaemonStatusHandle -> (TransferInfo -> Bool) -> IO (Maybe (Transfer, TransferInfo))
+getNextTransfer :: (TransferInfo -> Bool) -> Assistant (Maybe (Transfer, TransferInfo))
-getNextTransfer q dstatus acceptable = atomically $ do
+getNextTransfer acceptable = do
+	q <- getAssistant transferQueue
+	dstatus <- getAssistant daemonStatusHandle
+	liftIO $ atomically $ do
 		sz <- readTVar (queuesize q)
 		if sz < 1
 			then retry -- blocks until queuesize changes
@@ -169,8 +174,11 @@ getNextTransfer q dstatus acceptable = atomically $ do
 
 {- Moves transfers matching a condition from the queue, to the
  - currentTransfers map. -}
-getMatchingTransfers :: TransferQueue -> DaemonStatusHandle -> (Transfer -> Bool) -> IO [(Transfer, TransferInfo)]
+getMatchingTransfers :: (Transfer -> Bool) -> Assistant [(Transfer, TransferInfo)]
-getMatchingTransfers q dstatus c = atomically $ do
+getMatchingTransfers c = do
+	q <- getAssistant transferQueue
+	dstatus <- getAssistant daemonStatusHandle
+	liftIO $ atomically $ do
 		ts <- dequeueTransfersSTM q c
 		unless (null ts) $
 			adjustTransfersSTM dstatus $ \m -> M.union m $ M.fromList ts
@@ -178,11 +186,12 @@ getMatchingTransfers q dstatus c = atomically $ do
 
 {- Removes transfers matching a condition from the queue, and returns the
  - removed transfers. -}
-dequeueTransfers :: TransferQueue -> DaemonStatusHandle -> (Transfer -> Bool) -> IO [(Transfer, TransferInfo)]
+dequeueTransfers :: (Transfer -> Bool) -> Assistant [(Transfer, TransferInfo)]
-dequeueTransfers q dstatus c = do
+dequeueTransfers c = do
-	removed <- atomically $ dequeueTransfersSTM q c
+	q <- getAssistant transferQueue
+	removed <- liftIO $ atomically $ dequeueTransfersSTM q c
 	unless (null removed) $
-		notifyTransferOld dstatus
+		notifyTransfer
 	return removed
 
 dequeueTransfersSTM :: TransferQueue -> (Transfer -> Bool) -> STM [(Transfer, TransferInfo)]

Assistant/TransferSlots.hs

@@ -17,7 +17,7 @@ import qualified Control.Exception as E
 import Control.Concurrent
 import qualified Control.Concurrent.MSemN as MSemN
 
-type TransferGenerator = Assistant (Maybe (Transfer, TransferInfo, IO ()))
+type TransferGenerator = Assistant (Maybe (Transfer, TransferInfo, Assistant ()))
 
 {- Waits until a transfer slot becomes available, then runs a
  - TransferGenerator, and then runs the transfer action in its own thread. 
@@ -44,26 +44,30 @@ inImmediateTransferSlot gen = do
  - then pausing the thread until a ResumeTransfer exception is raised,
  - then rerunning the action.
  -}
-runTransferThread :: Maybe (Transfer, TransferInfo, IO ()) -> Assistant ()
+runTransferThread :: Maybe (Transfer, TransferInfo, Assistant ()) -> Assistant ()
 runTransferThread Nothing = flip MSemN.signal 1 <<~ transferSlots
 runTransferThread (Just (t, info, a)) = do
 	d <- getAssistant id
-	tid <- liftIO $ forkIO $ go d
+	aio <- asIO a
+	tid <- liftIO $ forkIO $ runTransferThread' d aio
 	updateTransferInfo t $ info { transferTid = Just tid }
+
+runTransferThread' :: AssistantData -> IO () -> IO ()
+runTransferThread' d a = go
 	where
-		go d = catchPauseResume d a
+		go = catchPauseResume a
-		pause d = catchPauseResume d $ runEvery (Seconds 86400) noop
+		pause = catchPauseResume $ 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 d a' = do
+		catchPauseResume a' = do
 			r <- E.try a' :: IO (Either E.SomeException ())
 			case r of
 				Left e -> case E.fromException e of
-					Just PauseTransfer -> pause d
+					Just PauseTransfer -> pause
-					Just ResumeTransfer -> go d
+					Just ResumeTransfer -> go
-					_ -> done d
+					_ -> done
-				_ -> done d
+				_ -> done
-		done d = flip runAssistant d $ 
+		done = flip runAssistant d $ 
 			flip MSemN.signal 1 <<~ transferSlots

Assistant/WebApp.hs

@@ -71,11 +71,8 @@ newWebAppState = do
 		{ showIntro = True
 		, otherRepos = otherrepos }
 
-getAssistantY :: forall sub a. (AssistantData -> a) -> GHandler sub WebApp a
+liftAssistant :: forall sub a. (Assistant a) -> GHandler sub WebApp a
-getAssistantY f = f <$> (assistantData <$> getYesod)
+liftAssistant a = liftIO . runAssistant a =<< assistantData <$> getYesod
-
-runAssistantY :: forall sub a. (Assistant a) -> GHandler sub WebApp a
-runAssistantY a = liftIO . runAssistant a =<< assistantData <$> getYesod
 
 getWebAppState :: forall sub. GHandler sub WebApp WebAppState
 getWebAppState = liftIO . atomically . readTMVar =<< webAppState <$> getYesod
@@ -95,7 +92,7 @@ modifyWebAppState a = go =<< webAppState <$> getYesod
 runAnnex :: forall sub a. a -> Annex a -> GHandler sub WebApp a
 runAnnex fallback a = ifM (noAnnex <$> getYesod)
 	( return fallback
-	, runAssistantY $ liftAnnex a
+	, liftAssistant $ liftAnnex a
 	)
 
 waitNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> NotificationId -> GHandler sub WebApp ()
@@ -109,7 +106,7 @@ newNotifier selector = do
 	liftIO $ notificationHandleToId <$> newNotificationHandle notifier
 
 getNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> GHandler sub WebApp NotificationBroadcaster
-getNotifier selector = selector <$> runAssistantY getDaemonStatus
+getNotifier selector = selector <$> liftAssistant getDaemonStatus
 
 {- Adds the auth parameter as a hidden field on a form. Must be put into
  - every form. -}

Assistant/WebApp/Configurators.hs

@@ -102,7 +102,7 @@ repoList onlyconfigured includehere
 	where
 		configured = do
 			rs <- filter (not . Remote.readonly) . syncRemotes
-				<$> runAssistantY getDaemonStatus
+				<$> liftAssistant getDaemonStatus
 			runAnnex [] $ do
 				u <- getUUID
 				let l = map Remote.uuid rs

Assistant/WebApp/Configurators/Edit.hs

@@ -77,7 +77,7 @@ setRepoConfig uuid mremote oldc newc = do
 				, Param name
 				]
 			void $ Remote.remoteListRefresh
-		runAssistantY updateSyncRemotes
+		liftAssistant updateSyncRemotes
 
 editRepositoryAForm :: RepoConfig -> AForm WebApp WebApp RepoConfig
 editRepositoryAForm def = RepoConfig

Assistant/WebApp/Configurators/Pairing.hs

@@ -87,17 +87,15 @@ getInprogressPairR _ = noPairing
  -}
 startPairing :: PairStage -> IO () -> (AlertButton -> Alert) -> Maybe UUID -> Text -> Secret -> Widget
 startPairing stage oncancel alert muuid displaysecret secret = do
-	dstatus <- lift $ getAssistantY daemonStatusHandle
 	urlrender <- lift getUrlRender
 	reldir <- fromJust . relDir <$> lift getYesod
 
-	sendrequests <- lift $ runAssistantY $ asIO2 $ mksendrequests urlrender
+	sendrequests <- lift $ liftAssistant $ asIO2 $ mksendrequests urlrender
-
 	{- Generating a ssh key pair can take a while, so do it in the
 	 - background. -}
-	void $ liftIO $ forkIO $ do
+	thread <- lift $ liftAssistant $ asIO $ do
-		keypair <- genSshKeyPair
+		keypair <- liftIO $ genSshKeyPair
-		pairdata <- PairData
+		pairdata <- liftIO $ PairData
 			<$> getHostname
 			<*> myUserName
 			<*> pure reldir
@@ -105,7 +103,8 @@ 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
+		startSending pip stage $ sendrequests sender
+	void $ liftIO $ forkIO thread
 
 	lift $ redirect $ InprogressPairR $ toSecretReminder displaysecret
 	where

Assistant/WebApp/Configurators/S3.hs

@@ -117,9 +117,9 @@ makeS3Remote :: S3Creds -> String -> (Remote -> Handler ()) -> RemoteConfig -> H
 makeS3Remote (S3Creds ak sk) name setup config = do
 	remotename <- runAnnex name $ fromRepo $ uniqueRemoteName name 0
 	liftIO $ S3.s3SetCredsEnv ( T.unpack ak, T.unpack sk)
-	r <- runAssistantY $ liftAnnex $ addRemote $ do
+	r <- liftAssistant $ liftAnnex $ addRemote $ do
 		makeSpecialRemote name S3.remote config
 		return remotename
 	setup r
-	runAssistantY $ syncNewRemote r
+	liftAssistant $ syncNewRemote r
 	redirect $ EditNewCloudRepositoryR $ Remote.uuid r

Assistant/WebApp/Configurators/Ssh.hs

@@ -283,7 +283,7 @@ makeSsh' rsync setup sshdata keypair =
 
 makeSshRepo :: Bool -> (Remote -> Handler ()) -> SshData -> Handler RepHtml
 makeSshRepo forcersync setup sshdata = do
-	r <- runAssistantY $ makeSshRemote forcersync sshdata
+	r <- liftAssistant $ makeSshRemote forcersync sshdata
 	setup r
 	redirect $ EditNewCloudRepositoryR $ Remote.uuid r
 

Assistant/WebApp/Configurators/XMPP.hs

@@ -35,8 +35,8 @@ import qualified Data.Text as T
 xmppNeeded :: Handler ()
 xmppNeeded = whenM (isNothing <$> runAnnex Nothing getXMPPCreds) $ do
 	urlrender <- getUrlRender
-	void $ runAssistantY $ do
+	void $ liftAssistant $ do
-		close <- asIO removeAlert
+		close <- asIO1 removeAlert
 		addAlert $ xmppNeededAlert $ AlertButton
 			{ buttonLabel = "Configure a Jabber account"
 			, buttonUrl = urlrender XMPPR
@@ -60,7 +60,7 @@ getXMPPR = xmppPage $ do
 	where
 		storecreds creds = do
 			void $ runAnnex undefined $ setXMPPCreds creds
-			runAssistantY notifyRestart
+			liftAssistant notifyRestart
 			redirect ConfigR
 #else
 getXMPPR = xmppPage $

Assistant/WebApp/DashBoard.hs

@@ -37,9 +37,8 @@ import Control.Concurrent
 transfersDisplay :: Bool -> Widget
 transfersDisplay warnNoScript = do
 	webapp <- lift getYesod
-	d <- lift $ getAssistantY id
 	current <- lift $ M.toList <$> getCurrentTransfers
-	queued <- liftIO $ getTransferQueue $ transferQueue d
+	queued <- lift $ liftAssistant getTransferQueue
 	autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int)
 	let transfers = simplifyTransfers $ current ++ queued
 	if null transfers

Assistant/WebApp/SideBar.hs

@@ -28,7 +28,7 @@ sideBarDisplay = do
 	let content = do
 		{- Add newest alerts to the sidebar. -}
 		alertpairs <- lift $ M.toList . alertMap
-			<$> runAssistantY getDaemonStatus
+			<$> liftAssistant getDaemonStatus
 		mapM_ renderalert $
 			take displayAlerts $ reverse $ sortAlertPairs alertpairs
 	let ident = "sidebar"
@@ -73,12 +73,12 @@ getSideBarR nid = do
 
 {- Called by the client to close an alert. -}
 getCloseAlert :: AlertId -> Handler ()
-getCloseAlert = runAssistantY . removeAlert
+getCloseAlert = liftAssistant . removeAlert
 
 {- When an alert with a button is clicked on, the button takes us here. -}
 getClickAlert :: AlertId -> Handler ()
 getClickAlert i = do
-	m <- alertMap <$> runAssistantY getDaemonStatus
+	m <- alertMap <$> liftAssistant getDaemonStatus
 	case M.lookup i m of
 		Just (Alert { alertButton = Just b }) -> do
 			{- Spawn a thread to run the action while redirecting. -}

Assistant/WebApp/Utility.hs

@@ -36,15 +36,13 @@ changeSyncable (Just r) True = do
 	syncRemote r
 changeSyncable (Just r) False = do
 	changeSyncFlag r False
-	d <- getAssistantY id
+	liftAssistant $ updateSyncRemotes
-	let dstatus = daemonStatusHandle d
-	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
+	void $ liftAssistant $ dequeueTransfers tofrom
 	mapM_ (cancelTransfer False) =<<
 		filter tofrom . M.keys <$>
-			runAssistantY (currentTransfers <$> getDaemonStatus)
+			liftAssistant (currentTransfers <$> getDaemonStatus)
 	where
 		tofrom t = transferUUID t == Remote.uuid r
 
@@ -60,24 +58,21 @@ changeSyncFlag r enabled = runAnnex undefined $ do
 
 {- Start syncing remote, using a background thread. -}
 syncRemote :: Remote -> Handler ()
-syncRemote = runAssistantY . syncNewRemote
+syncRemote = liftAssistant . syncNewRemote
 
 pauseTransfer :: Transfer -> Handler ()
 pauseTransfer = cancelTransfer True
 
 cancelTransfer :: Bool -> Transfer -> Handler ()
 cancelTransfer pause t = do
-	tq <- getAssistantY transferQueue
 	m <- getCurrentTransfers
-	dstatus <- getAssistantY daemonStatusHandle
+	unless pause $
-	unless pause $ liftIO $
 		{- remove queued transfer -}
-		void $ dequeueTransfers tq dstatus $
+		void $ liftAssistant $ dequeueTransfers $ equivilantTransfer t
-			equivilantTransfer t
 	{- stop running transfer -}
 	maybe noop stop (M.lookup t m)
 	where
-		stop info = runAssistantY $ do
+		stop info = liftAssistant $ do
 			{- When there's a thread associated with the
 			 - transfer, it's signaled first, to avoid it
 			 - displaying any alert about the transfer having
@@ -107,18 +102,16 @@ startTransfer t = do
 	where
 		go info = maybe (start info) resume $ transferTid info
 		startqueued = do
-			dstatus <- getAssistantY daemonStatusHandle
+			is <- liftAssistant $ map snd <$> getMatchingTransfers (== t)
-			q <- getAssistantY transferQueue
-			is <- liftIO $ map snd <$> getMatchingTransfers q dstatus (== t)
 			maybe noop start $ headMaybe is
 		resume tid = do
-			runAssistantY $ alterTransferInfo t $
+			liftAssistant $ alterTransferInfo t $
 				\i -> i { transferPaused = False }
 			liftIO $ throwTo tid ResumeTransfer
-		start info = runAssistantY $ do
+		start info = liftAssistant $ do
 			program <- liftIO readProgramFile
 			inImmediateTransferSlot $
 				Transferrer.startTransfer program t info
 
 getCurrentTransfers :: Handler TransferMap
-getCurrentTransfers = currentTransfers <$> runAssistantY getDaemonStatus
+getCurrentTransfers = currentTransfers <$> liftAssistant getDaemonStatus