author | unc0rr |
Sun, 30 Jan 2011 21:33:39 +0300 | |
changeset 4887 | 39f300fdbc64 |
parent 4866 | 64572716e097 |
child 4904 | 0eab727d4717 |
permissions | -rw-r--r-- |
1804 | 1 |
module Utils where |
2 |
||
3 |
import Control.Concurrent |
|
4 |
import Control.Concurrent.STM |
|
5 |
import Data.Char |
|
6 |
import Data.Word |
|
7 |
import qualified Data.Map as Map |
|
8 |
import qualified Data.IntMap as IntMap |
|
2304 | 9 |
import qualified Data.Set as Set |
2310 | 10 |
import Data.ByteString.Internal (w2c) |
1917 | 11 |
import Numeric |
12 |
import Network.Socket |
|
1964 | 13 |
import System.IO |
1917 | 14 |
import qualified Data.List as List |
2349 | 15 |
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
|
16 |
import Data.Maybe |
1804 | 17 |
------------------------------------------------- |
18 |
import qualified Codec.Binary.Base64 as Base64 |
|
4568 | 19 |
import qualified Data.ByteString.UTF8 as BUTF8 |
20 |
import qualified Data.ByteString as B |
|
1804 | 21 |
import CoreTypes |
22 |
||
1917 | 23 |
|
4568 | 24 |
sockAddr2String :: SockAddr -> IO String |
25 |
sockAddr2String (SockAddrInet _ hostAddr) = inet_ntoa hostAddr |
|
1917 | 26 |
sockAddr2String (SockAddrInet6 _ _ (a, b, c, d) _) = |
4568 | 27 |
return $ (foldr1 (.) |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
28 |
$ List.intersperse (\a -> ':':a) |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
29 |
$ concatMap (\n -> (\(a, b) -> [showHex a, showHex b]) $ divMod n 65536) [a, b, c, d]) [] |
1917 | 30 |
|
4568 | 31 |
toEngineMsg :: String -> String |
32 |
toEngineMsg msg = Base64.encode (fromIntegral (B.length encodedMsg) : (B.unpack encodedMsg)) |
|
33 |
where |
|
34 |
encodedMsg = BUTF8.fromString msg |
|
1804 | 35 |
|
4568 | 36 |
fromEngineMsg :: String -> Maybe String |
37 |
fromEngineMsg msg = liftM (map w2c) (Base64.decode msg >>= removeLength) |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
38 |
where |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
39 |
removeLength (x:xs) = if length xs == fromIntegral x then Just xs else Nothing |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
40 |
removeLength _ = Nothing |
2304 | 41 |
|
4568 | 42 |
checkNetCmd :: String -> (Bool, Bool) |
43 |
checkNetCmd msg = check decoded |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
44 |
where |
4568 | 45 |
decoded = fromEngineMsg msg |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
46 |
check Nothing = (False, False) |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
47 |
check (Just (m:ms)) = (m `Set.member` legalMessages, m == '+') |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
48 |
check _ = (False, False) |
4570
fa19f0579083
Merge unc0rr's rearranging of MAP/MAPGEN messages, also his suggested increase of char limit to 20000 and addition of the "c" game message
nemo
parents:
4568
diff
changeset
|
49 |
legalMessages = Set.fromList $ "M#+LlRrUuDdZzAaSjJ,sFNpPwtghbc12345" ++ slotMessages |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
50 |
slotMessages = "\128\129\130\131\132\133\134\135\136\137\138" |
1804 | 51 |
|
52 |
maybeRead :: Read a => String -> Maybe a |
|
53 |
maybeRead s = case reads s of |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
54 |
[(x, rest)] | all isSpace rest -> Just x |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
55 |
_ -> Nothing |
1804 | 56 |
|
4568 | 57 |
teamToNet :: Word16 -> TeamInfo -> [String] |
58 |
teamToNet protocol team |
|
59 |
| protocol < 30 = [ |
|
60 |
"ADD_TEAM", |
|
61 |
teamname team, |
|
62 |
teamgrave team, |
|
63 |
teamfort team, |
|
64 |
teamvoicepack team, |
|
65 |
teamowner team, |
|
66 |
show $ difficulty team |
|
67 |
] |
|
68 |
++ hhsInfo |
|
69 |
| otherwise = [ |
|
70 |
"ADD_TEAM", |
|
71 |
teamname team, |
|
72 |
teamgrave team, |
|
73 |
teamfort team, |
|
74 |
teamvoicepack team, |
|
75 |
teamflag team, |
|
76 |
teamowner team, |
|
77 |
show $ difficulty team |
|
78 |
] |
|
79 |
++ hhsInfo |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
80 |
where |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
81 |
hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team |
1804 | 82 |
|
83 |
modifyTeam :: TeamInfo -> RoomInfo -> RoomInfo |
|
84 |
modifyTeam team room = room{teams = replaceTeam team $ teams room} |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
85 |
where |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
86 |
replaceTeam _ [] = error "modifyTeam: no such team" |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
87 |
replaceTeam team (t:teams) = |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
88 |
if teamname team == teamname t then |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
89 |
team : teams |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
90 |
else |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
91 |
t : replaceTeam team teams |
1804 | 92 |
|
4568 | 93 |
illegalName :: String -> Bool |
4866
64572716e097
Disallow isSpace chars at start and end of nicknames and room names
unc0rr
parents:
4693
diff
changeset
|
94 |
illegalName s = null s || all isSpace s || isSpace (head s) || isSpace (last s) |
2150
45b695f3a7b9
Forbid room names and nicknames consisting only of space characters
unc0rr
parents:
2113
diff
changeset
|
95 |
|
4568 | 96 |
protoNumber2ver :: Word16 -> String |
1804 | 97 |
protoNumber2ver 17 = "0.9.7-dev" |
98 |
protoNumber2ver 19 = "0.9.7" |
|
99 |
protoNumber2ver 20 = "0.9.8-dev" |
|
100 |
protoNumber2ver 21 = "0.9.8" |
|
101 |
protoNumber2ver 22 = "0.9.9-dev" |
|
102 |
protoNumber2ver 23 = "0.9.9" |
|
103 |
protoNumber2ver 24 = "0.9.10-dev" |
|
104 |
protoNumber2ver 25 = "0.9.10" |
|
1953 | 105 |
protoNumber2ver 26 = "0.9.11-dev" |
2113 | 106 |
protoNumber2ver 27 = "0.9.11" |
107 |
protoNumber2ver 28 = "0.9.12-dev" |
|
2448 | 108 |
protoNumber2ver 29 = "0.9.12" |
109 |
protoNumber2ver 30 = "0.9.13-dev" |
|
3297 | 110 |
protoNumber2ver 31 = "0.9.13" |
111 |
protoNumber2ver 32 = "0.9.14-dev" |
|
4266 | 112 |
protoNumber2ver 33 = "0.9.14" |
113 |
protoNumber2ver 34 = "0.9.15-dev" |
|
4326 | 114 |
protoNumber2ver 35 = "0.9.14.1" |
4693 | 115 |
protoNumber2ver 37 = "0.9.15" |
116 |
protoNumber2ver 38 = "0.9.16-dev" |
|
117 |
protoNumber2ver w = show w |
|
1804 | 118 |
|
1964 | 119 |
askFromConsole :: String -> IO String |
120 |
askFromConsole msg = do |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
121 |
putStr msg |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
122 |
hFlush stdout |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2747
diff
changeset
|
123 |
getLine |