netserver/hwserv.hs
author unc0rr
Fri, 18 Apr 2008 18:06:17 +0000
changeset 849 82ac0596aa3c
child 851 8ffa4ad0d8ea
permissions -rw-r--r--
Start work on standalone server in Haskell
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
data ClientInfo =
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    12
	ClientInfo
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    13
	{
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    14
		handle :: Handle,
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    15
		nick :: String,
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    16
		game :: String,
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    17
		isMaster :: Bool
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    18
	}
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    19
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    20
data RoomInfo =
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    21
	RoomInfo
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    22
	{
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    23
		name :: String,
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    24
		password :: String
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    25
	}
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    26
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    27
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    28
handleCmd :: Handle -> TVar[ClientInfo] -> TVar[RoomInfo] -> (String, [String]) -> IO()
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    29
handleCmd clientHandle clientsList roomsList ("SAY", param) = do
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    30
		ls <- atomically(readTVar clientsList)
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    31
		sendOthers (map (\x -> handle x) ls) clientHandle (concat param)
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    32
		return ()
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 ("CREATE", [roomname]) = do
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    35
		manipState roomsList (\x -> (RoomInfo roomname ""):x)
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    36
		manipState clientsList (\x -> map (\xc -> if (clientHandle == handle xc) then xc{isMaster = True, game = roomname} else xc) x)
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    37
		sendMsg clientHandle ("JOINED " ++ roomname)
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    38
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    39
handleCmd clientHandle clientsList roomsList ("LIST", []) = do
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    40
		rl <- atomically $ readTVar roomsList
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    41
		sendMsg clientHandle (unlines $ map (\x -> name x) rl)
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
handleCmd clientHandle _ _ ("PING", _) = sendMsg clientHandle "PONG"
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    44
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    45
handleCmd clientHandle _ _ (_, _) = sendMsg clientHandle "Unknown cmd or bad syntax"
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    46
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    47
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    48
clientLoop :: Handle -> TVar[ClientInfo] -> TVar[RoomInfo] -> IO()
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    49
clientLoop clientHandle clientsList roomsList = do
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    50
		cline <- hGetLine clientHandle
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    51
		let (cmd, params) = extractCmd cline
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    52
		handleCmd clientHandle clientsList roomsList (cmd, params)
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    53
		if cmd /= "QUIT" then clientLoop clientHandle clientsList roomsList else return ()
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    54
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    55
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    56
main = do
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    57
	clientsList <- atomically $ newTVar[]
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    58
	roomsList <- atomically $ newTVar[]
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    59
	bracket
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    60
		(listenOn $ PortNumber 46631)
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    61
		(sClose)
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    62
		(loop clientsList roomsList)
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    63
		where
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    64
			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
    65
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    66
			addClient clist rlist (chandle, hostname, port) = do
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    67
				putStrLn $ "Client connected: " ++ show hostname
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    68
				hSetBuffering chandle LineBuffering
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    69
				manipState clist (\x -> (ClientInfo chandle "" "" False):x) -- add client to list
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    70
				forkIO $ finally
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    71
					(clientLoop chandle clist rlist)
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    72
					(do
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    73
					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
    74
					hClose chandle)