better handling of lifting from XMPP -> Assistant

4 files changed, 81 insertions, 87 deletions

diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs
index 9f5c42aa3..3b6dfedee 100644
--- a/Assistant/Monad.hs
+++ b/Assistant/Monad.hs
@@ -79,8 +79,8 @@ newAssistantData st dstatus = AssistantData
 	<*> newBuddyList
 	<*> newNetMessagerControl
 
-runAssistant :: Assistant a -> AssistantData -> IO a
-runAssistant a = runReaderT (mkAssistant a)
+runAssistant :: AssistantData -> Assistant a -> IO a
+runAssistant d a = runReaderT (mkAssistant a) d
 
 getAssistant :: (AssistantData -> a) -> Assistant a
 getAssistant = reader
@@ -97,23 +97,23 @@ liftAnnex a = do
 (<~>) :: (IO a -> IO b) -> Assistant a -> Assistant b
 io <~> a = do
 	d <- reader id
-	liftIO $ io $ runAssistant a d
+	liftIO $ io $ runAssistant d a
 
 {- Creates an IO action that will run an Assistant action when run. -}
 asIO :: Assistant a -> Assistant (IO a)
 asIO a = do
 	d <- reader id
-	return $ runAssistant a d
+	return $ runAssistant d a
 
 asIO1 :: (a -> Assistant b) -> Assistant (a -> IO b)
 asIO1 a = do
 	d <- reader id
-	return $ \v -> runAssistant (a v) d
+	return $ \v -> runAssistant d $ a v
 
 asIO2 :: (a -> b -> Assistant c) -> Assistant (a -> b -> IO c)
 asIO2 a = do
 	d <- reader id
-	return $ \v1 v2 -> runAssistant (a v1 v2) d
+	return $ \v1 v2 -> runAssistant d (a v1 v2)
 
 {- Runs an IO action on a selected field of the AssistantData. -}
 (<<~) :: (a -> IO b) -> (AssistantData -> a) -> Assistant b
diff --git a/Assistant/NamedThread.hs b/Assistant/NamedThread.hs
index 4622f8742..083252f94 100644
--- a/Assistant/NamedThread.hs
+++ b/Assistant/NamedThread.hs
@@ -19,12 +19,12 @@ runNamedThread (NamedThread name a) = do
 	liftIO . go $ d { threadName = name }
   where
 	go d = do
-		r <- E.try (runAssistant a d) :: IO (Either E.SomeException ())
+		r <- E.try (runAssistant d a) :: IO (Either E.SomeException ())
 		case r of
 			Right _ -> noop
 			Left e -> do
 				let msg = unwords [name, "crashed:", show e]
 				hPutStrLn stderr msg
 				-- TODO click to restart
-				flip runAssistant d $ void $
+				runAssistant d $ void $
 					addAlert $ warningAlert name msg
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index 3d454d9c8..7da2bccc6 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/Assistant/Threads/XMPPClient.hs
@@ -18,7 +18,7 @@ import Assistant.Sync
 import Assistant.DaemonStatus
 import qualified Remote
 import Utility.ThreadScheduler
-import Assistant.WebApp
+import Assistant.WebApp (UrlRenderer, renderUrl)
 import Assistant.WebApp.Types
 import Assistant.Alert
 import Assistant.Pairing
@@ -34,73 +34,72 @@ import qualified Git.Branch
 import Data.Time.Clock
 
 xmppClientThread :: UrlRenderer -> NamedThread
