netserver/newhwserv.hs
author unc0rr
Wed, 15 Oct 2008 15:59:19 +0000
changeset 1357 5b9012dd4a05
parent 1350 99a921e292f4
permissions -rw-r--r--
Oops... fix introduced bug
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
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1306
diff changeset
     8
import Control.Exception (setUncaughtExceptionHandler, handle, finally)
890
1d8c4a5ec622 - Improve server core
unc0rr
parents: 889
diff changeset
     9
import Control.Monad (forM, forM_, filterM, liftM)
1308
d5dcd6cfa5e2 Fix another server failure (when second client in room disconnects)
unc0rr
parents: 1307
diff changeset
    10
import Maybe (fromMaybe)
890
1d8c4a5ec622 - Improve server core
unc0rr
parents: 889
diff changeset
    11
import Data.List
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    12
import Miscutils
890
1d8c4a5ec622 - Improve server core
unc0rr
parents: 889
diff changeset
    13
import HWProto
1341
86d7d5ab22a2 Allow --port=PORT command-line parameter to specify the port to listen on
unc0rr
parents: 1340
diff changeset
    14
import Opts
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    15
889
3bf9dc791f45 Some work on newhwserv
unc0rr
parents: 878
diff changeset
    16
acceptLoop :: Socket -> TChan ClientInfo -> IO ()
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    17
acceptLoop servSock acceptChan = do
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    18
	(cHandle, host, port) <- accept servSock
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    19
	cChan <- atomically newTChan
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    20
	forkIO $ clientLoop cHandle cChan
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 893
diff changeset
    21
	atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False)
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    22
	hPutStrLn cHandle "CONNECTED\n"
1340
430d210d54ae Flush CONNECTED message, so client hasn't to wait for it on connect
unc0rr
parents: 1321
diff changeset
    23
	hFlush cHandle
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    24
	acceptLoop servSock acceptChan
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    25
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1306
diff changeset
    26
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    27
listenLoop :: Handle -> [String] -> TChan [String] -> IO ()
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    28
listenLoop handle buf chan = do
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    29
	str <- hGetLine handle
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    30
	if str == "" then do
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    31
		atomically $ writeTChan chan buf
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    32
		listenLoop handle [] chan
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    33
		else
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    34
		listenLoop handle (buf ++ [str]) chan
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    35
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1306
diff changeset
    36
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    37
clientLoop :: Handle -> TChan [String] -> IO ()
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    38
clientLoop handle chan =
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    39
	listenLoop handle [] chan
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    40
		`catch` (const $ clientOff >> return ())
1309
1a38a967bd48 Fix a bug with 'ghosts' on server
unc0rr
parents: 1308
diff changeset
    41
	where clientOff = atomically $ writeTChan chan ["QUIT"] -- if the client disconnects, we perform as if it sent QUIT message
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    42
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1306
diff changeset
    43
1306
e848447f29be Fix server crash on client disconnect
unc0rr
parents: 1305
diff changeset
    44
sendAnswers [] _ clients _ = return clients
e848447f29be Fix server crash on client disconnect
unc0rr
parents: 1305
diff changeset
    45
sendAnswers ((handlesFunc, answer):answers) client clients rooms = do
e848447f29be Fix server crash on client disconnect
unc0rr
parents: 1305
diff changeset
    46
	let recipients = handlesFunc client clients rooms
1321
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1309
diff changeset
    47
	putStrLn ("< " ++ (show answer))
1306
e848447f29be Fix server crash on client disconnect
unc0rr
parents: 1305
diff changeset
    48
e848447f29be Fix server crash on client disconnect
unc0rr
parents: 1305
diff changeset
    49
	clHandles' <- forM recipients $
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1306
diff changeset
    50
		\ch -> Control.Exception.handle (\e -> putStrLn (show e) >> hClose ch >> return [ch]) $
1309
1a38a967bd48 Fix a bug with 'ghosts' on server
unc0rr
parents: 1308
diff changeset
    51
			if (not $ null answer) && (head answer == "off") then hClose ch >> return [ch] else -- probably client with exception, don't send him anything
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1306
diff changeset
    52
			do
1306
e848447f29be Fix server crash on client disconnect
unc0rr
parents: 1305
diff changeset
    53
			forM_ answer (\str -> hPutStrLn ch str)
e848447f29be Fix server crash on client disconnect
unc0rr
parents: 1305
diff changeset
    54
			hPutStrLn ch ""
e848447f29be Fix server crash on client disconnect
unc0rr
parents: 1305
diff changeset
    55
			hFlush ch
