Assistant monad, stage 3

All toplevel named threads are converted to the Assistant monad.

Some utility functions still need to be converted.

2 files changed, 151 insertions, 152 deletions

diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs
index 116cc0fa1..77f84a4f6 100644
--- a/Assistant/Threads/PairListener.hs
+++ b/Assistant/Threads/PairListener.hs
@@ -11,8 +11,6 @@ import Assistant.Common
 import Assistant.Pairing
 import Assistant.Pairing.Network
 import Assistant.Pairing.MakeRemote
-import Assistant.ThreadedMonad
-import Assistant.ScanRemotes
 import Assistant.DaemonStatus
 import Assistant.WebApp
 import Assistant.WebApp.Types
@@ -27,117 +25,116 @@ import Data.Char
 thisThread :: ThreadName
 thisThread = "PairListener"
 
-pairListenerThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> UrlRenderer -> NamedThread
-pairListenerThread st dstatus scanremotes urlrenderer = thread $ liftIO $ withSocketsDo $
-	runEvery (Seconds 1) $ void $ tryIO $ do
-		sock <- getsock
-		go sock [] []
-	where
-		thread = NamedThread thisThread
+pairListenerThread :: UrlRenderer -> NamedThread
+pairListenerThread urlrenderer = NamedThread "PairListener" $ do
+	listener <- asIO $ go [] []
+	liftIO $ withSocketsDo $
+		runEvery (Seconds 1) $ void $ tryIO $ 
+			listener =<< getsock
+  where
+	{- Note this can crash if there's no network interface,
+	 - or only one like lo that doesn't support multicast. -}
+	getsock = multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort
 		
-		{- Note this can crash if there's no network interface,
-		 - or only one like lo that doesn't support multicast. -}
-		getsock = multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort
-		
-		go sock reqs cache = getmsg sock [] >>= \msg -> case readish msg of
-			Nothing -> go sock reqs cache
-			Just m -> do
-				sane <- checkSane msg
-				(pip, verified) <- verificationCheck m
-					=<< (pairingInProgress <$> getDaemonStatus dstatus)
-				let wrongstage = maybe False (\p -> pairMsgStage m <= inProgressPairStage p) pip
-				case (wrongstage, sane, pairMsgStage m) of
-					-- ignore our own messages, and
-					-- out of order messages
-					(True, _, _) -> go sock reqs cache
-					(_, False, _) -> go sock reqs cache
-					(_, _, PairReq) -> if m `elem` reqs
-						then go sock reqs (invalidateCache m cache)
-						else do
-							pairReqReceived verified dstatus urlrenderer m
-							go sock (m:take 10 reqs) (invalidateCache m cache)
-					(_, _, PairAck) ->
-						pairAckReceived verified pip st dstatus scanremotes m cache
-							>>= go sock reqs
-					(_, _, PairDone) -> do
-						pairDoneReceived verified pip st dstatus scanremotes m
-						go sock	reqs cache
+	go reqs cache sock = liftIO (getmsg sock []) >>= \msg -> case readish msg of
+		Nothing -> go reqs cache sock
+		Just m -> do
+			sane <- checkSane msg
+			(pip, verified) <- verificationCheck m
+				=<< (pairingInProgress <$> daemonStatus)
+			let wrongstage = maybe False (\p -> pairMsgStage m <= inProgressPairStage p) pip
+			case (wrongstage, sane, pairMsgStage m) of
+				-- ignore our own messages, and
+				-- out of order messages
+				(True, _, _) -> go reqs cache sock
+				(_, False, _) -> go reqs cache sock
+				(_, _, PairReq) -> if m `elem` reqs
+					then go reqs (invalidateCache m cache) sock
+					else do
+						pairReqReceived verified urlrenderer m
+						go (m:take 10 reqs) (invalidateCache m cache) sock
+				(_, _, PairAck) -> do
+					cache' <- pairAckReceived verified pip m cache
+					go reqs cache' sock
+				(_, _, PairDone) -> do
+					pairDoneReceived verified pip m
+					go reqs cache sock
 
-		{- As well as verifying the message using the shared secret,
-		 - check its UUID against the UUID we have stored. If
-		 - they're the same, someone is sending bogus messages,
-		 - which could be an attempt to brute force the shared
-		 - secret.
-		 -}
-		verificationCheck m (Just pip) = do
-			let verified = verifiedPairMsg m pip
-			let sameuuid = pairUUID (inProgressPairData pip) == pairUUID (pairMsgData m)
-			if not verified && sameuuid
-				then do
-					runThreadState st $
-						warning "detected possible pairing brute force attempt; disabled pairing"
-					stopSending dstatus pip
-					return (Nothing, False)
-				else return (Just pip, verified && sameuuid)
-		verificationCheck _ Nothing = return (Nothing, False)
+	{- As well as verifying the message using the shared secret,
+	 - check its UUID against the UUID we have stored. If
+	 - they're the same, someone is sending bogus messages,
+	 - which could be an attempt to brute force the shared secret. -}
+	verificationCheck _ Nothing = return (Nothing, False)
+	verificationCheck m (Just pip)
+		| not verified && sameuuid = do
+			liftAnnex $ warning
+				"detected possible pairing brute force attempt; disabled pairing"
+			stopSending pip <<~ daemonStatusHandle
+			return (Nothing, False)
+		|otherwise = return (Just pip, verified && sameuuid)
+	  where
+		verified = verifiedPairMsg m pip
+		sameuuid = pairUUID (inProgressPairData pip) == pairUUID (pairMsgData m)
 		
-		{- Various sanity checks on the content of the message. -}
-		checkSane msg 
-			{- Control characters could be used in a
-			 - console poisoning attack. -}
-			| any isControl msg || any (`elem` "\r\n") msg = do
-				runThreadState st $
-					warning "illegal control characters in pairing message; ignoring"
-				return False
-			| otherwise = return True
+	{- Various sanity checks on the content of the message. -}
+	checkSane msg 
+		{- Control characters could be used in a
+		 - console poisoning attack. -}
+		| any isControl msg || any (`elem` "\r\n") msg = do
+			liftAnnex $ warning
+				"illegal control characters in pairing message; ignoring"
+			return False
+		| otherwise = return True
 
-		{- PairReqs invalidate the cache of recently finished pairings.
-		 - This is so that, if a new pairing is started with the
-		 - same secret used before, a bogus PairDone is not sent. -}
-		invalidateCache msg = filter (not . verifiedPairMsg msg)
+	{- PairReqs invalidate the cache of recently finished pairings.
+	 - This is so that, if a new pairing is started with the
+	 - same secret used before, a bogus PairDone is not sent. -}
+	invalidateCache msg = filter (not . verifiedPairMsg msg)
 
-		getmsg sock c = do
-			(msg, n, _) <- recvFrom sock chunksz
-			if n < chunksz
-				then return $ c ++ msg
-				else getmsg sock $ c ++ msg
-			where
-				chunksz = 1024
+	getmsg sock c = do
+		(msg, n, _) <- recvFrom sock chunksz
+		if n < chunksz
+			then return $ c ++ msg
+			else getmsg sock $ c ++ msg
+		where
+			chunksz = 1024
 
 {- Show an alert when a PairReq is seen. -}
-pairReqReceived :: Bool -> DaemonStatusHandle -> UrlRenderer -> PairMsg -> IO ()
-pairReqReceived True _ _ _ = noop -- ignore our own PairReq
-pairReqReceived False dstatus urlrenderer msg = do
-	url <- renderUrl urlrenderer (FinishPairR msg) []
-	void $ addAlert dstatus $ pairRequestReceivedAlert repo
+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
+	liftIO $ void $ addAlert dstatus $ pairRequestReceivedAlert repo
 		AlertButton
 			{ buttonUrl = url
 			, buttonLabel = T.pack "Respond"
 			, buttonAction = Just $ removeAlert dstatus
 			}
-	where
-		repo = pairRepo msg
+  where
+	repo = pairRepo msg
 
 {- When a verified PairAck is seen, a host is ready to pair with us, and has
  - already configured our ssh key. Stop sending PairReqs, finish the pairing,
- - and send a single PairDone. 
- -}
-pairAckReceived :: Bool -> Maybe PairingInProgress -> ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PairMsg -> [PairingInProgress] -> IO [PairingInProgress]
-pairAckReceived True (Just pip) st dstatus scanremotes msg cache = do
-	stopSending dstatus pip
-	setupAuthorizedKeys msg
-	finishedPairing st dstatus scanremotes msg (inProgressSshKeyPair pip)
-	startSending dstatus pip PairDone $ multicastPairMsg
+ - and send a single PairDone. -}
+pairAckReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> [PairingInProgress] -> Assistant [PairingInProgress]
+pairAckReceived True (Just pip) msg cache = do
+	stopSending pip <<~ daemonStatusHandle
+	liftIO $ setupAuthorizedKeys msg
+	finishedPairing msg (inProgressSshKeyPair pip)
+	dstatus <- getAssistant daemonStatusHandle
+	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.
  - Perhaps our PairDone was not received. To handle this, we keep
  - a cache of recently finished pairings, and re-send PairDone in
  - response to stale PairAcks for them. -}
