fix server to not relay developer messages back to self

This fixes chat message echoing consistency too.

4 files changed, 38 insertions, 28 deletions

diff --git a/ControlWindow.hs b/ControlWindow.hs
index 3bd0e58..74514be 100644
--- a/ControlWindow.hs
+++ b/ControlWindow.hs
@@ -84,13 +84,19 @@ collectOutput ochan promptchan responsechan = do
 	myusername <- fromString <$> getLoginName
 	withLines stdin $ mapM_ $ processline myusername
   where
-	processline myusername l = atomically $ do
-		-- Is any particular input being prompted for now?
-		mp <- tryReadTChan promptchan
-		case mp of
-			Just _ -> writeTChan responsechan $ L.toStrict l
-			Nothing -> writeTMChan ochan $ ControlOutputAction $
-				ChatMessage (Val myusername) (Val $ L.toStrict l)
+	processline myusername l = do
+		mc <- atomically $ do
+			-- Is any particular input being prompted for now?
+			mp <- tryReadTChan promptchan
+			case mp of
+				Just _ -> do
+					writeTChan responsechan $ L.toStrict l
+					return Nothing
+				Nothing -> do
+					let c = ChatMessage (Val myusername) (Val $ L.toStrict l)
+					writeTMChan ochan $ ControlOutputAction c
+					return (Just c)
+		maybe (return ()) displayChatMessage mc
 
 displayInput :: TMChan ControlOutput -> TMChan ControlInput -> PromptChan -> ResponseChan -> IO ()
 displayInput ochan ichan promptchan responsechan = loop
@@ -103,13 +109,17 @@ displayInput ochan ichan promptchan responsechan = loop
 	go (Just (ControlInputAction (SessionKey k))) = do
 		askToAllow ochan promptchan responsechan k
 		loop
-	go (Just (ControlInputAction (ChatMessage username msg))) = do
-		B.putStr $ "<" <> val username <> "> " <> val msg
-		putStr "\n"
-		hFlush stdout
+	go (Just (ControlInputAction m@(ChatMessage {}))) = do
+		displayChatMessage m
 		loop
 	go _ = loop
 
+displayChatMessage :: ControlAction -> IO ()
+displayChatMessage (ChatMessage username msg) = do
+	B.putStr $ "<" <> val username <> "> " <> val msg <> "\n"
+	hFlush stdout
+displayChatMessage _ = return ()
+
 askToAllow :: TMChan ControlOutput -> PromptChan -> ResponseChan -> PerhapsSigned PublicKey -> IO ()
 askToAllow ochan _ _ (UnSigned pk) = atomically $ writeTMChan ochan $
 	ControlOutputAction $ SessionKeyRejected pk
diff --git a/Role/Developer.hs b/Role/Developer.hs
index efe476a..d05710e 100644
--- a/Role/Developer.hs
+++ b/Role/Developer.hs
@@ -410,6 +410,8 @@ processSessionStart sk ochan logger dsv = do
 		User (ActivityMessage act@(Activity (Seen (Val b)) Nothing _ _))
 			| verifySigned sigverifier act ->
 				(hash act, TtyOutput b)
+			| otherwise ->
+				error "Bad signature on startup message"
 		_ -> error $ "Unexpected startup message: " ++ show startmsg
 	atomically $ modifyTVar' st $ \ds -> ds
 		{ lastSeen = starthash
diff --git a/Server.hs b/Server.hs
index f8e8588..b9f46dd 100644
--- a/Server.hs
+++ b/Server.hs
@@ -56,13 +56,12 @@ listenSession (Session bchan _ _) = dupTMChan bchan
 -- | While writing a log to the session the LogLock is drained until
 -- the write has reached the log file. This prevents concurrent writes
 -- to the file, and allows writes to be blocked while reading the log file.
-writeSession :: Session -> Log -> IO ()
-writeSession (Session bchan loghv loglock) l = do
+writeSession :: Weak ThreadId -> Session -> Log -> IO ()
+writeSession tid (Session bchan loghv loglock) l = do
 	(ll, logh) <- atomically $ (,)
 		<$> takeTMVar loglock
 		<*> readTVar loghv
 	writeLogHandle l logh
-	tid <- mkWeakThreadId =<< myThreadId
 	atomically $ do
 		putTMVar loglock ll
 		writeTMChan bchan (Broadcast l tid)
@@ -135,9 +134,10 @@ user o ssv conn = withSessionID (serverDirectory o) $ \(loghv, sid) -> do
 			modifyTVar' ssv $ M.delete sid
 
 	go session = do
+		mytid <- mkWeakThreadId =<< myThreadId
 		userchan <- atomically $ listenSession session
 		_ <- relaytouser userchan
-			`race` relayfromuser session
+			`race` relayfromuser mytid session
 		return ()
 	
 	-- Relay all messages from the user's websocket to the
@@ -145,9 +145,9 @@ user o ssv conn = withSessionID (serverDirectory o) $ \(loghv, sid) -> do
 	-- (The user is allowed to send Developer messages too.. perhaps
 	-- they got them from a developer connected to them some other
 	-- way.)
-	relayfromuser session = relayFromSocket conn noRecentActivity (return ()) $ \msg -> do
+	relayfromuser mytid session = relayFromSocket conn noRecentActivity (return ()) $ \msg -> do
 		l <- mkLog msg <$> getPOSIXTime
-		writeSession session l
+		writeSession mytid session l
 	
 	-- Relay Developer messages from the channel to the user's websocket.
 	relaytouser userchan = do
@@ -177,18 +177,18 @@ developer o ssv sid conn = bracket setup cleanup go
 	go (Just session) = do
 		sendBinaryData conn (Ready ServerSends sid)
 		devchan <- replayBacklogAndListen o sid session conn
-		mytid <- myThreadId
-		_ <- relayfromdeveloper session
+		mytid <- mkWeakThreadId =<< myThreadId
+		_ <- relayfromdeveloper mytid session
 			`concurrently` relaytodeveloper mytid devchan
 		return ()
 	
 	-- Relay all Developer amessages from the developer's websocket
 	-- to the broadcast channel.
-	relayfromdeveloper session = relayFromSocket conn noRecentActivity (return ())
+	relayfromdeveloper mytid session = relayFromSocket conn noRecentActivity (return ())
 		$ \msg -> case msg of
 			Developer _ -> do
 				l <- mkLog msg <$> getPOSIXTime
-				writeSession session l
+				writeSession mytid session l
 			-- developer cannot send User messages
 			User _ -> return ()
 	
@@ -206,11 +206,11 @@ developer o ssv sid conn = bracket setup cleanup go
 					-- developers, without looping
 					-- back the developer's own messages.
 					Developer _ -> do
-						mtid <- deRefWeak from
-						case mtid of
-							Just tid | tid == mytid ->
-								return ()
-							_ -> sendit
+						rfrom <- deRefWeak from
+						rmy <- deRefWeak mytid
+						if rfrom == rmy
+							then return ()
+							else sendit
 				relaytodeveloper mytid devchan
 			Nothing -> do
 				sendBinaryData conn Done
diff --git a/TODO b/TODO
index bbb2091..050ff21 100644
--- a/TODO
+++ b/TODO
@@ -7,8 +7,6 @@
 * Multiple --downloads at the same time or close together fail
   with "thread blocked indefinitely in an STM transaction"
   Also see it occasionally with --debug.
-* For some reason, user chat does not echo back to them, but developer
-  chat does echo back to the developer.
 * The current rules for when an Activity Entered is accepted allow it to
   refer to an older activity than the last one. If echoing is disabled,
   two Activity Entered could be sent, each pointing at the most recent