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