better handling of lifting from XMPP -> Assistant

Assistant.hs

@@ -177,7 +177,7 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do
 	checkCanWatch
 	dstatus <- startDaemonStatus
 	liftIO $ daemonize $
-		runAssistant go =<< newAssistantData st dstatus
+		flip runAssistant go =<< newAssistantData st dstatus
   where
 	go = do
 		d <- getAssistant id
@@ -216,6 +216,5 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do
 	assist a = (False, a)
 	startthread d (watcher, t)
 		| watcher || assistant = void $ liftIO $ forkIO $
-			flip runAssistant d $
+			runAssistant d $ runNamedThread t
-				runNamedThread t
 		| otherwise = noop

Assistant/Monad.hs

@@ -79,8 +79,8 @@ newAssistantData st dstatus = AssistantData
 	<*> newBuddyList
 	<*> newNetMessagerControl
 
-runAssistant :: Assistant a -> AssistantData -> IO a
+runAssistant :: AssistantData -> Assistant a -> IO a
-runAssistant a = runReaderT (mkAssistant 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

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

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
+xmppClientThread urlrenderer = NamedThread "XMPPClient" $
-	{- All Assistant actions have to be converted into IO actions that
+	restartableClient . xmppClient urlrenderer =<< getAssistant id
-	 - can be run from within the XMPP monad using liftIO. Ugly. -}
+
-	iodebug <- asIO1 debug
+{- Runs the client, handing restart events. -}
-	iopull <- asIO1 pull
+restartableClient :: IO () -> Assistant ()
-	iopairMsgReceived <- asIO2 $ pairMsgReceived urlrenderer
+restartableClient a = forever $ do
-	ioupdatebuddies <- asIO1 $ \p ->
+	tid <- liftIO $ forkIO a
-		updateBuddyList (updateBuddies p) <<~ buddyList
+	waitNetMessagerRestart
-	ioemptybuddies <- asIO $
+	liftIO $ killThread tid
-		updateBuddyList (const noBuddies) <<~ buddyList
+
-	iorelay <- asIO1 relayNetMessage
+xmppClient :: UrlRenderer -> AssistantData -> IO ()
-	ioclientthread <- asIO $
+xmppClient urlrenderer d = do
-		go iorelay iodebug iopull ioupdatebuddies ioemptybuddies iopairMsgReceived
+	v <- liftAssistant $ liftAnnex getXMPPCreds
-	restartableClient ioclientthread
+	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
+	liftAssistant = runAssistant d
-		v <- liftAnnex getXMPPCreds
+	xAssistant = liftIO . liftAssistant
-		case v of
-			Nothing -> noop
-			Just c -> liftIO $ retry (runclient c) =<< getCurrentTime
-	  where
-		debug' = void . liftIO . iodebug
 
-		{- When the client exits, it's restarted;
+	{- When the client exits, it's restarted;
- 		 - if it keeps failing, back off to wait 5 minutes before
+ 	 - if it keeps failing, back off to wait 5 minutes before
- 		 - trying it again. -}
+	 - trying it again. -}
-		retry a starttime = do
+	retry client starttime = do
-			e <- a
+		e <- client
-			now <- getCurrentTime
+		now <- getCurrentTime
-			if diffUTCTime now starttime > 300
+		if diffUTCTime now starttime > 300
-				then do
+			then do
-					void $ iodebug ["connection lost; reconnecting", show e]
+				liftAssistant $ debug ["connection lost; reconnecting", show e]
-					retry a now
+				retry client now
-				else do
+			else do
-					void $ iodebug ["connection failed; will retry", show e]
+				liftAssistant $ debug ["connection failed; will retry", show e]
-					threadDelaySeconds (Seconds 300)
+				threadDelaySeconds (Seconds 300)
-					retry a =<< getCurrentTime
+				retry client =<< getCurrentTime
 
-		runclient c = void $ connectXMPP c $ \jid -> do
+	runclient c = liftIO $ connectXMPP c $ \jid -> do
-			selfjid <- bindJID jid
+		selfjid <- bindJID jid
-			debug' ["connected", show selfjid]
+		putStanza gitAnnexSignature
-			{- 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
+		xAssistant $ debug ["connected", show selfjid]
-			l <- decodeStanza selfjid <$> getStanza
+		{- The buddy list starts empty each time
-			debug' ["received:", show l]
+		 - the client connects, so that stale info
-			mapM_ (handle selfjid) l
+		 - is not retained. -}
+		void $ xAssistant $
+			updateBuddyList (const noBuddies) <<~ buddyList
 
-		handle _ (PresenceMessage p) =
+		xmppThread $ receivenotifications selfjid
-			void $ liftIO $ ioupdatebuddies p
+		forever $ do
-		handle _ (GotNetMessage QueryPresence) =
+			a <- xAssistant $ relayNetMessage selfjid
-			putStanza gitAnnexSignature
+			a
-		handle _ (GotNetMessage (NotifyPush us)) =
+
-			void $ liftIO $ iopull us
+	receivenotifications selfjid = forever $ do
-		handle selfjid (GotNetMessage (PairingNotification stage t u)) =
+		l <- decodeStanza selfjid <$> getStanza
-			maybe noop (\jid -> liftIO $ iopairMsgReceived (stage, u) (selfjid, jid)) (parseJID t)
+		xAssistant $ debug ["received:", show l]
-		handle _ (Ignorable _) = noop
+		mapM_ (handle selfjid) l
-		handle _ (Unknown _) = noop
+
-		handle _ (ProtocolError _) = noop
+	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 -> PairStage -> UUID -> JID -> JID -> Assistant ()
-pairMsgReceived urlrenderer (PairReq, theiruuid) (selfjid, theirjid)
+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

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

Assistant/WebApp.hs

@@ -71,7 +71,7 @@ newWebAppState = do
 		, otherRepos = otherrepos }
 
 liftAssistant :: forall sub a. (Assistant a) -> GHandler sub WebApp a
-liftAssistant a = liftIO . runAssistant a =<< assistantData <$> getYesod
+liftAssistant a = liftIO . flip runAssistant a =<< assistantData <$> getYesod
 
 getWebAppState :: forall sub. GHandler sub WebApp WebAppState
 getWebAppState = liftIO . atomically . readTMVar =<< webAppState <$> getYesod

Command/WebApp.hs

@@ -107,7 +107,7 @@ firstRun = do
 	urlrenderer <- newUrlRenderer
 	v <- newEmptyMVar
 	let callback a = Just $ a v
-	void $ flip runAssistant d $ runNamedThread $
+	void $ runAssistant d $ runNamedThread $
 		webAppThread d urlrenderer True 
 			(callback signaler)
 			(callback mainthread)