correct handling of handles

This commit is contained in:
nek0 2023-12-10 09:53:56 +01:00
parent cda2ffaed4
commit b9d28aa946

View file

@ -74,40 +74,39 @@ processRequests :: Game ()
processRequests = do processRequests = do
mainSocket <- asks rcMainSocket mainSocket <- asks rcMainSocket
socketList <- gets scClientSockets socketList <- gets scClientSockets
serverState <- gets scServerState void $ liftIO $ forkIO $ acceptConnection mainSocket socketList
void $ liftIO $ forkIO $ acceptConnection mainSocket socketList serverState
where where
acceptConnection mainSocket socketList serverState = whileM_ acceptConnection mainSocket socketList = do
(not . serverStop <$> liftIO (STM.atomically $ STM.readTMVar serverState))
(do
(clientSock, _) <- accept mainSocket (clientSock, _) <- accept mainSocket
putStrLn "accepted new connection" putStrLn "accepted new connection"
liftIO $ STM.atomically $ do liftIO $ STM.atomically $ do
list <- STM.takeTMVar socketList list <- STM.takeTMVar socketList
STM.putTMVar socketList ((clientSock, Nothing) : list) STM.putTMVar socketList ((clientSock, Nothing) : list)
) acceptConnection mainSocket socketList
-- | process incoming messages from clients -- | process incoming messages from clients
processMessages :: Game () processMessages :: Game ()
processMessages = do processMessages = do
clientsVar <- gets scClientSockets clientsVar <- gets scClientSockets
clients <- liftIO $ STM.atomically $ STM.readTMVar $ clientsVar clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar
newClients <- mapM newClients <- foldM
(\client@(clientSocket, mThread) -> (\acc (clientSocket, mThread) ->
if isNothing mThread case mThread of
then liftIO $ do Nothing -> liftIO $ do
connectionHandle <- socketToHandle clientSocket ReadMode
thread <- forkIO thread <- forkIO
(listenTo connectionHandle) (listenTo clientSocket)
pure (clientSocket, Just thread) pure $ (clientSocket, Just thread) : acc
else Just _ -> liftIO $ do
pure client pure acc
) )
[]
clients clients
liftIO $ STM.atomically $ do liftIO $ STM.atomically $ do
void $ STM.swapTMVar clientsVar newClients void $ STM.swapTMVar clientsVar newClients
where where
listenTo connectionHandle = do listenTo clientSocket = do
connectionHandle <- socketToHandle clientSocket ReadMode
hSetBuffering connectionHandle LineBuffering hSetBuffering connectionHandle LineBuffering
message <- hGetContents' connectionHandle message <- hGetContents' connectionHandle
putStr message putStr message
hClose connectionHandle