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 CPP, OverloadedStrings #-}
20
21#if defined(OFFICIAL_SERVER)
22module EngineInteraction(replayToDemo, checkNetCmd, toEngineMsg, drawnMapData, prependGhostPoints) where
23#else
24module EngineInteraction(checkNetCmd, toEngineMsg) where
25#endif
26
27import qualified Data.Set as Set
28import Control.Monad
29import qualified Codec.Binary.Base64 as Base64
30import qualified Data.ByteString.Char8 as B
31import qualified Data.ByteString as BW
32import qualified Data.ByteString.Lazy as BL
33import qualified Data.Map as Map
34import qualified Data.List as L
35import Data.Word
36import Data.Int
37import Data.Bits
38import Control.Arrow
39import Data.Maybe
40import Data.Binary
41import Data.Binary.Put
42-------------
43import CoreTypes
44import Utils
45
46#if defined(OFFICIAL_SERVER)
47import qualified Codec.Compression.Zlib.Internal as ZI
48import qualified Codec.Compression.Zlib as Z
49
50decompressWithoutExceptions :: BL.ByteString -> BL.ByteString
51decompressWithoutExceptions = BL.fromChunks . ZI.foldDecompressStreamWithInput chunk end err decomp
52    where
53        decomp = ZI.decompressST ZI.zlibFormat ZI.defaultDecompressParams
54        chunk = (:)
55        end _ = []
56        err = const $ [BW.empty]
57#endif
58
59toEngineMsg :: B.ByteString -> B.ByteString
60toEngineMsg msg = Base64.encode (fromIntegral (BW.length msg) `BW.cons` msg)
61
62
63{-fromEngineMsg :: B.ByteString -> Maybe B.ByteString
64fromEngineMsg msg = liftM BW.pack (Base64.decode (B.unpack msg) >>= removeLength)
65    where
66        removeLength (x:xs) = if length xs == fromIntegral x then Just xs else Nothing
67        removeLength _ = Nothing-}
68
69em :: B.ByteString -> B.ByteString
70em = toEngineMsg
71
72eml :: [B.ByteString] -> B.ByteString
73eml = em . B.concat
74
75splitMessages :: B.ByteString -> [B.ByteString]
76splitMessages = L.unfoldr (\b -> if B.null b then Nothing else Just $ B.splitAt (1 + fromIntegral (BW.head b)) b)
77
78
79checkNetCmd :: [Word8] -> B.ByteString -> (B.ByteString, B.ByteString, Maybe (Maybe B.ByteString))
80checkNetCmd teamsIndexes msg = check decoded
81    where
82        decoded = liftM splitMessages $ Base64.decode msg
83        check (Left _) = (B.empty, B.empty, Nothing)
84        check (Right msgs) = let (a, b) = (filter isLegal msgs, filter isNonEmpty a) in (encode a, encode b, lft a)
85        encode = Base64.encode . B.concat
86        isLegal m = (B.length m > 1) && (flip Set.member legalMessages . B.head . B.tail $ m) && not (isMalformed (B.head m) (B.tail m))
87        lft = foldr l Nothing
88        l m n = let m' = B.head $ B.tail m; tst = flip Set.member in
89                      if not $ tst timedMessages m' then n
90                        else if '+' /= m' then Just Nothing else Just . Just . Base64.encode $ m
91        isNonEmpty = (/=) '+' . B.head . B.tail
92        legalMessages = Set.fromList $ "M#+LlRrUuDdZzAaSjJ,NpPwtgfhbc12345" ++ slotMessages
93        slotMessages = "\128\129\130\131\132\133\134\135\136\137\138"
94        timedMessages = Set.fromList $ "+LlRrUuDdZzAaSjJ,NpPwtgfc12345" ++ slotMessages
95        isMalformed 'h' m | B.length m >= 3 = let hognum = m `B.index` 1; teamnum = m `BW.index` 2 in hognum < '1' || hognum > '8' || teamnum `L.notElem` teamsIndexes
96                          | otherwise = True
97        isMalformed _ _ = False
98
99#if defined(OFFICIAL_SERVER)
100replayToDemo :: [TeamInfo]
101        -> Map.Map B.ByteString B.ByteString
102        -> Map.Map B.ByteString [B.ByteString]
103        -> [B.ByteString]
104        -> (Maybe GameDetails, [B.ByteString])
105replayToDemo ti mParams prms msgs = if not sane then (Nothing, []) else (Just $ GameDetails scriptName infRopes vamp infattacks, concat [
106        [em "TD"]
107        , maybeScript
108        , maybeMap
109        , [eml ["etheme ", head $ prms Map.! "THEME"]]
110        , [eml ["eseed ", mParams Map.! "SEED"]]
111        , [eml ["e$gmflags ", showB gameFlags]]
112        , schemeFlags
113        , schemeAdditional
114        , [eml ["e$template_filter ", mParams Map.! "TEMPLATE"]]
115        , [eml ["e$feature_size ", mParams Map.! "FEATURE_SIZE"]]
116        , [eml ["e$mapgen ", mapgen]]
117        , mapgenSpecific
118        , concatMap teamSetup ti
119        , msgs
120        , [em "!"]
121        ])
122    where
123        keys1, keys2 :: Set.Set B.ByteString
124        keys1 = Set.fromList ["FEATURE_SIZE", "MAP", "MAPGEN", "MAZE_SIZE", "SEED", "TEMPLATE"]
125        keys2 = Set.fromList ["AMMO", "SCHEME", "SCRIPT", "THEME"]
126        sane = Set.null (keys1 Set.\\ Map.keysSet mParams)
127            && Set.null (keys2 Set.\\ Map.keysSet prms)
128            && (not . null . drop 41 $ scheme)
129            && (not . null . tail $ prms Map.! "AMMO")
130            && ((B.length . head . tail $ prms Map.! "AMMO") > 200)
131        mapGenTypes = ["+rnd+", "+maze+", "+drawn+", "+perlin+"]
132        scriptName = head . fromMaybe ["Normal"] $ Map.lookup "SCRIPT" prms
133        maybeScript = let s = scriptName in if s == "Normal" then [] else [eml ["escript Scripts/Multiplayer/", spaces2Underlining s, ".lua"]]
134        maybeMap = let m = mParams Map.! "MAP" in if m `elem` mapGenTypes then [] else [eml ["emap ", m]]
135        scheme = tail $ prms Map.! "SCHEME"
136        mapgen = mParams Map.! "MAPGEN"
137        mazeSizeMsg = eml ["e$maze_size ", mParams Map.! "MAZE_SIZE"]
138        mapgenSpecific = case mapgen of
139            "1" -> [mazeSizeMsg]
140            "2" -> [mazeSizeMsg]
141            "3" -> let d = head . fromMaybe [""] $ Map.lookup "DRAWNMAP" prms in if BW.length d <= 4 then [] else drawnMapData d
142            _ -> []
143        gameFlags :: Word32
144        gameFlags = foldl (\r (b, f) -> if b == "false" then r else r .|. f) 0 $ zip scheme gameFlagConsts
145        schemeFlags = map (\(v, (n, m)) -> eml [n, " ", showB $ (readInt_ v) * m])
146            $ filter (\(_, (n, _)) -> not $ B.null n)
147            $ zip (drop (length gameFlagConsts) scheme) schemeParams
148        schemeAdditional = let scriptParam = B.tail $ scheme !! 42 in [eml ["e$scriptparam ", scriptParam] | not $ B.null scriptParam]
149        ammoStr :: B.ByteString
150        ammoStr = head . tail $ prms Map.! "AMMO"
151        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
152                   (map (\(x, y) -> eml [x, " ", y]) $ zip ["eammloadt", "eammprob", "eammdelay", "eammreinf"] [a, b, c, d])
153                   ++ [em "eammstore" | scheme !! 14 == "true" || scheme !! 20 == "false"]
154        initHealth = scheme !! 27
155        teamSetup :: TeamInfo -> [B.ByteString]
156        teamSetup t = (++) ammo $
157                eml ["eaddteam <hash> ", showB $ (1 + (readInt_ $ teamcolor t) :: Int) * 2113696, " ", teamname t]
158                : em "erdriven"
159                : eml ["efort ", teamfort t]
160                : take (2 * hhnum t) (
161                    concatMap (\(HedgehogInfo hname hhat) -> [
162                            eml ["eaddhh ", showB $ difficulty t, " ", initHealth, " ", hname]
163                            , eml ["ehat ", hhat]
164                            ])
165                        $ hedgehogs t
166                        )
167        infRopes = ammoStr `B.index` 7  == '9'
168        vamp = gameFlags .&. 0x00000200 /= 0
169        infattacks = gameFlags .&. 0x00100000 /= 0
170        spaces2Underlining = B.map (\c -> if c == ' ' then '_' else c)
171
172drawnMapData :: B.ByteString -> [B.ByteString]
173drawnMapData =
174          L.map (\m -> eml ["edraw ", BW.pack m])
175        . L.unfoldr by200
176        . BL.unpack
177        . unpackDrawnMap
178    where
179        by200 :: [a] -> Maybe ([a], [a])
180        by200 [] = Nothing
181        by200 m = Just $ L.splitAt 200 m
182
183unpackDrawnMap :: B.ByteString -> BL.ByteString
184unpackDrawnMap = either
185        (const BL.empty)
186        (decompressWithoutExceptions . BL.pack . drop 4 . BW.unpack)
187        . Base64.decode
188
189compressWithLength :: BL.ByteString -> BL.ByteString
190compressWithLength b = BL.drop 8 . encode . runPut $ do
191    put $ ((fromIntegral $ BL.length b)::Word32)
192    mapM_ putWord8 $ BW.unpack $ BL.toStrict $ Z.compress b
193
194packDrawnMap :: BL.ByteString -> B.ByteString
195packDrawnMap =
196      Base64.encode
197    . BL.toStrict
198    . compressWithLength
199
200prependGhostPoints :: [(Int16, Int16)] -> B.ByteString -> B.ByteString
201prependGhostPoints pts dm = packDrawnMap $ (runPut $ forM_ pts $ \(x, y) -> put x >> put y >> putWord8 99) `BL.append` unpackDrawnMap dm
202
203schemeParams :: [(B.ByteString, Int)]
204schemeParams = [
205      ("e$damagepct", 1)
206    , ("e$turntime", 1000)
207    , ("", 0)
208    , ("e$sd_turns", 1)
209    , ("e$casefreq", 1)
210    , ("e$minestime", 1000)
211    , ("e$minesnum", 1)
212    , ("e$minedudpct", 1)
213    , ("e$explosives", 1)
214    , ("e$airmines", 1)
215    , ("e$healthprob", 1)
216    , ("e$hcaseamount", 1)
217    , ("e$waterrise", 1)
218    , ("e$healthdec", 1)
219    , ("e$ropepct", 1)
220    , ("e$getawaytime", 1)
221    , ("e$worldedge", 1)
222    ]
223
224
225gameFlagConsts :: [Word32]
226gameFlagConsts = [
227          0x00001000
228        , 0x00000010
229        , 0x00000004
230        , 0x00000008
231        , 0x00000020
232        , 0x00000040
233        , 0x00000080
234        , 0x00000100
235        , 0x00000200
236        , 0x00000400
237        , 0x00000800
238        , 0x00002000
239        , 0x00004000
240        , 0x00008000
241        , 0x00010000
242        , 0x00020000
243        , 0x00040000
244        , 0x00080000
245        , 0x00100000
246        , 0x00200000
247        , 0x00400000
248        , 0x00800000
249        , 0x01000000
250        , 0x02000000
251        , 0x04000000
252        ]
253#endif
254