-xmppClientThread urlrenderer = NamedThread "XMPPClient" $ do
-	{- All Assistant actions have to be converted into IO actions that
-	 - can be run from within the XMPP monad using liftIO. Ugly. -}
-	iodebug <- asIO1 debug
-	iopull <- asIO1 pull
-	iopairMsgReceived <- asIO2 $ pairMsgReceived urlrenderer
-	ioupdatebuddies <- asIO1 $ \p ->
-		updateBuddyList (updateBuddies p) <<~ buddyList
-	ioemptybuddies <- asIO $
-		updateBuddyList (const noBuddies) <<~ buddyList
-	iorelay <- asIO1 relayNetMessage
-	ioclientthread <- asIO $
-		go iorelay iodebug iopull ioupdatebuddies ioemptybuddies iopairMsgReceived
-	restartableClient ioclientthread
+xmppClientThread urlrenderer = NamedThread "XMPPClient" $
+	restartableClient . xmppClient urlrenderer =<< getAssistant id
+
+{- Runs the client, handing restart events. -}
+restartableClient :: IO () -> Assistant ()
+restartableClient a = forever $ do
+	tid <- liftIO $ forkIO a
+	waitNetMessagerRestart
+	liftIO $ killThread tid
+
+xmppClient :: UrlRenderer -> AssistantData -> IO ()
+xmppClient urlrenderer d = do
+	v <- liftAssistant $ liftAnnex getXMPPCreds
+	case v of
+		Nothing -> noop -- will be restarted once creds get configured
+		Just c -> retry (runclient c) =<< getCurrentTime
   where
-	go iorelay iodebug iopull ioupdatebuddies ioemptybuddies iopairMsgReceived = do
-		v <- liftAnnex getXMPPCreds
-		case v of
-			Nothing -> noop
-			Just c -> liftIO $ retry (runclient c) =<< getCurrentTime
-	  where
-		debug' = void . liftIO . iodebug
-
-		{- When the client exits, it's restarted;
- 		 - if it keeps failing, back off to wait 5 minutes before
- 		 - trying it again. -}
-		retry a starttime = do
-			e <- a
-			now <- getCurrentTime
-			if diffUTCTime now starttime > 300
-				then do
-					void $ iodebug ["connection lost; reconnecting", show e]
-					retry a now
-				else do
-					void $ iodebug ["connection failed; will retry", show e]
-					threadDelaySeconds (Seconds 300)
-					retry a =<< getCurrentTime
-
-		runclient c = void $ connectXMPP c $ \jid -> do
-			selfjid <- bindJID jid
-			debug' ["connected", show selfjid]
-			{- The buddy list starts empty each time
-			 - the client connects, so that stale info
-			 - is not retained. -}
-			void $ liftIO ioemptybuddies
-			putStanza gitAnnexSignature
-			xmppThread $ receivenotifications selfjid
-			forever $ do
-				a <- liftIO $ iorelay selfjid
-				a
-
-		receivenotifications selfjid = forever $ do
-			l <- decodeStanza selfjid <$> getStanza
-			debug' ["received:", show l]
-			mapM_ (handle selfjid) l
-
-		handle _ (PresenceMessage p) =
-			void $ liftIO $ ioupdatebuddies p
-		handle _ (GotNetMessage QueryPresence) =
-			putStanza gitAnnexSignature
-		handle _ (GotNetMessage (NotifyPush us)) =
-			void $ liftIO $ iopull us
-		handle selfjid (GotNetMessage (PairingNotification stage t u)) =
-			maybe noop (\jid -> liftIO $ iopairMsgReceived (stage, u) (selfjid, jid)) (parseJID t)
-		handle _ (Ignorable _) = noop
-		handle _ (Unknown _) = noop
-		handle _ (ProtocolError _) = noop
+	liftAssistant = runAssistant d
+	xAssistant = liftIO . liftAssistant
+
+	{- When the client exits, it's restarted;
+ 	 - if it keeps failing, back off to wait 5 minutes before
+	 - trying it again. -}
+	retry client starttime = do
+		e <- client
+		now <- getCurrentTime
+		if diffUTCTime now starttime > 300
+			then do
+				liftAssistant $ debug ["connection lost; reconnecting", show e]
+				retry client now
+			else do
+				liftAssistant $ debug ["connection failed; will retry", show e]
+				threadDelaySeconds (Seconds 300)
+				retry client =<< getCurrentTime
+
+	runclient c = liftIO $ connectXMPP c $ \jid -> do
+		selfjid <- bindJID jid
+		putStanza gitAnnexSignature
+
+		xAssistant $ debug ["connected", show selfjid]
+		{- The buddy list starts empty each time
+		 - the client connects, so that stale info
+		 - is not retained. -}
+		void $ xAssistant $
+			updateBuddyList (const noBuddies) <<~ buddyList
+
+		xmppThread $ receivenotifications selfjid
+		forever $ do
+			a <- xAssistant $ relayNetMessage selfjid
+			a
+
+	receivenotifications selfjid = forever $ do
+		l <- decodeStanza selfjid <$> getStanza
+		xAssistant $ debug ["received:", show l]
+		mapM_ (handle selfjid) l
+
+	handle _ (PresenceMessage p) = void $ xAssistant $ 
+		updateBuddyList (updateBuddies p) <<~ buddyList
+	handle _ (GotNetMessage QueryPresence) = putStanza gitAnnexSignature
+	handle _ (GotNetMessage (NotifyPush us)) = void $ xAssistant $
+		pull us
+	handle selfjid (GotNetMessage (PairingNotification stage t u)) =
+		maybe noop (xAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID t)
+	handle _ (Ignorable _) = noop
+	handle _ (Unknown _) = noop
+	handle _ (ProtocolError _) = noop
 
 data XMPPEvent
 	= GotNetMessage NetMessage
