# HG changeset patch # User unc0rr # Date 1224331066 0 # Node ID ff8863ebde1713a1d63ec6667eec8d635b9e5634 # Parent f5b1b3fd70cc1f5f979e0403cba85d0c7a13ebb1 Add hedgewars server to build process diff -r f5b1b3fd70cc -r ff8863ebde17 CMakeLists.txt --- a/CMakeLists.txt Sat Oct 18 08:59:43 2008 +0000 +++ b/CMakeLists.txt Sat Oct 18 11:57:46 2008 +0000 @@ -22,6 +22,7 @@ set(HEDGEWARS_PROTO_VER 17) add_subdirectory(bin) +add_subdirectory(netserver) add_subdirectory(QTfrontend) add_subdirectory(hedgewars) add_subdirectory(share) diff -r f5b1b3fd70cc -r ff8863ebde17 netserver/CMakeLists.txt --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/netserver/CMakeLists.txt Sat Oct 18 11:57:46 2008 +0000 @@ -0,0 +1,25 @@ +find_program(ghc_executable ghc) + +if (NOT ghc_executable) + message("Cannot find GHC" FATAL) +endif(NOT ghc_executable) + +set(hwserver_sources + HWProto.hs + Miscutils.hs + Opts.hs + hedgewars-server.hs + ) + +set(ghc_flags "--make" "hedgewars-server.hs") + +add_custom_command(OUTPUT "${EXECUTABLE_OUTPUT_PATH}/hedgewars-server${CMAKE_EXECUTABLE_SUFFIX}" + COMMAND "${ghc_executable}" + ARGS ${ghc_flags} + MAIN_DEPENDENCY "hedgewars-server.hs" + DEPENDS ${hwserver_sources} + ) + +add_custom_target(hedgewars-server ALL DEPENDS "${EXECUTABLE_OUTPUT_PATH}/hedgewars-server${CMAKE_EXECUTABLE_SUFFIX}") + +install(PROGRAMS "${EXECUTABLE_OUTPUT_PATH}/hedgewars-server${CMAKE_EXECUTABLE_SUFFIX}" DESTINATION bin) diff -r f5b1b3fd70cc -r ff8863ebde17 netserver/hedgewars-server.hs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/netserver/hedgewars-server.hs Sat Oct 18 11:57:46 2008 +0000 @@ -0,0 +1,94 @@ +module Main where + +import Network +import IO +import System.IO +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception (setUncaughtExceptionHandler, handle, finally) +import Control.Monad (forM, forM_, filterM, liftM) +import Maybe (fromMaybe) +import Data.List +import Miscutils +import HWProto +import Opts + +acceptLoop :: Socket -> TChan ClientInfo -> IO () +acceptLoop servSock acceptChan = do + (cHandle, host, port) <- accept servSock + cChan <- atomically newTChan + forkIO $ clientLoop cHandle cChan + atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False) + hPutStrLn cHandle "CONNECTED\n" + hFlush cHandle + acceptLoop servSock acceptChan + + +listenLoop :: Handle -> [String] -> TChan [String] -> IO () +listenLoop handle buf chan = do + str <- hGetLine handle + if str == "" then do + atomically $ writeTChan chan buf + listenLoop handle [] chan + else + listenLoop handle (buf ++ [str]) chan + + +clientLoop :: Handle -> TChan [String] -> IO () +clientLoop handle chan = + listenLoop handle [] chan + `catch` (const $ clientOff >> return ()) + where clientOff = atomically $ writeTChan chan ["QUIT"] -- if the client disconnects, we perform as if it sent QUIT message + + +sendAnswers [] _ clients _ = return clients +sendAnswers ((handlesFunc, answer):answers) client clients rooms = do + let recipients = handlesFunc client clients rooms + putStrLn ("< " ++ (show answer)) + + clHandles' <- forM recipients $ + \ch -> Control.Exception.handle (\e -> putStrLn (show e) >> hClose ch >> return [ch]) $ + if (not $ null answer) && (head answer == "off") then hClose ch >> return [ch] else -- probably client with exception, don't send him anything + do + forM_ answer (\str -> hPutStrLn ch str) + hPutStrLn ch "" + hFlush ch + if (not $ null answer) && (head answer == "BYE") then hClose ch >> return [ch] else return [] + + let mclients = remove clients $ concat clHandles' + + sendAnswers answers client mclients rooms + where + remove list rmClHandles = deleteFirstsBy2t (\ a b -> (Miscutils.handle a) == b) list rmClHandles + + +mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO () +mainLoop servSock acceptChan clients rooms = do + r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) + case r of + Left ci -> do + mainLoop servSock acceptChan (clients ++ [ci]) rooms + Right (cmd, client) -> do + putStrLn ("> " ++ show cmd) + + let (clientsFunc, roomsFunc, answers) = handleCmd client clients rooms $ cmd + let mrooms = roomsFunc rooms + let mclients = (clientsFunc clients) + let mclient = fromMaybe client $ find (== client) mclients + + clientsIn <- sendAnswers answers mclient mclients mrooms + + mainLoop servSock acceptChan clientsIn mrooms + + +startServer serverSocket = do + acceptChan <- atomically newTChan + forkIO $ acceptLoop serverSocket acceptChan + mainLoop serverSocket acceptChan [] [] + + +main = withSocketsDo $ do + flags <- opts + putStrLn $ "Listening on port " ++ show (getPort flags) + serverSocket <- listenOn $ PortNumber (getPort flags) + startServer serverSocket `finally` sClose serverSocket diff -r f5b1b3fd70cc -r ff8863ebde17 netserver/newhwserv.hs --- a/netserver/newhwserv.hs Sat Oct 18 08:59:43 2008 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,94 +0,0 @@ -module Main where - -import Network -import IO -import System.IO -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception (setUncaughtExceptionHandler, handle, finally) -import Control.Monad (forM, forM_, filterM, liftM) -import Maybe (fromMaybe) -import Data.List -import Miscutils -import HWProto -import Opts - -acceptLoop :: Socket -> TChan ClientInfo -> IO () -acceptLoop servSock acceptChan = do - (cHandle, host, port) <- accept servSock - cChan <- atomically newTChan - forkIO $ clientLoop cHandle cChan - atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False) - hPutStrLn cHandle "CONNECTED\n" - hFlush cHandle - acceptLoop servSock acceptChan - - -listenLoop :: Handle -> [String] -> TChan [String] -> IO () -listenLoop handle buf chan = do - str <- hGetLine handle - if str == "" then do - atomically $ writeTChan chan buf - listenLoop handle [] chan - else - listenLoop handle (buf ++ [str]) chan - - -clientLoop :: Handle -> TChan [String] -> IO () -clientLoop handle chan = - listenLoop handle [] chan - `catch` (const $ clientOff >> return ()) - where clientOff = atomically $ writeTChan chan ["QUIT"] -- if the client disconnects, we perform as if it sent QUIT message - - -sendAnswers [] _ clients _ = return clients -sendAnswers ((handlesFunc, answer):answers) client clients rooms = do - let recipients = handlesFunc client clients rooms - putStrLn ("< " ++ (show answer)) - - clHandles' <- forM recipients $ - \ch -> Control.Exception.handle (\e -> putStrLn (show e) >> hClose ch >> return [ch]) $ - if (not $ null answer) && (head answer == "off") then hClose ch >> return [ch] else -- probably client with exception, don't send him anything - do - forM_ answer (\str -> hPutStrLn ch str) - hPutStrLn ch "" - hFlush ch - if (not $ null answer) && (head answer == "BYE") then hClose ch >> return [ch] else return [] - - let mclients = remove clients $ concat clHandles' - - sendAnswers answers client mclients rooms - where - remove list rmClHandles = deleteFirstsBy2t (\ a b -> (Miscutils.handle a) == b) list rmClHandles - - -mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO () -mainLoop servSock acceptChan clients rooms = do - r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) - case r of - Left ci -> do - mainLoop servSock acceptChan (clients ++ [ci]) rooms - Right (cmd, client) -> do - putStrLn ("> " ++ show cmd) - - let (clientsFunc, roomsFunc, answers) = handleCmd client clients rooms $ cmd - let mrooms = roomsFunc rooms - let mclients = (clientsFunc clients) - let mclient = fromMaybe client $ find (== client) mclients - - clientsIn <- sendAnswers answers mclient mclients mrooms - - mainLoop servSock acceptChan clientsIn mrooms - - -startServer serverSocket = do - acceptChan <- atomically newTChan - forkIO $ acceptLoop serverSocket acceptChan - mainLoop serverSocket acceptChan [] [] - - -main = withSocketsDo $ do - flags <- opts - putStrLn $ "Listening on port " ++ show (getPort flags) - serverSocket <- listenOn $ PortNumber (getPort flags) - startServer serverSocket `finally` sClose serverSocket