-pairAckReceived _ _ _ dstatus _ msg cache = do
+pairAckReceived _ _ msg cache = do
 	let pips = filter (verifiedPairMsg msg) cache
+	dstatus <- getAssistant daemonStatusHandle
 	unless (null pips) $
-		forM_ pips $ \pip ->
+		liftIO $ forM_ pips $ \pip ->
 			startSending dstatus pip PairDone $ multicastPairMsg
 				(Just 1) (inProgressSecret pip) (inProgressPairData pip)
 	return cache
@@ -151,9 +148,9 @@ pairAckReceived _ _ _ dstatus _ msg cache = do
  - entering the secret. Would be better to start a fresh pair request in this
  - situation.
  -}
-pairDoneReceived :: Bool -> Maybe PairingInProgress -> ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PairMsg -> IO ()
-pairDoneReceived False _ _ _ _ _ = noop -- not verified
-pairDoneReceived True Nothing _ _ _ _ = noop -- not in progress
-pairDoneReceived True (Just pip) st dstatus scanremotes msg = do
-	stopSending dstatus pip
-	finishedPairing st dstatus scanremotes msg (inProgressSshKeyPair pip)
+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
+	finishedPairing msg (inProgressSshKeyPair pip)
diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs
index 2e880bef9..145abe86d 100644
--- a/Assistant/Threads/Transferrer.hs
+++ b/Assistant/Threads/Transferrer.hs
@@ -8,7 +8,6 @@
 module Assistant.Threads.Transferrer where
 
 import Assistant.Common
