diff --git a/quoridor-hs.cabal b/quoridor-hs.cabal --- a/quoridor-hs.cabal +++ b/quoridor-hs.cabal @@ -1,5 +1,5 @@ name: quoridor-hs -version: 0.1.0.0 +version: 0.1.1.0 synopsis: A Quoridor implementation in Haskell homepage: https://github.com/talw/quoridor-hs license: BSD3 @@ -8,7 +8,7 @@ maintainer: Tal Walter category: Game build-type: Simple -cabal-version: >=1.19 +cabal-version: >=1.18 description: An implementation in Haskell of the 2-to-4-player strategy game. @@ -51,7 +51,9 @@ snap-server ==0.9.*, filepath ==1.3.*, directory ==1.2.*, - network ==2.5.* + network >=2.5 && <2.7, + async ==2.0.*, + stm ==2.4.* -- hs-source-dirs: default-language: Haskell2010 @@ -64,7 +66,7 @@ hs-source-dirs: quoridor-exec main-is: Main.hs build-depends: base >=4.7 && <4.8, - quoridor-hs + quoridor-hs ==0.1.1.0 default-language: Haskell2010 GHC-Options: -Wall -threaded @@ -73,8 +75,8 @@ hs-source-dirs: tests main-is: Tests.hs build-depends: base >=4.7 && <4.8, - HUnit, - quoridor-hs, + HUnit ==1.2.*, + quoridor-hs ==0.1.1.0, mtl >=2.1 && <2.2 default-language: Haskell2010 type: exitcode-stdio-1.0 diff --git a/resources/console.html b/resources/console.html --- a/resources/console.html +++ b/resources/console.html @@ -8,14 +8,15 @@ -
-
-
-
- $ - -
-
+
+
+
+ $ + +
+
+
+

Chat panel

