12 import Numeric |
11 import Numeric |
13 import Network.Socket |
12 import Network.Socket |
14 import System.IO |
13 import System.IO |
15 import qualified Data.List as List |
14 import qualified Data.List as List |
16 import Control.Monad |
15 import Control.Monad |
17 import Data.Maybe |
16 import Maybe |
18 ------------------------------------------------- |
17 ------------------------------------------------- |
19 import qualified Codec.Binary.Base64 as Base64 |
18 import qualified Codec.Binary.Base64 as Base64 |
20 import qualified Data.ByteString.Char8 as B |
19 import qualified Data.ByteString.UTF8 as BUTF8 |
21 import qualified Data.ByteString as BW |
20 import qualified Data.ByteString as B |
22 import CoreTypes |
21 import CoreTypes |
23 |
22 |
24 |
23 |
25 sockAddr2String :: SockAddr -> IO B.ByteString |
24 sockAddr2String :: SockAddr -> IO String |
26 sockAddr2String (SockAddrInet _ hostAddr) = liftM B.pack $ inet_ntoa hostAddr |
25 sockAddr2String (SockAddrInet _ hostAddr) = inet_ntoa hostAddr |
27 sockAddr2String (SockAddrInet6 _ _ (a, b, c, d) _) = |
26 sockAddr2String (SockAddrInet6 _ _ (a, b, c, d) _) = |
28 return $ B.pack $ (foldr1 (.) |
27 return $ (foldr1 (.) |
29 $ List.intersperse (\a -> ':':a) |
28 $ List.intersperse (\a -> ':':a) |
30 $ concatMap (\n -> (\(a, b) -> [showHex a, showHex b]) $ divMod n 65536) [a, b, c, d]) [] |
29 $ concatMap (\n -> (\(a, b) -> [showHex a, showHex b]) $ divMod n 65536) [a, b, c, d]) [] |
31 |
30 |
32 toEngineMsg :: B.ByteString -> B.ByteString |
31 toEngineMsg :: String -> String |
33 toEngineMsg msg = B.pack $ Base64.encode (fromIntegral (BW.length msg) : (BW.unpack msg)) |
32 toEngineMsg msg = Base64.encode (fromIntegral (B.length encodedMsg) : (B.unpack encodedMsg)) |
|
33 where |
|
34 encodedMsg = BUTF8.fromString msg |
34 |
35 |
35 fromEngineMsg :: B.ByteString -> Maybe B.ByteString |
36 fromEngineMsg :: String -> Maybe String |
36 fromEngineMsg msg = Base64.decode (B.unpack msg) >>= removeLength >>= return . BW.pack |
37 fromEngineMsg msg = liftM (map w2c) (Base64.decode msg >>= removeLength) |
37 where |
38 where |
38 removeLength (x:xs) = if length xs == fromIntegral x then Just xs else Nothing |
39 removeLength (x:xs) = if length xs == fromIntegral x then Just xs else Nothing |
39 removeLength _ = Nothing |
40 removeLength _ = Nothing |
40 |
41 |
41 checkNetCmd :: B.ByteString -> (Bool, Bool) |
42 checkNetCmd :: String -> (Bool, Bool) |
42 checkNetCmd = check . liftM B.unpack . fromEngineMsg |
43 checkNetCmd msg = check decoded |
43 where |
44 where |
|
45 decoded = fromEngineMsg msg |
44 check Nothing = (False, False) |
46 check Nothing = (False, False) |
45 check (Just (m:ms)) = (m `Set.member` legalMessages, m == '+') |
47 check (Just (m:ms)) = (m `Set.member` legalMessages, m == '+') |
46 check _ = (False, False) |
48 check _ = (False, False) |
47 legalMessages = Set.fromList $ "M#+LlRrUuDdZzAaSjJ,sFNpPwtghb12345" ++ slotMessages |
49 legalMessages = Set.fromList $ "M#+LlRrUuDdZzAaSjJ,sFNpPwtghb12345" ++ slotMessages |
48 slotMessages = "\128\129\130\131\132\133\134\135\136\137\138" |
50 slotMessages = "\128\129\130\131\132\133\134\135\136\137\138" |
50 maybeRead :: Read a => String -> Maybe a |
52 maybeRead :: Read a => String -> Maybe a |
51 maybeRead s = case reads s of |
53 maybeRead s = case reads s of |
52 [(x, rest)] | all isSpace rest -> Just x |
54 [(x, rest)] | all isSpace rest -> Just x |
53 _ -> Nothing |
55 _ -> Nothing |
54 |
56 |
55 teamToNet :: TeamInfo -> [B.ByteString] |
57 teamToNet :: Word16 -> TeamInfo -> [String] |
56 teamToNet team = |
58 teamToNet protocol team |
57 "ADD_TEAM" |
59 | protocol < 30 = [ |
58 : teamname team |
60 "ADD_TEAM", |
59 : teamgrave team |
61 teamname team, |
60 : teamfort team |
62 teamgrave team, |
61 : teamvoicepack team |
63 teamfort team, |
62 : teamflag team |
64 teamvoicepack team, |
63 : teamowner team |
65 teamowner team, |
64 : (B.pack $ show $ difficulty team) |
66 show $ difficulty team |
65 : hhsInfo |
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 |
66 where |
80 where |
67 hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team |
81 hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team |
68 |
82 |
69 modifyTeam :: TeamInfo -> RoomInfo -> RoomInfo |
83 modifyTeam :: TeamInfo -> RoomInfo -> RoomInfo |
70 modifyTeam team room = room{teams = replaceTeam team $ teams room} |
84 modifyTeam team room = room{teams = replaceTeam team $ teams room} |
74 if teamname team == teamname t then |
88 if teamname team == teamname t then |
75 team : teams |
89 team : teams |
76 else |
90 else |
77 t : replaceTeam team teams |
91 t : replaceTeam team teams |
78 |
92 |
79 illegalName :: B.ByteString -> Bool |
93 illegalName :: String -> Bool |
80 illegalName = all isSpace . B.unpack |
94 illegalName = all isSpace |
81 |
95 |
82 protoNumber2ver :: Word16 -> B.ByteString |
96 protoNumber2ver :: Word16 -> String |
83 protoNumber2ver 17 = "0.9.7-dev" |
97 protoNumber2ver 17 = "0.9.7-dev" |
84 protoNumber2ver 19 = "0.9.7" |
98 protoNumber2ver 19 = "0.9.7" |
85 protoNumber2ver 20 = "0.9.8-dev" |
99 protoNumber2ver 20 = "0.9.8-dev" |
86 protoNumber2ver 21 = "0.9.8" |
100 protoNumber2ver 21 = "0.9.8" |
87 protoNumber2ver 22 = "0.9.9-dev" |
101 protoNumber2ver 22 = "0.9.9-dev" |