1 {-# LANGUAGE OverloadedStrings #-}
2 module FuncTorrent.Peer
7 import Prelude hiding (lookup, concat, replicate, splitAt)
10 import Data.ByteString (ByteString, pack, unpack, concat, hGet, hPut, singleton)
11 import qualified Data.ByteString.Char8 as BC (replicate, pack)
12 import Network (connectTo, PortID(..))
13 import Data.Binary (Binary(..))
14 import Data.Binary.Put (putWord32be, putWord16be, putWord8)
15 import Data.Binary.Get (getWord32be, getWord16be, getWord8)
16 import Control.Monad (replicateM, liftM)
17 import Control.Applicative ((<$>), liftA3)
23 data PeerState = PeerState { handle :: Handle
25 , am_interested :: Bool
26 , peer_choking :: Bool
27 , peer_interested :: Bool }
29 -- Maintain info on every piece and the current state of it.
30 -- should probably be a TVar.
31 type Pieces = [PieceData]
33 data PieceState = Pending
38 data PieceData = PieceData { index :: Int -- ^ Piece number
39 , peers :: [Peer] -- ^ list of peers who have this piece
40 , state :: PieceState } -- ^ state of the piece from download perspective.
42 -- | Peer is a PeerID, IP address, port tuple
43 data Peer = Peer ID IP Port
46 data PeerMsg = KeepAliveMsg
52 | BitFieldMsg ByteString
53 | RequestMsg Integer Integer Integer
54 | PieceMsg Integer Integer ByteString
55 | CancelMsg Integer Integer Integer
59 genHandShakeMsg :: ByteString -> String -> ByteString
60 genHandShakeMsg infoHash peer_id = concat [pstrlen, pstr, reserved, infoHash, peerID]
61 where pstrlen = singleton 19
62 pstr = BC.pack "BitTorrent protocol"
63 reserved = BC.replicate 8 '\0'
64 peerID = BC.pack peer_id
66 handShake :: Peer -> ByteString -> String -> IO Handle
67 handShake (Peer _ ip port) infoHash peerid = do
68 let hs = genHandShakeMsg infoHash peerid
69 h <- connectTo ip (PortNumber (fromIntegral port))
70 hSetBuffering h LineBuffering
73 let rlen = fromIntegral $ (unpack rlenBS) !! 0
77 instance Binary PeerMsg where
79 KeepAliveMsg -> putWord32be 0
80 ChokeMsg -> do putWord32be 1
82 UnChokeMsg -> do putWord32be 1
84 InterestedMsg -> do putWord32be 1
86 NotInterestedMsg -> do putWord32be 1
88 HaveMsg i -> do putWord32be 5
90 putWord32be (fromIntegral i)
91 BitFieldMsg bf -> do putWord32be $ fromIntegral (1 + bfListLen)
94 where bfList = unpack bf
95 bfListLen = length bfList
96 RequestMsg i o l -> do putWord32be 13
98 putWord32be (fromIntegral i)
99 putWord32be (fromIntegral o)
100 putWord32be (fromIntegral l)
101 PieceMsg i o b -> do putWord32be $ fromIntegral (9 + blocklen)
103 putWord32be (fromIntegral i)
104 putWord32be (fromIntegral o)
105 mapM_ putWord8 blockList
106 where blockList = unpack b
107 blocklen = length blockList
108 CancelMsg i o l -> do putWord32be 13
110 putWord32be (fromIntegral i)
111 putWord32be (fromIntegral o)
112 putWord32be (fromIntegral l)
113 PortMsg p -> do putWord32be 3
115 putWord16be (fromIntegral p)
121 1 -> return UnChokeMsg
122 2 -> return InterestedMsg
123 3 -> return NotInterestedMsg
124 4 -> liftM (HaveMsg . fromIntegral) getWord32be
125 5 -> liftM (BitFieldMsg . pack) (replicateM (fromIntegral l - 1) getWord8)
126 6 -> liftA3 RequestMsg getInteger getInteger getInteger
127 where getInteger = fromIntegral <$> getWord32be
128 7 -> liftA3 PieceMsg getInteger getInteger (pack <$> replicateM (fromIntegral l - 9) getWord8)
129 where getInteger = fromIntegral <$> getWord32be
130 8 -> liftA3 CancelMsg getInteger getInteger getInteger
131 where getInteger = fromIntegral <$> getWord32be
132 9 -> liftM (PortMsg . fromIntegral) getWord16be
133 _ -> error "unknown message ID"
135 -- loop1 :: shake hands with all peers, find out the pieces they have, form PieceData.
136 -- recvMsg :: Peer -> Handle -> Msg