1 {-# LANGUAGE OverloadedStrings #-} |
1 {- |
2 |
2 * Hedgewars, a free turn based strategy game |
3 module EngineInteraction where |
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 CPP, OverloadedStrings #-} |
|
20 |
|
21 #if defined(OFFICIAL_SERVER) |
|
22 module EngineInteraction(replayToDemo, checkNetCmd, toEngineMsg, drawnMapData) where |
|
23 #else |
|
24 module EngineInteraction(checkNetCmd, toEngineMsg) where |
|
25 #endif |
4 |
26 |
5 import qualified Data.Set as Set |
27 import qualified Data.Set as Set |
6 import Control.Monad |
28 import Control.Monad |
7 import qualified Codec.Binary.Base64 as Base64 |
29 import qualified Codec.Binary.Base64 as Base64 |
8 import qualified Data.ByteString.Char8 as B |
30 import qualified Data.ByteString.Char8 as B |
9 import qualified Data.ByteString as BW |
31 import qualified Data.ByteString as BW |
|
32 import qualified Data.ByteString.Lazy as BL |
10 import qualified Data.Map as Map |
33 import qualified Data.Map as Map |
11 import qualified Data.List as L |
34 import qualified Data.List as L |
12 import Data.Word |
35 import Data.Word |
13 import Data.Bits |
36 import Data.Bits |
14 import Control.Arrow |
37 import Control.Arrow |
15 import Data.Maybe |
38 import Data.Maybe |
16 ------------- |
39 ------------- |
17 import CoreTypes |
40 import CoreTypes |
18 import Utils |
41 import Utils |
19 |
42 |
|
43 #if defined(OFFICIAL_SERVER) |
|
44 {- |
|
45 this is snippet from http://stackoverflow.com/questions/10043102/how-to-catch-the-decompress-ioerror |
|
46 because standard 'catch' doesn't seem to catch decompression errors for some reason |
|
47 -} |
|
48 import qualified Codec.Compression.Zlib.Internal as Z |
|
49 |
|
50 decompressWithoutExceptions :: BL.ByteString -> Either String BL.ByteString |
|
51 decompressWithoutExceptions = finalise |
|
52 . Z.foldDecompressStream cons nil err |
|
53 . Z.decompressWithErrors Z.zlibFormat Z.defaultDecompressParams |
|
54 where err _ msg = Left msg |
|
55 nil = Right [] |
|
56 cons chunk = right (chunk :) |
|
57 finalise = right BL.fromChunks |
|
58 {- end snippet -} |
|
59 #endif |
20 |
60 |
21 toEngineMsg :: B.ByteString -> B.ByteString |
61 toEngineMsg :: B.ByteString -> B.ByteString |
22 toEngineMsg msg = B.pack $ Base64.encode (fromIntegral (BW.length msg) : BW.unpack msg) |
62 toEngineMsg msg = B.pack $ Base64.encode (fromIntegral (BW.length msg) : BW.unpack msg) |
23 |
63 |
24 |
64 |
25 fromEngineMsg :: B.ByteString -> Maybe B.ByteString |
65 {-fromEngineMsg :: B.ByteString -> Maybe B.ByteString |
26 fromEngineMsg msg = liftM BW.pack (Base64.decode (B.unpack msg) >>= removeLength) |
66 fromEngineMsg msg = liftM BW.pack (Base64.decode (B.unpack msg) >>= removeLength) |
27 where |
67 where |
28 removeLength (x:xs) = if length xs == fromIntegral x then Just xs else Nothing |
68 removeLength (x:xs) = if length xs == fromIntegral x then Just xs else Nothing |
29 removeLength _ = Nothing |
69 removeLength _ = Nothing-} |
30 |
70 |
|
71 em :: B.ByteString -> B.ByteString |
|
72 em = toEngineMsg |
|
73 |
|
74 eml :: [B.ByteString] -> B.ByteString |
|
75 eml = em . B.concat |
31 |
76 |
32 splitMessages :: B.ByteString -> [B.ByteString] |
77 splitMessages :: B.ByteString -> [B.ByteString] |
33 splitMessages = L.unfoldr (\b -> if B.null b then Nothing else Just $ B.splitAt (1 + fromIntegral (BW.head b)) b) |
78 splitMessages = L.unfoldr (\b -> if B.null b then Nothing else Just $ B.splitAt (1 + fromIntegral (BW.head b)) b) |
34 |
79 |
35 |
80 |
40 check Nothing = (B.empty, B.empty, Nothing) |
85 check Nothing = (B.empty, B.empty, Nothing) |
41 check (Just msgs) = let (a, b) = (filter isLegal msgs, filter isNonEmpty a) in (encode a, encode b, lft a) |
86 check (Just msgs) = let (a, b) = (filter isLegal msgs, filter isNonEmpty a) in (encode a, encode b, lft a) |
42 encode = B.pack . Base64.encode . BW.unpack . B.concat |
87 encode = B.pack . Base64.encode . BW.unpack . B.concat |
43 isLegal m = (B.length m > 1) && (flip Set.member legalMessages . B.head . B.tail $ m) |
88 isLegal m = (B.length m > 1) && (flip Set.member legalMessages . B.head . B.tail $ m) |
44 lft = foldr l Nothing |
89 lft = foldr l Nothing |
45 l m n = let m' = B.head $ B.tail m; tst = flip Set.member in |
90 l m n = let m' = B.head $ B.tail m; tst = flip Set.member in |
46 if not $ tst timedMessages m' then n |
91 if not $ tst timedMessages m' then n |
47 else if '+' /= m' then Just Nothing else Just . Just . B.pack . Base64.encode . BW.unpack $ m |
92 else if '+' /= m' then Just Nothing else Just . Just . B.pack . Base64.encode . BW.unpack $ m |
48 isNonEmpty = (/=) '+' . B.head . B.tail |
93 isNonEmpty = (/=) '+' . B.head . B.tail |
49 legalMessages = Set.fromList $ "M#+LlRrUuDdZzAaSjJ,sNpPwtghbc12345" ++ slotMessages |
94 legalMessages = Set.fromList $ "M#+LlRrUuDdZzAaSjJ,sNpPwtgfhbc12345" ++ slotMessages |
50 slotMessages = "\128\129\130\131\132\133\134\135\136\137\138" |
95 slotMessages = "\128\129\130\131\132\133\134\135\136\137\138" |
51 timedMessages = Set.fromList $ "+LlRrUuDdZzAaSjJ,NpPwtgc12345" ++ slotMessages |
96 timedMessages = Set.fromList $ "+LlRrUuDdZzAaSjJ,NpPwtgfc12345" ++ slotMessages |
52 |
97 |
53 |
98 #if defined(OFFICIAL_SERVER) |
54 replayToDemo :: [TeamInfo] |
99 replayToDemo :: [TeamInfo] |
55 -> Map.Map B.ByteString B.ByteString |
100 -> Map.Map B.ByteString B.ByteString |
56 -> Map.Map B.ByteString [B.ByteString] |
101 -> Map.Map B.ByteString [B.ByteString] |
57 -> [B.ByteString] |
102 -> [B.ByteString] |
58 -> [B.ByteString] |
103 -> (Maybe GameDetails, [B.ByteString]) |
59 replayToDemo ti mParams prms msgs = concat [ |
104 replayToDemo ti mParams prms msgs = if not sane then (Nothing, []) else (Just $ GameDetails scriptName infRopes vamp infattacks, concat [ |
60 [em "TD"] |
105 [em "TD"] |
61 , maybeScript |
106 , maybeScript |
62 , maybeMap |
107 , maybeMap |
63 , [eml ["etheme ", head $ prms Map.! "THEME"]] |
108 , [eml ["etheme ", head $ prms Map.! "THEME"]] |
64 , [eml ["eseed ", mParams Map.! "SEED"]] |
109 , [eml ["eseed ", mParams Map.! "SEED"]] |
65 , [eml ["e$gmflags ", showB gameFlags]] |
110 , [eml ["e$gmflags ", showB gameFlags]] |
66 , schemeFlags |
111 , schemeFlags |
|
112 , schemeAdditional |
67 , [eml ["e$template_filter ", mParams Map.! "TEMPLATE"]] |
113 , [eml ["e$template_filter ", mParams Map.! "TEMPLATE"]] |
|
114 , [eml ["e$feature_size ", mParams Map.! "FEATURE_SIZE"]] |
68 , [eml ["e$mapgen ", mapgen]] |
115 , [eml ["e$mapgen ", mapgen]] |
69 , mapgenSpecific |
116 , mapgenSpecific |
70 , concatMap teamSetup ti |
117 , concatMap teamSetup ti |
71 , msgs |
118 , msgs |
72 , [em "!"] |
119 , [em "!"] |
73 ] |
120 ]) |
74 where |
121 where |
75 em = toEngineMsg |
122 keys1, keys2 :: Set.Set B.ByteString |
76 eml = em . B.concat |
123 keys1 = Set.fromList ["FEATURE_SIZE", "MAP", "MAPGEN", "MAZE_SIZE", "SEED", "TEMPLATE"] |
77 mapGenTypes = ["+rnd+", "+maze+", "+drawn+"] |
124 keys2 = Set.fromList ["AMMO", "SCHEME", "SCRIPT", "THEME"] |
78 maybeScript = let s = head . fromMaybe ["Normal"] $ Map.lookup "SCRIPT" prms in if s == "Normal" then [] else [eml ["escript Scripts/Multiplayer/", s, ".lua"]] |
125 sane = Set.null (keys1 Set.\\ Map.keysSet mParams) |
|
126 && Set.null (keys2 Set.\\ Map.keysSet prms) |
|
127 && (not . null . drop 41 $ scheme) |
|
128 && (not . null . tail $ prms Map.! "AMMO") |
|
129 && ((B.length . head . tail $ prms Map.! "AMMO") > 200) |
|
130 mapGenTypes = ["+rnd+", "+maze+", "+drawn+", "+perlin+"] |
|
131 scriptName = head . fromMaybe ["Normal"] $ Map.lookup "SCRIPT" prms |
|
132 maybeScript = let s = scriptName in if s == "Normal" then [] else [eml ["escript Scripts/Multiplayer/", spaces2Underlining s, ".lua"]] |
79 maybeMap = let m = mParams Map.! "MAP" in if m `elem` mapGenTypes then [] else [eml ["emap ", m]] |
133 maybeMap = let m = mParams Map.! "MAP" in if m `elem` mapGenTypes then [] else [eml ["emap ", m]] |
80 scheme = tail $ prms Map.! "SCHEME" |
134 scheme = tail $ prms Map.! "SCHEME" |
81 mapgen = mParams Map.! "MAPGEN" |
135 mapgen = mParams Map.! "MAPGEN" |
|
136 mazeSizeMsg = eml ["e$maze_size ", mParams Map.! "MAZE_SIZE"] |
82 mapgenSpecific = case mapgen of |
137 mapgenSpecific = case mapgen of |
83 "+maze+" -> [eml ["e$maze_size ", head $ prms Map.! "MAZE_SIZE"]] |
138 "1" -> [mazeSizeMsg] |
84 "+drawn" -> drawnMapData . head $ prms Map.! "DRAWNMAP" |
139 "2" -> [mazeSizeMsg] |
|
140 "3" -> let d = head . fromMaybe [""] $ Map.lookup "DRAWNMAP" prms in if BW.length d <= 4 then [] else drawnMapData d |
85 _ -> [] |
141 _ -> [] |
86 gameFlags :: Word32 |
142 gameFlags :: Word32 |
87 gameFlags = foldl (\r (b, f) -> if b == "false" then r else r .|. f) 0 $ zip scheme gameFlagConsts |
143 gameFlags = foldl (\r (b, f) -> if b == "false" then r else r .|. f) 0 $ zip scheme gameFlagConsts |
88 schemeFlags = map (\(v, (n, m)) -> eml [n, " ", showB $ (readInt_ v) * m]) |
144 schemeFlags = map (\(v, (n, m)) -> eml [n, " ", showB $ (readInt_ v) * m]) |
89 $ filter (\(_, (n, _)) -> not $ B.null n) |
145 $ filter (\(_, (n, _)) -> not $ B.null n) |
90 $ zip (drop (length gameFlagConsts) scheme) schemeParams |
146 $ zip (drop (length gameFlagConsts) scheme) schemeParams |
|
147 schemeAdditional = let scriptParam = B.tail $ scheme !! 41 in [eml ["e$scriptparam ", scriptParam] | not $ B.null scriptParam] |
91 ammoStr :: B.ByteString |
148 ammoStr :: B.ByteString |
92 ammoStr = head . tail $ prms Map.! "AMMO" |
149 ammoStr = head . tail $ prms Map.! "AMMO" |
93 ammo = let l = B.length ammoStr `div` 4; ((a, b), (c, d)) = (B.splitAt l . fst &&& B.splitAt l . snd) . B.splitAt (l * 2) $ ammoStr in |
150 ammo = let l = B.length ammoStr `div` 4; ((a, b), (c, d)) = (B.splitAt l . fst &&& B.splitAt l . snd) . B.splitAt (l * 2) $ ammoStr in |
94 (map (\(x, y) -> eml [x, " ", y]) $ zip ["eammloadt", "eammprob", "eammdelay", "eammreinf"] [a, b, c, d]) |
151 (map (\(x, y) -> eml [x, " ", y]) $ zip ["eammloadt", "eammprob", "eammdelay", "eammreinf"] [a, b, c, d]) |
95 ++ [em "eammstore" | scheme !! 14 == "true" || scheme !! 20 == "false"] |
152 ++ [em "eammstore" | scheme !! 14 == "true" || scheme !! 20 == "false"] |