have server relay Devloper messages to other Developers

3 files changed, 43 insertions, 40 deletions

diff --git a/Role/Developer.hs b/Role/Developer.hs
index 1cc5a10..d6cbf2b 100644
--- a/Role/Developer.hs
+++ b/Role/Developer.hs
@@ -24,17 +24,13 @@ import Control.Monad
 run :: DeveloperOpts -> IO ()
 run = run' developer . debugUrl
 
-run' :: (TMChan (Message Entered) -> TMChan (Message Seen) -> SessionID -> IO ()) -> UrlString -> IO ()
+run' :: (TMChan (Message Entered) -> TMChan LogMessage -> SessionID -> IO ()) -> UrlString -> IO ()
 run' runner url = void $ runClientApp app
   where
 	connect = ConnectMode (T.pack url)
-	app = clientApp connect Developer userMessages runner
+	app = clientApp connect Developer Just runner
 
-userMessages :: LogMessage -> Maybe (Message Seen)
-userMessages (User m) = Just m
-userMessages (Developer _) = Nothing
-
-developer :: TMChan (Message Entered) -> TMChan (Message Seen) -> SessionID -> IO ()
+developer :: TMChan (Message Entered) -> TMChan LogMessage -> SessionID -> IO ()
 developer ichan ochan _ = withLogger "debug-me-developer.log" $ \logger -> do
 	(devstate, startoutput) <- processSessionStart ochan logger
 	emitOutput startoutput
@@ -90,22 +86,22 @@ sendTtyInput ichan devstate logger = go
 		go
 
 -- | Read activity from the TMChan and display it to the developer.
-sendTtyOutput :: TMChan (Message Seen) -> TVar DeveloperState -> Logger -> IO ()
+sendTtyOutput :: TMChan LogMessage -> TVar DeveloperState -> Logger -> IO ()
 sendTtyOutput ochan devstate logger = go
   where
 	go = do
-		v <- atomically $ getUserMessage ochan devstate
+		v <- atomically $ getServerMessage ochan devstate
 		case v of
 			Nothing -> return ()
-			Just (o, msg) -> do
-				logger $ User msg
+			Just (o, l) -> do
+				logger l
 				emitOutput o
 				go
 
 -- | Present our session key to the user. 
 -- Wait for them to accept or reject it, while displaying any Seen data
 -- in the meantime.
-authUser :: TMChan (Message Entered) -> TMChan (Message Seen) -> TVar DeveloperState -> Logger -> IO Bool
+authUser :: TMChan (Message Entered) -> TMChan LogMessage -> TVar DeveloperState -> Logger -> IO Bool
 authUser ichan ochan devstate logger = do
 	ds <- atomically $ readTVar devstate
 	pk <- myPublicKey (developerSessionKey ds)
@@ -117,8 +113,8 @@ authUser ichan ochan devstate logger = do
   where
 	waitresp pk = do
 		(o, msg) <- fromMaybe (error "Looks like that debug-me session is over.")
-			<$> atomically (getUserMessage ochan devstate)
-		logger $ User msg
+			<$> atomically (getServerMessage ochan devstate)
+		logger msg
 		emitOutput o
 		case o of
 			GotControl (SessionKeyAccepted pk')
@@ -132,6 +128,7 @@ data Output
 	| Beep
 	| ProtocolError String
 	| GotControl ControlAction
+	| NoOutput
 
 emitOutput :: Output -> IO ()
 emitOutput (ProtocolError e) =
@@ -144,31 +141,37 @@ emitOutput Beep = do
 	hFlush stdout
 emitOutput (GotControl _) =
 	return ()
+emitOutput NoOutput =
+	return ()
 
--- | Get messages from user, check their signature, and make sure that they
+-- | Get messages from server, check their signature, and make sure that they
 -- are properly chained from past messages, before returning.
-getUserMessage :: TMChan (Message Seen) -> TVar DeveloperState -> STM (Maybe (Output, Message Seen))
-getUserMessage ochan devstate = do
+getServerMessage :: TMChan LogMessage -> TVar DeveloperState -> STM (Maybe (Output, LogMessage))
+getServerMessage ochan devstate = do
 	mmsg <- readTMChan ochan
 	case mmsg of
 		Nothing -> return Nothing
-		Just msg -> do
+		Just (User msg) -> do
 			ds <- readTVar devstate
-			-- Check signature before doing anything else.
+			-- Check user's signature before doing anything else.
 			if verifySigned (developerSigVerifier ds) msg
 				then do
-					o <- process ds msg
-					return (Just (o, msg))
-				else getUserMessage ochan devstate
+					o <- processuser ds msg
+					return (Just (o, User msg))
+				else getServerMessage ochan devstate
+		Just (Developer msg) -> do
+			-- Not bothering to check signatures of messages
+			-- from other developers. XXX
+			return (Just (NoOutput, Developer msg))
   where
-	process ds (ActivityMessage act@(Activity (Seen (Val b)) _ _)) = do
+	processuser ds (ActivityMessage act@(Activity (Seen (Val b)) _ _)) = do
 		let (legal, ds') = isLegalSeen act ds
 		if legal
 			then do
 				writeTVar devstate ds'
 				return (TtyOutput b)
 			else return (ProtocolError $ "Illegal Seen value: " ++ show (act, hash act))
-	process ds (ControlMessage (Control (Rejected _) _)) = do
+	processuser ds (ControlMessage (Control (Rejected _) _)) = do
 		-- When they rejected a message we sent,
 		-- anything we sent subsequently will
 		-- also be rejected, so forget about it.
@@ -178,11 +181,11 @@ getUserMessage ochan devstate = do
 			}
 		writeTVar devstate ds'
 		return Beep
-	process _ (ControlMessage (Control c@(SessionKey _) _)) =
+	processuser _ (ControlMessage (Control c@(SessionKey _) _)) =
 		return (GotControl c)
-	process _ (ControlMessage (Control c@(SessionKeyAccepted _) _)) =
+	processuser _ (ControlMessage (Control c@(SessionKeyAccepted _) _)) =
 		return (GotControl c)
-	process _ (ControlMessage (Control c@(SessionKeyRejected _) _)) =
+	processuser _ (ControlMessage (Control c@(SessionKeyRejected _) _)) =
 		return (GotControl c)
 
 -- | Check if the Seen activity is legal, forming a chain with previous
@@ -230,15 +233,15 @@ isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _) ds
 	acth = hash act
 	yes ds' = (True, ds')
 
