1 {-# LANGUAGE OverloadedStrings #-}
2 module FuncTorrent.Peer
8 import Prelude hiding (lookup, concat, replicate, splitAt)
11 import Data.ByteString (ByteString, pack, unpack, concat, hGet, hPut, singleton)
12 import Data.ByteString.Lazy (fromStrict, fromChunks)
13 import qualified Data.ByteString.Char8 as BC (replicate, pack)
14 import Network (connectTo, PortID(..))
15 import Data.Binary (Binary(..), decode)
16 import Data.Binary.Put (putWord32be, putWord16be, putWord8)
17 import Data.Binary.Get (getWord32be, getWord16be, getWord8, runGet)
18 import Control.Monad (replicateM, liftM, forever)
19 import Control.Applicative ((<$>), liftA3)
25 data PeerState = PeerState { handle :: Handle
27 , am_interested :: Bool
28 , peer_choking :: Bool
29 , peer_interested :: Bool}
31 -- Maintain info on every piece and the current state of it.
32 -- should probably be a TVar.
33 type Pieces = [PieceData]
35 data PieceState = Pending
40 data PieceData = PieceData { index :: Int -- ^ Piece number
41 , peers :: [Peer] -- ^ list of peers who have this piece
42 , state :: PieceState } -- ^ state of the piece from download perspective.
44 -- | Peer is a PeerID, IP address, port tuple
45 data Peer = Peer ID IP Port
48 data PeerMsg = KeepAliveMsg
54 | BitFieldMsg ByteString
55 | RequestMsg Integer Integer Integer
56 | PieceMsg Integer Integer ByteString
57 | CancelMsg Integer Integer Integer
61 genHandShakeMsg :: ByteString -> String -> ByteString
62 genHandShakeMsg infoHash peer_id = concat [pstrlen, pstr, reserved, infoHash, peerID]
63 where pstrlen = singleton 19
64 pstr = BC.pack "BitTorrent protocol"
65 reserved = BC.replicate 8 '\0'
66 peerID = BC.pack peer_id
68 handShake :: Peer -> ByteString -> String -> IO Handle
69 handShake (Peer _ ip port) infoHash peerid = do
70 let hs = genHandShakeMsg infoHash peerid
71 h <- connectTo ip (PortNumber (fromIntegral port))
72 hSetBuffering h LineBuffering
75 let rlen = fromIntegral $ (unpack rlenBS) !! 0
79 instance Binary PeerMsg where
81 KeepAliveMsg -> putWord32be 0
82 ChokeMsg -> do putWord32be 1
84 UnChokeMsg -> do putWord32be 1
86 InterestedMsg -> do putWord32be 1
88 NotInterestedMsg -> do putWord32be 1
90 HaveMsg i -> do putWord32be 5
92 putWord32be (fromIntegral i)
93 BitFieldMsg bf -> do putWord32be $ fromIntegral (1 + bfListLen)
96 where bfList = unpack bf
97 bfListLen = length bfList
98 RequestMsg i o l -> do putWord32be 13
100 putWord32be (fromIntegral i)
101 putWord32be (fromIntegral o)
102 putWord32be (fromIntegral l)
103 PieceMsg i o b -> do putWord32be $ fromIntegral (9 + blocklen)
105 putWord32be (fromIntegral i)
106 putWord32be (fromIntegral o)
107 mapM_ putWord8 blockList
108 where blockList = unpack b
109 blocklen = length blockList
110 CancelMsg i o l -> do putWord32be 13
112 putWord32be (fromIntegral i)
113 putWord32be (fromIntegral o)
114 putWord32be (fromIntegral l)
115 PortMsg p -> do putWord32be 3
117 putWord16be (fromIntegral p)
123 1 -> return UnChokeMsg
124 2 -> return InterestedMsg
125 3 -> return NotInterestedMsg
126 4 -> liftM (HaveMsg . fromIntegral) getWord32be
127 5 -> liftM (BitFieldMsg . pack) (replicateM (fromIntegral l - 1) getWord8)
128 6 -> liftA3 RequestMsg getInteger getInteger getInteger
129 where getInteger = fromIntegral <$> getWord32be
130 7 -> liftA3 PieceMsg getInteger getInteger (pack <$> replicateM (fromIntegral l - 9) getWord8)
131 where getInteger = fromIntegral <$> getWord32be
132 8 -> liftA3 CancelMsg getInteger getInteger getInteger
133 where getInteger = fromIntegral <$> getWord32be
134 9 -> liftM (PortMsg . fromIntegral) getWord16be
135 _ -> error ("unknown message ID: " ++ show msgid)
137 getMsg :: Handle -> IO PeerMsg
142 then return KeepAliveMsg
144 putStrLn $ "len: " ++ show l
146 putStrLn $ "msg Type: " ++ show msgID
147 msg <- hGet h (l - 1)
148 return $ decode $ fromStrict $ concat [lBS, msgID, msg]
150 bsToInt :: ByteString -> Int
151 bsToInt x = fromIntegral (runGet getWord32be (fromChunks (return x)))
153 -- loop1 :: shake hands with all peers, find out the pieces they have, form PieceData.
154 -- recvMsg :: Peer -> Handle -> Msg
156 msgLoop :: Handle -> IO ()
157 msgLoop h = forever $ do
159 putStrLn $ "got a " ++ show msg