merge
authorunc0rr
Mon, 21 Mar 2011 21:23:39 +0300
changeset 5036 cb5fa93c7ae0
parent 5032 813554ab76b8 (diff)
parent 5035 a00636066077 (current diff)
child 5037 1edc06d2247c
merge
--- 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,