--- | Start by reading the initial two messages from the user side,
+-- | Start by reading the initial two messages from the user,
 -- their session key and the startup message.
-processSessionStart :: TMChan (Message Seen) -> Logger -> IO (TVar DeveloperState, Output)
+processSessionStart :: TMChan LogMessage -> Logger -> IO (TVar DeveloperState, Output)
 processSessionStart ochan logger = do
 	sessionmsg <- fromMaybe (error "Did not get session initialization message")
 		<$> atomically (readTMChan ochan)
-	logger $ User sessionmsg
+	logger sessionmsg
 	sigverifier <- case sessionmsg of
-		ControlMessage c@(Control (SessionKey pk) _) ->
+		User (ControlMessage c@(Control (SessionKey pk) _)) ->
 			let sv = mkSigVerifier pk
 			in if verifySigned sv c
 				then return sv
@@ -246,9 +249,9 @@ processSessionStart ochan logger = do
 		_ -> error $ "Unexpected session initialization message: " ++ show sessionmsg
 	startmsg <- fromMaybe (error "Did not get session startup message")
 		<$> atomically (readTMChan ochan)
-	logger $ User startmsg
+	logger startmsg
 	let (starthash, output) = case startmsg of
-		ActivityMessage act@(Activity (Seen (Val b)) Nothing _)
+		User (ActivityMessage act@(Activity (Seen (Val b)) Nothing _))
 			| verifySigned sigverifier act ->
 				(hash act, TtyOutput b)
 		_ -> error $ "Unexpected startup message: " ++ show startmsg
diff --git a/Role/Downloader.hs b/Role/Downloader.hs
index ede11a7..07148e8 100644
--- a/Role/Downloader.hs
+++ b/Role/Downloader.hs
@@ -7,12 +7,12 @@ import SessionID
 
 import Control.Concurrent.STM
 import Control.Concurrent.STM.TMChan
-import Role.Developer (run', processSessionStart, getUserMessage, Output(..))
+import Role.Developer (run', processSessionStart, getServerMessage, Output(..))
 
 run :: DownloadOpts -> IO ()
 run = run' downloader . downloadUrl
 
-downloader :: TMChan (Message Entered) -> TMChan (Message Seen) -> SessionID -> IO ()
+downloader :: TMChan (Message Entered) -> TMChan LogMessage -> SessionID -> IO ()
 downloader _ichan ochan sid = do
 	let logfile = sessionLogFile "." sid
 	putStrLn $ "Starting download to " ++ logfile
@@ -22,11 +22,11 @@ downloader _ichan ochan sid = do
 		go logger st
   where
 	go logger st = do
-		v <- atomically $ getUserMessage ochan st
+		v <- atomically $ getServerMessage ochan st
 		case v of
 			Nothing -> return ()
 			Just (o, msg) -> do
-				_ <- logger $ User msg
+				_ <- logger msg
 				case o of
 					ProtocolError e -> error ("Protocol error: " ++ e)
 					_ -> go logger st
diff --git a/Role/Watcher.hs b/Role/Watcher.hs
index ddffa79..c13234f 100644
--- a/Role/Watcher.hs
+++ b/Role/Watcher.hs
@@ -8,19 +8,19 @@ import SessionID
 
 import Control.Concurrent.STM
 import Control.Concurrent.STM.TMChan
-import Role.Developer (run', processSessionStart, getUserMessage, emitOutput)
+import Role.Developer (run', processSessionStart, getServerMessage, emitOutput)
 
 run :: WatchOpts -> IO ()
 run = run' watcher . watchUrl
 
-watcher :: TMChan (Message Entered) -> TMChan (Message Seen) -> SessionID -> IO ()
+watcher :: TMChan (Message Entered) -> TMChan LogMessage -> SessionID -> IO ()
 watcher _ichan ochan _ = inRawMode $ do
 	(st, startoutput) <- processSessionStart ochan nullLogger
 	emitOutput startoutput
 	go st
   where
 	go st = do
-		v <- atomically $ getUserMessage ochan st
+		v <- atomically $ getServerMessage ochan st
 		case v of
 			Nothing -> return ()
 			Just (o, _msg) -> do