diff options
Diffstat (limited to 'Server.hs')
-rw-r--r-- | Server.hs | 30 |
1 files changed, 15 insertions, 15 deletions
@@ -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 |