quoridor-hs 0.1.0.0 → 0.1.1.0
raw patch · 13 files changed
+458/−212 lines, 13 filesdep +asyncdep +stmdep ~HUnitdep ~networkdep ~quoridor-hsPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: async, stm
Dependency ranges changed: HUnit, network, quoridor-hs
API changes (from Hackage documentation)
- Paths_quoridor_hs: getBinDir :: IO FilePath
- Paths_quoridor_hs: getDataDir :: IO FilePath
- Paths_quoridor_hs: getDataFileName :: FilePath -> IO FilePath
- Paths_quoridor_hs: getLibDir :: IO FilePath
- Paths_quoridor_hs: getLibexecDir :: IO FilePath
- Paths_quoridor_hs: getSysconfDir :: IO FilePath
- Paths_quoridor_hs: version :: Version
- Quoridor.Cmdline.Messages: msgAwaitingTurn :: Color -> String
- Quoridor.Cmdline.Messages: msgGameEnd :: Color -> String
- Quoridor.Cmdline.Messages: msgInitialTurn :: String
- Quoridor.Cmdline.Messages: msgInputInstr :: String
- Quoridor.Cmdline.Messages: msgInvalidTurn :: String
- Quoridor.Cmdline.Messages: msgValidTurn :: Color -> Turn -> String
- Quoridor.Cmdline.Messages: validMovesChars :: String
- Quoridor.Cmdline.Network.Client: connectClient :: Bool -> Int -> IO ()
- Quoridor.Cmdline.Network.Common: ConnPlayer :: Socket -> Color -> ConnPlayer
- Quoridor.Cmdline.Network.Common: coplColor :: ConnPlayer -> Color
- Quoridor.Cmdline.Network.Common: coplSock :: ConnPlayer -> Socket
- Quoridor.Cmdline.Network.Common: data ConnPlayer
- Quoridor.Cmdline.Network.Common: instance Show ConnPlayer
- Quoridor.Cmdline.Network.Common: isAliveSock :: MonadIO m => Socket -> m Bool
- Quoridor.Cmdline.Network.Common: recvFromSock :: (Read r, Functor m, MonadIO m) => Socket -> m (Maybe r)
- Quoridor.Cmdline.Network.Common: sendToSock :: (Show s, MonadIO m) => s -> Socket -> m ()
- Quoridor.Cmdline.Network.Server: hostServer :: Int -> Int -> Game IO ()
- Quoridor.Cmdline.Options: ExHost :: ExecMode
- Quoridor.Cmdline.Options: ExJoin :: ExecMode
- Quoridor.Cmdline.Options: ExLocal :: ExecMode
- Quoridor.Cmdline.Options: ExProxy :: ExecMode
- Quoridor.Cmdline.Options: Options :: Int -> Int -> Int -> Int -> Int -> ExecMode -> Options
- Quoridor.Cmdline.Options: data ExecMode
- Quoridor.Cmdline.Options: data Options
- Quoridor.Cmdline.Options: getOptions :: [String] -> IO Options
- Quoridor.Cmdline.Options: instance Eq ExecMode
- Quoridor.Cmdline.Options: opBoardSize :: Options -> Int
- Quoridor.Cmdline.Options: opExecMode :: Options -> ExecMode
- Quoridor.Cmdline.Options: opGatesPerPlayer :: Options -> Int
- Quoridor.Cmdline.Options: opHostListenPort :: Options -> Int
- Quoridor.Cmdline.Options: opHttpListenPort :: Options -> Int
- Quoridor.Cmdline.Options: opNumOfPlayers :: Options -> Int
- Quoridor.Cmdline.Parse: parseTurn :: String -> Either String Turn
- Quoridor.Cmdline.Render: putColoredStrHtml :: (String, [Color]) -> IO ()
- Quoridor.Cmdline.Render: putColoredStrTerm :: (String, [Color]) -> IO ()
- Quoridor.Cmdline.Render: runRender :: GameState -> GameConfig -> [Cell] -> String
- Quoridor.Cmdline.Render: runRenderColor :: GameState -> GameConfig -> [Cell] -> (String, [Color])
- Quoridor.Helpers: andP :: (a -> Bool) -> (a -> Bool) -> a -> Bool
- Quoridor.Helpers: rotateList :: [a] -> [a]
- Quoridor.Helpers: unsafeLookup :: Ord k => k -> Map k a -> a
+ Quoridor: type ValidMoves = [Cell]
Files
- quoridor-hs.cabal +8/−6
- resources/console.html +9/−8
- resources/console.js +21/−7
- resources/style.css +27/−0
- src/Quoridor.hs +4/−1
- src/Quoridor/Cmdline.hs +12/−5
- src/Quoridor/Cmdline/Messages.hs +4/−1
- src/Quoridor/Cmdline/Network/Client.hs +103/−47
- src/Quoridor/Cmdline/Network/Common.hs +43/−17
- src/Quoridor/Cmdline/Network/Server.hs +142/−86
- src/Quoridor/Cmdline/Options.hs +24/−6
- src/Quoridor/Cmdline/Parse.hs +35/−13
- src/Quoridor/Cmdline/Render.hs +26/−15
quoridor-hs.cabal view
@@ -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 <talw10@gmail.com> 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
resources/console.html view
@@ -8,14 +8,15 @@ <script type="text/javascript" src="console.js"></script> </head> <body>- <div>- <div id="console" style="display: block">- <div id="console-output"></div>- <form id="console-input">- <code>$ </code><input type="text" size="64" id="line" />- <input type="submit" style="display: none" />- </form>- </div>+ <div id="console">+ <div id="console-output"></div>+ <form id="console-input">+ <code>$ </code><input type="text" size="64" id="line" />+ <input type="submit" style="display: none" />+ </form>+ </div>+ <div id="chat-output">+ <p class="stdin">Chat panel</p> </div> </body> </html>
resources/console.js view
@@ -1,5 +1,9 @@-function appendOutput(cls, text) {- $('#console-output').append('<pre class="' + cls + '">' + text + '</pre>');+function appendOutput(cls, text, id) {+ $(id).append('<pre class="' + cls + '">' + text + '</pre>');+ 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 () {
resources/style.css view
@@ -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 {
src/Quoridor.hs view
@@ -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,
src/Quoridor/Cmdline.hs view
@@ -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 ()
src/Quoridor/Cmdline/Messages.hs view
@@ -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!"
src/Quoridor/Cmdline/Network/Client.hs view
@@ -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-}
src/Quoridor/Cmdline/Network/Common.hs view
@@ -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
src/Quoridor/Cmdline/Network/Server.hs view
@@ -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 "....."
src/Quoridor/Cmdline/Options.hs view
@@ -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
src/Quoridor/Cmdline/Parse.hs view
@@ -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
src/Quoridor/Cmdline/Render.hs view
@@ -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 "<font class=\"%s\">%c</font>" (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 "<font class=\"%s\">%c</font>" (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