gameServer/ClientIO.hs
author koda
Sat, 19 Feb 2011 04:04:34 +0100
changeset 4952 df752b69a142
parent 4932 f11d80bac7ed
child 4982 3572eaf14340
permissions -rw-r--r--
Added tag Hedgewars-iOS-1.2.3 for changeset ae0c6c35414d
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
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     5
import Control.Concurrent.Chan
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
     6
import Control.Concurrent
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     7
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
     8
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
     9
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
    10
import qualified Data.ByteString.Char8 as B
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
----------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
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
    13
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
    14
import Utils
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    15
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
    16
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
pDelim :: B.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
    18
pDelim = B.pack "\n\n"
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
    19
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
bs2Packets :: B.ByteString -> ([[B.ByteString]], B.ByteString)
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4904
diff changeset
    21
bs2Packets = unfoldrE extractPackets
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
    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
    23
    extractPackets :: B.ByteString -> Either B.ByteString ([B.ByteString], B.ByteString)
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4904
diff changeset
    24
    extractPackets buf =
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
    25
        let buf' = until (not . B.isPrefixOf pDelim) (B.drop 2) buf in
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
    26
            let (bsPacket, bufTail) = B.breakSubstring pDelim buf' in
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
    27
                if B.null bufTail then
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
    28
                    Left bsPacket
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
    29
                    else
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
    30
                    if B.null bsPacket then 
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
    31
                        Left bufTail
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
    32
                        else
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
                        Right (B.splitWith (== '\n') bsPacket, bufTail)
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
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    35
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
    36
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
    37
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
    38
    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
    39
        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
    40
            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
    41
--            putStrLn $ show sock ++ " got smth: " ++ (show $ B.length 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
    42
            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
    43
                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
    44
                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
    45
                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
    46
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
    47
        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
    48
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
    49
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
    50
clientRecvLoop :: 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
    51
clientRecvLoop s chan ci = 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
    52
    msg <- (listenLoop s chan ci >> return "Connection closed") `catch` (return . B.pack . show)
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
    53
    clientOff msg
4585
6e747aef012f Another approach for fixing listener thread issues, should finally get rid of all problems. Not tested.
unc0rr
parents: 4579
diff changeset
    54
    where
6e747aef012f Another approach for fixing listener thread issues, should finally get rid of all problems. Not tested.
unc0rr
parents: 4579
diff changeset
    55
        clientOff msg = writeChan chan $ ClientMessage (ci, ["QUIT", msg])
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
    56
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
    57
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
    58
4585
6e747aef012f Another approach for fixing listener thread issues, should finally get rid of all problems. Not tested.
unc0rr
parents: 4579
diff changeset
    59
clientSendLoop :: Socket -> ThreadId -> Chan CoreMessage -> Chan [B.ByteString] -> ClientIndex -> IO ()
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4904
diff changeset
    60
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
    61
    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
    62
    Exception.handle
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4904
diff changeset
    63
        (\(e :: Exception.IOException) -> unless (isQuit answer) $ sendQuit e) $
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4904
diff changeset
    64
            sendAll s $ B.unlines answer `B.append` B.singleton '\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
    65
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4904
diff changeset
    66
    if isQuit answer then
4579
4e61c2a42121 Explicitly kill listening thread in try to prevent messages recieving bugs
unc0rr
parents: 4295
diff changeset
    67
        do
4585
6e747aef012f Another approach for fixing listener thread issues, should finally get rid of all problems. Not tested.
unc0rr
parents: 4579
diff changeset
    68
        Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s
4579
4e61c2a42121 Explicitly kill listening thread in try to prevent messages recieving bugs
unc0rr
parents: 4295
diff changeset
    69
        killThread tId
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4904
diff changeset
    70
        writeChan cChan $ Remove ci
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    71
        else
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4904
diff changeset
    72
        clientSendLoop s tId cChan chan ci
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    73
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    74
    where
4608
d0f758d0ff91 Make client quit on send exception (was commented due to another approach in handling connection lost)
unc0rr
parents: 4585
diff changeset
    75
        sendQuit e = do
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4904
diff changeset
    76
            print e
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4904
diff changeset
    77
            writeChan cChan $ ClientMessage (ci, ["QUIT", B.pack $ show e])
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4904
diff changeset
    78
        isQuit ("BYE":_) = True
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    79
        isQuit _ = False