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

minecraft.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 ()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 qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Char8 as C
import Control.Monad

{- 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
    
instance Binary ClientToServerPacket where
    put pkt = 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 = do
        tag <- getInt8
        case tag of
            0x00 -> return CTSKeepAlive
            0x01 -> liftM5 CTSLoginRequest get getMCStr getMCStr get get
            0x02 -> liftM  CTSHandshake getMCStr
            0x03 -> liftM  CTSChatMessage getMCStr
            0x05 -> liftM  CTSPlayerInventory get
            0x07 -> liftM3 CTSUseEntity get get get
            0x09 -> return CTSRespawn
            0x0A -> liftM  CTSPlayerState get
            0x0B -> liftM5 CTSPlayerPosition getFloat64be getFloat64be getFloat64be getFloat64be get
            0x0C -> liftM3 CTSPlayerLook getFloat32be getFloat32be get
            0x0D -> liftM7 CTSPlayerPositionAndLook getFloat64be getFloat64be getFloat64be getFloat64be getFloat32be getFloat32be get
            0x0E -> liftM5 CTSPlayerDigging get get get get get
            0x0F -> liftM5 CTSPlayerBlockPlacement get get get get get
            0x10 -> liftM2 CTSHoldingChange get get
            0x12 -> liftM2 CTSArmAnimation get get
            0x15 -> liftM9 CTSPickupSpawn get get get get get get get get get
            0xFF -> liftM  CTSDisconnect getMCStr
            otherwise -> error $ "Invalid packet tag: " ++ show tag

{- 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 ServerToClientPacket where
    put pkt = 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 = do
        tag <- getInt8
        case tag of
            0x00 -> return STCKeepAlive
            0x01 -> liftM5 STCLoginResponse get getMCStr getMCStr get get
            0x02 -> liftM  STCHandshake getMCStr
            0x03 -> liftM  STCChatMessage getMCStr
            0x04 -> liftM  STCTimeUpdate get
            0x05 -> liftM  STCPlayerInventory get
            0x06 -> liftM3 STCSpawnPosition get get get
            0x08 -> liftM  STCUpdateHealth get
            0x09 -> return STCRespawn
            0x0D -> liftM7 STCPlayerPositionAndLook getFloat64be getFloat64be getFloat64be getFloat64be getFloat32be getFloat32be get
            0x10 -> liftM2 STCHoldingChange get get
            0x11 -> liftM  STCAddToInventory get
            0x12 -> liftM2 STCAnimation get get
            0x14 -> liftM8 STCNamedEntitySpawn get getMCStr get get get get get get
            0x15 -> liftM9 STCPickupSpawn get get get get get get get get get
            0x16 -> liftM2 STCCollectItem get get
            0x17 -> liftM5 STCAddObjectOrVehicle get get get get get
            0x18 -> liftM7 STCMobSpawn get get get get get get get
            0x1C -> liftM4 STCEntityVelocity get get get get
            0x1D -> liftM  STCDestroyEntity get
            0x1E -> liftM  STCEntity get
            0x1F -> liftM4 STCEntityRelativeMove get get get get
            0x20 -> liftM3 STCEntityLook get get get
            0x21 -> liftM6 STCEntityLookAndRelativeMove get get get get get get
            0x22 -> liftM6 STCEntityTeleport get get get get get get
            0x26 -> liftM2 STCEntityDamage get get
            0x27 -> liftM2 STCAttachEntity get get
            0x32 -> liftM3 STCPreChunk get get get
            0x33 -> liftM7 STCMapChunk get get get get get get getMCChunkData
            0x34 -> liftM  STCMultiBlockChange get
            0x35 -> liftM5 STCBlockChange get get get get get
            0x3B -> liftM4 STCComplexEntity get get get getMCData
            0x3C -> liftM5 STCExplosion getFloat64be getFloat64be getFloat64be getFloat32be get
            0xFF -> liftM  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