diff options
Diffstat (limited to 'src/Network/BitTorrent/Exchange/Protocol.hs')
-rw-r--r-- | src/Network/BitTorrent/Exchange/Protocol.hs | 64 |
1 files changed, 47 insertions, 17 deletions
diff --git a/src/Network/BitTorrent/Exchange/Protocol.hs b/src/Network/BitTorrent/Exchange/Protocol.hs index 505f6ac6..dc25a9c9 100644 --- a/src/Network/BitTorrent/Exchange/Protocol.hs +++ b/src/Network/BitTorrent/Exchange/Protocol.hs | |||
@@ -5,10 +5,25 @@ | |||
5 | -- Stability : experimental | 5 | -- Stability : experimental |
6 | -- Portability : portable | 6 | -- Portability : portable |
7 | -- | 7 | -- |
8 | -- In order to establish the connection between peers we should send | 8 | -- Normally peer to peer communication consisting of the following |
9 | -- 'Handshake' message. The 'Handshake' is a required message and | 9 | -- steps: |
10 | -- must be the first message transmitted by the peer to the another | 10 | -- |
11 | -- peer. | 11 | -- * In order to establish the connection between peers we should |
12 | -- send 'Handshake' message. The 'Handshake' is a required message | ||
13 | -- and must be the first message transmitted by the peer to the | ||
14 | -- another peer. Another peer should reply with a handshake as well. | ||
15 | -- | ||
16 | -- * Next peer might sent bitfield message, but might not. In the | ||
17 | -- former case we should update bitfield peer have. Again, if we | ||
18 | -- have some pieces we should send bitfield. Normally bitfield | ||
19 | -- message should sent after the handshake message. | ||
20 | -- | ||
21 | -- * Regular exchange messages. TODO docs | ||
22 | -- | ||
23 | -- For more high level API see "Network.BitTorrent.Exchange" module. | ||
24 | -- | ||
25 | -- For more infomation see: | ||
26 | -- <https://wiki.theory.org/BitTorrentSpecification#Peer_wire_protocol_.28TCP.29> | ||
12 | -- | 27 | -- |
13 | {-# LANGUAGE OverloadedStrings #-} | 28 | {-# LANGUAGE OverloadedStrings #-} |
14 | {-# LANGUAGE RecordWildCards #-} | 29 | {-# LANGUAGE RecordWildCards #-} |
@@ -77,6 +92,9 @@ import Network.BitTorrent.Peer | |||
77 | Handshake | 92 | Handshake |
78 | -----------------------------------------------------------------------} | 93 | -----------------------------------------------------------------------} |
79 | 94 | ||
95 | -- | Handshake message is used to exchange all information necessary | ||
96 | -- to establish connection between peers. | ||
97 | -- | ||
80 | data Handshake = Handshake { | 98 | data Handshake = Handshake { |
81 | -- | Identifier of the protocol. | 99 | -- | Identifier of the protocol. |
82 | hsProtocol :: ByteString | 100 | hsProtocol :: ByteString |
@@ -113,7 +131,7 @@ instance Serialize Handshake where | |||
113 | <*> get | 131 | <*> get |
114 | <*> get | 132 | <*> get |
115 | 133 | ||
116 | 134 | -- | Extract capabilities from a peer handshake message. | |
117 | handshakeCaps :: Handshake -> Capabilities | 135 | handshakeCaps :: Handshake -> Capabilities |
118 | handshakeCaps = hsReserved | 136 | handshakeCaps = hsReserved |
119 | 137 | ||
@@ -122,7 +140,8 @@ ppHandshake :: Handshake -> Doc | |||
122 | ppHandshake Handshake {..} = | 140 | ppHandshake Handshake {..} = |
123 | text (BC.unpack hsProtocol) <+> ppClientInfo (clientInfo hsPeerID) | 141 | text (BC.unpack hsProtocol) <+> ppClientInfo (clientInfo hsPeerID) |
124 | 142 | ||
125 | -- | Get handshake message size in bytes from the length of protocol string. | 143 | -- | Get handshake message size in bytes from the length of protocol |
144 | -- string. | ||
126 | handshakeSize :: Word8 -> Int | 145 | handshakeSize :: Word8 -> Int |
127 | handshakeSize n = 1 + fromIntegral n + 8 + 20 + 20 | 146 | handshakeSize n = 1 + fromIntegral n + 8 + 20 + 20 |
128 | 147 | ||
@@ -138,7 +157,8 @@ defaultBTProtocol = "BitTorrent protocol" | |||
138 | defaultReserved :: Word64 | 157 | defaultReserved :: Word64 |
139 | defaultReserved = 0 | 158 | defaultReserved = 0 |
140 | 159 | ||
141 | -- | Length of info hash and peer id is unchecked, so it /should/ be equal 20. | 160 | -- | Length of info hash and peer id is unchecked, so it /should/ be |
161 | -- equal 20. | ||
142 | defaultHandshake :: InfoHash -> PeerID -> Handshake | 162 | defaultHandshake :: InfoHash -> PeerID -> Handshake |
143 | defaultHandshake = Handshake defaultBTProtocol defaultReserved | 163 | defaultHandshake = Handshake defaultBTProtocol defaultReserved |
144 | 164 | ||
@@ -202,6 +222,7 @@ instance Serialize BlockIx where | |||
202 | putInt (ixLength ix) | 222 | putInt (ixLength ix) |
203 | {-# INLINE put #-} | 223 | {-# INLINE put #-} |
204 | 224 | ||
225 | -- | Format block index in human readable form. | ||
205 | ppBlockIx :: BlockIx -> Doc | 226 | ppBlockIx :: BlockIx -> Doc |
206 | ppBlockIx BlockIx {..} = | 227 | ppBlockIx BlockIx {..} = |
207 | "piece = " <> int ixPiece <> "," <+> | 228 | "piece = " <> int ixPiece <> "," <+> |
@@ -219,6 +240,7 @@ data Block = Block { | |||
219 | , blkData :: !ByteString | 240 | , blkData :: !ByteString |
220 | } deriving (Show, Eq) | 241 | } deriving (Show, Eq) |
221 | 242 | ||
243 | -- | Format block in human readable form. Payload is ommitted. | ||
222 | ppBlock :: Block -> Doc | 244 | ppBlock :: Block -> Doc |
223 | ppBlock = ppBlockIx . blockIx | 245 | ppBlock = ppBlockIx . blockIx |
224 | 246 | ||
@@ -262,7 +284,7 @@ ixRange pieceSize ix = (offset, offset + len) | |||
262 | 284 | ||
263 | 285 | ||
264 | {----------------------------------------------------------------------- | 286 | {----------------------------------------------------------------------- |
265 | Handshake | 287 | Regular messages |
266 | -----------------------------------------------------------------------} | 288 | -----------------------------------------------------------------------} |
267 | 289 | ||
268 | -- | Messages used in communication between peers. | 290 | -- | Messages used in communication between peers. |
@@ -405,6 +427,7 @@ ppMessage msg = text (show msg) | |||
405 | Peer Status | 427 | Peer Status |
406 | -----------------------------------------------------------------------} | 428 | -----------------------------------------------------------------------} |
407 | 429 | ||
430 | -- | | ||
408 | data PeerStatus = PeerStatus { | 431 | data PeerStatus = PeerStatus { |
409 | psChoking :: Bool | 432 | psChoking :: Bool |
410 | , psInterested :: Bool | 433 | , psInterested :: Bool |
@@ -414,38 +437,45 @@ data PeerStatus = PeerStatus { | |||
414 | initPeerStatus :: PeerStatus | 437 | initPeerStatus :: PeerStatus |
415 | initPeerStatus = PeerStatus True False | 438 | initPeerStatus = PeerStatus True False |
416 | 439 | ||
440 | -- | Update choking field. | ||
417 | setChoking :: Bool -> PeerStatus -> PeerStatus | 441 | setChoking :: Bool -> PeerStatus -> PeerStatus |
418 | setChoking b ps = ps { psChoking = b } | 442 | setChoking b ps = ps { psChoking = b } |
419 | 443 | ||
444 | -- | Update interested field. | ||
420 | setInterested :: Bool -> PeerStatus -> PeerStatus | 445 | setInterested :: Bool -> PeerStatus -> PeerStatus |
421 | setInterested b ps = ps { psInterested = b } | 446 | setInterested b ps = ps { psInterested = b } |
422 | 447 | ||
423 | 448 | -- | | |
424 | |||
425 | data SessionStatus = SessionStatus { | 449 | data SessionStatus = SessionStatus { |
426 | seClientStatus :: PeerStatus | 450 | seClientStatus :: PeerStatus |
427 | , sePeerStatus :: PeerStatus | 451 | , sePeerStatus :: PeerStatus |
428 | } | 452 | } |
429 | 453 | ||
454 | -- | Initial session status after two peers handshaked. | ||
430 | initSessionStatus :: SessionStatus | 455 | initSessionStatus :: SessionStatus |
431 | initSessionStatus = SessionStatus initPeerStatus initPeerStatus | 456 | initSessionStatus = SessionStatus initPeerStatus initPeerStatus |
432 | 457 | ||
433 | setClientStatus :: (PeerStatus -> PeerStatus) -> SessionStatus -> SessionStatus | 458 | -- | Update client status. |
459 | setClientStatus :: (PeerStatus -> PeerStatus) | ||
460 | -> SessionStatus -> SessionStatus | ||
434 | setClientStatus f ss = ss { seClientStatus = f (seClientStatus ss) } | 461 | setClientStatus f ss = ss { seClientStatus = f (seClientStatus ss) } |
435 | 462 | ||
436 | setPeerStatus :: (PeerStatus -> PeerStatus) -> SessionStatus -> SessionStatus | 463 | -- | Update peer status. |
464 | setPeerStatus :: (PeerStatus -> PeerStatus) | ||
465 | -> SessionStatus -> SessionStatus | ||
437 | setPeerStatus f ss = ss { sePeerStatus = f (sePeerStatus ss) } | 466 | setPeerStatus f ss = ss { sePeerStatus = f (sePeerStatus ss) } |
438 | 467 | ||
439 | -- | Can the /client/ to upload to the /peer/? | 468 | -- | Can the /client/ to upload to the /peer/? |
440 | canUpload :: SessionStatus -> Bool | 469 | canUpload :: SessionStatus -> Bool |
441 | canUpload SessionStatus { seClientStatus = client, sePeerStatus = peer} = | 470 | canUpload SessionStatus {..} |
442 | psInterested peer && not (psChoking client) | 471 | = psInterested sePeerStatus && not (psChoking seClientStatus) |
443 | 472 | ||
444 | -- | Can the /client/ download from the /peer/? | 473 | -- | Can the /client/ download from the /peer/? |
445 | canDownload :: SessionStatus -> Bool | 474 | canDownload :: SessionStatus -> Bool |
446 | canDownload SessionStatus { seClientStatus = client, sePeerStatus = peer } = | 475 | canDownload SessionStatus {..} |
447 | psInterested client && not (psChoking peer) | 476 | = psInterested seClientStatus && not (psChoking sePeerStatus) |
448 | 477 | ||
449 | -- | Indicates have many peers are allowed to download from the client. | 478 | -- | Indicates how many peers are allowed to download from the client |
479 | -- by default. | ||
450 | defaultUnchokeSlots :: Int | 480 | defaultUnchokeSlots :: Int |
451 | defaultUnchokeSlots = 4 \ No newline at end of file | 481 | defaultUnchokeSlots = 4 \ No newline at end of file |