{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} module HaxParse.Parser where import Codec.Compression.Zlib import Control.Applicative ((<$>), (<*>), pure) import Control.Monad import Data.Binary import Data.Binary.Get import Data.Binary.IEEE754 import Data.Bits import qualified Data.ByteString.Lazy.Char8 as C import Data.Char import Data.Default import qualified Data.IntMap as I import Data.Monoid import HaxParse.AST import Numeric import Prelude hiding (Left, Right) import Text.Parsec.Char import Text.Parsec.Combinator import Text.Parsec.Error import Text.Parsec.Prim data ParserState = ParserState { frame :: Word32 , curDiscId :: Word32 , playerList :: I.IntMap Player } instance Default ParserState where def = ParserState 0 0 mempty type Parser = Parsec C.ByteString ParserState instance (Monad m) => Stream C.ByteString m Char where uncons = return . C.uncons parseFromFile :: Parser a -> FilePath -> IO (Either ParseError a) parseFromFile p fname = do inp <- C.readFile fname return (runP p def fname inp) parseFile :: FilePath -> IO (Either ParseError Replay) parseFile m = parseFromFile haxParser m haxParser :: Parser Replay haxParser = do vers <- int32 header <- count 4 anyChar when (header /= "HBRP") . fail $ "Did not find correct HBR header. Expected HBRP, found " ++ show header framecount <- int32 setInput . decompress =<< getInput firstframe <- int32 r <- room_ prog <- bool d <- if prog then discs_ else pure [] players_ count 14 $ char '\NUL' ev <- many event plist <- fmap playerList getState return Replay { version = vers , frameCount = framecount , firstFrame = firstframe , room = r , inProgress = prog , discs = d , players = plist , events = ev } room_ :: Parser Room room_ = do roomname <- str l <- bool scorelimit <- int8 timelimit <- int8 r <- int32 kotaken <- bool koside <- side ballx <- double bally <- double redscore <- int32 bluescore <- int32 time <- double pausetimer <- int8 st <- stadium_ return Room { roomName = roomname , locked = l , scoreLimit = scorelimit , timeLimit = timelimit , rules = r , kickoffTaken = kotaken , kickoffSide = koside , ballCoords = (ballx, bally) , redScore = redscore , blueScore = bluescore , timer = time , pauseTimer = pausetimer , stadium = st } int64 :: Parser Word64 int64 = do s <- count 8 anyChar return $ runGet getWord64be $ C.pack s double :: Parser Double double = do s <- count 8 anyChar return $ runGet getFloat64be $ C.pack s int32 :: Parser Word32 int32 = do s <- count 4 anyChar return $ runGet getWord32be $ C.pack s int16 :: Parser Word16 int16 = do s <- count 2 anyChar return $ runGet getWord16be $ C.pack s int8 :: Parser Word8 int8 = fromIntegral . ord <$> anyChar str :: Parser C.ByteString str = do len <- int16 C.pack <$> count (fromIntegral len) anyChar bool :: Parser Bool bool = do m <- ord <$> anyChar case m of 0 -> return False 1 -> return True x -> fail $ "Unexpected value for boolean: " ++ show x side :: Parser Side side = do s <- int8 case s of 1 -> return Red 2 -> return Blue _ -> return Spec stadium_ :: Parser Stadium stadium_ = do st <- int8 if st < 255 then return $ [minBound..maxBound] !! fromIntegral st else fail $ "Custom stadiums not handled yet!" discs_ :: Parser [Disc] discs_ = do s <- int32 count (fromIntegral s) disc disc :: Parser Disc disc = do discid <- curDiscId <$> getState modifyState (\p -> p { curDiscId = curDiscId p + 1 }) posx <- double posy <- double speedx <- double speedy <- double r <- double bco <- double im <- double damp <- double col <- Color . flip showHex "" <$> int32 m <- mask_ g <- mask_ return Disc { discId = discid , pos = (posx, posy) , speed = (speedx, speedy) , radius = r , bCoefficient = bco , invMass = im , damping = damp , color = col , mask = m , group = g } mask_ :: Parser Mask mask_ = do start <- int32 if start + 1 == 0 then pure $ Mask ["all"] else return . Mask $ go start [] where go 0 ms = ms go m xs | m .&. 32 /= 0 = go (m .&. (complement 32)) ("wall":xs) | m .&. 16 /= 0 = go (m .&. (complement 16)) ("blueKO":xs) | m .&. 8 /= 0 = go (m .&. (complement 8)) ("redKO":xs) | m .&. 4 /= 0 = go (m .&. (complement 4)) ("blue":xs) | m .&. 2 /= 0 = go (m .&. (complement 2)) ("red":xs) | m .&. 1 /= 0 = go (m .&. (complement 1)) ("ball":xs) | otherwise = fail $ "Heh??? " ++ show m players_ :: Parser () players_ = do p <- int32 void $ count (fromIntegral p) player player :: Parser () player = do pid <- fromIntegral <$> int32 uname <- str a <- bool t <- side n <- int8 av <- str inp <- int32 ak <- bool d <- bool ct <- str h <- int16 did <- int32 let p = Player { name = uname , initial = True , admin = a , team = t , number = n , avatar = av , input = inp , autoKick = ak , desync = d , country = ct , handicap = h , pDiscId = did } modifyState (\st -> st { playerList = I.insert pid p (playerList st) }) event :: Parser Action event = do timeUpdate <- bool "is it a time update?" when timeUpdate $ do frames <- int32 modifyState (\st -> st { frame = frame st + frames }) fc <- frame <$> getState pid <- fromIntegral <$> int32 evty <- int8 result <- case evty of 0 -> newPlayer 1 -> departure 2 -> Chat <$> str 4 -> pure StartMatch 5 -> pure StopMatch 6 -> discMove 7 -> TeamChange <$> int32 <*> side 10 -> ChangeAvatar <$> str 15 -> pingBroadcast x -> fail $ "heh non-exhaustive match for " ++ show x return $ Action pid fc result departure :: Parser Event departure = do p <- int16 k <- bool r <- if k then Just <$> str else pure Nothing b <- bool return Departure { dId = fromIntegral p , kicked = k , banned = b , reason = r } newPlayer :: Parser Event newPlayer = do i <- fromIntegral <$> int32 n <- str ai <- bool ct <- str let p = Player { name = n , initial = False , admin = ai , team = Spec , number = 0 , avatar = "" , input = 0 , autoKick = False , desync = False , country = ct , handicap = 0 , pDiscId = -1 } modifyState (\st -> st { playerList = I.insert i p $ playerList st }) return $ NewPlayer { npId = i , npName = n , npAdmin = ai , npCountry = ct } pingBroadcast :: Parser Event pingBroadcast = do p <- int8 PingBroadcast . zip [0..] . map (*4) <$> count (fromIntegral p) int8 discMove :: Parser Event discMove = do m <- int8 return . DiscMove $ [ Nop , Move [Up] , Move [Down] , Move [Up, Down] , Move [Left] , Move [Up, Left] , Move [Down, Left] , Move [Up, Down, Left] , Move [Right] , Move [Up, Right] , Move [Down, Right] , Move [Up, Down, Right] , Move [Left, Right] , Move [Up, Left, Right] , Move [Down, Left, Right] , Move [Up, Down, Left, Right] , Kick , MoveKick [Up] , MoveKick [Down] , MoveKick [Up, Down] , MoveKick [Left] , MoveKick [Up, Left] , MoveKick [Down, Left] , MoveKick [Up, Down, Left] , MoveKick [Right] , MoveKick [Up, Right] , MoveKick [Down, Right] , MoveKick [Up, Down, Right] , MoveKick [Left, Right] , MoveKick [Up, Left, Right] , MoveKick [Down, Left, Right] , MoveKick [Up, Down, Left, Right]] !! fromIntegral m