author | unc0rr |
Wed, 22 Oct 2008 15:31:35 +0000 | |
changeset 1396 | abb28dcb6d0d |
parent 1394 | 962001cfcf48 |
child 1397 | 471c42a1c358 |
permissions | -rw-r--r-- |
1370 | 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) |
|
1384 | 9 |
import Control.Monad (forM, forM_, filterM, liftM, when, unless) |
1391 | 10 |
import Maybe (fromMaybe, isJust, fromJust) |
1370 | 11 |
import Data.List |
12 |
import Miscutils |
|
13 |
import HWProto |
|
14 |
import Opts |
|
1396 | 15 |
import System.Posix |
1370 | 16 |
|
17 |
acceptLoop :: Socket -> TChan ClientInfo -> IO () |
|
18 |
acceptLoop servSock acceptChan = do |
|
19 |
(cHandle, host, port) <- accept servSock |
|
1384 | 20 |
hPutStrLn cHandle "CONNECTED\n" |
21 |
hFlush cHandle |
|
1370 | 22 |
cChan <- atomically newTChan |
23 |
forkIO $ clientLoop cHandle cChan |
|
1391 | 24 |
atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False False) |
1370 | 25 |
acceptLoop servSock acceptChan |
26 |
||
27 |
||
28 |
listenLoop :: Handle -> [String] -> TChan [String] -> IO () |
|
29 |
listenLoop handle buf chan = do |
|
30 |
str <- hGetLine handle |
|
31 |
if str == "" then do |
|
32 |
atomically $ writeTChan chan buf |
|
33 |
listenLoop handle [] chan |
|
34 |
else |
|
35 |
listenLoop handle (buf ++ [str]) chan |
|
36 |
||
37 |
||
38 |
clientLoop :: Handle -> TChan [String] -> IO () |
|
39 |
clientLoop handle chan = |
|
40 |
listenLoop handle [] chan |
|
41 |
`catch` (const $ clientOff >> return ()) |
|
42 |
where clientOff = atomically $ writeTChan chan ["QUIT"] -- if the client disconnects, we perform as if it sent QUIT message |
|
43 |
||
44 |
||
45 |
sendAnswers [] _ clients _ = return clients |
|
46 |
sendAnswers ((handlesFunc, answer):answers) client clients rooms = do |
|
47 |
let recipients = handlesFunc client clients rooms |
|
1381 | 48 |
unless (null recipients) $ putStrLn ("< " ++ (show answer)) |
1370 | 49 |
|
50 |
clHandles' <- forM recipients $ |
|
1394
962001cfcf48
If exception is on client quit, then just remove that client
unc0rr
parents:
1393
diff
changeset
|
51 |
\ch -> Control.Exception.handle (\e -> putStrLn ("handle exception: " ++ show e) >> if head answer == "BYE" then return [ch] else return []) $ -- cannot just remove |
1370 | 52 |
do |
53 |
forM_ answer (\str -> hPutStrLn ch str) |
|
54 |
hPutStrLn ch "" |
|
55 |
hFlush ch |
|
1394
962001cfcf48
If exception is on client quit, then just remove that client
unc0rr
parents:
1393
diff
changeset
|
56 |
if head answer == "BYE" then hClose ch >> return [ch] else return [] |
1370 | 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 |
||
1391 | 65 |
reactCmd :: [String] -> ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ([ClientInfo], [RoomInfo]) |
66 |
reactCmd cmd client clients rooms = do |
|
67 |
putStrLn ("> " ++ show cmd) |
|
68 |
||
69 |
let (clientsFunc, roomsFunc, answers) = handleCmd client clients rooms $ cmd |
|
70 |
let mrooms = roomsFunc rooms |
|
71 |
let mclients = (clientsFunc clients) |
|
72 |
let mclient = fromMaybe client $ find (== client) mclients |
|
73 |
||
74 |
clientsIn <- sendAnswers answers mclient mclients mrooms |
|
75 |
let quitClient = find forceQuit $ clientsIn |
|
76 |
if isJust quitClient then reactCmd ["QUIT"] (fromJust quitClient) clientsIn mrooms else return (clientsIn, mrooms) |
|
77 |
||
78 |
||
1370 | 79 |
mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO () |
80 |
mainLoop servSock acceptChan clients rooms = do |
|
81 |
r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) |
|
82 |
case r of |
|
83 |
Left ci -> do |
|
84 |
mainLoop servSock acceptChan (clients ++ [ci]) rooms |
|
85 |
Right (cmd, client) -> do |
|
1391 | 86 |
(clientsIn, mrooms) <- reactCmd cmd client clients rooms |
1370 | 87 |
|
1385 | 88 |
let hadRooms = (not $ null rooms) && (null mrooms) |
89 |
in unless ((not $ isDedicated globalOptions) && ((null clientsIn) || hadRooms)) $ |
|
90 |
mainLoop servSock acceptChan clientsIn mrooms |
|
1370 | 91 |
|
92 |
||
93 |
startServer serverSocket = do |
|
94 |
acceptChan <- atomically newTChan |
|
95 |
forkIO $ acceptLoop serverSocket acceptChan |
|
96 |
mainLoop serverSocket acceptChan [] [] |
|
97 |
||
98 |
||
99 |
main = withSocketsDo $ do |
|
1396 | 100 |
installHandler sigPIPE Ignore Nothing; |
1383 | 101 |
putStrLn $ "Listening on port " ++ show (listenPort globalOptions) |
102 |
serverSocket <- listenOn $ PortNumber (listenPort globalOptions) |
|
1370 | 103 |
startServer serverSocket `finally` sClose serverSocket |