netserver/newhwserv.hs
author unc0rr
Sun, 27 Apr 2008 10:14:00 +0000
changeset 878 45bff6dadfce
parent 877 ebb801acd8b9
child 889 3bf9dc791f45
permissions -rw-r--r--
- Fix baseball bat - Small formatting changes in newhwserv
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)
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
     9
import Control.Monad (forM, filterM, liftM)
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    10
import Miscutils
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    11
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    12
type Client = (TChan String, Handle)
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    13
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    14
acceptLoop :: Socket -> TChan Client -> IO ()
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
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    19
	atomically $ writeTChan acceptChan (cChan, cHandle)
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    20
	acceptLoop servSock acceptChan
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    21
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    22
listenLoop :: Handle -> TChan String -> IO ()
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    23
listenLoop handle chan = do
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    24
	str <- hGetLine handle
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    25
	atomically $ writeTChan chan str
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    26
	listenLoop handle chan
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    27
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    28
clientLoop :: Handle -> TChan String -> IO ()
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    29
clientLoop handle chan =
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    30
	listenLoop handle chan
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    31
		`catch` (const $ clientOff >> return ())
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    32
		`finally` hClose handle
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    33
	where clientOff = atomically $ writeTChan chan "QUIT"
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    34
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    35
mainLoop :: Socket -> TChan Client -> [Client] -> IO ()
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    36
mainLoop servSock acceptChan clients = do
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    37
	r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients)
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    38
	case r of
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    39
		Left (ch, h) -> do
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    40
			mainLoop servSock acceptChan $ (ch, h):clients
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    41
		Right (line, handle) -> do
878
45bff6dadfce - Fix baseball bat
unc0rr
parents: 877
diff changeset
    42
			clients' <- forM clients $
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    43
					\(ch, h) -> do
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    44
						hPutStrLn h line
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    45
						hFlush h
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    46
						return [(ch,h)]
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    47
					`catch` const (hClose h >> return [])
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    48
			mainLoop servSock acceptChan $ concat clients'
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    49
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    50
tselect :: [(TChan a, t)] -> STM (a, t)
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    51
tselect = foldl orElse retry . map (\(ch, ty) -> (flip (,) ty) `fmap` readTChan ch)
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    52
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    53
startServer serverSocket = do
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    54
	acceptChan <- atomically newTChan
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    55
	forkIO $ acceptLoop serverSocket acceptChan
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    56
	mainLoop serverSocket acceptChan []
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    57
878
45bff6dadfce - Fix baseball bat
unc0rr
parents: 877
diff changeset
    58
main = withSocketsDo $ do
877
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    59
	serverSocket <- listenOn $ Service "hedgewars"
ebb801acd8b9 Try new approach for netserver
unc0rr
parents:
diff changeset
    60
	startServer serverSocket `finally` sClose serverSocket