gameServer/ClientIO.hs
author koda
Thu, 24 Mar 2011 17:28:36 +0100
changeset 5046 fc6639d56799
parent 5037 1edc06d2247c
child 5059 68a5415ca8ea
permissions -rw-r--r--
this brings compatibility up with SDL HEAD (5504), but maybe breaks compatibility with sdl 1.2 so please test! still has problems with keyboard input and rendered ttf textures
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
     1
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     2
module ClientIO where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     3
2296
19f2f76dc346 Patch for compiling with 6.10 (define NEW_EXCEPTIONS to do that)
unc0rr
parents: 2126
diff changeset
     4
import qualified Control.Exception as Exception
5032
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
     5
import Control.Monad.State
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     6
import Control.Concurrent.Chan
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
     7
import Control.Concurrent
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     8
import Control.Monad
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
     9
import Network
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    10
import Network.Socket.ByteString
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    11
import qualified Data.ByteString.Char8 as B
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
----------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
import CoreTypes
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    14
import RoomsAndClients
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    15
import Utils
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    16
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    17
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    18
pDelim :: B.ByteString
5030
42746c5d4a80 Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents: 5012
diff changeset
    19
pDelim = "\n\n"
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    20
5032
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    21
bs2Packets = runState takePacks
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    22
5032
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    23
takePacks :: State B.ByteString [[B.ByteString]]
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    24
takePacks
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    25
  = do modify (until (not . B.isPrefixOf pDelim) (B.drop 2))
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    26
       packet <- state $ B.breakSubstring pDelim
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    27
       buf <- get
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    28
       if B.null buf then put packet >> return [] else
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    29
        if B.null packet then  return [] else
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    30
         do packets <- takePacks
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    31
            return (B.splitWith (== '\n') packet : packets)
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    32
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    33
listenLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO ()
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    34
listenLoop sock chan ci = recieveWithBufferLoop B.empty
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    35
    where
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    36
        recieveWithBufferLoop recvBuf = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    37
            recvBS <- recv sock 4096
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    38
            unless (B.null recvBS) $ do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    39
                let (packets, newrecvBuf) = bs2Packets $ B.append recvBuf recvBS
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    40
                forM_ packets sendPacket
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    41
                recieveWithBufferLoop newrecvBuf
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    42
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    43
        sendPacket packet = writeChan chan $ ClientMessage (ci, packet)
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    44
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    45
clientRecvLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO ()
5011
73c5839d4447 I must have been on drugs when wrote it
unc0rr
parents: 5001
diff changeset
    46
clientRecvLoop s chan ci =
5037
1edc06d2247c Fix ghost players (used Prelude.catch instead of Control.Exception.catch)
unc0rr
parents: 5032
diff changeset
    47
        (listenLoop s chan ci >> return "Connection closed")
1edc06d2247c Fix ghost players (used Prelude.catch instead of Control.Exception.catch)
unc0rr
parents: 5032
diff changeset
    48
        `Exception.catch` (\(e :: ShutdownThreadException) -> return . B.pack . show $ e)
1edc06d2247c Fix ghost players (used Prelude.catch instead of Control.Exception.catch)
unc0rr
parents: 5032
diff changeset
    49
        `Exception.catch` (\(e :: Exception.IOException) -> return . B.pack . show $ e)
1edc06d2247c Fix ghost players (used Prelude.catch instead of Control.Exception.catch)
unc0rr
parents: 5032
diff changeset
    50
        >>= clientOff >> remove
4585
6e747aef012f Another approach for fixing listener thread issues, should finally get rid of all problems. Not tested.
unc0rr
parents: 4579
diff changeset
    51
    where
6e747aef012f Another approach for fixing listener thread issues, should finally get rid of all problems. Not tested.
unc0rr
parents: 4579
diff changeset
    52
        clientOff msg = writeChan chan $ ClientMessage (ci, ["QUIT", msg])
4996
76ef3d8bd78e Fix crash (accessing already deleted client record) by reverting to old client removing handling + throwTo
unc0rr
parents: 4982
diff changeset
    53
        remove = writeChan chan $ Remove ci
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    54
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    55
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    56
4585
6e747aef012f Another approach for fixing listener thread issues, should finally get rid of all problems. Not tested.
unc0rr
parents: 4579
diff changeset
    57
clientSendLoop :: Socket -> ThreadId -> Chan CoreMessage -> Chan [B.ByteString] -> ClientIndex -> IO ()
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4904
diff changeset
    58
clientSendLoop s tId cChan chan ci = do
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    59
    answer <- readChan chan
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    60
    Exception.handle
5000
72d8fb26223d - Don't pretend client sent some message from sending thread (fixes crash when client is already deleted by recieveng thread)
unc0rr
parents: 4998
diff changeset
    61
        (\(e :: Exception.IOException) -> unless (isQuit answer) . killReciever $ show e) $
5030
42746c5d4a80 Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents: 5012
diff changeset
    62
            sendAll s $ B.unlines answer `B.snoc` '\n'
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    63
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4904
diff changeset
    64
    if isQuit answer then
4579
4e61c2a42121 Explicitly kill listening thread in try to prevent messages recieving bugs
unc0rr
parents: 4295
diff changeset
    65
        do
4585
6e747aef012f Another approach for fixing listener thread issues, should finally get rid of all problems. Not tested.
unc0rr
parents: 4579
diff changeset
    66
        Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s
5001
312f4dd41753 Better quit message
unc0rr
parents: 5000
diff changeset
    67
        killReciever . B.unpack $ quitMessage answer
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    68
        else
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4904
diff changeset
    69
        clientSendLoop s tId cChan chan ci
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    70
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    71
    where
5000
72d8fb26223d - Don't pretend client sent some message from sending thread (fixes crash when client is already deleted by recieveng thread)
unc0rr
parents: 4998
diff changeset
    72
        killReciever = Exception.throwTo tId . ShutdownThreadException
5001
312f4dd41753 Better quit message
unc0rr
parents: 5000
diff changeset
    73
        quitMessage ["BYE"] = "bye"
312f4dd41753 Better quit message
unc0rr
parents: 5000
diff changeset
    74
        quitMessage ("BYE":msg:_) = msg
312f4dd41753 Better quit message
unc0rr
parents: 5000
diff changeset
    75
        quitMessage _ = error "quitMessage"
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4904
diff changeset
    76
        isQuit ("BYE":_) = True
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    77
        isQuit _ = False