author | unc0rr |
Mon, 03 Nov 2008 09:49:25 +0000 | |
changeset 1464 | 693db7cd6f25 |
parent 1463 | 659157f76171 |
child 1465 | 08e98772235c |
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) |
|
1461
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
9 |
import Control.Monad |
1391 | 10 |
import Maybe (fromMaybe, isJust, fromJust) |
1370 | 11 |
import Data.List |
12 |
import Miscutils |
|
13 |
import HWProto |
|
14 |
import Opts |
|
1397 | 15 |
|
1398 | 16 |
#if !defined(mingw32_HOST_OS) |
1396 | 17 |
import System.Posix |
1397 | 18 |
#endif |
19 |
||
1461
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
20 |
data Messages = |
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
21 |
Accept ClientInfo |
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
22 |
| ClientMessage ([String], ClientInfo) |
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
23 |
| CoreMessage [String] |
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
24 |
|
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
25 |
messagesLoop :: TChan [String] -> IO() |
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
26 |
messagesLoop messagesChan = forever $ do |
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
27 |
threadDelay (30 * 10^6) -- 30 seconds |
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
28 |
atomically $ writeTChan messagesChan ["PING"] |
1370 | 29 |
|
30 |
acceptLoop :: Socket -> TChan ClientInfo -> IO () |
|
31 |
acceptLoop servSock acceptChan = do |
|
32 |
(cHandle, host, port) <- accept servSock |
|
1384 | 33 |
hPutStrLn cHandle "CONNECTED\n" |
34 |
hFlush cHandle |
|
1370 | 35 |
cChan <- atomically newTChan |
36 |
forkIO $ clientLoop cHandle cChan |
|
1403 | 37 |
atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False False False) |
1370 | 38 |
acceptLoop servSock acceptChan |
39 |
||
40 |
||
41 |
listenLoop :: Handle -> [String] -> TChan [String] -> IO () |
|
42 |
listenLoop handle buf chan = do |
|
43 |
str <- hGetLine handle |
|
44 |
if str == "" then do |
|
45 |
atomically $ writeTChan chan buf |
|
46 |
listenLoop handle [] chan |
|
47 |
else |
|
48 |
listenLoop handle (buf ++ [str]) chan |
|
49 |
||
50 |
||
51 |
clientLoop :: Handle -> TChan [String] -> IO () |
|
52 |
clientLoop handle chan = |
|
53 |
listenLoop handle [] chan |
|
54 |
`catch` (const $ clientOff >> return ()) |
|
55 |
where clientOff = atomically $ writeTChan chan ["QUIT"] -- if the client disconnects, we perform as if it sent QUIT message |
|
56 |
||
57 |
||
58 |
sendAnswers [] _ clients _ = return clients |
|
59 |
sendAnswers ((handlesFunc, answer):answers) client clients rooms = do |
|
60 |
let recipients = handlesFunc client clients rooms |
|
1381 | 61 |
unless (null recipients) $ putStrLn ("< " ++ (show answer)) |
1370 | 62 |
|
63 |
clHandles' <- forM recipients $ |
|
1464
693db7cd6f25
Print comprehensive info about what's going on, don't try to close already closed handle
unc0rr
parents:
1463
diff
changeset
|
64 |
\ch -> Control.Exception.handle (handleException ch) $ -- cannot just remove |
1370 | 65 |
do |
66 |
forM_ answer (\str -> hPutStrLn ch str) |
|
67 |
hPutStrLn ch "" |
|
68 |
hFlush ch |
|
1394
962001cfcf48
If exception is on client quit, then just remove that client
unc0rr
parents:
1393
diff
changeset
|
69 |
if head answer == "BYE" then hClose ch >> return [ch] else return [] |
1370 | 70 |
|
71 |
let mclients = remove clients $ concat clHandles' |
|
72 |
||
73 |
sendAnswers answers client mclients rooms |
|
74 |
where |
|
75 |
remove list rmClHandles = deleteFirstsBy2t (\ a b -> (Miscutils.handle a) == b) list rmClHandles |
|
1464
693db7cd6f25
Print comprehensive info about what's going on, don't try to close already closed handle
unc0rr
parents:
1463
diff
changeset
|
76 |
handleException ch e = do |
693db7cd6f25
Print comprehensive info about what's going on, don't try to close already closed handle
unc0rr
parents:
1463
diff
changeset
|
77 |
putStrLn ("handle exception: " ++ show e) |
693db7cd6f25
Print comprehensive info about what's going on, don't try to close already closed handle
unc0rr
parents:
1463
diff
changeset
|
78 |
handleInfo <- hShow ch |
693db7cd6f25
Print comprehensive info about what's going on, don't try to close already closed handle
unc0rr
parents:
1463
diff
changeset
|
79 |
putStrLn ("handle info: " ++ handleInfo) |
693db7cd6f25
Print comprehensive info about what's going on, don't try to close already closed handle
unc0rr
parents:
1463
diff
changeset
|
80 |
|
693db7cd6f25
Print comprehensive info about what's going on, don't try to close already closed handle
unc0rr
parents:
1463
diff
changeset
|
81 |
cl <- hIsClosed ch |
693db7cd6f25
Print comprehensive info about what's going on, don't try to close already closed handle
unc0rr
parents:
1463
diff
changeset
|
82 |
unless cl (hClose ch) |
693db7cd6f25
Print comprehensive info about what's going on, don't try to close already closed handle
unc0rr
parents:
1463
diff
changeset
|
83 |
|
693db7cd6f25
Print comprehensive info about what's going on, don't try to close already closed handle
unc0rr
parents:
1463
diff
changeset
|
84 |
if head answer == "BYE" then return [ch] else return [] |
1370 | 85 |
|
86 |
||
1391 | 87 |
reactCmd :: [String] -> ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ([ClientInfo], [RoomInfo]) |
88 |
reactCmd cmd client clients rooms = do |
|
89 |
putStrLn ("> " ++ show cmd) |
|
90 |
||
91 |
let (clientsFunc, roomsFunc, answers) = handleCmd client clients rooms $ cmd |
|
92 |
let mrooms = roomsFunc rooms |
|
93 |
let mclients = (clientsFunc clients) |
|
94 |
let mclient = fromMaybe client $ find (== client) mclients |
|
95 |
||
96 |
clientsIn <- sendAnswers answers mclient mclients mrooms |
|
97 |
let quitClient = find forceQuit $ clientsIn |
|
98 |
if isJust quitClient then reactCmd ["QUIT"] (fromJust quitClient) clientsIn mrooms else return (clientsIn, mrooms) |
|
99 |
||
100 |
||
1461
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
101 |
mainLoop :: Socket -> TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO () |
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
102 |
mainLoop servSock acceptChan messagesChan clients rooms = do |
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
103 |
r <- atomically $ (Accept `fmap` readTChan acceptChan) `orElse` (ClientMessage `fmap` tselect clients) `orElse` (CoreMessage `fmap` readTChan messagesChan) |
1370 | 104 |
case r of |
1461
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
105 |
Accept ci -> |
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
106 |
mainLoop servSock acceptChan messagesChan (clients ++ [ci]) rooms |
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
107 |
ClientMessage (cmd, client) -> do |
1391 | 108 |
(clientsIn, mrooms) <- reactCmd cmd client clients rooms |
1370 | 109 |
|
1385 | 110 |
let hadRooms = (not $ null rooms) && (null mrooms) |
111 |
in unless ((not $ isDedicated globalOptions) && ((null clientsIn) || hadRooms)) $ |
|
1461
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
112 |
mainLoop servSock acceptChan messagesChan clientsIn mrooms |
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
113 |
CoreMessage msg -> if not $ null $ clients then |
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
114 |
do |
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
115 |
let client = head clients -- don't care |
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
116 |
(clientsIn, mrooms) <- reactCmd msg client clients rooms |
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
117 |
mainLoop servSock acceptChan messagesChan clientsIn mrooms |
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
118 |
else |
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
119 |
mainLoop servSock acceptChan messagesChan clients rooms |
1370 | 120 |
|
121 |
||
122 |
startServer serverSocket = do |
|
123 |
acceptChan <- atomically newTChan |
|
124 |
forkIO $ acceptLoop serverSocket acceptChan |
|
1461
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
125 |
|
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
126 |
messagesChan <- atomically newTChan |
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
127 |
forkIO $ messagesLoop messagesChan |
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
128 |
|
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1403
diff
changeset
|
129 |
mainLoop serverSocket acceptChan messagesChan [] [] |
1370 | 130 |
|
131 |
||
132 |
main = withSocketsDo $ do |
|
1398 | 133 |
#if !defined(mingw32_HOST_OS) |
1396 | 134 |
installHandler sigPIPE Ignore Nothing; |
1397 | 135 |
#endif |
1383 | 136 |
putStrLn $ "Listening on port " ++ show (listenPort globalOptions) |
137 |
serverSocket <- listenOn $ PortNumber (listenPort globalOptions) |
|
1370 | 138 |
startServer serverSocket `finally` sClose serverSocket |