gameServer/ClientIO.hs
author nemo
Sun, 11 Mar 2012 20:12:31 -0400
changeset 6770 7d2c6cdb816a
parent 5989 23407ecb1826
child 7252 74a92f39703b
permissions -rw-r--r--
Start on adding drowning bonus to bat/firepunch/whip. AI still is not smart enough to change direction when firepunching to face the water, or change the angle of the bat. Also try to weight cost of switches based on how many switches were available.

{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, Rank2Types #-}
module ClientIO where

import qualified Control.Exception as Exception
import Control.Monad.State
import Control.Concurrent.Chan
import Control.Concurrent
import Network
import Network.Socket.ByteString
import qualified Data.ByteString.Char8 as B
----------------
import CoreTypes
import RoomsAndClients


pDelim :: B.ByteString
pDelim = "\n\n"

bs2Packets :: B.ByteString -> ([[B.ByteString]], B.ByteString)
bs2Packets = runState takePacks

takePacks :: State B.ByteString [[B.ByteString]]
takePacks
  = do modify (until (not . B.isPrefixOf pDelim) (B.drop 2))
       packet <- state $ B.breakSubstring pDelim
       buf <- get
       if B.null buf then put packet >> return [] else
        if B.null packet then  return [] else
         do packets <- takePacks
            return (B.splitWith (== '\n') packet : packets)

listenLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO ()
listenLoop sock chan ci = recieveWithBufferLoop B.empty
    where
        recieveWithBufferLoop recvBuf = do
            recvBS <- recv sock 4096
            unless (B.null recvBS) $ do
                let (packets, newrecvBuf) = bs2Packets $ B.append recvBuf recvBS
                forM_ packets sendPacket
                recieveWithBufferLoop newrecvBuf

        sendPacket packet = writeChan chan $ ClientMessage (ci, packet)

clientRecvLoop :: Socket -> Chan CoreMessage -> Chan [B.ByteString] -> ClientIndex -> (forall a. IO a -> IO a) -> IO ()
clientRecvLoop s chan clChan ci restore =
    myThreadId >>=
    \t -> (restore $ forkIO (clientSendLoop s t clChan ci) >>
        listenLoop s chan ci >> return "Connection closed")
        `Exception.catch` (\(e :: Exception.IOException) -> return . B.pack . show $ e)
        `Exception.catch` (\(e :: ShutdownThreadException) -> return . B.pack . show $ e)
        >>= clientOff >> remove
    where
        clientOff msg = writeChan chan $ ClientMessage (ci, ["QUIT", msg])
        remove = writeChan chan $ Remove ci



clientSendLoop :: Socket -> ThreadId -> Chan [B.ByteString] -> ClientIndex -> IO ()
clientSendLoop s tId chan ci = do
    answer <- readChan chan

    when (isQuit answer) $
        killReciever . B.unpack $ quitMessage answer

    Exception.handle
        (\(e :: Exception.IOException) -> unless (isQuit answer) . killReciever $ show e) $
            sendAll s $ B.unlines answer `B.snoc` '\n'

    if isQuit answer then
        do
        Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s
        else
        clientSendLoop s tId chan ci

    where
        killReciever = Exception.throwTo tId . ShutdownThreadException
        quitMessage ["BYE"] = "bye"
        quitMessage ("BYE":msg:_) = msg
        quitMessage _ = error "quitMessage"
        isQuit ("BYE":_) = True
        isQuit _ = False