blob: a4d987e66d4858c184fb9e75307878aba8850843 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
{-# LANGUAGE OverloadedStrings #-}
module Network.BitTorrent.PeerWire.Protocol
(
-- * Messages
Message(..)
, ppMessage
) where
import Control.Applicative
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as Lazy
import Data.Serialize
import Text.PrettyPrint
import Network
import Network.BitTorrent.PeerWire.Block
import Data.Bitfield
-- | Messages used in communication between peers.
--
-- Note: If some extensions are disabled (not present in extension
-- mask) and client receive message used by the disabled
-- extension then the client MUST close the connection.
--
data Message = KeepAlive
| Choke
| Unchoke
| Interested
| NotInterested
-- | Zero-based index of a piece that has just been
-- successfully downloaded and verified via the hash.
| Have !PieceIx
-- | The bitfield message may only be sent immediately
-- after the handshaking sequence is complete, and
-- before any other message are sent. If client have no
-- pieces then bitfield need not to be sent.
| Bitfield !Bitfield
-- | Request for a particular block. If a client is
-- requested a block that another peer do not have the
-- peer might not answer at all.
| Request !BlockIx
-- | Response for a request for a block.
| Piece !Block
-- | Used to cancel block requests. It is typically
-- used during "End Game".
| Cancel !BlockIx
| Port !PortNumber
-- | BEP 6: Then peer have all pieces it might send the
-- 'HaveAll' message instead of 'Bitfield'
-- message. Used to save bandwidth.
| HaveAll
-- | BEP 6: Then peer have no pieces it might send
-- 'HaveNone' message intead of 'Bitfield'
-- message. Used to save bandwidth.
| HaveNone
-- | BEP 6: This is an advisory message meaning "you
-- might like to download this piece." Used to avoid
-- excessive disk seeks and amount of IO.
| SuggestPiece !PieceIx
-- | BEP 6: Notifies a requesting peer that its request
-- will not be satisfied.
| RejectRequest !BlockIx
-- | BEP 6: This is an advisory messsage meaning "if
-- you ask for this piece, I'll give it to you even if
-- you're choked." Used to shorten starting phase.
| AllowedFast !PieceIx
deriving (Show, Eq)
instance Serialize Message where
get = do
len <- getInt
-- _ <- lookAhead $ ensure len
if len == 0 then return KeepAlive
else do
mid <- getWord8
case mid of
0x00 -> return Choke
0x01 -> return Unchoke
0x02 -> return Interested
0x03 -> return NotInterested
0x04 -> Have <$> getInt
0x05 -> (Bitfield . fromBitmap) <$> getByteString (pred len)
0x06 -> Request <$> get
0x07 -> Piece <$> getBlock (len - 9)
0x08 -> Cancel <$> get
0x09 -> (Port . fromIntegral) <$> getWord16be
0x0E -> return HaveAll
0x0F -> return HaveNone
0x0D -> SuggestPiece <$> getInt
0x10 -> RejectRequest <$> get
0x11 -> AllowedFast <$> getInt
_ -> do
rm <- remaining >>= getBytes
fail $ "unknown message ID: " ++ show mid ++ "\n"
++ "remaining available bytes: " ++ show rm
where
getBlock :: Int -> Get Block
getBlock len = Block <$> getInt <*> getInt <*> getBytes len
{-# INLINE getBlock #-}
put KeepAlive = putInt 0
put Choke = putInt 1 >> putWord8 0x00
put Unchoke = putInt 1 >> putWord8 0x01
put Interested = putInt 1 >> putWord8 0x02
put NotInterested = putInt 1 >> putWord8 0x03
put (Have i) = putInt 5 >> putWord8 0x04 >> putInt i
put (Bitfield bf) = putInt l >> putWord8 0x05 >> putLazyByteString b
where b = toBitmap bf
l = succ (fromIntegral (Lazy.length b))
{-# INLINE l #-}
put (Request blk) = putInt 13 >> putWord8 0x06 >> put blk
put (Piece blk) = putInt l >> putWord8 0x07 >> putBlock
where l = 9 + B.length (blkData blk)
{-# INLINE l #-}
putBlock = do putInt (blkPiece blk)
putInt (blkOffset blk)
putByteString (blkData blk)
{-# INLINE putBlock #-}
put (Cancel blk) = putInt 13 >> putWord8 0x08 >> put blk
put (Port p ) = putInt 3 >> putWord8 0x09 >> putWord16be (fromIntegral p)
put HaveAll = putInt 1 >> putWord8 0x0E
put HaveNone = putInt 1 >> putWord8 0x0F
put (SuggestPiece pix) = putInt 5 >> putWord8 0x0D >> putInt pix
put (RejectRequest ix) = putInt 13 >> putWord8 0x10 >> put ix
put (AllowedFast ix) = putInt 5 >> putWord8 0x11 >> putInt ix
-- | Format messages in human readable form. Note that output is
-- compact and suitable for logging: only useful information but not
-- payload bytes.
--
ppMessage :: Message -> Doc
ppMessage (Bitfield _) = "Bitfield"
ppMessage (Piece blk) = "Piece" <+> ppBlock blk
ppMessage (Cancel ix) = "Cancel" <+> ppBlockIx ix
ppMessage (SuggestPiece pix) = "Suggest" <+> int pix
ppMessage (RejectRequest ix) = "Reject" <+> ppBlockIx ix
ppMessage msg = text (show msg)
|