e848447f29be Fix server crash on client disconnect
unc0rr
parents: 1305
diff changeset
    56
			if (not $ null answer) && (head answer == "BYE") then hClose ch >> return [ch] else return []
e848447f29be Fix server crash on client disconnect
unc0rr
parents: 1305
diff changeset
    57
e848447f29be Fix server crash on client disconnect
unc0rr
parents: 1305
diff changeset
    58
	let mclients = remove clients $ concat clHandles'
e848447f29be Fix server crash on client disconnect
unc0rr
parents: 1305
diff changeset
    59
e848447f29be Fix server crash on client disconnect
unc0rr
parents: 1305
diff changeset
    60
	sendAnswers answers client mclients rooms
e848447f29be Fix server crash on client disconnect
unc0rr
parents: 1305
diff changeset
    61
	where
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1306
diff changeset
    62
		remove list rmClHandles = deleteFirstsBy2t (\ a b -> (Miscutils.handle a) == b) list rmClHandles
1306
e848447f29be Fix server crash on client disconnect
unc0rr
parents: 1305
diff changeset
    63
e848447f29be Fix server crash on client disconnect
unc0rr
parents: 1305
diff changeset
    64
889
3bf9dc791f45 Some work on newhwserv
unc0rr
parents: 878
diff changeset
    65
mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ()
3bf9dc791f45 Some work on newhwserv
unc0rr
parents: 878
diff changeset
    66
mainLoop servSock acceptChan clients rooms = do
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    67
	r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients)
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    68
	case r of
889
3bf9dc791f45 Some work on newhwserv
unc0rr
parents: 878
diff changeset
    69
		Left ci -> do
1350
99a921e292f4 - Reverse the order of client list
unc0rr
parents: 1341
diff changeset
    70
			mainLoop servSock acceptChan (clients ++ [ci]) rooms
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    71
		Right (cmd, client) -> do
1302
4290ba4a14ca Remove deprecated stuff
unc0rr
parents: 1082
diff changeset
    72
			putStrLn ("> " ++ show cmd)
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1306
diff changeset
    73
1305
453882eb4467 - Fix build of server (has some bugs now)
unc0rr
parents: 1304
diff changeset
    74
			let (clientsFunc, roomsFunc, answers) = handleCmd client clients rooms $ cmd
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 1081
diff changeset
    75
			let mrooms = roomsFunc rooms
1308
d5dcd6cfa5e2 Fix another server failure (when second client in room disconnects)
unc0rr
parents: 1307
diff changeset
    76
			let mclients = (clientsFunc clients)
d5dcd6cfa5e2 Fix another server failure (when second client in room disconnects)
unc0rr
parents: 1307
diff changeset
    77
			let mclient = fromMaybe client $ find (== client) mclients
1305
453882eb4467 - Fix build of server (has some bugs now)
unc0rr
parents: 1304
diff changeset
    78
1308
d5dcd6cfa5e2 Fix another server failure (when second client in room disconnects)
unc0rr
parents: 1307
diff changeset
    79
			clientsIn <- sendAnswers answers mclient mclients mrooms
1306
e848447f29be Fix server crash on client disconnect
unc0rr
parents: 1305
diff changeset
    80
			
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1306
diff changeset
    81
			mainLoop servSock acceptChan clientsIn mrooms
ce26e16d18ab - Now actually fix
unc0rr
parents: 1306
diff changeset
    82
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    83
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    84
startServer serverSocket = do
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    85
	acceptChan <- atomically newTChan
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    86
	forkIO $ acceptLoop serverSocket acceptChan
889
3bf9dc791f45 Some work on newhwserv
unc0rr
parents: 878
diff changeset
    87
	mainLoop serverSocket acceptChan [] []
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    88
1307
ce26e16d18ab - Now actually fix
unc0rr
parents: 1306
diff changeset
    89
878
45bff6dadfce - Fix baseball bat
unc0rr
parents: 877
diff changeset
    90
main = withSocketsDo $ do
1341
86d7d5ab22a2 Allow --port=PORT command-line parameter to specify the port to listen on
unc0rr
parents: 1340
diff changeset
    91
	flags <- opts
86d7d5ab22a2 Allow --port=PORT command-line parameter to specify the port to listen on
unc0rr
parents: 1340
diff changeset
    92
	putStrLn $ "Listening on port " ++ show (getPort flags)
86d7d5ab22a2 Allow --port=PORT command-line parameter to specify the port to listen on
unc0rr
parents: 1340
diff changeset
    93
	serverSocket <- listenOn $ PortNumber (getPort flags)
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    94
	startServer serverSocket `finally` sClose serverSocket