@@ -153,13 +152,6 @@ relayNetMessage selfjid = convert =<< waitNetMessage
 				return $ putStanza $
 					pairingNotification stage u tojid selfjid
 
-{- Runs the client, handing restart events. -}
-restartableClient :: IO () -> Assistant ()
-restartableClient a = forever $ do
-	tid <- liftIO $ forkIO a
-	waitNetMessagerRestart
-	liftIO $ killThread tid
-
 {- Runs a XMPP action in a separate thread, using a session to allow it
  - to access the same XMPP client. -}
 xmppThread :: XMPP () -> XMPP ()
@@ -196,8 +188,8 @@ pull us = do
 		unlessM (all id . fst <$> manualPull branch [r]) $
 			pullone rs branch
 
-pairMsgReceived :: UrlRenderer -> (PairStage, UUID) -> (JID, JID) -> Assistant ()
-pairMsgReceived urlrenderer (PairReq, theiruuid) (selfjid, theirjid)
+pairMsgReceived :: UrlRenderer -> PairStage -> UUID -> JID -> JID -> Assistant ()
+pairMsgReceived urlrenderer PairReq theiruuid selfjid theirjid
 	-- PairReq from another client using our JID is automatically accepted.
 	| baseJID selfjid == baseJID theirjid = do
 		selfuuid <- liftAnnex getUUID
@@ -215,7 +207,8 @@ pairMsgReceived urlrenderer (PairReq, theiruuid) (selfjid, theirjid)
 				, buttonLabel = T.pack "Respond"
 				, buttonAction = Just close
 				}
-pairMsgReceived _ (PairAck, theiruuid) (_selfjid, theirjid) =
+
+pairMsgReceived _ PairAck theiruuid _selfjid theirjid =
 	{- PairAck must come from one of the buddies we are pairing with;
 	 - don't pair with just anyone. -}
 	whenM (isBuddyPairing theirjid) $ do
@@ -224,7 +217,8 @@ pairMsgReceived _ (PairAck, theiruuid) (_selfjid, theirjid) =
 		sendNetMessage $
 			PairingNotification PairDone (formatJID theirjid) selfuuid
 		finishXMPPPairing theirjid theiruuid
-pairMsgReceived _ (PairDone, _theiruuid) (_selfjid, theirjid) =
+
+pairMsgReceived _ PairDone _theiruuid _selfjid theirjid =
 	changeBuddyPairing theirjid False
 
 isBuddyPairing :: JID -> Assistant Bool
diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs
index 8039c561d..7c9f74702 100644
--- a/Assistant/TransferSlots.hs
+++ b/Assistant/TransferSlots.hs
@@ -69,5 +69,5 @@ runTransferThread' d a = go
 				Just ResumeTransfer -> go
 				_ -> done
 			_ -> done
-	done = flip runAssistant d $ 
+	done = runAssistant d $ 
 		flip MSemN.signal 1 <<~ transferSlots