|
877
|
1 |
module Main where
|
|
|
2 |
|
|
|
3 |
import Network
|
|
|
4 |
import IO
|
|
|
5 |
import System.IO
|
|
|
6 |
import Control.Concurrent
|
|
|
7 |
import Control.Concurrent.STM
|
|
|
8 |
import Control.Exception (finally)
|
|
890
|
9 |
import Control.Monad (forM, forM_, filterM, liftM)
|
|
|
10 |
import Data.List
|
|
877
|
11 |
import Miscutils
|
|
890
|
12 |
import HWProto
|
|
877
|
13 |
|
|
889
|
14 |
acceptLoop :: Socket -> TChan ClientInfo -> IO ()
|
|
877
|
15 |
acceptLoop servSock acceptChan = do
|
|
|
16 |
(cHandle, host, port) <- accept servSock
|
|
|
17 |
cChan <- atomically newTChan
|
|
|
18 |
forkIO $ clientLoop cHandle cChan
|
|
889
|
19 |
atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" "" False)
|
|
877
|
20 |
acceptLoop servSock acceptChan
|
|
|
21 |
|
|
|
22 |
listenLoop :: Handle -> TChan String -> IO ()
|
|
|
23 |
listenLoop handle chan = do
|
|
|
24 |
str <- hGetLine handle
|
|
|
25 |
atomically $ writeTChan chan str
|
|
|
26 |
listenLoop handle chan
|
|
|
27 |
|
|
|
28 |
clientLoop :: Handle -> TChan String -> IO ()
|
|
|
29 |
clientLoop handle chan =
|
|
|
30 |
listenLoop handle chan
|
|
|
31 |
`catch` (const $ clientOff >> return ())
|
|
|
32 |
`finally` hClose handle
|
|
|
33 |
where clientOff = atomically $ writeTChan chan "QUIT"
|
|
|
34 |
|
|
889
|
35 |
mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ()
|
|
|
36 |
mainLoop servSock acceptChan clients rooms = do
|
|
877
|
37 |
r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients)
|
|
|
38 |
case r of
|
|
889
|
39 |
Left ci -> do
|
|
|
40 |
mainLoop servSock acceptChan (ci:clients) rooms
|
|
890
|
41 |
Right (line, client) -> do
|
|
|
42 |
let (doQuit, toMe, strs) = handleCmd client sameRoom rooms line
|
|
|
43 |
|
|
|
44 |
clients' <- forM sameRoom $
|
|
889
|
45 |
\ci -> do
|
|
890
|
46 |
if (handle ci /= handle client) || toMe then do
|
|
|
47 |
forM_ strs (\str -> hPutStrLn (handle ci) str)
|
|
|
48 |
hFlush (handle ci)
|
|
|
49 |
return []
|
|
|
50 |
else if doQuit then return [ci] else return []
|
|
|
51 |
`catch` const (hClose (handle ci) >> return [ci])
|
|
|
52 |
|
|
|
53 |
mainLoop servSock acceptChan (deleteFirstsBy (\ a b -> handle a == handle b) clients (concat clients')) rooms
|
|
|
54 |
where
|
|
|
55 |
sameRoom = filter (\cl -> room cl == room client) clients
|
|
877
|
56 |
|
|
|
57 |
startServer serverSocket = do
|
|
|
58 |
acceptChan <- atomically newTChan
|
|
|
59 |
forkIO $ acceptLoop serverSocket acceptChan
|
|
889
|
60 |
mainLoop serverSocket acceptChan [] []
|
|
877
|
61 |
|
|
878
|
62 |
main = withSocketsDo $ do
|
|
877
|
63 |
serverSocket <- listenOn $ Service "hedgewars"
|
|
|
64 |
startServer serverSocket `finally` sClose serverSocket
|