-import Assistant.ThreadedMonad
 import Assistant.DaemonStatus
 import Assistant.TransferQueue
 import Assistant.TransferSlots
@@ -23,75 +22,78 @@ import Locations.UserConfig
 
 import System.Process (create_group)
 
-thisThread :: ThreadName
-thisThread = "Transferrer"
-
 {- For now only one transfer is run at a time. -}
 maxTransfers :: Int
 maxTransfers = 1
 
 {- Dispatches transfers from the queue. -}
-transfererThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> TransferSlots -> CommitChan -> NamedThread
-transfererThread st dstatus transferqueue slots commitchan = thread $ liftIO $ go =<< readProgramFile
-	where
-		thread = NamedThread thisThread
-		go program = forever $ inTransferSlot dstatus slots $
-			maybe (return Nothing) (uncurry $ startTransfer st dstatus commitchan program)
-				=<< getNextTransfer transferqueue dstatus notrunning
-		{- Skip transfers that are already running. -}
-		notrunning = isNothing . startedTime
+transfererThread :: NamedThread
+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 $
+		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 :: ThreadState -> DaemonStatusHandle -> CommitChan -> FilePath -> Transfer -> TransferInfo -> TransferGenerator
-startTransfer st dstatus commitchan program t info = case (transferRemote info, associatedFile info) of
-	(Just remote, Just file) -> ifM (runThreadState st $ shouldTransfer t info)
+startTransfer :: FilePath -> Transfer -> TransferInfo -> Assistant (Maybe (Transfer, TransferInfo, IO ()))
+startTransfer program t info = case (transferRemote info, associatedFile info) of
+	(Just remote, Just file) -> ifM (liftAnnex $ shouldTransfer t info)
 		( do
-			brokendebug thisThread [ "Transferring:" , show t ]
-			notifyTransfer dstatus
-			return $ Just (t, info, transferprocess remote file)
+			debug [ "Transferring:" , show t ]
+			notifyTransfer <<~ daemonStatusHandle
+			tp <- asIO2 transferprocess
+			return $ Just (t, info, tp remote file)
 		, do
-			brokendebug thisThread [ "Skipping unnecessary transfer:" , show t ]
-			void $ removeTransfer dstatus t
+			debug [ "Skipping unnecessary transfer:" , show t ]
+			void $ flip removeTransfer t <<~ daemonStatusHandle
 			return Nothing
 		)
 	_ -> return Nothing
