1{- 2 * Hedgewars, a free turn based strategy game 3 * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com> 4 * 5 * This program is free software; you can redistribute it and/or modify 6 * it under the terms of the GNU General Public License as published by 7 * the Free Software Foundation; version 2 of the License 8 * 9 * This program is distributed in the hope that it will be useful, 10 * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 * GNU General Public License for more details. 13 * 14 * You should have received a copy of the GNU General Public License 15 * along with this program; if not, write to the Free Software 16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 17 \-} 18 19{-# LANGUAGE OverloadedStrings,CPP #-} 20module Utils where 21 22import Data.Char 23import Data.Word 24import qualified Data.Map as Map 25import qualified Data.Char as Char 26import Numeric 27import Network.Socket 28import System.IO 29import qualified Data.List as List 30import Control.Monad 31import qualified Data.ByteString.Lazy as BL 32import qualified Data.ByteString.Char8 as B 33import qualified Data.ByteString.UTF8 as UTF8 34import Data.Maybe 35#if defined(OFFICIAL_SERVER) 36import qualified Data.Aeson.Types as Aeson 37import qualified Data.Text as Text 38#endif 39------------------------------------------------- 40import CoreTypes 41 42 43sockAddr2String :: SockAddr -> IO B.ByteString 44sockAddr2String (SockAddrInet _ hostAddr) = liftM B.pack $ inet_ntoa hostAddr 45sockAddr2String (SockAddrInet6 _ _ (a, b, c, d) _) = 46 return $ B.pack $ (foldr1 (.) 47 $ List.intersperse (':':) 48 $ concatMap (\n -> (\(a0, a1) -> [showHex a0, showHex a1]) $ divMod n 65536) [a, b, c, d]) [] 49 50maybeRead :: Read a => String -> Maybe a 51maybeRead s = case reads s of 52 [(x, rest)] | all isSpace rest -> Just x 53 _ -> Nothing 54 55teamToNet :: TeamInfo -> [B.ByteString] 56teamToNet team = 57 "ADD_TEAM" 58 : teamname team 59 : teamgrave team 60 : teamfort team 61 : teamvoicepack team 62 : teamflag team 63 : teamowner team 64 : (showB . difficulty $ team) 65 : hhsInfo 66 where 67 hhsInfo = concatMap (\(HedgehogInfo n hat) -> [n, hat]) $ hedgehogs team 68 69modifyTeam :: TeamInfo -> RoomInfo -> RoomInfo 70modifyTeam team room = room{teams = replaceTeam team $ teams room} 71 where 72 replaceTeam _ [] = error "modifyTeam: no such team" 73 replaceTeam tm (t:ts) = 74 if teamname tm == teamname t then 75 tm : ts 76 else 77 t : replaceTeam tm ts 78 79-- NOTE: Don't forget to update the error messages when you change the naming rules! 80illegalName :: B.ByteString -> Bool 81illegalName b = B.null b || length s > 40 || all isSpace s || isSpace (head s) || isSpace (last s) || any isIllegalChar s 82 where 83 s = UTF8.toString b 84 isIllegalChar c = c `List.elem` ("$()*+?[]^{|}\x7F" ++ ['\x00'..'\x1F'] ++ ['\xFFF0'..'\xFFFF']) 85 86protoNumber2ver :: Word16 -> B.ByteString 87protoNumber2ver v = Map.findWithDefault "Unknown" v vermap 88 where 89 vermap = Map.fromList [ 90 (17, "0.9.7-dev") 91 , (19, "0.9.7") 92 , (20, "0.9.8-dev") 93 , (21, "0.9.8") 94 , (22, "0.9.9-dev") 95 , (23, "0.9.9") 96 , (24, "0.9.10-dev") 97 , (25, "0.9.10") 98 , (26, "0.9.11-dev") 99 , (27, "0.9.11") 100 , (28, "0.9.12-dev") 101 , (29, "0.9.12") 102 , (30, "0.9.13-dev") 103 , (31, "0.9.13") 104 , (32, "0.9.14-dev") 105 , (33, "0.9.14") 106 , (34, "0.9.15-dev") 107 , (35, "0.9.14.1") 108 , (37, "0.9.15") 109 , (38, "0.9.16-dev") 110 , (39, "0.9.16") 111 , (40, "0.9.17-dev") 112 , (41, "0.9.17") 113 , (42, "0.9.18-dev") 114 , (43, "0.9.18") 115 , (44, "0.9.19-dev") 116 , (45, "0.9.19") 117 , (46, "0.9.20-dev") 118 , (47, "0.9.20") 119 , (48, "0.9.21-dev") 120 , (49, "0.9.21") 121 , (50, "0.9.22-dev") 122 , (51, "0.9.22") 123 , (52, "0.9.23-dev") 124 , (53, "0.9.23") 125 , (54, "0.9.24-dev") 126 , (55, "0.9.24") 127 , (56, "0.9.25-dev") 128 , (57, "0.9.25") 129 , (58, "1.0.0-dev") 130 , (59, "1.0.0") 131 , (60, "1.0.1-dev") 132 ] 133 134askFromConsole :: B.ByteString -> IO B.ByteString 135askFromConsole msg = do 136 B.putStr msg 137 hFlush stdout 138 B.getLine 139 140 141unfoldrE :: (b -> Either b (a, b)) -> b -> ([a], b) 142unfoldrE f b = 143 case f b of 144 Right (a, new_b) -> let (a', b') = unfoldrE f new_b in (a : a', b') 145 Left new_b -> ([], new_b) 146 147showB :: (Show a) => a -> B.ByteString 148showB = B.pack . show 149 150readInt_ :: (Num a) => B.ByteString -> a 151readInt_ str = 152 case B.readInt str of 153 Just (i, t) | B.null t -> fromIntegral i 154 _ -> 0 155 156cutHost :: B.ByteString -> B.ByteString 157cutHost = B.intercalate "." . flip (++) ["*","*"] . List.take 2 . B.split '.' 158 159caseInsensitiveCompare :: B.ByteString -> B.ByteString -> Bool 160caseInsensitiveCompare a b = upperCase a == upperCase b 161 162upperCase :: B.ByteString -> B.ByteString 163upperCase = UTF8.fromString . map Char.toUpper . UTF8.toString 164 165roomInfo :: Word16 -> B.ByteString -> RoomInfo -> [B.ByteString] 166roomInfo p n r 167 | p < 46 = [ 168 showB $ isJust $ gameInfo r, 169 name r, 170 showB $ playersIn r, 171 showB $ length $ teams r, 172 n, 173 Map.findWithDefault "+rnd+" "MAP" (mapParams r), 174 head (Map.findWithDefault ["Default"] "SCHEME" (params r)), 175 head (Map.findWithDefault ["Default"] "AMMO" (params r)) 176 ] 177 | p < 48 = [ 178 showB $ isJust $ gameInfo r, 179 name r, 180 showB $ playersIn r, 181 showB $ length $ teams r, 182 n, 183 Map.findWithDefault "+rnd+" "MAP" (mapParams r), 184 head (Map.findWithDefault ["Normal"] "SCRIPT" (params r)), 185 head (Map.findWithDefault ["Default"] "SCHEME" (params r)), 186 head (Map.findWithDefault ["Default"] "AMMO" (params r)) 187 ] 188 | otherwise = [ 189 B.pack roomFlags, 190 name r, 191 showB $ playersIn r, 192 showB $ length $ teams r, 193 n, 194 Map.findWithDefault "+rnd+" "MAP" (mapParams r), 195 head (Map.findWithDefault ["Normal"] "SCRIPT" (params r)), 196 head (Map.findWithDefault ["Default"] "SCHEME" (params r)), 197 head (Map.findWithDefault ["Default"] "AMMO" (params r)) 198 ] 199 where 200 roomFlags = concat [ 201 "-" 202 , ['g' | isJust $ gameInfo r] 203 , ['p' | not . B.null $ password r] 204 , ['j' | isRestrictedJoins r] 205 , ['r' | isRegisteredOnly r] 206 ] 207 208answerFullConfigParams :: 209 ClientInfo 210 -> Map.Map B.ByteString B.ByteString 211 -> Map.Map B.ByteString [B.ByteString] 212 -> [Action] 213answerFullConfigParams cl mpr pr 214 | clientProto cl < 38 = map (toAnswer cl) $ 215 (reverse . map (\(a, b) -> (a, [b])) $ Map.toList mpr) 216 ++ (("SCHEME", pr Map.! "SCHEME") 217 : (filter (\(p, _) -> p /= "SCHEME") $ Map.toList pr)) 218 219 | clientProto cl < 48 = map (toAnswer cl) $ 220 ("FULLMAPCONFIG", let l = Map.elems mpr in if length l > 5 then tail l else l) 221 : ("SCHEME", pr Map.! "SCHEME") 222 : (filter (\(p, _) -> p /= "SCHEME") $ Map.toList pr) 223 224 | otherwise = map (toAnswer cl) $ 225 ("FULLMAPCONFIG", Map.elems mpr) 226 : ("SCHEME", pr Map.! "SCHEME") 227 : (filter (\(p, _) -> p /= "SCHEME") $ Map.toList pr) 228 where 229 toAnswer cl (paramName, paramStrs) = AnswerClients [sendChan cl] $ "CFG" : paramName : paramStrs 230 231 232answerAllTeams :: ClientInfo -> [TeamInfo] -> [Action] 233answerAllTeams cl = concatMap toAnswer 234 where 235 clChan = sendChan cl 236 toAnswer team = 237 [AnswerClients [clChan] $ teamToNet team, 238 AnswerClients [clChan] ["TEAM_COLOR", teamname team, teamcolor team], 239 AnswerClients [clChan] ["HH_NUM", teamname team, showB $ hhnum team]] 240 241 242-- Locale function to localize strings. 243-- loc is just the identity functions, but it will be collected by scripts 244-- for localization. Use loc to mark a string for translation. 245loc :: B.ByteString -> B.ByteString 246loc = id 247 248maybeNick :: Maybe ClientInfo -> B.ByteString 249maybeNick = fromMaybe "[]" . liftM nick 250 251-- borrowed from Data.List, just more general in types 252deleteBy2 :: (a -> b -> Bool) -> a -> [b] -> [b] 253deleteBy2 _ _ [] = [] 254deleteBy2 eq x (y:ys) = if x `eq` y then ys else y : deleteBy2 eq x ys 255 256deleteFirstsBy2 :: (a -> b -> Bool) -> [a] -> [b] -> [a] 257deleteFirstsBy2 eq = foldl (flip (deleteBy2 (flip eq))) 258 259sanitizeName :: B.ByteString -> B.ByteString 260sanitizeName = B.map sc 261 where 262 sc c | isAlphaNum c = c 263 | otherwise = '_' 264 265isRegistered :: ClientInfo -> Bool 266isRegistered = (<) 0 . B.length . webPassword 267 268#if defined(OFFICIAL_SERVER) 269instance Aeson.ToJSON B.ByteString where 270 toJSON = Aeson.toJSON . B.unpack 271 272instance Aeson.FromJSON B.ByteString where 273 parseJSON = Aeson.withText "ByteString" $ pure . B.pack . Text.unpack 274 275instance Aeson.ToJSONKey B.ByteString where 276 toJSONKey = Aeson.toJSONKeyText (Text.pack . B.unpack) 277 278instance Aeson.FromJSONKey B.ByteString where 279 fromJSONKey = Aeson.FromJSONKeyTextParser (return . B.pack . Text.unpack) 280#endif 281