--- a/gameServer/Actions.hs Sun Mar 20 15:22:55 2011 -0400
+++ b/gameServer/Actions.hs Mon Mar 21 21:23:39 2011 +0300
@@ -103,7 +103,7 @@
vars si = [
"MOTD_NEW", serverMessage si,
"MOTD_OLD", serverMessageForOldVersions si,
- "LATEST_PROTO", B.pack . show $ latestReleaseVersion si
+ "LATEST_PROTO", showB $ latestReleaseVersion si
]
@@ -118,7 +118,7 @@
processAction (NoticeMessage n) = do
chan <- client's sendChan
- processAction $ AnswerClients [chan] ["NOTICE", B.pack . show . fromEnum $ n]
+ processAction $ AnswerClients [chan] ["NOTICE", showB . fromEnum $ n]
processAction (ByeClient msg) = do
(Just ci) <- gets clientIndex
@@ -301,7 +301,7 @@
})
]
where
- rmTeamMsg = toEngineMsg $ B.singleton 'F' `B.append` teamName
+ rmTeamMsg = toEngineMsg $ 'F' `B.cons` teamName
processAction (RemoveClientTeams clId) = do
@@ -376,7 +376,7 @@
modify (\s -> s{clientIndex = Just banId})
clHost <- client's host
currentTime <- io getCurrentTime
- let msg = "Ban for " `B.append` (B.pack . show $ seconds) `B.append` "seconds (" `B.append` reason ` B.append` ")"
+ let msg = B.concat ["Ban for ", B.pack . show $ seconds, "seconds (", reason, ")"]
mapM_ processAction [
AddIP2Bans clHost msg (addUTCTime seconds currentTime)
, KickClient banId
--- a/gameServer/ClientIO.hs Sun Mar 20 15:22:55 2011 -0400
+++ b/gameServer/ClientIO.hs Mon Mar 21 21:23:39 2011 +0300
@@ -2,6 +2,7 @@
module ClientIO where
import qualified Control.Exception as Exception
+import Control.Monad.State
import Control.Concurrent.Chan
import Control.Concurrent
import Control.Monad
@@ -15,23 +16,19 @@
pDelim :: B.ByteString
-pDelim = B.pack "\n\n"
+pDelim = "\n\n"
+
+bs2Packets = runState takePacks
-bs2Packets :: B.ByteString -> ([[B.ByteString]], B.ByteString)
-bs2Packets = unfoldrE extractPackets
- where
- extractPackets :: B.ByteString -> Either B.ByteString ([B.ByteString], B.ByteString)
- extractPackets buf =
- let buf' = until (not . B.isPrefixOf pDelim) (B.drop 2) buf in
- let (bsPacket, bufTail) = B.breakSubstring pDelim buf' in
- if B.null bufTail then
- Left bsPacket
- else
- if B.null bsPacket then
- Left bufTail
- else
- Right (B.splitWith (== '\n') bsPacket, bufTail)
-
+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
@@ -59,7 +56,7 @@
answer <- readChan chan
Exception.handle
(\(e :: Exception.IOException) -> unless (isQuit answer) . killReciever $ show e) $
- sendAll s $ B.unlines answer `B.append` B.singleton '\n'
+ sendAll s $ B.unlines answer `B.snoc` '\n'
if isQuit answer then
do
--- a/gameServer/HWProtoCore.hs Sun Mar 20 15:22:55 2011 -0400
+++ b/gameServer/HWProtoCore.hs Mon Mar 21 21:23:39 2011 +0300
@@ -50,7 +50,7 @@
let clRoom = room rnc roomId
let roomMasterSign = if isMaster cl then "@" else ""
let adminSign = if isAdministrator cl then "@" else ""
- let roomInfo = if roomId /= lobbyId then roomMasterSign `B.append` "room " `B.append` name clRoom else adminSign `B.append` "lobby"
+ let roomInfo = if roomId /= lobbyId then B.concat [roomMasterSign, "room ", name clRoom] else adminSign `B.append` "lobby"
let roomStatus = if gameinprogress clRoom then
if teamsInGame cl > 0 then "(playing)" else "(spectating)"
else
@@ -61,9 +61,9 @@
answerClient [
"INFO",
nick cl,
- "[" `B.append` host cl `B.append` "]",
+ B.concat ["[", host cl, "]"],
protoNumber2ver $ clientProto cl,
- "[" `B.append` roomInfo `B.append` "]" `B.append` roomStatus
+ B.concat ["[", roomInfo, "]", roomStatus]
]
--- a/gameServer/HWProtoInRoomState.hs Sun Mar 20 15:22:55 2011 -0400
+++ b/gameServer/HWProtoInRoomState.hs Mon Mar 21 21:23:39 2011 +0300
@@ -73,9 +73,7 @@
canAddNumber r = 48 - (sum . map hhnum $ teams r)
findTeam = find (\t -> tName == teamname t) . teams
newTeam ci clNick r = TeamInfo ci clNick tName color grave fort voicepack flag dif (newTeamHHNum r) (hhsList hhsInfo)
- dif = case B.readInt difStr of
- Just (i, t) | B.null t -> fromIntegral i
- _ -> 0
+ dif = readInt_ difStr
hhsList [] = []
hhsList [_] = error "Hedgehogs list with odd elements number"
hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs
@@ -122,11 +120,9 @@
[]
else
[ModifyRoom $ modifyTeam team{hhnum = hhNumber},
- AnswerClients others ["HH_NUM", teamName, B.pack $ show hhNumber]]
+ AnswerClients others ["HH_NUM", teamName, showB hhNumber]]
where
- hhNumber = case B.readInt numberStr of
- Just (i, t) | B.null t -> fromIntegral i
- _ -> 0
+ hhNumber = readInt_ numberStr
findTeam = find (\t -> teamName == teamname t) . teams
canAddNumber = (-) 48 . sum . map hhnum . teams
@@ -261,6 +257,6 @@
chans <- roomSameClanChans
return [AnswerClients chans ["EM", engineMsg cl]]
where
- engineMsg cl = toEngineMsg $ "b" `B.append` nick cl `B.append` "(team): " `B.append` msg `B.append` "\x20\x20"
+ engineMsg cl = toEngineMsg $ B.concat ["b", nick cl, "(team): ", msg, "\x20\x20"]
handleCmd_inRoom _ = return [ProtocolError "Incorrect command (state: in room)"]
--- a/gameServer/HWProtoLobbyState.hs Sun Mar 20 15:22:55 2011 -0400
+++ b/gameServer/HWProtoLobbyState.hs Mon Mar 21 21:23:39 2011 +0300
@@ -22,7 +22,7 @@
toAnswer team =
[AnswerClients [clChan] $ teamToNet team,
AnswerClients [clChan] ["TEAM_COLOR", teamname team, teamcolor team],
- AnswerClients [clChan] ["HH_NUM", teamname team, B.pack . show $ hhnum team]]
+ AnswerClients [clChan] ["HH_NUM", teamname team, showB $ hhnum team]]
handleCmd_lobby :: CmdHandler
@@ -169,10 +169,8 @@
cl <- thisClient
return [ModifyServerInfo (\si -> si{latestReleaseVersion = readNum}) | isAdministrator cl && readNum > 0]
where
- readNum = case B.readInt protoNum of
- Just (i, t) | B.null t -> fromIntegral i
- _ -> 0
-
+ readNum = readInt_ protoNum
+
handleCmd_lobby ["GET_SERVER_VAR"] = do
cl <- thisClient
return [SendServerVars | isAdministrator cl]
--- a/gameServer/HWProtoNEState.hs Sun Mar 20 15:22:55 2011 -0400
+++ b/gameServer/HWProtoNEState.hs Mon Mar 21 21:23:39 2011 +0300
@@ -32,7 +32,7 @@
else
return $
ModifyClient (\c -> c{clientProto = parsedProto}) :
- AnswerClients [sendChan cl] ["PROTO", B.pack $ show parsedProto] :
+ AnswerClients [sendChan cl] ["PROTO", showB parsedProto] :
[CheckRegistered | not . B.null $ nick cl]
where
parsedProto = case B.readInt protoNum of
--- a/gameServer/Utils.hs Sun Mar 20 15:22:55 2011 -0400
+++ b/gameServer/Utils.hs Mon Mar 21 21:23:39 2011 +0300
@@ -11,6 +11,8 @@
import qualified Data.List as List
import Control.Monad
import qualified Codec.Binary.Base64 as Base64
+import qualified Data.ByteString.Lazy as BL
+import qualified Text.Show.ByteString as BS
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString as BW
-------------------------------------------------
@@ -34,11 +36,12 @@
removeLength _ = Nothing
checkNetCmd :: B.ByteString -> (Bool, Bool)
-checkNetCmd = check . liftM B.unpack . fromEngineMsg
+checkNetCmd msg = check decoded
where
+ decoded = fromEngineMsg msg
check Nothing = (False, False)
- check (Just (m:_)) = (m `Set.member` legalMessages, m == '+')
- check _ = (False, False)
+ check (Just ms) | B.length ms > 0 = let m = B.head ms in (m `Set.member` legalMessages, m == '+')
+ | otherwise = (False, False)
legalMessages = Set.fromList $ "M#+LlRrUuDdZzAaSjJ,sFNpPwtghbc12345" ++ slotMessages
slotMessages = "\128\129\130\131\132\133\134\135\136\137\138"
@@ -56,7 +59,7 @@
: teamvoicepack team
: teamflag team
: teamowner team
- : (B.pack . show $ difficulty team)
+ : (showB . difficulty $ team)
: hhsInfo
where
hhsInfo = concatMap (\(HedgehogInfo n hat) -> [n, hat]) $ hedgehogs team
@@ -72,9 +75,7 @@
t : replaceTeam tm ts
illegalName :: B.ByteString -> Bool
-illegalName b = null s || all isSpace s || isSpace (head s) || isSpace (last s)
- where
- s = B.unpack b
+illegalName s = B.null s || B.all isSpace s || isSpace (B.head s) || isSpace (B.last s)
protoNumber2ver :: Word16 -> B.ByteString
protoNumber2ver v = Map.findWithDefault "Unknown" v vermap
@@ -115,5 +116,11 @@
Right (a, new_b) -> let (a', b') = unfoldrE f new_b in (a : a', b')
Left new_b -> ([], new_b)
-showB :: Show a => a -> B.ByteString
-showB = B.pack .show
+showB :: (BS.Show a) => a -> B.ByteString
+showB = B.concat . BL.toChunks . BS.show
+
+readInt_ :: (Num a) => B.ByteString -> a
+readInt_ str =
+ case B.readInt str of
+ Just (i, t) | B.null t -> fromIntegral i
+ _ -> 0
--- a/gameServer/hedgewars-server.cabal Sun Mar 20 15:22:55 2011 -0400
+++ b/gameServer/hedgewars-server.cabal Mon Mar 21 21:23:39 2011 +0300
@@ -20,6 +20,7 @@
containers,
array,
bytestring,
+ bytestring-show,
network-bytestring,
network,
time,