diff --git a/resources/console.js b/resources/console.js --- a/resources/console.js +++ b/resources/console.js @@ -1,5 +1,9 @@ -function appendOutput(cls, text) { - $('#console-output').append('
' + text + '
'); +function appendOutput(cls, text, id) { + $(id).append('
' + text + '
'); + if (id === '#chat-output') + { + $(id)[0].scrollTop = $(id)[0].scrollHeight; + } $('#line').focus(); $('#line')[0].scrollIntoView({block: "end", behavior: "instant"}); } @@ -10,22 +14,32 @@ var uri = "ws://"+hostName+":"+port+"/play" var ws = new WebSocket(uri); - appendOutput('stderr', 'Opening WebSockets connection...\n'); + appendOutput('stderr', 'Opening WebSockets connection...\n', '#console-output'); ws.onerror = function(event) { - appendOutput('stderr', 'WebSockets error: ' + event.data + '\n'); + appendOutput('stderr', 'WebSockets error: ' + event.data + '\n', '#console-output'); }; ws.onopen = function() { - appendOutput('stderr', 'WebSockets connection successful!\n'); + appendOutput('stderr', 'WebSockets connection successful!\n', '#console-output'); }; ws.onclose = function() { - appendOutput('stderr', 'WebSockets connection closed.\n'); + appendOutput('stderr', 'WebSockets connection closed.\n', '#console-output'); }; ws.onmessage = function(event) { - appendOutput('stdout', event.data); + try + { + var chatMsg = $.parseJSON(event.data); + if (chatMsg.msgType === 'chat') + { + appendOutput('stdout',chatMsg.text.concat('\n'), '#chat-output'); + } + } + catch (e) { + appendOutput('stdout', event.data, '#console-output'); + } }; $('#console-input').submit(function () { diff --git a/resources/style.css b/resources/style.css --- a/resources/style.css +++ b/resources/style.css @@ -5,6 +5,11 @@ background-color: #444; } +p { + color: #cfc; + font-family: 'Inconsolata', monospace; +} + form { color: #cfc; font-family: 'Inconsolata', monospace; @@ -20,6 +25,28 @@ font-size: 16px; margin: 0px; padding: 0px; +} + +#console { + display: block; + width: 60%; + height: 900px; + float: left; + overflow-y: auto; +} + +#console-output { + overflow-y: auto; +} + +#chat-output { + display: block; + float: left; + width: 30%; + min-width: 250px; + padding: 0px 0px 0px 30px; + height: 900px; + overflow-y: auto; } pre { diff --git a/src/Quoridor.hs b/src/Quoridor.hs --- a/src/Quoridor.hs +++ b/src/Quoridor.hs @@ -9,7 +9,7 @@ runReaderT) import Control.Monad.State (MonadIO, MonadState, MonadTrans, StateT, evalState, get, gets, lift, modify, put, - runStateT, void, when) + runStateT, void) import Data.List (find, sort) import qualified Data.Map as M import qualified Data.Set as S @@ -30,6 +30,9 @@ -- | Size of the board in one dimension. -- The board is a square type BoardSize = Int + +-- | List of valid moves for a player +type ValidMoves = [Cell] -- | The monad used for running the game. -- Basically adds layers of ReaderT for configuration, diff --git a/src/Quoridor/Cmdline.hs b/src/Quoridor/Cmdline.hs --- a/src/Quoridor/Cmdline.hs +++ b/src/Quoridor/Cmdline.hs @@ -11,6 +11,7 @@ import System.Exit (exitSuccess) import Network.Simple.TCP (withSocketsDo) +import Text.Printf (printf) import Quoridor import Quoridor.Cmdline.Messages (msgGameEnd, msgInitialTurn, @@ -20,7 +21,7 @@ import Quoridor.Cmdline.Options (ExecMode (..), Options (..), getOptions) import Quoridor.Cmdline.Parse (parseTurn) -import Quoridor.Cmdline.Render (putColoredStrTerm, +import Quoridor.Cmdline.Render (putColoredBoardTerm, runRenderColor) -- | The main entry point to quoridor-exec @@ -33,12 +34,18 @@ , boardSize = opBoardSize opts , numOfPlayers = opNumOfPlayers opts } + addr = opHostListenAddr opts + listenPort = opHostListenPort opts + httpListenPort = opHttpListenPort opts + when (opExecMode opts /= ExLocal) $ do + putStrLn $ printf "Chosen address: %s" addr + putStrLn $ printf "Chosen port: %d" listenPort case opExecMode opts of ExLocal -> runGame playLocal gc ExHost -> withSocketsDo $ runGame - (hostServer (opHostListenPort opts) (opHttpListenPort opts)) gc + (hostServer listenPort httpListenPort) gc joinOrProxy -> withSocketsDo $ - connectClient (joinOrProxy == ExProxy) $ opHostListenPort opts + connectClient (joinOrProxy == ExProxy) addr listenPort exitSuccess -- playLocal used to be structured similarly to @@ -71,8 +78,8 @@ -- Function that could be common to playLocal, -- playClient(handleWinOrTurn, wonAction, renderBoard) and playServer(handleParse) -- if I change playClient and playServer to be in the same vein as playLocal -renderBoard :: GameState -> GameConfig -> [Cell] -> IO () -renderBoard gs gc vms = putColoredStrTerm $ runRenderColor gs gc vms +renderBoard :: GameState -> GameConfig -> ValidMoves -> IO () +renderBoard gs gc vms = putColoredBoardTerm $ runRenderColor gs gc vms handleParse :: MonadIO m => m String -> (String -> m ()) -> (Turn -> m ()) -> m () diff --git a/src/Quoridor/Cmdline/Messages.hs b/src/Quoridor/Cmdline/Messages.hs --- a/src/Quoridor/Cmdline/Messages.hs +++ b/src/Quoridor/Cmdline/Messages.hs @@ -5,7 +5,10 @@ import Quoridor (Color, Turn) msgAwaitingTurn :: Color -> String -msgAwaitingTurn c = "Waiting for " ++ show c ++ " to make a move." +msgAwaitingTurn c = "Waiting for " ++ show c ++ " to make his turn." + +msgYourTurn :: String +msgYourTurn = "It's your turn." msgGameEnd :: Color -> String msgGameEnd c = show c ++ " won!" diff --git a/src/Quoridor/Cmdline/Network/Client.hs b/src/Quoridor/Cmdline/Network/Client.hs --- a/src/Quoridor/Cmdline/Network/Client.hs +++ b/src/Quoridor/Cmdline/Network/Client.hs @@ -1,63 +1,119 @@ +{-# LANGUAGE BangPatterns #-} + module Quoridor.Cmdline.Network.Client ( connectClient ) where -import Control.Applicative ((<$>)) -import Control.Monad (when) -import Control.Monad.State (liftIO) -import Control.Monad.State (MonadIO) -import Data.Maybe (fromMaybe) -import System.IO (hFlush, hReady, stdin, - stdout) +import Control.Concurrent.Async (race) +import Control.Concurrent.MVar (MVar, newMVar, withMVar) +import Control.Monad (unless, when) +import Data.Functor (void) +import Data.Maybe (isJust) +import System.IO (BufferMode (LineBuffering), + hFlush, hReady, + hSetBuffering, stdin, stdout) import Network.Simple.TCP (Socket, connect) import Quoridor import Quoridor.Cmdline.Messages import Quoridor.Cmdline.Network.Common -import Quoridor.Cmdline.Render (putColoredStrHtml, - putColoredStrTerm, +import Quoridor.Cmdline.Parse (parseMessage) +import Quoridor.Cmdline.Render (putChatMessageJson, + putColoredBoardHtml, + putColoredBoardTerm, runRenderColor) --- | Given a port, joins a game server that listens --- on the given port. -connectClient :: Bool -> Int -> IO () -connectClient isProxy port = connect "127.0.0.1" (show port) $ - \(connSock, _) -> do - msg <- recvFromServer connSock - flushStrLn msg - (gc, c) <- recvFromServer connSock - playClient connSock isProxy gc c +-- | Given an address, joins a game server that listens +-- on that address. +connectClient :: Bool -> String -> Int -> IO () +connectClient isProxy addr port = connect addr (show port) $ + \(sock, _) -> do + -- In case the client is invoked as a proxy + -- because the default is BlockBuffering + hSetBuffering stdout LineBuffering + let go = do + msg <- recvMsg sock + case msg of + WaitMsg str -> flushStrLn str >> go + FstGameMsg gc c -> do + writeLock <- newMVar () + void $ race (handleServerInput isProxy gc c sock writeLock) + (handleUserInput c sock writeLock) + _ -> error "connectClient - unexpected Message" + go -playClient :: Socket -> Bool -> GameConfig -> Color -> IO () -playClient connSock isProxy gc myColor = play - where - play = do - (gs, vm, msg) <- recvFromServer connSock - emptyInput - (if isProxy then putColoredStrHtml else putColoredStrTerm) $ - runRenderColor gs gc vm + {-(gc, c) <- recvFromServer connSock-} + {-playClient connSock isProxy gc c-} + +{-playClient :: Socket -> Bool -> GameConfig -> Color -> IO ()-} +{-playClient connSock isProxy gc myColor = play-} + {-where-} + {-play = do-} + {-(gs, vm, msg) <- recvFromServer connSock-} + {-[>emptyInput<] -- unneccessary if we're concurrent-} + {-(if isProxy then putColoredStrHtml-} + {-else (putChar '\n' >>) . putColoredStrTerm) $-} + {-runRenderColor gs gc vm-} + {-flushStrLn msg-} + {-hFlush stdout-} + {-case winner gs of-} + {-Just c ->-} + {-flushStrLn $ msgGameEnd c-} + {-Nothing -> do-} + {-let currPC = color $ currP gs-} + {-if currPC /= myColor-} + {-then do-} + {-flushStrLn $ msgAwaitingTurn currPC-} + {-play-} + {-else do-} + {-strTurn <- getLine-} + {-sendToSock strTurn connSock-} + {-play-} + +handleServerInput :: Bool -> GameConfig -> Color -> Socket -> MVar () -> IO () +handleServerInput isProxy gc myColor sock writeLock = go + where + go = do + msg <- recvMsg sock + quit <- case msg of + GameMsg gs vm str -> handleGameMsg gs vm str + ChatMsg col str -> handleChatMsg col str >> return False + _ -> error "handleServerInput - unexpected Message" + unless quit go + + handleGameMsg :: GameState -> ValidMoves -> String -> IO Bool + handleGameMsg gs vm msg = do + -- WHNF to avoid computing the board string inside withMVar + let !boardStr = runRenderColor gs gc vm + putBoardStrFunc = if isProxy then putColoredBoardHtml + else (putChar '\n' >>) . putColoredBoardTerm + withMVar writeLock $ \_ -> do + putBoardStrFunc boardStr flushStrLn msg - hFlush stdout - case winner gs of - Just c -> - flushStrLn $ msgGameEnd c - Nothing -> do - let currPC = color $ currP gs - if currPC /= myColor - then do - flushStrLn $ msgAwaitingTurn currPC - play - else do - strTurn <- liftIO getLine - sendToSock strTurn connSock - play + flushStrLn $ case (winner gs, color $ currP gs) of + (Just c, _) -> msgGameEnd c + (Nothing, c) | c == myColor -> msgYourTurn + | otherwise -> msgAwaitingTurn c + return $ isJust $ winner gs + handleChatMsg :: Color -> String -> IO () + handleChatMsg col msg = when isProxy $ putChatMessageJson col msg -recvFromServer :: (Functor m, MonadIO m, Read r) => Socket -> m r -recvFromServer sock = fromMaybe throwErr <$> recvFromSock sock - where throwErr = error "Lost connection with the server" +handleUserInput :: Color -> Socket -> MVar () -> IO () +handleUserInput c sock writeLock = go + where + go = do + input <- getLine + either + (\err -> withMVar writeLock $ \_ -> putStrLn err) + (`sendMsg` sock) + $ parseMessage c input + go +{-recvFromServer :: (Functor m, MonadIO m) => Socket -> m Message-} +{-recvFromServer = recvMsg-} + -- | Like putStrLn, but flushes right afterwards. flushStrLn :: String -> IO () flushStrLn = (hFlush stdout <<) . putStrLn @@ -69,8 +125,8 @@ -- while it wasn't the player's turn, will -- be fed to the server and generate an error message per line, -- or even play a turn, which may or may not be intentional. -emptyInput :: IO () -emptyInput = do - inputExists <- hReady stdin - when inputExists $ getLine >> emptyInput +{-emptyInput :: IO ()-} +{-emptyInput = do-} + {-inputExists <- hReady stdin-} + {-when inputExists $ getLine >> emptyInput-} diff --git a/src/Quoridor/Cmdline/Network/Common.hs b/src/Quoridor/Cmdline/Network/Common.hs --- a/src/Quoridor/Cmdline/Network/Common.hs +++ b/src/Quoridor/Cmdline/Network/Common.hs @@ -1,30 +1,48 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} module Quoridor.Cmdline.Network.Common ( ConnPlayer (..) - , sendToSock - , recvFromSock + , Message (..) + , sendMsg + , recvMsg , isAliveSock ) where -import Control.Applicative ((<$>)) -import Control.Exception (ErrorCall (..), SomeException, catch, - handle) -import Control.Monad.State (MonadIO, liftIO, replicateM_) -import qualified Data.ByteString.Char8 as BC -import Data.Maybe (fromJust) -import Text.Printf (printf) +import Control.Exception (Exception, SomeException, catch, + handle, throw) +import Control.Monad.State (MonadIO, liftIO, replicateM_) +import qualified Data.ByteString.Char8 as BC +import Data.Maybe (fromJust) +import Data.Typeable (Typeable) +import Text.Printf (printf) -import Network.Simple.TCP (Socket, recv, send) -import Numeric (readHex, showHex) +import Control.Concurrent.STM (TChan) +import Network.Simple.TCP (Socket, recv, send) +import Numeric (readHex, showHex) import Quoridor data ConnPlayer = ConnPlayer - { coplSock :: Socket + { coplChan :: TChan Message , coplColor :: Color - } deriving Show + } +data NetworkException = NetworkException + deriving (Show, Typeable) +instance Exception NetworkException + +data Message = FstGameMsg GameConfig Color + | GameMsg GameState ValidMoves String + | ChatMsg Color String + | TurnMsg Turn + | WaitMsg String + deriving (Read, Show) + +-- | Type-safer than sendToSock/recvFromSock duo +sendMsg :: (MonadIO m) => Message -> Socket -> m () +sendMsg = sendToSock + sendToSock :: (Show s, MonadIO m) => s -> Socket -> m () sendToSock s sock = do send sock $ BC.pack $ @@ -39,12 +57,20 @@ `catch` \(_ :: SomeException) -> return False -recvFromSock :: (Read r, Functor m, MonadIO m) => Socket -> m (Maybe r) -recvFromSock sock = liftIO $ handle (\(ErrorCall _) -> return Nothing) $ do +-- | Type-safer than sendToSock/recvFromSock duo +recvMsg :: (MonadIO m, Functor m) => Socket -> m Message +recvMsg = recvFromSock +{-recvMsg = (fromJust <$>) . recvFromSock-} + +recvFromSock :: (Read r, Functor m, MonadIO m) => Socket -> m r +recvFromSock sock = liftIO $ handle handler $ do mHexSize <- recv sock 4 let ((size,_):_) = readHex $ BC.unpack $ fromJust mHexSize if size == 0 - then recvFromSock sock -- To handle size 0 messages which are just isAlive check + -- To handle size 0 messages which are just isAlive check + then recvFromSock sock else do mValue <- recv sock size - return $ (read . BC.unpack) <$> mValue + return $ read $ BC.unpack $ fromJust mValue + where + handler (_ :: SomeException) = throw NetworkException diff --git a/src/Quoridor/Cmdline/Network/Server.hs b/src/Quoridor/Cmdline/Network/Server.hs --- a/src/Quoridor/Cmdline/Network/Server.hs +++ b/src/Quoridor/Cmdline/Network/Server.hs @@ -4,122 +4,185 @@ ( hostServer ) where -import Control.Applicative ((<$>)) -import Control.Concurrent (ThreadId, forkIO, killThread, - myThreadId, threadDelay, - throwTo) -import Control.Exception (bracket, handle) -import Control.Monad (filterM, forever, unless, - (>=>)) +import Control.Concurrent (forkFinally, forkIO, + threadDelay) +import Control.Exception (bracket) +import Control.Monad (filterM, forM_, forever, + unless, when, zipWithM) import Control.Monad.Reader (ask) import Control.Monad.State (MonadIO, get, liftIO) import qualified Data.ByteString as B +import Data.Functor (void) import Data.List (find) -import Data.Maybe (fromJust, fromMaybe) +import Data.Maybe (fromJust, isNothing) import System.Directory (getCurrentDirectory) import System.IO (Handle, hClose, hFlush) import System.Process (runInteractiveCommand, - terminateProcess, - waitForProcess) + terminateProcess) +import Control.Concurrent.Async (race) +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, + takeMVar) +import Control.Concurrent.STM (STM, TChan, TVar, atomically, + modifyTVar, newTChanIO, + newTVarIO, readTChan, + readTVar, writeTChan) import Network.Simple.TCP (HostPreference (Host), - accept, listen) + Socket, accept, listen) import qualified Network.WebSockets as WS import qualified Network.WebSockets.Snap as WS import qualified Snap.Core as Snap import qualified Snap.Http.Server as Snap import qualified Snap.Util.FileServe as Snap import System.FilePath (()) +import Text.Printf (printf) import Paths_quoridor_hs (getDataDir) import Quoridor import Quoridor.Cmdline.Messages import Quoridor.Cmdline.Network.Common -import Quoridor.Cmdline.Parse (parseTurn) +type PChans = TVar [TChan Message] +type GameChan = TChan (Color, Turn) + -- | Given a port, hosts a game server that listens -- on the given port. --- This returns a Game monad which should be used with runGame. +-- This isn't optimal. If a player keeps on connecting and +-- disconnecting, there's no limit to the depth of the stack that is +-- possible here. hostServer :: Int -> Int -> Game IO () hostServer quoriHostPort httpPort = do liftIO $ forkIO $ httpListen quoriHostPort httpPort listen (Host "127.0.0.1") (show quoriHostPort) $ \(lstnSock, _) -> do gc <- ask + gameChan <- liftIO newTChanIO + playerChans <- liftIO $ newTVarIO [] - let getPlayers 0 socks = do - coSocks <- liftIO $ filterM isAliveSock socks - if length coSocks /= length socks - then getPlayers (length socks - length coSocks) coSocks - else do - let colors = map toEnum [0..] - connPs = zipWith ConnPlayer socks colors - {-getConnPlayers socks' = zipWith ConnPlayer socks' colors-} - {-connPs = getConnPlayers socks-} - mapM_ (\p -> sendToPlayer (gc, coplColor p) p) connPs - playServer connPs + let + getPlayers 0 socks = do + coSocks <- filterM isAliveSock socks + if length coSocks /= length socks + then do + let playersLeft = length socks - length coSocks + msg = printf "Some players were disconnected. \ + \Waiting for %d more. " + playersLeft + liftIO $ putStrLn msg + liftIO $ forM_ coSocks $ sendMsg $ WaitMsg msg + getPlayers playersLeft coSocks + else do + let colors = map toEnum [0..] + doneConnPs <- liftIO $ + zipWithM (handleClient gameChan playerChans) socks colors + let connPs = map snd doneConnPs + let dones = map fst doneConnPs + forM_ connPs $ \p -> + sendToPlayer (FstGameMsg gc (coplColor p)) p - getPlayers n socks = accept lstnSock $ \(connSock, _) -> do - let msg = "Connected. " ++ if n > 1 - then "Waiting for other players." else "" - liftIO $ putStrLn msg - sendToSock msg connSock - getPlayers (n-1) $ connSock : socks + handleGame gameChan connPs + -- Allow 10 seconds for the clients to shutdown + void $ liftIO $ race (threadDelay $ 10 * 1000 * 1000) + (mapM_ takeMVar dones) - getPlayers (numOfPlayers gc) [] + getPlayers n socks = accept lstnSock $ \(connSock, _) -> do + let msg = if n - 1 > 0 + then printf "Waiting for %d more player(s)." $ n - 1 + else "Everyone connected. Rechecking connections..." + liftIO $ putStrLn msg + sendMsg (WaitMsg msg) connSock + getPlayers (n-1) $ connSock : socks -playServer :: [ConnPlayer] -> Game IO () -playServer connPs = play msgInitialTurn - where - play msg = do - gs <- get - vm <- getCurrentValidMoves - mapM_ (sendToPlayer (gs,vm,msg)) connPs - case winner gs of - Just _ -> liftIO $ threadDelay $ 10 * 1000 * 1000 - Nothing -> do - let currColor = color $ currP gs - currConnP = fromJust $ find ((currColor ==) . coplColor) connPs - sendToCurrPlayer x = sendToPlayer x currConnP + getPlayers (numOfPlayers gc) [] - execValidTurn = do - strTurn <- recvFromPlayer currConnP - let reAskForInput msg' = do sendToCurrPlayer (gs,vm,msg') - execValidTurn - either reAskForInput - (makeTurn >=> maybe (reAskForInput msgInvalidTurn) - return) - $ parseTurn strTurn +handleClient :: GameChan -> PChans -> Socket -> + Color -> IO (MVar (), ConnPlayer) +handleClient gameChan playerChans sock col = do + chan <- newTChanIO + atomically $ modifyTVar playerChans (chan :) + done <- newEmptyMVar + let action = race (handleMsgSend chan sock) + (handleClientInput gameChan playerChans col sock) + finally _ = putMVar done () + forkFinally action finally + return (done, ConnPlayer chan col) - turn <- execValidTurn - play $ msgValidTurn currColor turn +handleGame :: GameChan -> [ConnPlayer] -> Game IO () +handleGame gameChan connPs = go msgInitialTurn + where + go msg = do + gs <- get + vm <- getCurrentValidMoves + liftIO $ atomically $ + broadcast (GameMsg gs vm msg) $ map coplChan connPs + when (isNothing $ winner gs) $ do + let currColor = color $ currP gs + currConnP = fromJust $ find ((currColor ==) . coplColor) connPs + getTurnOfCurrP = do + (col, turn) <- atomically $ readTChan gameChan + if col == currColor then return turn + else getTurnOfCurrP + execValidTurn = do + turn <- liftIO getTurnOfCurrP + let reAskForInput msg' = do sendToPlayer (GameMsg gs vm msg') + currConnP + execValidTurn + makeTurn turn >>= maybe (reAskForInput msgInvalidTurn) + return + turn <- execValidTurn + go $ msgValidTurn currColor turn -sendToPlayer :: (Show s, MonadIO m) => s -> ConnPlayer -> m () -sendToPlayer s cnp = sendToSock s $ coplSock cnp +sendToPlayer :: MonadIO m => Message -> ConnPlayer -> m () +sendToPlayer msg cnp = liftIO $ atomically $ writeTChan (coplChan cnp) msg -- | The error message will appear only if the current player exits. -- To handle the case where other players will exit I'll have to rewrite the whole -- mechanism to be asynchronous between players. -recvFromPlayer :: (Functor m, MonadIO m) => ConnPlayer -> m String -recvFromPlayer cnp = fromMaybe throwErr <$> recvFromSock (coplSock cnp) - where throwErr = error $ "Lost connection with " ++ show (coplColor cnp) +{-recvFromPlayer :: (Functor m, MonadIO m) => ConnPlayer -> m String-} +{-recvFromPlayer cnp = fromMaybe throwErr <$> recvFromSock (coplSock cnp)-} + {-where throwErr = error $ "Lost connection with " ++ show (coplColor cnp)-} +handleMsgSend :: TChan Message -> Socket -> IO () +handleMsgSend chan sock = do + msg <- atomically $ readTChan chan + sendMsg msg sock + handleMsgSend chan sock + +handleClientInput :: GameChan -> PChans -> Color -> Socket -> IO () +handleClientInput gameChan playerChans col sock = go + where + go = do + msg <- recvMsg sock + atomically $ case msg of + chatMsg@(ChatMsg _ _) -> readTVar playerChans >>= broadcast chatMsg + TurnMsg turn -> writeTChan gameChan (col, turn) + _ -> error "handleClientInput - unexpected Message" + go + +broadcast :: Message -> [TChan Message] -> STM () +broadcast msg playerChans = forM_ playerChans $ flip writeTChan msg + + +-- Web interface + httpListen :: Int -> Int -> IO () -httpListen quoriHostPort httpPort = Snap.httpServe config $ app quoriHostPort - where - config = Snap.setPort httpPort $ - Snap.setErrorLog Snap.ConfigNoLog $ - Snap.setAccessLog Snap.ConfigNoLog - Snap.defaultConfig - app :: Int -> Snap.Snap () - app port = do - dataDir <- liftIO getDataDir - Snap.route - [ ("", Snap.ifTop $ Snap.serveFile $ dataDir "console.html") - , ("console.js", Snap.serveFile $ dataDir "console.js") - , ("style.css", Snap.serveFile $ dataDir "style.css") - , ("play", acceptWSPlayer port) - ] +httpListen quoriHostPort httpPort = do + putStrLn "Http server: " + Snap.httpServe config $ app quoriHostPort + where + config = Snap.setPort httpPort $ + Snap.setErrorLog Snap.ConfigNoLog $ + Snap.setAccessLog Snap.ConfigNoLog + Snap.defaultConfig + app :: Int -> Snap.Snap () + app port = do + dataDir <- liftIO getDataDir + Snap.route + [ ("", Snap.ifTop $ Snap.serveFile $ dataDir "console.html") + , ("console.js", Snap.serveFile $ dataDir "console.js") + , ("style.css", Snap.serveFile $ dataDir "style.css") + , ("play", acceptWSPlayer port) + ] acceptWSPlayer :: Int -> Snap.Snap () acceptWSPlayer port = WS.runWebSocketsSnap $ \pending -> @@ -131,18 +194,13 @@ let acqRsrc = do (hIn, hOut, _, ph) <- runInteractiveCommand cmd conn <- WS.acceptRequest pending - outT <- forkIO $ copyHandleToConn hOut conn - tId <- myThreadId - inT <- forkIO $ copyConnToHandle conn hIn tId - return (hIn, hOut, ph, inT, outT) - freeRsrc (hIn, hOut, ph, inT, outT) = do - killThread inT - killThread outT + return (hIn, hOut, ph, conn) + freeRsrc (hIn, hOut, ph, _) = do hClose hIn hClose hOut terminateProcess ph bracket acqRsrc freeRsrc $ - \(_,_,ph,_,_) -> waitForProcess ph + \(hIn,hOut,_,conn) -> race (copyHandleToConn hOut conn) (copyConnToHandle conn hIn) return () @@ -155,14 +213,12 @@ copyHandleToConn h c where -copyConnToHandle :: WS.Connection -> Handle -> ThreadId -> IO () -copyConnToHandle c h t = handle thrower $ forever $ do +copyConnToHandle :: WS.Connection -> Handle -> IO () +copyConnToHandle c h = forever $ do bs <- WS.receiveData c putStrLn $ previewStr $ "WS < " ++ show bs B.hPutStr h bs hFlush h - where - thrower e = throwTo t (e :: WS.ConnectionException) previewStr :: String -> String previewStr str = prvw ++ if not $ null rst then "....." diff --git a/src/Quoridor/Cmdline/Options.hs b/src/Quoridor/Cmdline/Options.hs --- a/src/Quoridor/Cmdline/Options.hs +++ b/src/Quoridor/Cmdline/Options.hs @@ -5,6 +5,8 @@ ) where import Control.Monad (unless) +import Data.Char (isDigit) +import Data.Maybe (fromMaybe, isNothing) import System.Environment (getProgName) import System.Exit (exitFailure, exitSuccess) @@ -20,6 +22,7 @@ { opBoardSize :: Int , opNumOfPlayers :: Int , opGatesPerPlayer :: Int + , opHostListenAddr :: String , opHostListenPort :: Int , opHttpListenPort :: Int , opExecMode :: ExecMode @@ -35,6 +38,7 @@ { opBoardSize = 9 , opNumOfPlayers = 2 , opGatesPerPlayer = 10 + , opHostListenAddr = "127.0.0.1" , opHostListenPort = 33996 , opHttpListenPort = 33997 , opExecMode = ExLocal @@ -96,7 +100,7 @@ , Option "h" ["host"] (portOptionArg ExHost) - "Host a game server. default port 33997" + "Host a game server. default port 33996" , Option "j" ["join"] (portOptionArg ExJoin) @@ -124,16 +128,30 @@ where portOptionArg execMode = OptArg (\arg opts -> do - argNum <- maybe (return $ opHostListenPort opts) - (rangedOption 1025 65535) arg + let mAddr = getAddr =<< arg + addr = fromMaybe (opHostListenAddr opts) mAddr + mPort = getPort =<< arg + port <- maybe (return $ opHostListenPort opts) + (rangedOption 1025 65535 . show) mPort return opts - { opExecMode = execMode - , opHostListenPort = argNum + { opExecMode = execMode + , opHostListenPort = port + , opHostListenAddr = addr }) - "PORT" + "ADDR/PORT (either or both)" + rangedOption x y arg = do let argNum = read arg unless (isInRange argNum x y) $ do putUsageInfoLn exitFailure return argNum + + getAddr s | ':' `elem` s = Just $ takeWhile (/= ':') s + | isNothing $ getPort s = Just s + | otherwise = Nothing + + getPort s | length s <= 5 && isNum s = Just (read s :: Int) + | ':' `elem` s = getPort $ tail $ dropWhile (/= ':') s + | otherwise = Nothing + where isNum = all isDigit diff --git a/src/Quoridor/Cmdline/Parse.hs b/src/Quoridor/Cmdline/Parse.hs --- a/src/Quoridor/Cmdline/Parse.hs +++ b/src/Quoridor/Cmdline/Parse.hs @@ -1,23 +1,36 @@ module Quoridor.Cmdline.Parse - ( parseTurn + ( parseTurn, + parseMessage ) where -import Control.Applicative (pure) -import Data.Char (toUpper) -import Data.Functor ((<$>)) -import Data.List (elemIndex) -import Data.Maybe (fromJust) +import Control.Applicative (pure) +import Data.Char (toUpper) +import Data.Functor ((<$>)) +import Data.List (elemIndex) +import Data.Maybe (fromJust) -import Text.Parsec (Parsec, char, digit, eof, many1, - oneOf, parse, spaces, (<|>)) +import Text.Parsec (Parsec, anyChar, char, digit, + eof, many1, manyTill, oneOf, + parse, spaces, (<|>)) import Quoridor -import Quoridor.Cmdline.Messages (validMovesChars) +import Quoridor.Cmdline.Messages (validMovesChars) +import Quoridor.Cmdline.Network.Common (Message (TurnMsg, ChatMsg)) type Parse = Parsec String () -- helper functions +pMessage :: Color -> Parse Message +pMessage col = + (TurnMsg <$> pTurn) <|> (ChatMsg col <$> pChat) + +-- t STRING +pChat :: Parse String +pChat = do + char 't' + asToken $ manyTill anyChar eof + pTurn :: Parse Turn pTurn = do res <- pMove <|> pShortCutMove <|> pPutGate @@ -61,17 +74,26 @@ asToken :: Parse a -> Parse a asToken p = spaces >> p +parseShowErrMsgs :: Parse a -> String -> Either String a +parseShowErrMsgs p str = func $ parse p "" str + where func (Left errMsgs) = Left $ show errMsgs + func (Right x) = Right x -- exported functions -- | Given a string representing a turn, --- Parses it and returns the Turn +-- Parses it and returns the Turn. +-- This is used by the local client, which doesn't use +-- the Message type -- -- Note: This is not the same string as show turn, it is -- a more concise, for example: "m y x" to move -- to (y,x) parseTurn :: String -> Either String Turn -parseTurn s = func $ parse pTurn "" s - where func (Left errMsgs) = Left $ show errMsgs - func (Right x) = Right x +parseTurn = parseShowErrMsgs pTurn + +-- | Aggregates the turn parser with a chat parser to +-- make a Message parser +parseMessage :: Color -> String -> Either String Message +parseMessage col = parseShowErrMsgs $ pMessage col diff --git a/src/Quoridor/Cmdline/Render.hs b/src/Quoridor/Cmdline/Render.hs --- a/src/Quoridor/Cmdline/Render.hs +++ b/src/Quoridor/Cmdline/Render.hs @@ -1,8 +1,10 @@ module Quoridor.Cmdline.Render ( runRender , runRenderColor - , putColoredStrTerm - , putColoredStrHtml + , putColoredBoardTerm + , putColoredStrJson + , putColoredBoardHtml + , putChatMessageJson ) where import Control.Monad.Reader (ReaderT, reader, runReaderT) @@ -48,7 +50,7 @@ --- exported functions -- | Returns a String of the game board along with some basic info -runRender :: GameState -> GameConfig -> [Cell] -> String +runRender :: GameState -> GameConfig -> ValidMoves -> String runRender gs gc vms = D.toList w where (_,w) = runWriter (runStateT (runReaderT (render cp) gc) initialRenderState) @@ -63,27 +65,37 @@ -- and a series of IO () actions, one per character, which describe how -- to set the terminal color. putColoredStr can be used to apply -- those actions automatically -runRenderColor :: GameState -> GameConfig -> [Cell] -> (String, [CA.Color]) +runRenderColor :: GameState -> GameConfig -> ValidMoves -> (String, [CA.Color]) runRenderColor = ((addColor .) .) . runRender -- | Given an input such as the output of runRenderColor, writes the -- game board along with some basic info, to the screen, applying -- the IO actions to colorize the output. -putColoredStrTerm :: (String, [CA.Color]) -> IO () -putColoredStrTerm (str, colors) = mapM_ putColoredChar $ zip str colors - where putColoredChar (ch, col) = colorToAction col >> putChar ch - colorToAction col = - CA.setSGR [CA.SetColor CA.Foreground CA.Vivid col] +putColoredBoardTerm :: (String, [CA.Color]) -> IO () +putColoredBoardTerm (str, colors) = mapM_ putColoredChar $ zip str colors + where putColoredChar (ch, col) = colorToAction col >> putChar ch + colorToAction col = + CA.setSGR [CA.SetColor CA.Foreground CA.Vivid col] + -- | This is wasteful compared to having this logic in the browser's javascript. -- However this is still amounts to very little data being transferred, and that way -- I can avoid duplicating the coloring logic" -putColoredStrHtml :: (String, [CA.Color]) -> IO () -putColoredStrHtml (str, colors) = putStr $ concatMap addColorProp $ zip str colors - where addColorProp (ch, CA.White) = [ch] - addColorProp (ch, col) = printf "%c" (show col) ch +putColoredBoardHtml :: (String, [CA.Color]) -> IO () +putColoredBoardHtml (str, colors) = putStr $ concatMap addColorProp $ zip str colors + where + addColorProp (ch, CA.White) = [ch] + addColorProp (ch, col) = printf "%c" (show col) ch +putColoredStrJson :: String -> String -> IO () +putColoredStrJson msgType text = putStrLn $ printf "{ \ + \ \"msgType\": \"%s\", \ + \ \"text\": \"%s\" \ + \ }" msgType text +putChatMessageJson :: Color -> String -> IO () +putChatMessageJson col msg = putColoredStrJson "chat" inner + where inner = printf "%s : %s" (show col) msg :: String --- helper functions @@ -191,8 +203,7 @@ colorLetter :: Color -> Char colorLetter = head . show --- | Given a board render, attaches an IO action per character --- that changes terminal color accordingly. +-- | Given a board render, attaches a color per character addColor :: String -> (String, [CA.Color]) addColor str = (str, map addColorChar str) where