netserver/newhwserv.hs
author unc0rr
Fri, 19 Sep 2008 14:15:19 +0000
changeset 1271 e64221369875
parent 1082 596b1dcdc1df
child 1302 4290ba4a14ca
permissions -rw-r--r--
Graphics update
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
     1
module Main where
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
     2
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
     3
import Network
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
     4
import IO
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
     5
import System.IO
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
     6
import Control.Concurrent
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
     7
import Control.Concurrent.STM
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
     8
import Control.Exception (finally)
890
1d8c4a5ec622 - Improve server core
unc0rr
parents: 889
diff changeset
     9
import Control.Monad (forM, forM_, filterM, liftM)
1d8c4a5ec622 - Improve server core
unc0rr
parents: 889
diff changeset
    10
import Data.List
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    11
import Miscutils
890
1d8c4a5ec622 - Improve server core
unc0rr
parents: 889
diff changeset
    12
import HWProto
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    13
889
3bf9dc791f45 Some work on newhwserv
unc0rr
parents: 878
diff changeset
    14
acceptLoop :: Socket -> TChan ClientInfo -> IO ()
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    15
acceptLoop servSock acceptChan = do
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    16
	(cHandle, host, port) <- accept servSock
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    17
	cChan <- atomically newTChan
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    18
	forkIO $ clientLoop cHandle cChan
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
    19
	atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False)
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    20
	hPutStrLn cHandle "CONNECTED\n"
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    21
	acceptLoop servSock acceptChan
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    22
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    23
listenLoop :: Handle -> [String] -> TChan [String] -> IO ()
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    24
listenLoop handle buf chan = do
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    25
	str <- hGetLine handle
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    26
	if str == "" then do
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    27
		atomically $ writeTChan chan buf
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    28
		listenLoop handle [] chan
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    29
		else
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    30
		listenLoop handle (buf ++ [str]) chan
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    31
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    32
clientLoop :: Handle -> TChan [String] -> IO ()
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    33
clientLoop handle chan =
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    34
	listenLoop handle [] chan
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    35
		`catch` (const $ clientOff >> return ())
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    36
	where clientOff = atomically $ writeTChan chan ["QUIT"]
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    37
889
3bf9dc791f45 Some work on newhwserv
unc0rr
parents: 878
diff changeset
    38
mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ()
3bf9dc791f45 Some work on newhwserv
unc0rr
parents: 878
diff changeset
    39
mainLoop servSock acceptChan clients rooms = do
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    40
	r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients)
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    41
	case r of
889
3bf9dc791f45 Some work on newhwserv
unc0rr
parents: 878
diff changeset
    42
		Left ci -> do
3bf9dc791f45 Some work on newhwserv
unc0rr
parents: 878
diff changeset
    43
			mainLoop servSock acceptChan (ci:clients) rooms
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    44
		Right (cmd, client) -> do
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    45
			print ("> " ++ show cmd)
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    46
			let (clientsFunc, roomsFunc, handlesFunc, answer) = handleCmd client clients rooms $ cmd
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    47
			print ("< " ++ show answer)
890
1d8c4a5ec622 - Improve server core
unc0rr
parents: 889
diff changeset
    48
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    49
			let mclients = clientsFunc clients
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    50
			let mrooms = roomsFunc rooms
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    51
			let recipients = handlesFunc client clients rooms
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    52
			
901
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 898
diff changeset
    53
			clHandles' <- forM recipients $
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 898
diff changeset
    54
					\ch -> do
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    55
							forM_ answer (\str -> hPutStrLn ch str)
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    56
							hPutStrLn ch ""
901
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 898
diff changeset
    57
							hFlush ch
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    58
							if (not $ null answer) && (head answer == "ROOMABANDONED") then hClose ch >> return [ch] else return []
901
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 898
diff changeset
    59
					`catch` const (hClose ch >> return [ch])
890
1d8c4a5ec622 - Improve server core
unc0rr
parents: 889
diff changeset
    60
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    61
			clHandle' <- if (not $ null answer) && (head answer == "QUIT") then hClose (handle client) >> return [handle client] else return []
891
701f86df9b4c Properly handle QUIT command. Now, we can concentrate on protocol implementation
unc0rr
parents: 890
diff changeset
    62
901
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 898
diff changeset
    63
			mainLoop servSock acceptChan (remove (remove mclients (concat clHandles')) clHandle') mrooms
890
1d8c4a5ec622 - Improve server core
unc0rr
parents: 889
diff changeset
    64
			where
901
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 898
diff changeset
    65
				remove list rmClHandles = deleteFirstsBy2t (\ a b -> (handle a) == b) list rmClHandles
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    66
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    67
startServer serverSocket = do
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    68
	acceptChan <- atomically newTChan
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    69
	forkIO $ acceptLoop serverSocket acceptChan
889
3bf9dc791f45 Some work on newhwserv
unc0rr
parents: 878
diff changeset
    70
	mainLoop serverSocket acceptChan [] []
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    71
878
45bff6dadfce - Fix baseball bat
unc0rr
parents: 877
diff changeset
    72
main = withSocketsDo $ do
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    73
	serverSocket <- listenOn $ Service "hedgewars"
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    74
	startServer serverSocket `finally` sClose serverSocket