read bytes off the handle and parse a message

[functorrent.git] / src / FuncTorrent / Peer.hs

diff --git a/src/FuncTorrent/Peer.hs b/src/FuncTorrent/Peer.hs
index 6b2ec720145320ecfad50cc0182c953b62e8135a..29d57143d814fb780a93f2a06c746667b8a266aa 100644 (file)
--- a/src/FuncTorrent/Peer.hs
+++ b/src/FuncTorrent/Peer.hs
@@ -7,11 +7,15 @@ module FuncTorrent.Peer
 import Prelude hiding (lookup, concat, replicate, splitAt)
 
 import System.IO
-import Data.ByteString (ByteString, unpack, concat, hGet, hPut, singleton)
-import Data.ByteString.Char8 (replicate, pack)
+import Data.ByteString (ByteString, pack, unpack, concat, hGet, hPut, singleton, append)
+import Data.ByteString.Lazy (fromStrict)
+import qualified Data.ByteString.Char8 as BC (replicate, pack, readInt)
 import Network (connectTo, PortID(..))
-import Data.Binary (Binary(..))
-import Data.Binary.Put (putWord32be, putWord8)
+import Data.Binary (Binary(..), decode)
+import Data.Binary.Put (putWord32be, putWord16be, putWord8)
+import Data.Binary.Get (getWord32be, getWord16be, getWord8)
+import Control.Monad (replicateM, liftM)
+import Control.Applicative ((<$>), liftA3)
 
 type ID = String
 type IP = String
@@ -21,7 +25,7 @@ data PeerState = PeerState { handle :: Handle
                            , am_choking :: Bool
                            , am_interested :: Bool
                            , peer_choking :: Bool
-                           , peer_interested :: Bool }
+                           , peer_interested :: Bool}
 
 -- Maintain info on every piece and the current state of it.
 -- should probably be a TVar.
@@ -56,20 +60,20 @@ data PeerMsg = KeepAliveMsg
 genHandShakeMsg :: ByteString -> String -> ByteString
 genHandShakeMsg infoHash peer_id = concat [pstrlen, pstr, reserved, infoHash, peerID]
   where pstrlen = singleton 19
-        pstr = pack "BitTorrent protocol"
-        reserved = replicate 8 '\0'
-        peerID = pack peer_id
+        pstr = BC.pack "BitTorrent protocol"
+        reserved = BC.replicate 8 '\0'
+        peerID = BC.pack peer_id
 
 handShake :: Peer -> ByteString -> String -> IO Handle
 handShake (Peer _ ip port) infoHash peerid = do
   let hs = genHandShakeMsg infoHash peerid
-  handle <- connectTo ip (PortNumber (fromIntegral port))
-  hSetBuffering handle LineBuffering
-  hPut handle hs
-  rlenBS <- hGet handle 1
+  h <- connectTo ip (PortNumber (fromIntegral port))
+  hSetBuffering h LineBuffering
+  hPut h hs
+  rlenBS <- hGet h 1
   let rlen = fromIntegral $ (unpack rlenBS) !! 0
-  hGet handle rlen
-  return handle
+  hGet h rlen
+  return h
 
 instance Binary PeerMsg where
   put msg = case msg of
@@ -82,9 +86,9 @@ instance Binary PeerMsg where
                                  putWord8 2
              NotInterestedMsg -> do putWord32be 1
                                     putWord8 3
-             HaveMsg index -> do putWord32be 5
-                                 putWord8 4
-                                 putWord32be (fromIntegral index)
+             HaveMsg i -> do putWord32be 5
+                             putWord8 4
+                             putWord32be (fromIntegral i)
              BitFieldMsg bf -> do putWord32be $ fromIntegral (1 + bfListLen)
                                   putWord8 5
                                   mapM_ putWord8 bfList
@@ -102,9 +106,40 @@ instance Binary PeerMsg where
                                   mapM_ putWord8 blockList
                                     where blockList = unpack b
                                           blocklen = length blockList
-             CancelMsg i o l -> undefined
-             PortMsg p -> undefined
-  get = undefined
+             CancelMsg i o l -> do putWord32be 13
+                                   putWord8 8
+                                   putWord32be (fromIntegral i)
+                                   putWord32be (fromIntegral o)
+                                   putWord32be (fromIntegral l)
+             PortMsg p -> do putWord32be 3
+                             putWord8 9
+                             putWord16be (fromIntegral p)
+  get = do
+    l <- getWord32be
+    msgid <- getWord8
+    case msgid of
+     0 -> return ChokeMsg
+     1 -> return UnChokeMsg
+     2 -> return InterestedMsg
+     3 -> return NotInterestedMsg
+     4 -> liftM (HaveMsg . fromIntegral) getWord32be
+     5 -> liftM (BitFieldMsg . pack) (replicateM (fromIntegral l - 1) getWord8)
+     6 -> liftA3 RequestMsg getInteger getInteger getInteger
+       where getInteger = fromIntegral <$> getWord32be
+     7 -> liftA3 PieceMsg getInteger getInteger (pack  <$> replicateM (fromIntegral l - 9) getWord8)
+       where getInteger = fromIntegral <$> getWord32be
+     8 -> liftA3 CancelMsg getInteger getInteger getInteger
+       where getInteger = fromIntegral <$> getWord32be
+     9 -> liftM (PortMsg . fromIntegral) getWord16be
+     _ -> error "unknown message ID"
+
+getMsg :: Handle -> IO PeerMsg
+getMsg h = do
+  lBS <- hGet h 4
+  let (Just (l, _)) = BC.readInt lBS
+  msg <- hGet h l
+  return $ decode $ fromStrict $ append lBS msg
+
 
 -- loop1 :: shake hands with all peers, find out the pieces they have, form PieceData.
 -- recvMsg :: Peer -> Handle -> Msg