Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Merge branch 'template-haskell' of github.com:glguy/minecraft-proxy i…

…nto template-haskell
  • Loading branch information...
commit 6baab965c4c0bf61c3e00d88a37b7269da99b56c 2 parents 0b3dbb9 + 2bfe088
@glguy authored
Showing with 77 additions and 50 deletions.
  1. +2 −1  Protocol.hs
  2. +32 −26 ProtocolHelper.hs
  3. +43 −23 Proxy.hs
View
3  Protocol.hs
@@ -280,7 +280,8 @@ packetData "Message"
]
, con' 0x33 "Mapchunk"
[] `addField`
- Field { fieldType = strictType isStrict [t|(ChunkLoc,Maybe (Array (Int8, Int8, Int8) BlockId
+ Field { fieldType = strictType isStrict
+ [t|(ChunkLoc,Maybe ( Array (Int8, Int8, Int8) BlockId
, ByteString
, ByteString
, ByteString))|]
View
58 ProtocolHelper.hs
@@ -130,15 +130,23 @@ enum "BlockId" "UnknownBlock" blocks
enum16 "ItemId" "OtherItem" items
-mapchunkDataGet :: Get (ChunkLoc, Maybe (Array (Int8,Int8,Int8) BlockId,ByteString,ByteString,ByteString))
+
+coords bx by bz sx sy sz = do -- The x z y order is intentional
+ x' <- take (fromIntegral sx + 1) [fromIntegral bx ..]
+ z' <- take (fromIntegral sz + 1) [fromIntegral bz ..]
+ y' <- take (fromIntegral sy + 1) [fromIntegral by ..]
+ return (x',y',z')
+
+mapchunkDataGet :: Get (ChunkLoc, Maybe (Array (Int8,Int8,Int8) BlockId,
+ ByteString,ByteString,ByteString))
mapchunkDataGet =
do (x,y,z,sx,sy,sz) <- getJ :: Get (Int32, Int16, Int32, Int8, Int8, Int8)
let (chunk,(bx,by,bz)) = decomposeCoords x (fromIntegral y) z
let block_count = (fromIntegral sx + 1)
* (fromIntegral sy + 1)
* (fromIntegral sz + 1)
- toArray :: [BlockId] -> Array (Int8,Int8,Int8) BlockId
- toArray xs = array ((bx,by,bz),(bx+sx,by+sy,bz+sz)) (zip (coords bx by bz sx sy sz) xs)
+ toArray xs = array ((bx,by,bz),(bx+sx,by+sy,bz+sz))
+ (zip (coords bx by bz sx sy sz) xs)
len <- getJ :: Get Int32
compressed <- getLazyByteString (fromIntegral len)
return $! case safeDecompress compressed of
@@ -152,29 +160,10 @@ mapchunkDataGet =
<*> getLazyByteString (block_count `div` 2)
in (chunk,Just $ runGet parser uncompressed)
-coords bx by bz sx sy sz = do -- The x z y order is intentional
- x' <- take (fromIntegral sx + 1) [fromIntegral bx ..]
- z' <- take (fromIntegral sz + 1) [fromIntegral bz ..]
- y' <- take (fromIntegral sy + 1) [fromIntegral by ..]
- return (x',y',z')
-
-
-putMaybe16 :: (a -> Put) -> Maybe a -> Put
-putMaybe16 _ Nothing = putJ( -1 :: Int16)
-putMaybe16 p (Just x) = p x
-getMaybe16 :: Get a -> Get (Maybe a)
-getMaybe16 p = do
- mb <- lookAheadM $ isNil <$> getJ
- case mb of
- Nothing -> Just <$> p
- Just () -> return Nothing
- where
- isNil :: Int16 -> Maybe ()
- isNil x = guard (x == (-1))
-
-
-mapchunkDataPut :: (ChunkLoc,Maybe (Array (Int8,Int8,Int8) BlockId,ByteString,ByteString,ByteString)) -> Put
+mapchunkDataPut :: (ChunkLoc, Maybe (Array (Int8,Int8,Int8) BlockId,
+ ByteString,ByteString,ByteString)) ->
+ Put
mapchunkDataPut ((cx,cz),mbRest) =
do let (blockArr, metas, blights, slights) = case mbRest of
Nothing -> error "Can't put bad chunk"
@@ -204,6 +193,21 @@ mapchunkDataPut ((cx,cz),mbRest) =
putWord32be (fromIntegral (L.length compressed))
putLazyByteString compressed
+putMaybe16 :: (a -> Put) -> Maybe a -> Put
+putMaybe16 _ Nothing = putJ( -1 :: Int16)
+putMaybe16 p (Just x) = p x
+
+getMaybe16 :: Get a -> Get (Maybe a)
+getMaybe16 p = do
+ mb <- lookAheadM $ isNil <$> getJ
+ case mb of
+ Nothing -> Just <$> p
+ Just () -> return Nothing
+ where
+ isNil :: Int16 -> Maybe ()
+ isNil x = guard (x == (-1))
+
+
putChanges :: [((Int8,Int8,Int8),BlockId, Int8)] -> Put
putChanges xs = do
putWord16be (fromIntegral (length xs))
@@ -244,7 +248,9 @@ putCoords xs = do
safeDecompress :: ByteString -> Either String ByteString
safeDecompress
- = ZI.foldDecompressStream (fmap . LI.Chunk) (Right LI.Empty) (\ _ str -> Left str)
+ = ZI.foldDecompressStream (fmap . LI.Chunk)
+ (Right LI.Empty)
+ (\ _ str -> Left str)
. ZI.decompressWithErrors ZI.zlibFormat ZI.defaultDecompressParams
-- | 'decomposeCoords' computes the chunk coordinates and the
View
66 Proxy.hs
@@ -87,7 +87,8 @@ main = withSocketsDo $ do
, addrFlags = [AI_ADDRCONFIG] }
serverAI <- head <$> getAddrInfo (Just activeHints) (Just host) (Just port)
- waitThreadGroup $ map (makeListenerThread (configConsoleFile config) serverAI) proxyAIs
+ waitThreadGroup $
+ map (makeListenerThread (configConsoleFile config) serverAI) proxyAIs
-- | 'makeListenerThread' binds to the specified address on the proxy
@@ -103,11 +104,13 @@ makeListenerThread consoleFile serverAI proxyAI = do
bindSocketToAddrInfo l proxyAI
listen l 5
- putStr $ "Ready to accept connections on " ++ show (addrAddress proxyAI) ++ "\n"
+ putStr $ "Ready to accept connections on "
+ ++ show (addrAddress proxyAI) ++ "\n"
- forever $ do (clientSock, clientAddr) <- accept l
- _ <- forkIO (handleClient consoleFile serverAI clientSock clientAddr)
- return ()
+ forever $
+ do (clientSock, clientAddr) <- accept l
+ _ <- forkIO (handleClient consoleFile serverAI clientSock clientAddr)
+ return ()
handleClient ::
Maybe FilePath {- ^ console file path -} ->
@@ -144,11 +147,15 @@ proxy consoleFile c s = do
let bad who (SomeException e) = print e >> writeChan var who
start who f xsm = forkIO . handle (bad who) . traverse_ f =<< xsm
- serverToProxy <- start "inbound" (inboundLogic clientChan state) (getMessages s)
- clientToProxy <- start "outbound" (outboundLogic clientChan serverChan state) (getMessages c)
- proxyToClient <- start "inbound network" (sendAll c) (getChanContents clientChan)
- proxyToServer <- start "outbound network" (sendAll s) (getChanContents serverChan)
+ serverToProxy <- start "from server"
+ (inboundLogic clientChan state)
+ (getMessages s)
+ clientToProxy <- start "from client"
+ (outboundLogic clientChan serverChan state)
+ (getMessages c)
+ proxyToClient <- start "to client" (sendAll c) (getChanContents clientChan)
+ proxyToServer <- start "to server" (sendAll s) (getChanContents serverChan)
who <- readChan var
putStr who
@@ -173,6 +180,10 @@ inboundLogic ::
IO ()
inboundLogic clientChan state msg = do
+ case msg of
+ NamedEntitySpawn _ name _ _ _ _ _ _ ->
+ tellPlayer clientChan $ name ++ " in range"
+ _ -> return ()
-- Track entities
changedEid <- modifyMVar (gameState state) $ \ gs -> do
(change, gs') <- updateGameState msg gs
@@ -182,13 +193,13 @@ inboundLogic clientChan state msg = do
glass <- readIORef (glassVar state)
time <- readIORef (timeVar state)
let msg' = case msg of
- Mapchunk (chunk, Just (bs, a, b, c))
- | glass -> Mapchunk (chunk, Just (fmap makeGlass bs, a, b, c))
- Mapchunk (chunk, Nothing) -> Chat $ "Bad map chunk " ++ show chunk
- TimeUpdate {} -> case time of
- Nothing -> msg
- Just t -> TimeUpdate t
- _ -> msg
+ Mapchunk (chunk, Just (bs, a, b, c))
+ | glass -> Mapchunk (chunk, Just (fmap makeGlass bs, a, b, c))
+ Mapchunk (chunk, Nothing) -> Chat $ "Bad map chunk " ++ show chunk
+ TimeUpdate {} -> case time of
+ Nothing -> msg
+ Just t -> TimeUpdate t
+ _ -> msg
-- Update compass
followMsgs <- withMVar (followVar state) $ \ interested ->
@@ -268,7 +279,7 @@ processCommand clientChan state "follow off" = do
modifyMVar_ (followVar state) $ \ _ -> do
mb <- spawnLocation <$> readMVar (gameState state)
case mb of
- Nothing -> tellPlayer clientChan "Follow disabled - spawn point unknown"
+ Nothing -> tellPlayer clientChan "Follow disabled - spawn point unknown"
Just (x,y,z) -> sendMessages clientChan [SpawnPosition x y z]
*> tellPlayer clientChan "Follow disabled - compass restored"
return Nothing
@@ -402,9 +413,12 @@ drawLine :: Message ->
Maybe (ItemId, Int8, Int16) {- ^ Hand contents -} ->
[Message]
drawLine msg x y z x1 y1 z1 f o
- | x == x1 && y == y1 = [PlayerBlockPlacement x y z2 f o | z2 <- [min z z1 .. max z z1]]
- | x == x1 && z == z1 = [PlayerBlockPlacement x y2 z f o | y2 <- [min y y1 .. max y y1]]
- | z == z1 && y == y1 = [PlayerBlockPlacement x2 y z f o | x2 <- [min x x1 .. max x x1]]
+ | x == x1 && y == y1 = [PlayerBlockPlacement x y z2 f o
+ | z2 <- [min z z1 .. max z z1]]
+ | x == x1 && z == z1 = [PlayerBlockPlacement x y2 z f o
+ | y2 <- [min y y1 .. max y y1]]
+ | z == z1 && y == y1 = [PlayerBlockPlacement x2 y z f o
+ | x2 <- [min x x1 .. max x x1]]
| otherwise = [msg]
lookupBlock :: BlockMap -> ChunkLoc -> BlockLoc -> IO (Maybe BlockId)
@@ -412,7 +426,11 @@ lookupBlock bm chunkC blockC = do
for (Map.lookup chunkC bm) $ \ (blockArray, _) ->
readArray blockArray blockC
-filterGlassUpdate :: BlockMap -> BlockId -> (ChunkLoc, [BlockLoc]) -> IO (ChunkLoc, [BlockLoc])
+filterGlassUpdate ::
+ BlockMap ->
+ BlockId ->
+ (ChunkLoc, [BlockLoc]) ->
+ IO (ChunkLoc, [BlockLoc])
filterGlassUpdate bm victim (chunk, blocks) = do
let isVictim x = x == Just victim
xs <- filterM (\ c -> isVictim <$> lookupBlock bm chunk c) blocks
@@ -551,8 +569,10 @@ waitThreadGroup ::
IO ()
waitThreadGroup xs = do
var <- newEmptyMVar
- threadIds <- for xs $ \ x -> forkIO $ x `Control.Exception.catch`
- \ (SomeException e) -> print e >> putMVar var ()
+ threadIds <- for xs $ \ x -> forkIO $ x
+ `catch` \ (SomeException e) ->
+ do print e
+ putMVar var ()
takeMVar var
traverse_ killThread threadIds
Please sign in to comment.
Something went wrong with that request. Please try again.