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