netserver/hwserv.hs
author unc0rr
Sun, 27 Apr 2008 10:14:00 +0000
changeset 878 45bff6dadfce
parent 852 f756a1d3324c
permissions -rw-r--r--
- Fix baseball bat - Small formatting changes in newhwserv
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
849
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     1
module Main where
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     2
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     3
import Network
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     4
import IO
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     5
import System.IO
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     6
import Control.Concurrent
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     7
import Control.Concurrent.STM
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     8
import Control.Exception (finally)
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     9
import Miscutils
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    10
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    11
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    12
handleCmd :: Handle -> TVar[ClientInfo] -> TVar[RoomInfo] -> (String, [String]) -> IO()
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    13
handleCmd clientHandle clientsList roomsList ("SAY", param) = do
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    14
		ls <- atomically(readTVar clientsList)
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    15
		sendOthers (map (\x -> handle x) ls) clientHandle (concat param)
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    16
		return ()
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    17
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    18
handleCmd clientHandle clientsList roomsList ("CREATE", [roomname]) = do
852
f756a1d3324c Handle the case when the room is already created by someone else
unc0rr
parents: 851
diff changeset
    19
		res <- manipState2 clientsList roomsList (hcCreate)
f756a1d3324c Handle the case when the room is already created by someone else
unc0rr
parents: 851
diff changeset
    20
		if res then sendMsg clientHandle ("JOINED " ++ roomname) else sendMsg clientHandle "Already exists"
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    21
		where
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    22
			hcCreate ci ri = if (null $ filter (\ xr -> roomname == name xr) ri) then
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    23
				(map
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    24
					(\ xc
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    25
						-> if (clientHandle == handle xc) then
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    26
								xc {isMaster = True, room = roomname}
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    27
							else
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    28
								xc)
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    29
					ci,
852
f756a1d3324c Handle the case when the room is already created by someone else
unc0rr
parents: 851
diff changeset
    30
					(RoomInfo roomname "") : ri, True)
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    31
				else
852
f756a1d3324c Handle the case when the room is already created by someone else
unc0rr
parents: 851
diff changeset
    32
					(ci, ri, False)
849
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    33
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    34
handleCmd clientHandle clientsList roomsList ("LIST", []) = do
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    35
		rl <- atomically $ readTVar roomsList
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    36
		sendMsg clientHandle (unlines $ map (\x -> name x) rl)
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    37
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    38
handleCmd clientHandle _ _ ("PING", _) = sendMsg clientHandle "PONG"
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    39
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    40
handleCmd clientHandle _ _ (_, _) = sendMsg clientHandle "Unknown cmd or bad syntax"
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    41
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    42
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    43
clientLoop :: Handle -> TVar[ClientInfo] -> TVar[RoomInfo] -> IO()
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    44
clientLoop clientHandle clientsList roomsList = do
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    45
		cline <- hGetLine clientHandle
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    46
		let (cmd, params) = extractCmd cline
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    47
		handleCmd clientHandle clientsList roomsList (cmd, params)
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    48
		if cmd /= "QUIT" then clientLoop clientHandle clientsList roomsList else return ()
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    49
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    50
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    51
main = do
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    52
	clientsList <- atomically $ newTVar[]
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    53
	roomsList <- atomically $ newTVar[]
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    54
	bracket
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    55
		(listenOn $ Service "hedgewars")
849
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    56
		(sClose)
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    57
		(loop clientsList roomsList)
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    58
		where
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    59
			loop clist rlist sock = accept sock >>= addClient clist rlist >> loop clist rlist sock
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    60
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    61
			addClient clist rlist (chandle, hostname, port) = do
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    62
				putStrLn $ "Client connected: " ++ show hostname
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    63
				hSetBuffering chandle LineBuffering
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    64
				manipState clist (\x -> (ClientInfo chandle "" "" False):x) -- add client to list
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    65
				forkIO $ finally
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    66
					(clientLoop chandle clist rlist)
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    67
					(do
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    68
					manipState clist (\x -> filter (\x -> chandle /= handle x) x) -- remove client from list
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    69
					hClose chandle)