Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

move all proxy state into one value

  • Loading branch information...
commit b25bd7e34f2d50576368eda3b1b4ec5508e78513 1 parent 0c225ca
@glguy authored
Showing with 122 additions and 95 deletions.
  1. +22 −8 GameState.hs
  2. +3 −1 Protocol.hs
  3. +97 −86 Proxy.hs
View
30 GameState.hs
@@ -1,6 +1,7 @@
module GameState where
import Data.Array.IO
+import Control.Applicative
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
@@ -23,7 +24,7 @@ import JavaBinary
type EntityMap = Map EntityId (Either String MobId, Int32, Int32, Int32)
-type BlockMap = Map (Int32, Int32) (IOArray (Int8, Int8, Int8) BlockId)
+type BlockMap = Map (Int32, Int32) (IOArray (Int8, Int8, Int8) BlockId, IOUArray (Int8, Int8, Int8) Word8)
data GameState = GS
{ entityMap :: !EntityMap
@@ -119,16 +120,25 @@ decomposeCoords x y z = ((x `shiftR` 4
)
setChunk x y z sx sy sz bs ms bm = do
- (arr,bm') <- case Map.lookup chunk bm of
- Nothing -> do arr <- newArray ((0,0,0),(0xf,0x7f,0xf)) Air
- return (arr, Map.insert chunk arr bm)
- Just arr -> return (arr, bm)
+ (blockArray,metaArray,bm') <- case Map.lookup chunk bm of
+ Nothing -> do
+ blockArray <- newArray ((0,0,0),(0xf,0x7f,0xf)) Air
+ metaArray <- newArray ((0,0,0),(0xf,0x7f,0xf)) (0 :: Word8)
+ return (blockArray, metaArray, Map.insert chunk (blockArray, metaArray) bm)
+ Just (blockArray, metaArray) -> return (blockArray, metaArray, bm)
- zipWithM (writeArray arr) coords bs
+ zipWithM_ (writeArray blockArray) coords bs
+ zipWithM_ (writeMetaData metaArray) (pairs coords) (L.unpack ms)
return bm'
where
(chunk,(bx,by,bz)) = decomposeCoords x (fromIntegral y) z
+ pairs (x:y:z) = (x,y) : pairs z
+ pairs _ = []
+
+ writeMetaData arr (x,y) m = writeArray arr x (m `shiftR` 4)
+ *> writeArray arr y (m .&. 0xf)
+
coords = do x <- take (fromIntegral sx + 1) [bx ..]
z <- take (fromIntegral sz + 1) [bz ..]
y <- take (fromIntegral sy + 1) [by ..]
@@ -142,7 +152,10 @@ setBlocks x z changes bm = do
return bm
where
- aux arr (coord, ty, meta) = writeArray arr (splitCoord coord) ty
+ aux (blockArray, metaArray) (coord, ty, meta) = let c = splitCoord coord
+ in writeArray blockArray c ty
+ *> writeArray metaArray c (fromIntegral meta)
+
splitCoord :: Int16 -> (Int8, Int8, Int8)
splitCoord c = (fromIntegral (c' `shiftR` 12), fromIntegral (c' .&. 0x7f), fromIntegral (c' `shiftR` 8 .&. 0xf))
where c' :: Word16
@@ -152,7 +165,8 @@ setBlock :: Int32 -> Int8 -> Int32 -> BlockId -> Int8 -> BlockMap -> IO BlockMap
setBlock x y z blockid meta bm = do
case Map.lookup chunk bm of
Nothing -> return ()
- Just arr -> writeArray arr block blockid
+ Just (blockArray, metaArray) -> writeArray blockArray block blockid
+ *> writeArray metaArray block (fromIntegral meta)
return bm
where
(chunk,block) = decomposeCoords x (fromIntegral y) z
View
4 Protocol.hs
@@ -468,6 +468,7 @@ data BlockId
| Portal
| JackOLantern
| Cake
+ | UnknownBlock Int8
deriving (Show, Read, Eq)
instance JavaBinary BlockId where
@@ -557,8 +558,9 @@ instance JavaBinary BlockId where
0x5A -> return Portal
0x5B -> return JackOLantern
0x5C -> return Cake
- _ -> error ("block id " ++ show tag)
+ _ -> return $ UnknownBlock tag
+ putJ (UnknownBlock tag) = putJ (tag :: Int8)
putJ Air = putJ (0x00 :: Int8)
putJ Stone = putJ (0x01 :: Int8)
putJ Grass = putJ (0x02 :: Int8)
View
183 Proxy.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE RecordWildCards #-}
module Main where
import Protocol
@@ -28,6 +29,23 @@ import qualified Network
import JavaBinary
import GameState
+data ProxyState = PS
+ { gameState :: MVar GameState
+ , glassVar :: IORef Bool
+ , lineVar :: IORef (Bool, [Message])
+ , digVar :: IORef Int
+ , followVar :: IORef (Maybe EntityId)
+ }
+
+newProxyState = do
+ gameState <- newMVar newGameState
+ glassVar <- newIORef False
+ lineVar <- newIORef (False, [])
+ digVar <- newIORef 1
+ followVar <- newIORef Nothing
+ followVar <- newIORef Nothing
+ return PS {..}
+
main :: IO ()
main = do
(host,port) <- do
@@ -43,39 +61,39 @@ main = do
putStr "Got connection from "
print csa
- s <- socket AF_INET Stream defaultProtocol
- ais <- getAddrInfo (Just defaultHints { addrFamily = AF_INET
- , addrSocketType = Stream })
- (Just host) (Just port)
- case ais of
- (ai : _ ) -> do let sa = addrAddress ai
- print sa
- connect s sa
- proxy c s
- _ -> fail "Unable to resolve server address"
+ do
+ s <- socket AF_INET Stream defaultProtocol
+ ais <- getAddrInfo (Just defaultHints { addrFamily = AF_INET
+ , addrSocketType = Stream })
+ (Just host) (Just port)
+ case ais of
+ (ai : _ ) -> do let sa = addrAddress ai
+ print sa
+ connect s sa
+ proxy c s
+ _ -> fail "Unable to resolve server address"
+ `Control.Exception.catch` \ (SomeException e) -> do
+ sendAll c $ encode $ Disconnect (show e)
+ fail (show e)
proxy :: Socket -> Socket -> IO a
proxy c s = do
var <- newEmptyMVar
- emap <- newMVar newGameState
- glassvar <- newIORef False
- digspeed <- newIORef False
- follow <- newIORef Nothing
- macro <- newIORef (False, [])
- chan <- newChan
- schan <- newChan
+ state <- newProxyState
+ clientChan <- newChan
+ serverChan <- newChan
_ <- forkIO $ do
sbs <- getContents s
- traverse_ (proxy1 chan (inboundLogic follow emap glassvar))
+ traverse_ (proxy1 clientChan (inboundLogic state))
(toMessages sbs)
`bad` putMVar var "inbound"
- _ <- forkIO $ forever (sendAll c =<< readChan chan )
+ _ <- forkIO $ forever (sendAll c =<< readChan clientChan)
`bad` putMVar var "inbound network"
- _ <- forkIO $ forever (sendAll s =<< readChan schan )
+ _ <- forkIO $ forever (sendAll s =<< readChan serverChan)
`bad` putMVar var "outbound network"
_ <- forkIO $ do
cbs <- getContents c
- traverse_ (proxy1 schan (outboundLogic chan follow emap glassvar digspeed macro))
+ traverse_ (proxy1 serverChan (outboundLogic clientChan state))
(toMessages cbs)
`bad` putMVar var "outbound"
who <- takeMVar var
@@ -85,12 +103,13 @@ proxy c s = do
where
bad m n = m `Control.Exception.catch` \ (SomeException e) -> print e >> n
-inboundLogic :: IORef (Maybe EntityId) ->
- MVar GameState ->
- IORef Bool ->
- Message ->
- IO [Message]
-inboundLogic follow emap glassvar msg = do
+makeGlass Dirt = Glass
+makeGlass Stone = Glass
+makeGlass Grass = Glass
+makeGlass block = block
+
+inboundLogic :: ProxyState -> Message -> IO [Message]
+inboundLogic state msg = do
case msg of
Entity {} -> return ()
EntityLook {} -> return ()
@@ -104,93 +123,85 @@ inboundLogic follow emap glassvar msg = do
Mapchunk {} -> return ()
_ -> putStrLn $ "inbound: " ++ show msg
- changedEid <- modifyMVar emap $ \ gs -> do
+ changedEid <- modifyMVar (gameState state) $ \ gs -> do
(change, gs') <- updateGameState msg gs
gs' `seq` return (gs', change)
- glass <- readIORef glassvar
+ glass <- readIORef (glassVar state)
let msg' = case msg of
Mapchunk x y z sx sy sz bs a b c
| glass -> Mapchunk x y z sx sy sz (map makeGlass bs) a b c
_ -> msg
- makeGlass Dirt = Glass
- makeGlass Stone = Glass
- makeGlass Grass = Glass
- makeGlass block = block
- interested <- readIORef follow
+ interested <- readIORef $ followVar state
case interested of
Just ieid | interested == changedEid -> do
- e <- entityMap <$> readMVar emap
+ e <- entityMap <$> readMVar (gameState state)
case Map.lookup ieid e of
Just (_ty, x, y, z) ->
return [SpawnPosition (x `div` 32) (y `div` 32) (z `div` 32),msg']
_ -> return [msg']
_ -> return [msg']
-processCommand cchan follow emap glassvar digspeed _ "glass on"
- = writeIORef glassvar True
- *> tellPlayer cchan "Glass On"
- *> return []
-processCommand cchan follow emap glassvar digspeed _ "glass off"
- = writeIORef glassvar False
- *> tellPlayer cchan "Glass Off"
- *> return []
+processCommand :: Chan L.ByteString -> ProxyState -> String -> IO [Message]
-processCommand cchan follow emap glassvar digspeed _ "dig on"
- = writeIORef digspeed True
- *> tellPlayer cchan "Dig On"
+processCommand clientChan state "glass on"
+ = writeIORef (glassVar state) True
+ *> tellPlayer clientChan "Glass On"
*> return []
-processCommand cchan follow emap glassvar digspeed _ "dig off"
- = writeIORef digspeed False
- *> tellPlayer cchan "Dig Off"
+processCommand clientChan state "glass off"
+ = writeIORef (glassVar state) False
+ *> tellPlayer clientChan "Glass Off"
*> return []
-processCommand cchan follow emap glassvar digspeed _ text
- | "follow " `isPrefixOf` text
+processCommand clientChan state text | "dig " `isPrefixOf` text
+ = case reads $ drop 4 text of
+ [(n,_)] -> writeIORef (digVar state) n
+ *> tellPlayer clientChan "Dig Set"
+ *> return []
+
+ _ -> tellPlayer clientChan "Bad dig number"
+ *> return []
+
+processCommand clientChan state text | "follow " `isPrefixOf` text
= case reads key of
- [(eid, _)] -> do writeIORef follow $ Just $ EID eid
- tellPlayer cchan "Follow registered"
- _ -> do e <- entityMap <$> readMVar emap
+ [(eid, _)] -> do writeIORef (followVar state) $ Just $ EID eid
+ tellPlayer clientChan "Follow registered"
+ _ -> do e <- entityMap <$> readMVar (gameState state)
case find (\ (_,(x,_,_,_)) -> x == Left key) (Map.assocs e) of
- Just (k,_) -> writeIORef follow (Just k)
- *> tellPlayer cchan "Follow registered"
- Nothing -> tellPlayer cchan "Player not found"
+ Just (k,_) -> writeIORef (followVar state) (Just k)
+ *> tellPlayer clientChan "Follow registered"
+ Nothing -> tellPlayer clientChan "Player not found"
*> return []
where key = drop 7 text
-processCommand cchan follow emap glassvar digspeed macro "lines on"
- = writeIORef macro (True, [])
- *> tellPlayer cchan "Lines On"
+processCommand clientChan state "lines on"
+ = writeIORef (lineVar state) (True, [])
+ *> tellPlayer clientChan "Lines On"
*> return []
-processCommand cchan follow emap glassvar digspeed macro "lines off"
- = do (_ , xs) <- readIORef macro
- writeIORef macro (False, xs)
- tellPlayer cchan "Lines Off"
- return []
+processCommand clientChan state "lines off"
+ = modifyIORef (lineVar state) (\ (_ , xs) -> (False, xs))
+ *> tellPlayer clientChan "Lines Off"
+ *> return []
-processCommand cchan follow emap glassvar _ _ _ = do
- tellPlayer cchan "Command not understood"
- return []
+processCommand clientChan _ _
+ = tellPlayer clientChan "Command not understood"
+ *> return []
-tellPlayer cchan text = writeChan cchan $ encode $ Chat $ "\194\167\&6" ++ text
+tellPlayer chan text = writeChan chan $ encode $ Chat $ "\194\167\&6" ++ text
outboundLogic :: Chan ByteString ->
- IORef (Maybe EntityId) ->
- MVar GameState ->
- IORef Bool ->
- IORef Bool ->
- IORef (Bool, [Message]) ->
+ ProxyState ->
Message ->
IO [Message]
-outboundLogic cchan follow emap glassvar digspeed macro msg = do
+outboundLogic clientChan state msg = do
- (recording, macros) <- readIORef macro
+ (recording, macros) <- readIORef $ lineVar state
case msg of
PlayerPosition {} -> return [msg]
@@ -199,33 +210,33 @@ outboundLogic cchan follow emap glassvar digspeed macro msg = do
Player {} -> return [msg]
KeepAliv -> return [msg]
PlayerDigging Digging x y z face -> do
- active <- readIORef digspeed
- if active then return [msg,msg,msg,msg] else return [msg]
+ n <- readIORef $ digVar state
+ return $ replicate n msg
PlayerBlockPlacement x y z _ (Just (IID 0x15B, _, _)) -> do
- bm <- blockMap <$> readMVar emap
+ bm <- blockMap <$> readMVar (gameState state)
let (chunkC,blockC) = decomposeCoords x (fromIntegral y) z
case Map.lookup chunkC bm of
- Just arr -> do
+ Just (arr,_) -> do
blockId <- readArray arr blockC
if (blockId /= Air) then do
- tellPlayer cchan "Glass attack!"
+ tellPlayer clientChan "Glass attack!"
glassMsgs <- mapM (makeGlassUpdate bm blockId) $ chunkedNearby (x, fromIntegral y, z)
print glassMsgs
- writeChan cchan $ runPut $ traverse_ putJ $ Prelude.concat glassMsgs
+ writeChan clientChan $ runPut $ traverse_ putJ $ Prelude.concat glassMsgs
return []
else return [msg]
where
_ -> return [msg]
PlayerBlockPlacement x1 y1 z1 f o | recording -> case macros of
[PlayerBlockPlacement x y z f o] -> do
- writeIORef macro (recording, [msg])
+ writeIORef (lineVar state) (recording, [msg])
if x == x1 && y == y1 then return [PlayerBlockPlacement x y z2 f o | z2 <- [min z z1 .. max z z1]]
else if x == x1 && z == z1 then return [PlayerBlockPlacement x y2 z f o | y2 <- [min y y1 .. max y y1]]
else if z == z1 && y == y1 then return [PlayerBlockPlacement x2 y z f o | x2 <- [min x x1 .. max x x1]]
else return [msg]
- _ -> do writeIORef macro (recording, [msg]) *> return [msg]
- Chat ('\\':xs) -> processCommand cchan follow emap glassvar digspeed macro xs
+ _ -> do writeIORef (lineVar state) (recording, [msg]) *> return [msg]
+ Chat ('\\':xs) -> processCommand clientChan state xs
_ -> do putStrLn $ "outbound: " ++ show msg
return [msg]
@@ -233,7 +244,7 @@ outboundLogic cchan follow emap glassvar digspeed macro msg = do
lookupBlock bm chunkC blockC = do
case Map.lookup chunkC bm of
Nothing -> return Nothing
- Just arr -> Just <$> readArray arr blockC
+ Just (arr,_) -> Just <$> readArray arr blockC
makeGlassUpdate :: BlockMap -> BlockId -> ((Int32,Int32),[(Int8, Int8,Int8)]) -> IO [Message]
makeGlassUpdate bm victim ((cx,cz), blocks) = do
Please sign in to comment.
Something went wrong with that request. Please try again.