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 (setUncaughtExceptionHandler, handle, finally) |
|
9 import Control.Monad (forM, forM_, filterM, liftM) |
|
10 import Maybe (fromMaybe) |
|
11 import Data.List |
|
12 import Miscutils |
|
13 import HWProto |
|
14 import Opts |
|
15 |
|
16 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
|
17 acceptLoop servSock acceptChan = do |
|
18 (cHandle, host, port) <- accept servSock |
|
19 cChan <- atomically newTChan |
|
20 forkIO $ clientLoop cHandle cChan |
|
21 atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False) |
|
22 hPutStrLn cHandle "CONNECTED\n" |
|
23 hFlush cHandle |
|
24 acceptLoop servSock acceptChan |
|
25 |
|
26 |
|
27 listenLoop :: Handle -> [String] -> TChan [String] -> IO () |
|
28 listenLoop handle buf chan = do |
|
29 str <- hGetLine handle |
|
30 if str == "" then do |
|
31 atomically $ writeTChan chan buf |
|
32 listenLoop handle [] chan |
|
33 else |
|
34 listenLoop handle (buf ++ [str]) chan |
|
35 |
|
36 |
|
37 clientLoop :: Handle -> TChan [String] -> IO () |
|
38 clientLoop handle chan = |
|
39 listenLoop handle [] chan |
|
40 `catch` (const $ clientOff >> return ()) |
|
41 where clientOff = atomically $ writeTChan chan ["QUIT"] -- if the client disconnects, we perform as if it sent QUIT message |
|
42 |
|
43 |
|
44 sendAnswers [] _ clients _ = return clients |
|
45 sendAnswers ((handlesFunc, answer):answers) client clients rooms = do |
|
46 let recipients = handlesFunc client clients rooms |
|
47 putStrLn ("< " ++ (show answer)) |
|
48 |
|
49 clHandles' <- forM recipients $ |
|
50 \ch -> Control.Exception.handle (\e -> putStrLn (show e) >> hClose ch >> return [ch]) $ |
|
51 if (not $ null answer) && (head answer == "off") then hClose ch >> return [ch] else -- probably client with exception, don't send him anything |
|
52 do |
|
53 forM_ answer (\str -> hPutStrLn ch str) |
|
54 hPutStrLn ch "" |
|
55 hFlush ch |
|
56 if (not $ null answer) && (head answer == "BYE") then hClose ch >> return [ch] else return [] |
|
57 |
|
58 let mclients = remove clients $ concat clHandles' |
|
59 |
|
60 sendAnswers answers client mclients rooms |
|
61 where |
|
62 remove list rmClHandles = deleteFirstsBy2t (\ a b -> (Miscutils.handle a) == b) list rmClHandles |
|
63 |
|
64 |
|
65 mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO () |
|
66 mainLoop servSock acceptChan clients rooms = do |
|
67 r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) |
|
68 case r of |
|
69 Left ci -> do |
|
70 mainLoop servSock acceptChan (clients ++ [ci]) rooms |
|
71 Right (cmd, client) -> do |
|
72 putStrLn ("> " ++ show cmd) |
|
73 |
|
74 let (clientsFunc, roomsFunc, answers) = handleCmd client clients rooms $ cmd |
|
75 let mrooms = roomsFunc rooms |
|
76 let mclients = (clientsFunc clients) |
|
77 let mclient = fromMaybe client $ find (== client) mclients |
|
78 |
|
79 clientsIn <- sendAnswers answers mclient mclients mrooms |
|
80 |
|
81 mainLoop servSock acceptChan clientsIn mrooms |
|
82 |
|
83 |
|
84 startServer serverSocket = do |
|
85 acceptChan <- atomically newTChan |
|
86 forkIO $ acceptLoop serverSocket acceptChan |
|
87 mainLoop serverSocket acceptChan [] [] |
|
88 |
|
89 |
|
90 main = withSocketsDo $ do |
|
91 flags <- opts |
|
92 putStrLn $ "Listening on port " ++ show (getPort flags) |
|
93 serverSocket <- listenOn $ PortNumber (getPort flags) |
|
94 startServer serverSocket `finally` sClose serverSocket |
|