fix server to not relay developer messages back to self

This fixes chat message echoing consistency too.

1 files changed, 15 insertions, 15 deletions

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