author | unc0rr |
Sat, 17 May 2008 16:59:32 +0000 | |
changeset 938 | 0c8d2085fa71 |
parent 901 | 2f5ce9a584f9 |
child 1081 | 5be338fa4e2c |
permissions | -rw-r--r-- |
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 |
|
894 | 19 |
atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" 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 |
where clientOff = atomically $ writeTChan chan "QUIT" |
|
33 |
||
889 | 34 |
mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO () |
35 |
mainLoop servSock acceptChan clients rooms = do |
|
877 | 36 |
r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) |
37 |
case r of |
|
889 | 38 |
Left ci -> do |
39 |
mainLoop servSock acceptChan (ci:clients) rooms |
|
901
2f5ce9a584f9
Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents:
898
diff
changeset
|
40 |
Right (line, clhandle) -> do |
2f5ce9a584f9
Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents:
898
diff
changeset
|
41 |
let (mclients, mrooms, recipients, strs) = handleCmd clhandle clients rooms $ words line |
890 | 42 |
|
901
2f5ce9a584f9
Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents:
898
diff
changeset
|
43 |
clHandles' <- forM recipients $ |
2f5ce9a584f9
Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents:
898
diff
changeset
|
44 |
\ch -> do |
2f5ce9a584f9
Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents:
898
diff
changeset
|
45 |
forM_ strs (\str -> hPutStrLn ch str) |
2f5ce9a584f9
Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents:
898
diff
changeset
|
46 |
hFlush ch |
2f5ce9a584f9
Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents:
898
diff
changeset
|
47 |
if (not $ null strs) && (head strs == "ROOMABANDONED") then hClose ch >> return [ch] else return [] |
2f5ce9a584f9
Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents:
898
diff
changeset
|
48 |
`catch` const (hClose ch >> return [ch]) |
890 | 49 |
|
901
2f5ce9a584f9
Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents:
898
diff
changeset
|
50 |
clHandle' <- if (not $ null strs) && (head strs == "QUIT") then hClose clhandle >> return [clhandle] else return [] |
891
701f86df9b4c
Properly handle QUIT command. Now, we can concentrate on protocol implementation
unc0rr
parents:
890
diff
changeset
|
51 |
|
901
2f5ce9a584f9
Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents:
898
diff
changeset
|
52 |
mainLoop servSock acceptChan (remove (remove mclients (concat clHandles')) clHandle') mrooms |
890 | 53 |
where |
901
2f5ce9a584f9
Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents:
898
diff
changeset
|
54 |
remove list rmClHandles = deleteFirstsBy2t (\ a b -> (handle a) == b) list rmClHandles |
877 | 55 |
|
56 |
startServer serverSocket = do |
|
57 |
acceptChan <- atomically newTChan |
|
58 |
forkIO $ acceptLoop serverSocket acceptChan |
|
889 | 59 |
mainLoop serverSocket acceptChan [] [] |
877 | 60 |
|
878 | 61 |
main = withSocketsDo $ do |
877 | 62 |
serverSocket <- listenOn $ Service "hedgewars" |
63 |
startServer serverSocket `finally` sClose serverSocket |