-	where
-		direction = transferDirection t
-		isdownload = direction == Download
+  where
+	direction = transferDirection t
+	isdownload = direction == Download
 
-		transferprocess remote file = void $ do
-			(_, _, _, pid)
-				<- createProcess (proc program $ toCommand params)
-					{ create_group = True }
-			{- Alerts are only shown for successful transfers.
-			 - Transfers can temporarily fail for many reasons,
-			 - so there's no point in bothering the user about
-			 - those. The assistant should recover.
-			 -
-			 - Also, after a successful transfer, the location
-			 - log has changed. Indicate that a commit has been
-			 - made, in order to queue a push of the git-annex
-			 - branch out to remotes that did not participate
-			 - in the transfer.
-			 -}
-			whenM ((==) ExitSuccess <$> waitForProcess pid) $ do
-				void $ addAlert dstatus $
-					makeAlertFiller True $
-						transferFileAlert direction True file
-				recordCommit commitchan
-			where
-				params =
-					[ Param "transferkey"
-					, Param "--quiet"
-					, Param $ key2file $ transferKey t
-					, Param $ if isdownload
-						then "--from"
-						else "--to"
-					, Param $ Remote.name remote
-					, Param "--file"
-					, File file
-					]
+	transferprocess remote file = void $ do
+		(_, _, _, pid)
+			<- liftIO $ createProcess (proc program $ toCommand params)
+				{ create_group = True }
+		{- Alerts are only shown for successful transfers.
+		 - Transfers can temporarily fail for many reasons,
+		 - so there's no point in bothering the user about
+		 - those. The assistant should recover.
+		 -
+		 - Also, after a successful transfer, the location
+		 - log has changed. Indicate that a commit has been
+		 - made, in order to queue a push of the git-annex
+		 - branch out to remotes that did not participate
+		 - in the transfer.
+		 -}
+		whenM (liftIO $ (==) ExitSuccess <$> waitForProcess pid) $ do
+			dstatus <- getAssistant daemonStatusHandle
+			liftIO $ void $ addAlert dstatus $
+				makeAlertFiller True $
+					transferFileAlert direction True file
+			recordCommit <<~ commitChan
+	  where
+		params =
+			[ Param "transferkey"
+			, Param "--quiet"
+			, Param $ key2file $ transferKey t
+			, Param $ if isdownload
+				then "--from"
+				else "--to"
+			, Param $ Remote.name remote
+			, Param "--file"
+			, File file
+			]
 
 {- Checks if the file to download is already present, or the remote
  - being uploaded to isn't known to have the file. -}