netserver/newhwserv.hs
changeset 893 149244d86bf1
parent 892 dfe97199f17e
child 894 2ca76a7f3121
equal deleted inserted replaced
892:dfe97199f17e 893:149244d86bf1
    37 	r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients)
    37 	r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients)
    38 	case r of
    38 	case r of
    39 		Left ci -> do
    39 		Left ci -> do
    40 			mainLoop servSock acceptChan (ci:clients) rooms
    40 			mainLoop servSock acceptChan (ci:clients) rooms
    41 		Right (line, client) -> do
    41 		Right (line, client) -> do
    42 			let (recipients, strs) = handleCmd client sameRoom rooms $ words line
    42 			let (mclient, mrooms, recipients, strs) = handleCmd client clients rooms $ words line
    43 
    43 
    44 			clients' <- forM recipients $
    44 			clients' <- forM recipients $
    45 					\ci -> do
    45 					\ci -> do
    46 							forM_ strs (\str -> hPutStrLn (handle ci) str)
    46 							forM_ strs (\str -> hPutStrLn (handle ci) str)
    47 							hFlush (handle ci)
    47 							hFlush (handle ci)
    48 							return []
    48 							return []
    49 					`catch` const (hClose (handle ci) >> return [ci])
    49 					`catch` const (hClose (handle ci) >> return [ci])
    50 
    50 
    51 			client' <- if head strs == "QUIT" then hClose (handle client) >> return [client] else return []
    51 			client' <- if head strs == "QUIT" then hClose (handle client) >> return [client] else return []
    52 
    52 
    53 			mainLoop servSock acceptChan (remove (remove clients (concat clients')) client') rooms
    53 			mainLoop servSock acceptChan (remove (remove (mclient : filter (\cl -> handle cl /= handle client) clients) (concat clients')) client') mrooms
    54 			where
    54 			where
    55 				sameRoom = filter (\cl -> room cl == room client) clients
       
    56 				remove list rmClients = deleteFirstsBy (\ a b -> handle a == handle b) list rmClients
    55 				remove list rmClients = deleteFirstsBy (\ a b -> handle a == handle b) list rmClients
    57 
    56 
    58 startServer serverSocket = do
    57 startServer serverSocket = do
    59 	acceptChan <- atomically newTChan
    58 	acceptChan <- atomically newTChan
    60 	forkIO $ acceptLoop serverSocket acceptChan
    59 	forkIO $ acceptLoop serverSocket acceptChan