Skip to content

Instantly share code, notes, and snippets.

@michaelt

michaelt/amity.hs

Forked from DylanLukes/amity.hs
Created December 3, 2010 16:23
Show Gist options
  • Save michaelt/727175 to your computer and use it in GitHub Desktop.
Save michaelt/727175 to your computer and use it in GitHub Desktop.
Download ZIP
with idiom brackets in minecraft.hs
Raw
amity.hs
import System.IO
import Network
import Minecraft
import Control.Monad
import Control.Monad.Fix
import Control.Monad.Trans
import Control.Monad.BinaryProtocol
import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.STM.TChan
import Data.Int
import Data.List.Split
import Data.Binary
import Network.HTTP hiding (password)
import Text.Printf
-- State for the program: Session ID
type AmityState = (String, TChan ClientToServerPacket)
protocolVersion :: Int32
protocolVersion = 6
launcherVersion :: Int
launcherVersion = 12
name :: String
name = "amity"
password :: String
password = "snaaake"
initBot :: BinaryProtocol ()
initBot = do
-- Initialize the connection
send (CTSHandshake name)
flush
packetProtocol :: AmityState -> BinaryProtocol ()
packetProtocol ast@(sid, pktqueue) = do
-- Produce work from input
pkt <- receive
putStrLnBP $ "PacketType " ++ show pkt
case pkt of
STCLoginResponse eid str1 str2 ms dm ->
putStrLnBP $ "Received login response with EID: " ++ show eid
STCHandshake hs -> do
putStrLnBP $ "Received Handshake: " ++ hs
case hs of
"-" -> putStrLnBP "No authentication necessary."
"+" -> putStrLnBP "Password protected."
otherwise -> do
putStrLnBP "Authenticating with minecraft.net..."
-- Make sure we can log in safely.
let url = printf "http://www.minecraft.net/game/joinserver.jsp?user=%s&sessionId=%s&serverId=%s" name sid hs
putStrLnBP $ "URL: " ++ url
rq <- liftIO . simpleHTTP $ getRequest url
verified <- liftIO $ getResponseBody rq
putStrLnBP $ "Verified?: " ++ verified
enqueuePacket ast (CTSLoginRequest protocolVersion name "Password" 0 0)
flush
STCExplosion x y z r recs -> do
enqueuePacket ast (CTSChatMessage "Damn boy, stop blowin' shit up!")
flush
STCKick msg -> putStrLnBP $ "Kicked with reason: " ++ msg
otherwise -> return ()
-- Dequeue as many packets as possible, and send them
dequeuePackets ast
enqueuePacket :: AmityState -> ClientToServerPacket -> BinaryProtocol ()
enqueuePacket ast@(_, pktqueue) pkt = liftIO . atomically $ writeTChan pktqueue pkt
dequeuePackets :: AmityState -> BinaryProtocol ()
dequeuePackets ast@(_, pktqueue) = do
pkts <- liftIO . atomically $ while (liftM not . isEmptyTChan $ pktqueue) (readTChan pktqueue)
forM_ pkts send
flush
botProtocol :: AmityState -> BinaryProtocol ()
botProtocol ast = do
-- Initialize the connection
putStrLnBP "Initializing connection."
initBot
-- Create a thread to supply keep alives
putStrLnBP "Starting keep alive supplier..."
liftIO . forkIO . forever $ keepAlive ast
-- Do work
putStrLnBP "Starting main loop..."
forever $ packetProtocol ast
keepAlive :: AmityState -> IO ()
keepAlive ast@(_, pktqueue) = liftIO $ do
atomically $ writeTChan pktqueue (CTSKeepAlive)
threadDelay (20 * 1000000)
putStrLnBP :: String -> BinaryProtocol ()
putStrLnBP = liftIO . putStrLn
while :: (Monad m) => m Bool -> m a -> m [a]
while p x = do b <- p; if b then (do v <- x; vs <- while p x; return (v:vs)) else return []
main :: IO ()
main = withSocketsDo $ do
putStrLn "Starting Amity v0.0"
rq <- simpleHTTP . getRequest $ printf "http://minecraft.net/game/getversion.jsp?user=%s&password=%s&version=%d" name password launcherVersion
str <- getResponseBody rq
putStrLn $ "WHOLE STRING: " ++ str
sid <- liftM ((!! 3) . splitOn ":") $ getResponseBody rq
putStrLn $ "Session ID: " ++ sid
-- Create Packet Queue
pktqueue <- newTChanIO
let ast = (sid, pktqueue)
-- GO GO GO!
h <- connectTo "209.159.158.150" (PortNumber 25565)
runProtocol (botProtocol ast) h h
hClose h
Raw
minecraft.hs
{-# OPTIONS_GHC -F -pgmF she #-}
module Minecraft
( ClientToServerPacket(..)
, ServerToClientPacket(..)
, MCInventoryItem
, MCInventoryUpdate
, MCBlockChange
, MCMultiBlockChange
, MCExplosionRecords
) where
import Data.Int
import Data.Bits
import Data.Binary
import Data.Binary.Put
import Data.Binary.Get
import Data.Binary.IEEE754
import Control.Monad
import Control.Monad.Fix
import Control.Monad.Trans
import Control.Monad.BinaryProtocol
import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.STM.TChan
import Data.Int
import Data.List.Split
import Network.HTTP
import Network.Socket
import Text.Printf
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Char8 as C
import System.IO (hClose)
import Network
import Control.Applicative
{- Client to Server packets -}
data ClientToServerPacket
= CTSKeepAlive
| CTSLoginRequest Int32 String String Int64 Int8
| CTSHandshake String
| CTSChatMessage String
| CTSPlayerInventory MCInventoryUpdate
| CTSUseEntity Int32 Int32 Bool
| CTSRespawn
| CTSPlayerState Bool
| CTSPlayerPosition Double Double Double Double Bool
| CTSPlayerLook Float Float Bool
| CTSPlayerPositionAndLook Double Double Double Double Float Float Bool
| CTSPlayerDigging Int8 Int32 Int8 Int32 Int8
| CTSPlayerBlockPlacement Int16 Int32 Int8 Int32 Int8
| CTSHoldingChange Int32 Int16
| CTSArmAnimation Int32 Int8
| CTSPickupSpawn Int32 Int16 Int8 Int32 Int32 Int32 Int8 Int8 Int8
| CTSDisconnect String
deriving Show
{- Server to Client packets -}
data ServerToClientPacket
= STCKeepAlive
| STCLoginResponse Int32 String String Int64 Int8
| STCHandshake String
| STCChatMessage String
| STCTimeUpdate Int64
| STCPlayerInventory MCInventoryUpdate
| STCSpawnPosition Int32 Int32 Int32
| STCUpdateHealth Int8
| STCRespawn
| STCPlayerPositionAndLook Double Double Double Double Float Float Bool
| STCHoldingChange Int32 Int16
| STCAddToInventory MCInventoryItem
| STCAnimation Int32 Int8
| STCNamedEntitySpawn Int32 String Int32 Int32 Int32 Int8 Int8 Int16
| STCPickupSpawn Int32 Int16 Int8 Int32 Int32 Int32 Int8 Int8 Int8
| STCCollectItem Int32 Int32
| STCAddObjectOrVehicle Int32 Int8 Int32 Int32 Int32
| STCMobSpawn Int32 Int8 Int32 Int32 Int32 Int8 Int8
| STCEntityVelocity Int32 Int16 Int16 Int16
| STCDestroyEntity Int32
| STCEntity Int32
| STCEntityRelativeMove Int32 Int8 Int8 Int8
| STCEntityLook Int32 Int8 Int8
| STCEntityLookAndRelativeMove Int32 Int8 Int8 Int8 Int8 Int8
| STCEntityTeleport Int32 Int32 Int32 Int32 Int8 Int8
| STCEntityDamage Int32 Int8
| STCAttachEntity Int32 Int32
| STCPreChunk Int32 Int32 Bool
| STCMapChunk Int32 Int16 Int32 Int8 Int8 Int8 LB.ByteString
| STCMultiBlockChange MCMultiBlockChange
| STCBlockChange Int32 Int8 Int32 Int8 Int8
| STCComplexEntity Int32 Int16 Int32 LB.ByteString
| STCExplosion Double Double Double Float MCExplosionRecords
| STCKick String
deriving Show
instance Binary ClientToServerPacket where
put pkt = sequence_ pktlist where
pktlist = case pkt of
CTSKeepAlive -> [putInt8 0x00]
CTSLoginRequest a b c d e -> [putInt8 0x01, put a, putMCStr b, putMCStr c, put d, put e]
CTSHandshake a -> [putInt8 0x02, putMCStr a]
CTSChatMessage a -> [putInt8 0x03, putMCStr a]
CTSPlayerInventory a -> [put a]
CTSUseEntity a b c -> [put (a, b, c)]
CTSRespawn -> [putInt8 0x09]
CTSPlayerState a -> [putInt8 0x0A, put a]
CTSPlayerPosition a b c d e -> [putInt8 0x0B, putFloat64be a, putFloat64be b, putFloat64be c, putFloat64be d, put e]
CTSPlayerLook a b c -> [putInt8 0x0C, putFloat32be a, putFloat32be b, put c]
CTSPlayerPositionAndLook a b c d e f g -> [putInt8 0x0D, putFloat64be a, putFloat64be b, putFloat64be c, putFloat64be d, putFloat32be e, putFloat32be f, put g]
CTSPlayerDigging a b c d e -> [putInt8 0x0E, put (a, b, c, d, e)]
CTSPlayerBlockPlacement a b c d e -> [putInt8 0x0F, put (a, b, c, d, e)]
CTSHoldingChange a b -> [putInt8 0x10, put (a, b)]
CTSArmAnimation a b -> [putInt8 0x12, put (a, b)]
CTSPickupSpawn a b c d e f g h i -> [putInt8 0x15, put (a, b, c, d, e, f, g, h, i)]
CTSDisconnect a -> [putInt8 0xFF, put a]
get =
getInt8 >>= \tag -> case tag of
0x00 -> (| CTSKeepAlive |)
0x01 -> (| CTSLoginRequest get getMCStr getMCStr get get |)
0x02 -> (| CTSHandshake getMCStr |)
0x03 -> (| CTSChatMessage getMCStr |)
0x05 -> (| CTSPlayerInventory get |)
0x07 -> (| CTSUseEntity get get get |)
0x09 -> (| CTSRespawn |)
0x0A -> (| CTSPlayerState get |)
0x0B -> (| CTSPlayerPosition getFloat64be getFloat64be getFloat64be getFloat64be get |)
0x0C -> (| CTSPlayerLook getFloat32be getFloat32be get |)
0x0D -> (| CTSPlayerPositionAndLook getFloat64be getFloat64be getFloat64be getFloat64be getFloat32be getFloat32be get |)
0x0E -> (| CTSPlayerDigging get get get get get |)
0x0F -> (| CTSPlayerBlockPlacement get get get get get |)
0x10 -> (| CTSHoldingChange get get |)
0x12 -> (| CTSArmAnimation get get |)
0x15 -> (| CTSPickupSpawn get get get get get get get get get |)
0xFF -> (| CTSDisconnect getMCStr |)
otherwise -> error $ "Invalid packet tag: " ++ show tag
instance Binary ServerToClientPacket where
put pkt = sequence_ pktlist where
pktlist = case pkt of
STCKeepAlive -> [putInt8 0x00]
STCLoginResponse a b c d e -> [putInt8 0x01, put a, putMCStr b, putMCStr c, put (d, e)]
STCHandshake a -> [putInt8 0x02, putMCStr a]
STCChatMessage a -> [putInt8 0x03, putMCStr a]
STCTimeUpdate a -> [putInt8 0x04, put a]
STCPlayerInventory a -> [putInt8 0x05, put a]
STCSpawnPosition a b c -> [putInt8 0x06, put (a, b, c)]
STCUpdateHealth a -> [putInt8 0x08, put a]
STCRespawn -> [putInt8 0x09]
STCPlayerPositionAndLook a b c d e f g -> [putInt8 0x0D, putFloat64be a, putFloat64be b,
putFloat64be c, putFloat64be d,
putFloat32be e, putFloat32be f, put g]
STCHoldingChange a b -> [putInt8 0x10, put (a, b)]
STCAddToInventory a -> [putInt8 0x11, put a]
STCAnimation a b -> [putInt8 0x12, put (a, b)]
STCNamedEntitySpawn a b c d e f g h -> [putInt8 0x14, put a, putMCStr b, put (c, d, e, f, g, h)]
STCPickupSpawn a b c d e f g h i -> [putInt8 0x15, put (a, b, c, d, e, f, g, h, i)]
STCCollectItem a b -> [putInt8 0x16, put (a, b)]
STCAddObjectOrVehicle a b c d e -> [putInt8 0x17, put (a, b, c, d, e)]
STCMobSpawn a b c d e f g -> [putInt8 0x18, put (a, b, c, d, e, f, g)]
STCEntityVelocity a b c d -> [putInt8 0x1C, put (a, b, c, d)]
STCDestroyEntity a -> [putInt8 0x1D, put a]
STCEntity a -> [putInt8 0x1E, put a]
STCEntityRelativeMove a b c d -> [putInt8 0x1F, put (a, b, c, d)]
STCEntityLook a b c -> [putInt8 0x20, put (a, b, c)]
STCEntityLookAndRelativeMove a b c d e f -> [putInt8 0x21, put (a, b, c, d, e, f)]
STCEntityTeleport a b c d e f -> [putInt8 0x22, put (a, b, c, d, e, f)]
STCEntityDamage a b -> [putInt8 0x26, put (a, b)]
STCAttachEntity a b -> [putInt8 0x27, put (a, b)]
STCPreChunk a b c -> [putInt8 0x32, put (a, b, c)]
STCMapChunk a b c d e f g -> [putInt8 0x33, put (a, b, c, d, e, f), putMCChunkData g]
STCMultiBlockChange a -> [putInt8 0x34, put a]
STCBlockChange a b c d e -> [putInt8 0x35, put (a, b, c, d, e)]
STCComplexEntity a b c d -> [putInt8 0x3B, put (a, b, c), putMCData d]
STCExplosion a b c d e -> [putInt8 0x3C, putFloat64be a, putFloat64be b,
putFloat64be c, putFloat32be d, put e]
STCKick a -> [putInt8 0xFF, putMCStr a]
get =
getInt8 >>= \tag -> case tag of
0x00 -> (| STCKeepAlive |)
0x01 -> (| STCLoginResponse get getMCStr getMCStr get get |)
0x02 -> (| STCHandshake getMCStr |)
0x03 -> (| STCChatMessage getMCStr |)
0x04 -> (| STCTimeUpdate get |)
0x05 -> (| STCPlayerInventory get |)
0x06 -> (| STCSpawnPosition get get get |)
0x08 -> (| STCUpdateHealth get |)
0x09 -> (| STCRespawn |)
0x0D -> (| STCPlayerPositionAndLook getFloat64be getFloat64be getFloat64be getFloat64be getFloat32be getFloat32be get |)
0x10 -> (| STCHoldingChange get get |)
0x11 -> (| STCAddToInventory get |)
0x12 -> (| STCAnimation get get |)
0x14 -> (| STCNamedEntitySpawn get getMCStr get get get get get get |)
0x15 -> (| STCPickupSpawn get get get get get get get get get |)
0x16 -> (| STCCollectItem get get |)
0x17 -> (| STCAddObjectOrVehicle get get get get get |)
0x18 -> (| STCMobSpawn get get get get get get get |)
0x1C -> (| STCEntityVelocity get get get get |)
0x1D -> (| STCDestroyEntity get |)
0x1E -> (| STCEntity get |)
0x1F -> (| STCEntityRelativeMove get get get get |)
0x20 -> (| STCEntityLook get get get |)
0x21 -> (| STCEntityLookAndRelativeMove get get get get get get |)
0x22 -> (| STCEntityTeleport get get get get get get |)
0x26 -> (| STCEntityDamage get get |)
0x27 -> (| STCAttachEntity get get |)
0x32 -> (| STCPreChunk get get get |)
0x33 -> (| STCMapChunk get get get get get get getMCChunkData |)
0x34 -> (| STCMultiBlockChange get |)
0x35 -> (| STCBlockChange get get get get get |)
0x3B -> (| STCComplexEntity get get get getMCData |)
0x3C -> (| STCExplosion getFloat64be getFloat64be getFloat64be getFloat32be get |)
0xFF -> (| STCKick getMCStr |)
otherwise -> error $ "Invalid packet tag: " ++ show tag
{- Data Types -}
-- Type representing a single inventory item
type MCInventoryItem = (Int16, Int8, Int16)
-- Type representing an entire Inventory update fromt the server.
data MCInventoryUpdate = MCInventoryUpdate Int32 Int16 [MCInventoryItem] deriving Show
instance Binary MCInventoryUpdate where
put (MCInventoryUpdate sec cnt inv) = do
put sec
put cnt
forM_ inv $ \itm@(iid, cnt, hlh) -> case iid of
-1 -> put (-1 :: Int16)
otherwise -> put itm
get = do
t <- get
c <- get
items <- replicateM (fromIntegral c) $ do
iid <- get :: Get Int16
case iid of
-1 -> return (-1, 0, 0)
otherwise -> do
cnt <- get
hlh <- get
return (iid, cnt, hlh)
return (MCInventoryUpdate t c items)
-- Type for each entry in the multiple block change
type MCBlockChange = (Int8, Int8, Int8, Int8, Int8)
-- Data type packaging a multiple block-change in a nicer format
data MCMultiBlockChange = MCMultiBlockChange Int32 Int32 [MCBlockChange] deriving Show
instance Binary MCMultiBlockChange where
put (MCMultiBlockChange chx chy blks) = do
put chx
put chy
put (fromIntegral (length blks) :: Int16)
forM_ blks $ \(x, y, z, _, _) ->
put $ shiftL (fromIntegral x :: Int16) 12 .|. shiftL (fromIntegral z :: Int16) 8 .|. (fromIntegral y :: Int16)
forM_ blks $ \(_, _, _, t, _) -> put t
forM_ blks $ \(_, _, _, _, md) -> put md
get = do
chx <- get
chy <- get
len <- get :: Get Int16
pos <- replicateM (fromIntegral len :: Int) $ do
cd <- get :: Get Int16
let x = fromIntegral (shiftR cd 12)
z = fromIntegral (shiftR cd 8 .&. 0x0F)
y = fromIntegral (cd .&. 0xFF)
return (x, y, z)
t <- replicateM (fromIntegral len :: Int) get
md <- replicateM (fromIntegral len :: Int) get
let blks = zipWith3 (\ (a, b, c) d e -> (a, b, c, d, e) `asTypeOf` (a, a, a, a, a)) pos t md
return (MCMultiBlockChange chx chy blks)
type MCExplosionRecord = (Int8, Int8, Int8)
data MCExplosionRecords = MCExplosionRecords [MCExplosionRecord] deriving Show
instance Binary MCExplosionRecords where
put (MCExplosionRecords recs) = do
put (fromIntegral (length recs) :: Int32)
forM_ recs put
get = do
count <- get :: Get Int32
recs <- replicateM (fromIntegral count :: Int) get
return (MCExplosionRecords recs)
{- Utility stuff -}
putInt8 :: Int -> Put
putInt8 i = put (fromIntegral i :: Int8)
getInt8 :: Get Int8
getInt8 = get :: Get Int8
getMCStr :: Get String
getMCStr = do
len <- get :: Get Int16
replicateM (fromIntegral len :: Int) (get :: Get Char)
putMCStr :: String -> Put
putMCStr s = do
put (fromIntegral (length s) :: Int16)
mapM_ put s
putMCStr' :: String -> Put
putMCStr' s = do
let bs = C.pack s
put (fromIntegral (LB.length bs) :: Int16)
putLazyByteString bs
getMCStr' :: Get String
getMCStr' = do
len <- get :: Get Int16
bs <- getLazyByteString (fromIntegral len :: Int64)
return $ C.unpack bs
putMCChunkData :: LB.ByteString -> Put
putMCChunkData bs = do
put (fromIntegral (LB.length bs) :: Int32)
putLazyByteString bs
getMCChunkData :: Get LB.ByteString
getMCChunkData = do
len <- get :: Get Int32
getLazyByteString (fromIntegral len :: Int64)
putMCData :: LB.ByteString -> Put
putMCData bs = do
put (fromIntegral (LB.length bs) :: Int16)
putLazyByteString bs
getMCData :: Get LB.ByteString
getMCData = do
len <- get :: Get Int16
getLazyByteString (fromIntegral len :: Int64)
-- liftM6 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m a6 -> m r
-- liftM6 f m1 m2 m3 m4 m5 m6 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; return (f x1 x2 x3 x4 x5 x6) }
--
-- liftM7 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m a6 -> m a7 -> m r
-- liftM7 f m1 m2 m3 m4 m5 m6 m7 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; x7 <- m7; return (f x1 x2 x3 x4 x5 x6 x7) }
--
-- liftM8 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m a6 -> m a7 -> m a8 -> m r
-- liftM8 f m1 m2 m3 m4 m5 m6 m7 m8 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; x7 <- m7; x8 <- m8; return (f x1 x2 x3 x4 x5 x6 x7 x8) }
--
-- liftM9 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m a6 -> m a7 -> m a8 -> m a9 -> m r
-- liftM9 f m1 m2 m3 m4 m5 m6 m7 m8 m9 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; x7 <- m7; x8 <- m8; x9 <- m9; return (f x1 x2 x3 x4 x5 x6 x7 x8 x9) }
keepAlive ast@(_, pktqueue) = liftIO $ do
atomically $ writeTChan pktqueue (CTSKeepAlive)
threadDelay (20 * 1000000)
-- putStrLnBP :: String -> BinaryProtocol ()
-- putStrLnBP = liftIO . putStrLn
while :: (Monad m) => m Bool -> m a -> m [a]
while p x = do b <- p; if b then (do v <- x; vs <- while p x; return (v:vs)) else return []
-- main :: IO ()
-- main = withSocketsDo $ do
-- putStrLn "Starting Amity v0.0"
-- rq <- simpleHTTP . getRequest $ printf "http://minecraft.net/game/getversion.jsp?user=%s&password=%s&version=%d" name password launcherVersion
-- str <- getResponseBody rq
-- putStrLn $ "WHOLE STRING: " ++ str
-- sid <- liftM ((!! 3) . splitOn ":") $ getResponseBody rq
-- putStrLn $ "Session ID: " ++ sid
-- -- Create Packet Queue
-- pktqueue <- newTChanIO
-- let ast = (sid, pktqueue)
-- -- GO GO GO!
-- h <- connectTo "209.159.158.150" (PortNumber 25565)
-- runProtocol (botProtocol ast) h h
-- hClose h
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment