gameServer/ClientIO.hs
author Wuzzy <almikes@aol.com>
Mon, 25 Sep 2017 20:09:33 +0200
changeset 12520 22f2a586b9ca
parent 11046 47a8c19ecb60
child 13673 1aa5e884326a
permissions -rw-r--r--
Remove checkpoints in ASA: Getting to the device This means the player now must win this mission in one go. Justification: There were many ways for the mission to be saved in an unwinnable state, there are many ways to win this mission and the checkpoints try to "force" one particular way. Also, this mission isn't too long anyway.

{-
 * Hedgewars, a free turn based strategy game
 * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com>
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; version 2 of the License
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 \-}

{-# 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 = receiveWithBufferLoop B.empty
    where
        receiveWithBufferLoop recvBuf = do
            recvBS <- recv sock 4096
            unless (B.null recvBS) $ do
                let (packets, newrecvBuf) = bs2Packets $ B.append recvBuf recvBS
                forM_ packets sendPacket
                when (B.length newrecvBuf > 128 * 1024) $ sendPacket ["QUIT", "Protocol violation"]
                receiveWithBufferLoop $ B.copy 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 :: ShutdownThreadException) -> return . B.pack . show $ e)
        `Exception.catch` (\(e :: Exception.IOException) -> return . B.pack . show $ e)
        `Exception.catch` (\(e :: Exception.SomeException) -> return . B.pack . show $ e)
      )
        >>= clientOff) `Exception.finally` remove
    where
        clientOff msg = writeChan chan $ ClientMessage (ci, ["QUIT", msg])
        remove = do
            clientOff "Client is in some weird state"
            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.SomeException) -> unless (isQuit answer) . killReciever $ show e) $
            sendAll s $ B.unlines answer `B.snoc` '\n'

    if isQuit answer then
        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