15 acceptLoop servSock acceptChan = do |
15 acceptLoop servSock acceptChan = do |
16 (cHandle, host, port) <- accept servSock |
16 (cHandle, host, port) <- accept servSock |
17 cChan <- atomically newTChan |
17 cChan <- atomically newTChan |
18 forkIO $ clientLoop cHandle cChan |
18 forkIO $ clientLoop cHandle cChan |
19 atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False) |
19 atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False) |
20 hPutStrLn cHandle "CONNECTED" |
20 hPutStrLn cHandle "CONNECTED\n" |
21 acceptLoop servSock acceptChan |
21 acceptLoop servSock acceptChan |
22 |
22 |
23 listenLoop :: Handle -> TChan String -> IO () |
23 listenLoop :: Handle -> [String] -> TChan [String] -> IO () |
24 listenLoop handle chan = do |
24 listenLoop handle buf chan = do |
25 str <- hGetLine handle |
25 str <- hGetLine handle |
26 atomically $ writeTChan chan str |
26 if str == "" then do |
27 listenLoop handle chan |
27 atomically $ writeTChan chan buf |
|
28 listenLoop handle [] chan |
|
29 else |
|
30 listenLoop handle (buf ++ [str]) chan |
28 |
31 |
29 clientLoop :: Handle -> TChan String -> IO () |
32 clientLoop :: Handle -> TChan [String] -> IO () |
30 clientLoop handle chan = |
33 clientLoop handle chan = |
31 listenLoop handle chan |
34 listenLoop handle [] chan |
32 `catch` (const $ clientOff >> return ()) |
35 `catch` (const $ clientOff >> return ()) |
33 where clientOff = atomically $ writeTChan chan "QUIT" |
36 where clientOff = atomically $ writeTChan chan ["QUIT"] |
34 |
37 |
35 mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO () |
38 mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO () |
36 mainLoop servSock acceptChan clients rooms = do |
39 mainLoop servSock acceptChan clients rooms = do |
37 r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) |
40 r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) |
38 case r of |
41 case r of |
39 Left ci -> do |
42 Left ci -> do |
40 mainLoop servSock acceptChan (ci:clients) rooms |
43 mainLoop servSock acceptChan (ci:clients) rooms |
41 Right (line, clhandle) -> do |
44 Right (cmd, client) -> do |
42 let (mclients, mrooms, recipients, strs) = handleCmd clhandle clients rooms $ words line |
45 print ("> " ++ show cmd) |
|
46 let (clientsFunc, roomsFunc, handlesFunc, answer) = handleCmd client clients rooms $ cmd |
|
47 print ("< " ++ show answer) |
43 |
48 |
|
49 let mclients = clientsFunc clients |
|
50 let mrooms = roomsFunc rooms |
|
51 let recipients = handlesFunc client clients rooms |
|
52 |
44 clHandles' <- forM recipients $ |
53 clHandles' <- forM recipients $ |
45 \ch -> do |
54 \ch -> do |
46 forM_ strs (\str -> hPutStrLn ch str) |
55 forM_ answer (\str -> hPutStrLn ch str) |
|
56 hPutStrLn ch "" |
47 hFlush ch |
57 hFlush ch |
48 if (not $ null strs) && (head strs == "ROOMABANDONED") then hClose ch >> return [ch] else return [] |
58 if (not $ null answer) && (head answer == "ROOMABANDONED") then hClose ch >> return [ch] else return [] |
49 `catch` const (hClose ch >> return [ch]) |
59 `catch` const (hClose ch >> return [ch]) |
50 |
60 |
51 clHandle' <- if (not $ null strs) && (head strs == "QUIT") then hClose clhandle >> return [clhandle] else return [] |
61 clHandle' <- if (not $ null answer) && (head answer == "QUIT") then hClose (handle client) >> return [handle client] else return [] |
52 |
62 |
53 mainLoop servSock acceptChan (remove (remove mclients (concat clHandles')) clHandle') mrooms |
63 mainLoop servSock acceptChan (remove (remove mclients (concat clHandles')) clHandle') mrooms |
54 where |
64 where |
55 remove list rmClHandles = deleteFirstsBy2t (\ a b -> (handle a) == b) list rmClHandles |
65 remove list rmClHandles = deleteFirstsBy2t (\ a b -> (handle a) == b) list rmClHandles |
56 |
66 |