diff options
author | Sam Truzjan <pxqr.sta@gmail.com> | 2014-04-26 07:42:57 +0400 |
---|---|---|
committer | Sam Truzjan <pxqr.sta@gmail.com> | 2014-04-26 07:42:57 +0400 |
commit | a7fda9d39ed82cb9d3ad0c28e76e88e59539a492 (patch) | |
tree | 925183a691bbb57ca5f7140614e1fdbc610b3b1e /src/Network | |
parent | 4587ffd5406162bb06a6549ffd2ff277e0a93916 (diff) | |
parent | 85bf8475bbbce79b1bedde641192fa945614283d (diff) |
Merge branch 'tidy' into dev
Diffstat (limited to 'src/Network')
33 files changed, 2125 insertions, 1917 deletions
diff --git a/src/Network/BitTorrent.hs b/src/Network/BitTorrent.hs index bcc7cfcf..91a58887 100644 --- a/src/Network/BitTorrent.hs +++ b/src/Network/BitTorrent.hs | |||
@@ -57,7 +57,5 @@ module Network.BitTorrent | |||
57 | ) where | 57 | ) where |
58 | 58 | ||
59 | import Data.Torrent | 59 | import Data.Torrent |
60 | import Data.Torrent.InfoHash | ||
61 | import Data.Torrent.Magnet | ||
62 | import Network.BitTorrent.Client | 60 | import Network.BitTorrent.Client |
63 | import Network.BitTorrent.Internal.Types \ No newline at end of file | 61 | import Network.BitTorrent.Internal.Types \ No newline at end of file |
diff --git a/src/Network/BitTorrent/Address.hs b/src/Network/BitTorrent/Address.hs new file mode 100644 index 00000000..eeb04c74 --- /dev/null +++ b/src/Network/BitTorrent/Address.hs | |||
@@ -0,0 +1,1172 @@ | |||
1 | -- | | ||
2 | -- Module : Network.BitTorrent.Address | ||
3 | -- Copyright : (c) Sam Truzjan 2013 | ||
4 | -- (c) Daniel Gröber 2013 | ||
5 | -- License : BSD3 | ||
6 | -- Maintainer : pxqr.sta@gmail.com | ||
7 | -- Stability : provisional | ||
8 | -- Portability : portable | ||
9 | -- | ||
10 | -- Peer and Node addresses. | ||
11 | -- | ||
12 | {-# LANGUAGE FlexibleInstances #-} | ||
13 | {-# LANGUAGE RecordWildCards #-} | ||
14 | {-# LANGUAGE StandaloneDeriving #-} | ||
15 | {-# LANGUAGE ViewPatterns #-} | ||
16 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
17 | {-# LANGUAGE MultiParamTypeClasses #-} | ||
18 | {-# LANGUAGE DeriveDataTypeable #-} | ||
19 | {-# LANGUAGE DeriveFunctor #-} | ||
20 | {-# LANGUAGE TemplateHaskell #-} | ||
21 | {-# OPTIONS -fno-warn-orphans #-} | ||
22 | module Network.BitTorrent.Address | ||
23 | ( -- * Address | ||
24 | Address (..) | ||
25 | , fromAddr | ||
26 | |||
27 | -- ** IP | ||
28 | , IPv4 | ||
29 | , IPv6 | ||
30 | , IP (..) | ||
31 | |||
32 | -- * PeerId | ||
33 | -- $peer-id | ||
34 | , PeerId | ||
35 | |||
36 | -- ** Generation | ||
37 | , genPeerId | ||
38 | , timestamp | ||
39 | , entropy | ||
40 | |||
41 | -- ** Encoding | ||
42 | , azureusStyle | ||
43 | , shadowStyle | ||
44 | , defaultClientId | ||
45 | , defaultVersionNumber | ||
46 | |||
47 | -- * PeerAddr | ||
48 | -- $peer-addr | ||
49 | , PeerAddr(..) | ||
50 | , defaultPorts | ||
51 | , peerSockAddr | ||
52 | , peerSocket | ||
53 | |||
54 | -- * Node | ||
55 | -- ** Id | ||
56 | , NodeId | ||
57 | , testIdBit | ||
58 | , genNodeId | ||
59 | , NodeDistance | ||
60 | , distance | ||
61 | |||
62 | -- ** Info | ||
63 | , NodeAddr (..) | ||
64 | , NodeInfo (..) | ||
65 | , rank | ||
66 | |||
67 | -- * Fingerprint | ||
68 | -- $fingerprint | ||
69 | , Software (..) | ||
70 | , Fingerprint (..) | ||
71 | , libFingerprint | ||
72 | , fingerprint | ||
73 | |||
74 | -- * Utils | ||
75 | , libUserAgent | ||
76 | ) where | ||
77 | |||
78 | import Control.Applicative | ||
79 | import Control.Monad | ||
80 | import Data.BEncode as BE | ||
81 | import Data.BEncode as BS | ||
82 | import Data.BEncode.BDict (BKey) | ||
83 | import Data.Bits | ||
84 | import Data.ByteString as BS | ||
85 | import Data.ByteString.Internal as BS | ||
86 | import Data.ByteString.Base16 as Base16 | ||
87 | import Data.ByteString.Char8 as BC | ||
88 | import Data.ByteString.Char8 as BS8 | ||
89 | import qualified Data.ByteString.Lazy as BL | ||
90 | import qualified Data.ByteString.Lazy.Builder as BS | ||
91 | import Data.Char | ||
92 | import Data.Convertible | ||
93 | import Data.Default | ||
94 | import Data.Foldable | ||
95 | import Data.IP | ||
96 | import Data.List as L | ||
97 | import Data.List.Split as L | ||
98 | import Data.Maybe (fromMaybe, catMaybes) | ||
99 | import Data.Monoid | ||
100 | import Data.Hashable | ||
101 | import Data.Ord | ||
102 | import Data.Serialize as S | ||
103 | import Data.String | ||
104 | import Data.Time | ||
105 | import Data.Typeable | ||
106 | import Data.Version | ||
107 | import Data.Word | ||
108 | import qualified Text.ParserCombinators.ReadP as RP | ||
109 | import Text.Read (readMaybe) | ||
110 | import Network.HTTP.Types.QueryLike | ||
111 | import Network.Socket | ||
112 | import Text.PrettyPrint as PP hiding ((<>)) | ||
113 | import Text.PrettyPrint.Class | ||
114 | import System.Locale (defaultTimeLocale) | ||
115 | import System.Entropy | ||
116 | |||
117 | -- import Paths_bittorrent (version) | ||
118 | |||
119 | {----------------------------------------------------------------------- | ||
120 | -- Address | ||
121 | -----------------------------------------------------------------------} | ||
122 | |||
123 | instance Pretty UTCTime where | ||
124 | pretty = PP.text . show | ||
125 | |||
126 | class (Eq a, Serialize a, Typeable a, Hashable a, Pretty a) | ||
127 | => Address a where | ||
128 | toSockAddr :: a -> SockAddr | ||
129 | fromSockAddr :: SockAddr -> Maybe a | ||
130 | |||
131 | fromAddr :: (Address a, Address b) => a -> Maybe b | ||
132 | fromAddr = fromSockAddr . toSockAddr | ||
133 | |||
134 | -- | Note that port is zeroed. | ||
135 | instance Address IPv4 where | ||
136 | toSockAddr = SockAddrInet 0 . toHostAddress | ||
137 | fromSockAddr (SockAddrInet _ h) = Just (fromHostAddress h) | ||
138 | fromSockAddr _ = Nothing | ||
139 | |||
140 | -- | Note that port is zeroed. | ||
141 | instance Address IPv6 where | ||
142 | toSockAddr h = SockAddrInet6 0 0 (toHostAddress6 h) 0 | ||
143 | fromSockAddr (SockAddrInet6 _ _ h _) = Just (fromHostAddress6 h) | ||
144 | fromSockAddr _ = Nothing | ||
145 | |||
146 | -- | Note that port is zeroed. | ||
147 | instance Address IP where | ||
148 | toSockAddr (IPv4 h) = toSockAddr h | ||
149 | toSockAddr (IPv6 h) = toSockAddr h | ||
150 | fromSockAddr sa = | ||
151 | IPv4 <$> fromSockAddr sa | ||
152 | <|> IPv6 <$> fromSockAddr sa | ||
153 | |||
154 | setPort :: PortNumber -> SockAddr -> SockAddr | ||
155 | setPort port (SockAddrInet _ h ) = SockAddrInet port h | ||
156 | setPort port (SockAddrInet6 _ f h s) = SockAddrInet6 port f h s | ||
157 | setPort _ (SockAddrUnix s ) = SockAddrUnix s | ||
158 | {-# INLINE setPort #-} | ||
159 | |||
160 | getPort :: SockAddr -> Maybe PortNumber | ||
161 | getPort (SockAddrInet p _ ) = Just p | ||
162 | getPort (SockAddrInet6 p _ _ _) = Just p | ||
163 | getPort (SockAddrUnix _ ) = Nothing | ||
164 | {-# INLINE getPort #-} | ||
165 | |||
166 | instance Address a => Address (NodeAddr a) where | ||
167 | toSockAddr NodeAddr {..} = setPort nodePort $ toSockAddr nodeHost | ||
168 | fromSockAddr sa = NodeAddr <$> fromSockAddr sa <*> getPort sa | ||
169 | |||
170 | instance Address a => Address (PeerAddr a) where | ||
171 | toSockAddr PeerAddr {..} = setPort peerPort $ toSockAddr peerHost | ||
172 | fromSockAddr sa = PeerAddr Nothing <$> fromSockAddr sa <*> getPort sa | ||
173 | |||
174 | {----------------------------------------------------------------------- | ||
175 | -- Peer id | ||
176 | -----------------------------------------------------------------------} | ||
177 | -- $peer-id | ||
178 | -- | ||
179 | -- 'PeerID' represent self assigned peer identificator. Ideally each | ||
180 | -- host in the network should have unique peer id to avoid | ||
181 | -- collisions, therefore for peer ID generation we use good entropy | ||
182 | -- source. Peer ID is sent in /tracker request/, sent and received in | ||
183 | -- /peer handshakes/ and used in DHT queries. | ||
184 | -- | ||
185 | |||
186 | -- TODO use unpacked Word160 form (length is known statically) | ||
187 | |||
188 | -- | Peer identifier is exactly 20 bytes long bytestring. | ||
189 | newtype PeerId = PeerId { getPeerId :: ByteString } | ||
190 | deriving (Show, Eq, Ord, BEncode, Typeable) | ||
191 | |||
192 | peerIdLen :: Int | ||
193 | peerIdLen = 20 | ||
194 | |||
195 | -- | For testing purposes only. | ||
196 | instance Default PeerId where | ||
197 | def = azureusStyle defaultClientId defaultVersionNumber "" | ||
198 | |||
199 | instance Hashable PeerId where | ||
200 | hashWithSalt = hashUsing getPeerId | ||
201 | {-# INLINE hashWithSalt #-} | ||
202 | |||
203 | instance Serialize PeerId where | ||
204 | put = putByteString . getPeerId | ||
205 | get = PeerId <$> getBytes peerIdLen | ||
206 | |||
207 | instance QueryValueLike PeerId where | ||
208 | toQueryValue (PeerId pid) = Just pid | ||
209 | {-# INLINE toQueryValue #-} | ||
210 | |||
211 | instance IsString PeerId where | ||
212 | fromString str | ||
213 | | BS.length bs == peerIdLen = PeerId bs | ||
214 | | otherwise = error $ "Peer id should be 20 bytes long: " ++ show str | ||
215 | where | ||
216 | bs = fromString str | ||
217 | |||
218 | instance Pretty PeerId where | ||
219 | pretty = text . BC.unpack . getPeerId | ||
220 | |||
221 | instance Convertible BS.ByteString PeerId where | ||
222 | safeConvert bs | ||
223 | | BS.length bs == peerIdLen = pure (PeerId bs) | ||
224 | | otherwise = convError "invalid length" bs | ||
225 | |||
226 | ------------------------------------------------------------------------ | ||
227 | |||
228 | -- | Pad bytestring so it's becomes exactly request length. Conversion | ||
229 | -- is done like so: | ||
230 | -- | ||
231 | -- * length < size: Complete bytestring by given charaters. | ||
232 | -- | ||
233 | -- * length = size: Output bytestring as is. | ||
234 | -- | ||
235 | -- * length > size: Drop last (length - size) charaters from a | ||
236 | -- given bytestring. | ||
237 | -- | ||
238 | byteStringPadded :: ByteString -- ^ bytestring to be padded. | ||
239 | -> Int -- ^ size of result builder. | ||
240 | -> Char -- ^ character used for padding. | ||
241 | -> BS.Builder | ||
242 | byteStringPadded bs s c = | ||
243 | BS.byteString (BS.take s bs) <> | ||
244 | BS.byteString (BC.replicate padLen c) | ||
245 | where | ||
246 | padLen = s - min (BS.length bs) s | ||
247 | |||
248 | -- | Azureus-style encoding have the following layout: | ||
249 | -- | ||
250 | -- * 1 byte : '-' | ||
251 | -- | ||
252 | -- * 2 bytes: client id | ||
253 | -- | ||
254 | -- * 4 bytes: version number | ||
255 | -- | ||
256 | -- * 1 byte : '-' | ||
257 | -- | ||
258 | -- * 12 bytes: random number | ||
259 | -- | ||
260 | azureusStyle :: ByteString -- ^ 2 character client ID, padded with 'H'. | ||
261 | -> ByteString -- ^ Version number, padded with 'X'. | ||
262 | -> ByteString -- ^ Random number, padded with '0'. | ||
263 | -> PeerId -- ^ Azureus-style encoded peer ID. | ||
264 | azureusStyle cid ver rnd = PeerId $ BL.toStrict $ BS.toLazyByteString $ | ||
265 | BS.char8 '-' <> | ||
266 | byteStringPadded cid 2 'H' <> | ||
267 | byteStringPadded ver 4 'X' <> | ||
268 | BS.char8 '-' <> | ||
269 | byteStringPadded rnd 12 '0' | ||
270 | |||
271 | -- | Shadow-style encoding have the following layout: | ||
272 | -- | ||
273 | -- * 1 byte : client id. | ||
274 | -- | ||
275 | -- * 0-4 bytes: version number. If less than 4 then padded with | ||
276 | -- '-' char. | ||
277 | -- | ||
278 | -- * 15 bytes : random number. If length is less than 15 then | ||
279 | -- padded with '0' char. | ||
280 | -- | ||
281 | shadowStyle :: Char -- ^ Client ID. | ||
282 | -> ByteString -- ^ Version number. | ||
283 | -> ByteString -- ^ Random number. | ||
284 | -> PeerId -- ^ Shadow style encoded peer ID. | ||
285 | shadowStyle cid ver rnd = PeerId $ BL.toStrict $ BS.toLazyByteString $ | ||
286 | BS.char8 cid <> | ||
287 | byteStringPadded ver 4 '-' <> | ||
288 | byteStringPadded rnd 15 '0' | ||
289 | |||
290 | |||
291 | -- | 'HS'- 2 bytes long client identifier. | ||
292 | defaultClientId :: ByteString | ||
293 | defaultClientId = "HS" | ||
294 | |||
295 | -- | Gives exactly 4 bytes long version number for any version of the | ||
296 | -- package. Version is taken from .cabal file. | ||
297 | defaultVersionNumber :: ByteString | ||
298 | defaultVersionNumber = BS.take 4 $ BC.pack $ foldMap show $ | ||
299 | versionBranch myVersion | ||
300 | where | ||
301 | Fingerprint _ myVersion = libFingerprint | ||
302 | |||
303 | ------------------------------------------------------------------------ | ||
304 | |||
305 | -- | Gives 15 characters long decimal timestamp such that: | ||
306 | -- | ||
307 | -- * 6 bytes : first 6 characters from picoseconds obtained with %q. | ||
308 | -- | ||
309 | -- * 1 byte : character \'.\' for readability. | ||
310 | -- | ||
311 | -- * 9..* bytes: number of whole seconds since the Unix epoch | ||
312 | -- (!)REVERSED. | ||
313 | -- | ||
314 | -- Can be used both with shadow and azureus style encoding. This | ||
315 | -- format is used to make the ID's readable for debugging purposes. | ||
316 | -- | ||
317 | timestamp :: IO ByteString | ||
318 | timestamp = (BC.pack . format) <$> getCurrentTime | ||
319 | where | ||
320 | format t = L.take 6 (formatTime defaultTimeLocale "%q" t) ++ "." ++ | ||
321 | L.take 9 (L.reverse (formatTime defaultTimeLocale "%s" t)) | ||
322 | |||
323 | -- | Gives 15 character long random bytestring. This is more robust | ||
324 | -- method for generation of random part of peer ID than 'timestamp'. | ||
325 | entropy :: IO ByteString | ||
326 | entropy = getEntropy 15 | ||
327 | |||
328 | -- NOTE: entropy generates incorrrect peer id | ||
329 | |||
330 | -- | Here we use 'azureusStyle' encoding with the following args: | ||
331 | -- | ||
332 | -- * 'HS' for the client id; ('defaultClientId') | ||
333 | -- | ||
334 | -- * Version of the package for the version number; | ||
335 | -- ('defaultVersionNumber') | ||
336 | -- | ||
337 | -- * UTC time day ++ day time for the random number. ('timestamp') | ||
338 | -- | ||
339 | genPeerId :: IO PeerId | ||
340 | genPeerId = azureusStyle defaultClientId defaultVersionNumber <$> timestamp | ||
341 | |||
342 | {----------------------------------------------------------------------- | ||
343 | -- Peer Addr | ||
344 | -----------------------------------------------------------------------} | ||
345 | -- $peer-addr | ||
346 | -- | ||
347 | -- 'PeerAddr' is used to represent peer address. Currently it's | ||
348 | -- just peer IP and peer port but this might change in future. | ||
349 | -- | ||
350 | |||
351 | {----------------------------------------------------------------------- | ||
352 | -- Port number | ||
353 | -----------------------------------------------------------------------} | ||
354 | |||
355 | instance BEncode PortNumber where | ||
356 | toBEncode = toBEncode . fromEnum | ||
357 | fromBEncode = fromBEncode >=> portNumber | ||
358 | where | ||
359 | portNumber :: Integer -> BS.Result PortNumber | ||
360 | portNumber n | ||
361 | | 0 <= n && n <= fromIntegral (maxBound :: Word16) | ||
362 | = pure $ fromIntegral n | ||
363 | | otherwise = decodingError $ "PortNumber: " ++ show n | ||
364 | |||
365 | instance Serialize PortNumber where | ||
366 | get = fromIntegral <$> getWord16be | ||
367 | {-# INLINE get #-} | ||
368 | put = putWord16be . fromIntegral | ||
369 | {-# INLINE put #-} | ||
370 | |||
371 | instance Hashable PortNumber where | ||
372 | hashWithSalt s = hashWithSalt s . fromEnum | ||
373 | {-# INLINE hashWithSalt #-} | ||
374 | |||
375 | instance Pretty PortNumber where | ||
376 | pretty = PP.int . fromEnum | ||
377 | {-# INLINE pretty #-} | ||
378 | |||
379 | {----------------------------------------------------------------------- | ||
380 | -- IP addr | ||
381 | -----------------------------------------------------------------------} | ||
382 | |||
383 | class IPAddress i where | ||
384 | toHostAddr :: i -> Either HostAddress HostAddress6 | ||
385 | |||
386 | instance IPAddress IPv4 where | ||
387 | toHostAddr = Left . toHostAddress | ||
388 | {-# INLINE toHostAddr #-} | ||
389 | |||
390 | instance IPAddress IPv6 where | ||
391 | toHostAddr = Right . toHostAddress6 | ||
392 | {-# INLINE toHostAddr #-} | ||
393 | |||
394 | instance IPAddress IP where | ||
395 | toHostAddr (IPv4 ip) = toHostAddr ip | ||
396 | toHostAddr (IPv6 ip) = toHostAddr ip | ||
397 | {-# INLINE toHostAddr #-} | ||
398 | |||
399 | deriving instance Typeable IP | ||
400 | deriving instance Typeable IPv4 | ||
401 | deriving instance Typeable IPv6 | ||
402 | |||
403 | ipToBEncode :: Show i => i -> BValue | ||
404 | ipToBEncode ip = BString $ BS8.pack $ show ip | ||
405 | {-# INLINE ipToBEncode #-} | ||
406 | |||
407 | ipFromBEncode :: Read a => BValue -> BS.Result a | ||
408 | ipFromBEncode (BString (BS8.unpack -> ipStr)) | ||
409 | | Just ip <- readMaybe (ipStr) = pure ip | ||
410 | | otherwise = decodingError $ "IP: " ++ ipStr | ||
411 | ipFromBEncode _ = decodingError $ "IP: addr should be a bstring" | ||
412 | |||
413 | instance BEncode IP where | ||
414 | toBEncode = ipToBEncode | ||
415 | {-# INLINE toBEncode #-} | ||
416 | fromBEncode = ipFromBEncode | ||
417 | {-# INLINE fromBEncode #-} | ||
418 | |||
419 | instance BEncode IPv4 where | ||
420 | toBEncode = ipToBEncode | ||
421 | {-# INLINE toBEncode #-} | ||
422 | fromBEncode = ipFromBEncode | ||
423 | {-# INLINE fromBEncode #-} | ||
424 | |||
425 | instance BEncode IPv6 where | ||
426 | toBEncode = ipToBEncode | ||
427 | {-# INLINE toBEncode #-} | ||
428 | fromBEncode = ipFromBEncode | ||
429 | {-# INLINE fromBEncode #-} | ||
430 | |||
431 | -- | When 'get'ing an IP it must be 'isolate'd to the appropriate | ||
432 | -- number of bytes since we have no other way of telling which | ||
433 | -- address type we are trying to parse | ||
434 | instance Serialize IP where | ||
435 | put (IPv4 ip) = put ip | ||
436 | put (IPv6 ip) = put ip | ||
437 | |||
438 | get = do | ||
439 | n <- remaining | ||
440 | case n of | ||
441 | 4 -> IPv4 <$> get | ||
442 | 16 -> IPv6 <$> get | ||
443 | _ -> fail "Wrong number of bytes remaining to parse IP" | ||
444 | |||
445 | instance Serialize IPv4 where | ||
446 | put = putWord32host . toHostAddress | ||
447 | get = fromHostAddress <$> getWord32host | ||
448 | |||
449 | instance Serialize IPv6 where | ||
450 | put ip = put $ toHostAddress6 ip | ||
451 | get = fromHostAddress6 <$> get | ||
452 | |||
453 | instance Pretty IPv4 where | ||
454 | pretty = PP.text . show | ||
455 | {-# INLINE pretty #-} | ||
456 | |||
457 | instance Pretty IPv6 where | ||
458 | pretty = PP.text . show | ||
459 | {-# INLINE pretty #-} | ||
460 | |||
461 | instance Pretty IP where | ||
462 | pretty = PP.text . show | ||
463 | {-# INLINE pretty #-} | ||
464 | |||
465 | instance Hashable IPv4 where | ||
466 | hashWithSalt = hashUsing toHostAddress | ||
467 | {-# INLINE hashWithSalt #-} | ||
468 | |||
469 | instance Hashable IPv6 where | ||
470 | hashWithSalt s a = hashWithSalt s (toHostAddress6 a) | ||
471 | |||
472 | instance Hashable IP where | ||
473 | hashWithSalt s (IPv4 h) = hashWithSalt s h | ||
474 | hashWithSalt s (IPv6 h) = hashWithSalt s h | ||
475 | |||
476 | {----------------------------------------------------------------------- | ||
477 | -- Peer addr | ||
478 | -----------------------------------------------------------------------} | ||
479 | -- TODO check semantic of ord and eq instances | ||
480 | |||
481 | -- | Peer address info normally extracted from peer list or peer | ||
482 | -- compact list encoding. | ||
483 | data PeerAddr a = PeerAddr | ||
484 | { peerId :: !(Maybe PeerId) | ||
485 | |||
486 | -- | This is usually 'IPv4', 'IPv6', 'IP' or unresolved | ||
487 | -- 'HostName'. | ||
488 | , peerHost :: !a | ||
489 | |||
490 | -- | The port the peer listenning for incoming P2P sessions. | ||
491 | , peerPort :: {-# UNPACK #-} !PortNumber | ||
492 | } deriving (Show, Eq, Ord, Typeable, Functor) | ||
493 | |||
494 | peer_ip_key, peer_id_key, peer_port_key :: BKey | ||
495 | peer_ip_key = "ip" | ||
496 | peer_id_key = "peer id" | ||
497 | peer_port_key = "port" | ||
498 | |||
499 | -- | The tracker's 'announce response' compatible encoding. | ||
500 | instance (Typeable a, BEncode a) => BEncode (PeerAddr a) where | ||
501 | toBEncode PeerAddr {..} = toDict $ | ||
502 | peer_ip_key .=! peerHost | ||
503 | .: peer_id_key .=? peerId | ||
504 | .: peer_port_key .=! peerPort | ||
505 | .: endDict | ||
506 | |||
507 | fromBEncode = fromDict $ do | ||
508 | peerAddr <$>! peer_ip_key | ||
509 | <*>? peer_id_key | ||
510 | <*>! peer_port_key | ||
511 | where | ||
512 | peerAddr = flip PeerAddr | ||
513 | |||
514 | -- | The tracker's 'compact peer list' compatible encoding. The | ||
515 | -- 'peerId' is always 'Nothing'. | ||
516 | -- | ||
517 | -- For more info see: <http://www.bittorrent.org/beps/bep_0023.html> | ||
518 | -- | ||
519 | -- TODO: test byte order | ||
520 | instance (Serialize a) => Serialize (PeerAddr a) where | ||
521 | put PeerAddr {..} = put peerHost >> put peerPort | ||
522 | get = PeerAddr Nothing <$> get <*> get | ||
523 | |||
524 | -- | @127.0.0.1:6881@ | ||
525 | instance Default (PeerAddr IPv4) where | ||
526 | def = "127.0.0.1:6881" | ||
527 | |||
528 | -- | @127.0.0.1:6881@ | ||
529 | instance Default (PeerAddr IP) where | ||
530 | def = IPv4 <$> def | ||
531 | |||
532 | -- | Example: | ||
533 | -- | ||
534 | -- @peerPort \"127.0.0.1:6881\" == 6881@ | ||
535 | -- | ||
536 | instance IsString (PeerAddr IPv4) where | ||
537 | fromString str | ||
538 | | [hostAddrStr, portStr] <- splitWhen (== ':') str | ||
539 | , Just hostAddr <- readMaybe hostAddrStr | ||
540 | , Just portNum <- toEnum <$> readMaybe portStr | ||
541 | = PeerAddr Nothing hostAddr portNum | ||
542 | | otherwise = error $ "fromString: unable to parse (PeerAddr IPv4): " ++ str | ||
543 | |||
544 | instance Read (PeerAddr IPv4) where | ||
545 | readsPrec i = RP.readP_to_S $ do | ||
546 | ipv4 <- RP.readS_to_P (readsPrec i) | ||
547 | _ <- RP.char ':' | ||
548 | port <- toEnum <$> RP.readS_to_P (readsPrec i) | ||
549 | return $ PeerAddr Nothing ipv4 port | ||
550 | |||
551 | readsIPv6_port :: String -> [((IPv6, PortNumber), String)] | ||
552 | readsIPv6_port = RP.readP_to_S $ do | ||
553 | ip <- RP.char '[' *> (RP.readS_to_P reads) <* RP.char ']' | ||
554 | _ <- RP.char ':' | ||
555 | port <- toEnum <$> read <$> (RP.many1 $ RP.satisfy isDigit) <* RP.eof | ||
556 | return (ip,port) | ||
557 | |||
558 | instance IsString (PeerAddr IPv6) where | ||
559 | fromString str | ||
560 | | [((ip,port),"")] <- readsIPv6_port str = | ||
561 | PeerAddr Nothing ip port | ||
562 | | otherwise = error $ "fromString: unable to parse (PeerAddr IPv6): " ++ str | ||
563 | |||
564 | instance IsString (PeerAddr IP) where | ||
565 | fromString str | ||
566 | | '[' `L.elem` str = IPv6 <$> fromString str | ||
567 | | otherwise = IPv4 <$> fromString str | ||
568 | |||
569 | -- | fingerprint + "at" + dotted.host.inet.addr:port | ||
570 | -- TODO: instances for IPv6, HostName | ||
571 | instance Pretty a => Pretty (PeerAddr a) where | ||
572 | pretty PeerAddr {..} | ||
573 | | Just pid <- peerId = pretty (fingerprint pid) <+> "at" <+> paddr | ||
574 | | otherwise = paddr | ||
575 | where | ||
576 | paddr = pretty peerHost <> ":" <> text (show peerPort) | ||
577 | |||
578 | instance Hashable a => Hashable (PeerAddr a) where | ||
579 | hashWithSalt s PeerAddr {..} = | ||
580 | s `hashWithSalt` peerId `hashWithSalt` peerHost `hashWithSalt` peerPort | ||
581 | |||
582 | -- | Ports typically reserved for bittorrent P2P listener. | ||
583 | defaultPorts :: [PortNumber] | ||
584 | defaultPorts = [6881..6889] | ||
585 | |||
586 | _resolvePeerAddr :: (IPAddress i) => PeerAddr HostName -> PeerAddr i | ||
587 | _resolvePeerAddr = undefined | ||
588 | |||
589 | _peerSockAddr :: PeerAddr IP -> (Family, SockAddr) | ||
590 | _peerSockAddr PeerAddr {..} = | ||
591 | case peerHost of | ||
592 | IPv4 ipv4 -> | ||
593 | (AF_INET, SockAddrInet peerPort (toHostAddress ipv4)) | ||
594 | IPv6 ipv6 -> | ||
595 | (AF_INET6, SockAddrInet6 peerPort 0 (toHostAddress6 ipv6) 0) | ||
596 | |||
597 | peerSockAddr :: PeerAddr IP -> SockAddr | ||
598 | peerSockAddr = snd . _peerSockAddr | ||
599 | |||
600 | -- | Create a socket connected to the address specified in a peerAddr | ||
601 | peerSocket :: SocketType -> PeerAddr IP -> IO Socket | ||
602 | peerSocket socketType pa = do | ||
603 | let (family, addr) = _peerSockAddr pa | ||
604 | sock <- socket family socketType defaultProtocol | ||
605 | connect sock addr | ||
606 | return sock | ||
607 | |||
608 | {----------------------------------------------------------------------- | ||
609 | -- Node info | ||
610 | -----------------------------------------------------------------------} | ||
611 | -- $node-info | ||
612 | -- | ||
613 | -- A \"node\" is a client\/server listening on a UDP port | ||
614 | -- implementing the distributed hash table protocol. The DHT is | ||
615 | -- composed of nodes and stores the location of peers. BitTorrent | ||
616 | -- clients include a DHT node, which is used to contact other nodes | ||
617 | -- in the DHT to get the location of peers to download from using | ||
618 | -- the BitTorrent protocol. | ||
619 | |||
620 | -- TODO more compact representation ('ShortByteString's?) | ||
621 | |||
622 | -- | Each node has a globally unique identifier known as the \"node | ||
623 | -- ID.\" | ||
624 | -- | ||
625 | -- Normally, /this/ node id should be saved between invocations | ||
626 | -- of the client software. | ||
627 | newtype NodeId = NodeId ByteString | ||
628 | deriving (Show, Eq, Ord, BEncode, Typeable) | ||
629 | |||
630 | nodeIdSize :: Int | ||
631 | nodeIdSize = 20 | ||
632 | |||
633 | -- | Meaningless node id, for testing purposes only. | ||
634 | instance Default NodeId where | ||
635 | def = NodeId (BS.replicate nodeIdSize 0) | ||
636 | |||
637 | instance Serialize NodeId where | ||
638 | get = NodeId <$> getByteString nodeIdSize | ||
639 | {-# INLINE get #-} | ||
640 | put (NodeId bs) = putByteString bs | ||
641 | {-# INLINE put #-} | ||
642 | |||
643 | -- | ASCII encoded. | ||
644 | instance IsString NodeId where | ||
645 | fromString str | ||
646 | | L.length str == nodeIdSize = NodeId (fromString str) | ||
647 | | otherwise = error "fromString: invalid NodeId length" | ||
648 | {-# INLINE fromString #-} | ||
649 | |||
650 | -- | base16 encoded. | ||
651 | instance Pretty NodeId where | ||
652 | pretty (NodeId nid) = PP.text $ BC.unpack $ Base16.encode nid | ||
653 | |||
654 | -- | Test if the nth bit is set. | ||
655 | testIdBit :: NodeId -> Word -> Bool | ||
656 | testIdBit (NodeId bs) i | ||
657 | | fromIntegral i < nodeIdSize * 8 | ||
658 | , (q, r) <- quotRem (fromIntegral i) 8 | ||
659 | = testBit (BS.index bs q) r | ||
660 | | otherwise = False | ||
661 | {-# INLINE testIdBit #-} | ||
662 | |||
663 | -- TODO WARN is the 'system' random suitable for this? | ||
664 | -- | Generate random NodeID used for the entire session. | ||
665 | -- Distribution of ID's should be as uniform as possible. | ||
666 | -- | ||
667 | genNodeId :: IO NodeId | ||
668 | genNodeId = NodeId <$> getEntropy nodeIdSize | ||
669 | |||
670 | ------------------------------------------------------------------------ | ||
671 | |||
672 | -- | In Kademlia, the distance metric is XOR and the result is | ||
673 | -- interpreted as an unsigned integer. | ||
674 | newtype NodeDistance = NodeDistance BS.ByteString | ||
675 | deriving (Eq, Ord) | ||
676 | |||
677 | instance Pretty NodeDistance where | ||
678 | pretty (NodeDistance bs) = foldMap bitseq $ BS.unpack bs | ||
679 | where | ||
680 | listBits w = L.map (testBit w) (L.reverse [0..bitSize w - 1]) | ||
681 | bitseq = foldMap (int . fromEnum) . listBits | ||
682 | |||
683 | -- | distance(A,B) = |A xor B| Smaller values are closer. | ||
684 | distance :: NodeId -> NodeId -> NodeDistance | ||
685 | distance (NodeId a) (NodeId b) = NodeDistance (BS.pack (BS.zipWith xor a b)) | ||
686 | |||
687 | ------------------------------------------------------------------------ | ||
688 | |||
689 | data NodeAddr a = NodeAddr | ||
690 | { nodeHost :: !a | ||
691 | , nodePort :: {-# UNPACK #-} !PortNumber | ||
692 | } deriving (Eq, Typeable, Functor) | ||
693 | |||
694 | instance Show a => Show (NodeAddr a) where | ||
695 | showsPrec i NodeAddr {..} | ||
696 | = showsPrec i nodeHost <> showString ":" <> showsPrec i nodePort | ||
697 | |||
698 | instance Read (NodeAddr IPv4) where | ||
699 | readsPrec i x = [ (fromPeerAddr a, s) | (a, s) <- readsPrec i x ] | ||
700 | |||
701 | -- | @127.0.0.1:6882@ | ||
702 | instance Default (NodeAddr IPv4) where | ||
703 | def = "127.0.0.1:6882" | ||
704 | |||
705 | -- | KRPC compatible encoding. | ||
706 | instance Serialize a => Serialize (NodeAddr a) where | ||
707 | get = NodeAddr <$> get <*> get | ||
708 | {-# INLINE get #-} | ||
709 | put NodeAddr {..} = put nodeHost >> put nodePort | ||
710 | {-# INLINE put #-} | ||
711 | |||
712 | -- | Torrent file compatible encoding. | ||
713 | instance BEncode a => BEncode (NodeAddr a) where | ||
714 | toBEncode NodeAddr {..} = toBEncode (nodeHost, nodePort) | ||
715 | {-# INLINE toBEncode #-} | ||
716 | fromBEncode b = uncurry NodeAddr <$> fromBEncode b | ||
717 | {-# INLINE fromBEncode #-} | ||
718 | |||
719 | instance Hashable a => Hashable (NodeAddr a) where | ||
720 | hashWithSalt s NodeAddr {..} = hashWithSalt s (nodeHost, nodePort) | ||
721 | {-# INLINE hashWithSalt #-} | ||
722 | |||
723 | instance Pretty ip => Pretty (NodeAddr ip) where | ||
724 | pretty NodeAddr {..} = pretty nodeHost <> ":" <> pretty nodePort | ||
725 | |||
726 | -- | Example: | ||
727 | -- | ||
728 | -- @nodePort \"127.0.0.1:6881\" == 6881@ | ||
729 | -- | ||
730 | instance IsString (NodeAddr IPv4) where | ||
731 | fromString = fromPeerAddr . fromString | ||
732 | |||
733 | fromPeerAddr :: PeerAddr a -> NodeAddr a | ||
734 | fromPeerAddr PeerAddr {..} = NodeAddr | ||
735 | { nodeHost = peerHost | ||
736 | , nodePort = peerPort | ||
737 | } | ||
738 | |||
739 | ------------------------------------------------------------------------ | ||
740 | |||
741 | data NodeInfo a = NodeInfo | ||
742 | { nodeId :: !NodeId | ||
743 | , nodeAddr :: !(NodeAddr a) | ||
744 | } deriving (Show, Eq, Functor) | ||
745 | |||
746 | instance Eq a => Ord (NodeInfo a) where | ||
747 | compare = comparing nodeId | ||
748 | |||
749 | -- | KRPC 'compact list' compatible encoding: contact information for | ||
750 | -- nodes is encoded as a 26-byte string. Also known as "Compact node | ||
751 | -- info" the 20-byte Node ID in network byte order has the compact | ||
752 | -- IP-address/port info concatenated to the end. | ||
753 | instance Serialize a => Serialize (NodeInfo a) where | ||
754 | get = NodeInfo <$> get <*> get | ||
755 | put NodeInfo {..} = put nodeId >> put nodeAddr | ||
756 | |||
757 | instance Pretty ip => Pretty (NodeInfo ip) where | ||
758 | pretty NodeInfo {..} = pretty nodeId <> "@(" <> pretty nodeAddr <> ")" | ||
759 | |||
760 | instance Pretty ip => Pretty [NodeInfo ip] where | ||
761 | pretty = PP.vcat . PP.punctuate "," . L.map pretty | ||
762 | |||
763 | -- | Order by closeness: nearest nodes first. | ||
764 | rank :: Eq ip => NodeId -> [NodeInfo ip] -> [NodeInfo ip] | ||
765 | rank nid = L.sortBy (comparing (distance nid . nodeId)) | ||
766 | |||
767 | {----------------------------------------------------------------------- | ||
768 | -- Fingerprint | ||
769 | -----------------------------------------------------------------------} | ||
770 | -- $fingerprint | ||
771 | -- | ||
772 | -- 'Fingerprint' is used to identify the client implementation and | ||
773 | -- version which also contained in 'Peer'. For exsample first 6 | ||
774 | -- bytes of peer id of this this library are @-HS0100-@ while for | ||
775 | -- mainline we have @M4-3-6--@. We could extract this info and | ||
776 | -- print in human-friendly form: this is useful for debugging and | ||
777 | -- logging. | ||
778 | -- | ||
779 | -- For more information see: | ||
780 | -- <http://bittorrent.org/beps/bep_0020.html> | ||
781 | -- | ||
782 | -- | ||
783 | -- NOTE: Do /not/ use this information to control client | ||
784 | -- capabilities (such as supported enchancements), this should be | ||
785 | -- done using 'Network.BitTorrent.Extension'! | ||
786 | -- | ||
787 | |||
788 | -- TODO FIXME | ||
789 | version :: Version | ||
790 | version = Version [0, 0, 0, 3] [] | ||
791 | |||
792 | -- | List of registered client versions + 'IlibHSbittorrent' (this | ||
793 | -- package) + 'IUnknown' (for not recognized software). All names are | ||
794 | -- prefixed by \"I\" because some of them starts from lowercase letter | ||
795 | -- but that is not a valid Haskell constructor name. | ||
796 | -- | ||
797 | data Software = | ||
798 | IUnknown | ||
799 | |||
800 | | IMainline | ||
801 | |||
802 | | IABC | ||
803 | | IOspreyPermaseed | ||
804 | | IBTQueue | ||
805 | | ITribler | ||
806 | | IShadow | ||
807 | | IBitTornado | ||
808 | |||
809 | -- UPnP(!) Bit Torrent !??? | ||
810 | -- 'U' - UPnP NAT Bit Torrent | ||
811 | | IBitLord | ||
812 | | IOpera | ||
813 | | IMLdonkey | ||
814 | |||
815 | | IAres | ||
816 | | IArctic | ||
817 | | IAvicora | ||
818 | | IBitPump | ||
819 | | IAzureus | ||
820 | | IBitBuddy | ||
821 | | IBitComet | ||
822 | | IBitflu | ||
823 | | IBTG | ||
824 | | IBitRocket | ||
825 | | IBTSlave | ||
826 | | IBittorrentX | ||
827 | | IEnhancedCTorrent | ||
828 | | ICTorrent | ||
829 | | IDelugeTorrent | ||
830 | | IPropagateDataClient | ||
831 | | IEBit | ||
832 | | IElectricSheep | ||
833 | | IFoxTorrent | ||
834 | | IGSTorrent | ||
835 | | IHalite | ||
836 | | IlibHSbittorrent | ||
837 | | IHydranode | ||
838 | | IKGet | ||
839 | | IKTorrent | ||
840 | | ILH_ABC | ||
841 | | ILphant | ||
842 | | ILibtorrent | ||
843 | | ILibTorrent | ||
844 | | ILimeWire | ||
845 | | IMonoTorrent | ||
846 | | IMooPolice | ||
847 | | IMiro | ||
848 | | IMoonlightTorrent | ||
849 | | INetTransport | ||
850 | | IPando | ||
851 | | IqBittorrent | ||
852 | | IQQDownload | ||
853 | | IQt4TorrentExample | ||
854 | | IRetriever | ||
855 | | IShareaza | ||
856 | | ISwiftbit | ||
857 | | ISwarmScope | ||
858 | | ISymTorrent | ||
859 | | Isharktorrent | ||
860 | | ITorrentDotNET | ||
861 | | ITransmission | ||
862 | | ITorrentstorm | ||
863 | | ITuoTu | ||
864 | | IuLeecher | ||
865 | | IuTorrent | ||
866 | | IVagaa | ||
867 | | IBitLet | ||
868 | | IFireTorrent | ||
869 | | IXunlei | ||
870 | | IXanTorrent | ||
871 | | IXtorrent | ||
872 | | IZipTorrent | ||
873 | deriving (Show, Eq, Ord, Enum, Bounded) | ||
874 | |||
875 | parseSoftware :: ByteString -> Software | ||
876 | parseSoftware = f . BC.unpack | ||
877 | where | ||
878 | f "AG" = IAres | ||
879 | f "A~" = IAres | ||
880 | f "AR" = IArctic | ||
881 | f "AV" = IAvicora | ||
882 | f "AX" = IBitPump | ||
883 | f "AZ" = IAzureus | ||
884 | f "BB" = IBitBuddy | ||
885 | f "BC" = IBitComet | ||
886 | f "BF" = IBitflu | ||
887 | f "BG" = IBTG | ||
888 | f "BR" = IBitRocket | ||
889 | f "BS" = IBTSlave | ||
890 | f "BX" = IBittorrentX | ||
891 | f "CD" = IEnhancedCTorrent | ||
892 | f "CT" = ICTorrent | ||
893 | f "DE" = IDelugeTorrent | ||
894 | f "DP" = IPropagateDataClient | ||
895 | f "EB" = IEBit | ||
896 | f "ES" = IElectricSheep | ||
897 | f "FT" = IFoxTorrent | ||
898 | f "GS" = IGSTorrent | ||
899 | f "HL" = IHalite | ||
900 | f "HS" = IlibHSbittorrent | ||
901 | f "HN" = IHydranode | ||
902 | f "KG" = IKGet | ||
903 | f "KT" = IKTorrent | ||
904 | f "LH" = ILH_ABC | ||
905 | f "LP" = ILphant | ||
906 | f "LT" = ILibtorrent | ||
907 | f "lt" = ILibTorrent | ||
908 | f "LW" = ILimeWire | ||
909 | f "MO" = IMonoTorrent | ||
910 | f "MP" = IMooPolice | ||
911 | f "MR" = IMiro | ||
912 | f "ML" = IMLdonkey | ||
913 | f "MT" = IMoonlightTorrent | ||
914 | f "NX" = INetTransport | ||
915 | f "PD" = IPando | ||
916 | f "qB" = IqBittorrent | ||
917 | f "QD" = IQQDownload | ||
918 | f "QT" = IQt4TorrentExample | ||
919 | f "RT" = IRetriever | ||
920 | f "S~" = IShareaza | ||
921 | f "SB" = ISwiftbit | ||
922 | f "SS" = ISwarmScope | ||
923 | f "ST" = ISymTorrent | ||
924 | f "st" = Isharktorrent | ||
925 | f "SZ" = IShareaza | ||
926 | f "TN" = ITorrentDotNET | ||
927 | f "TR" = ITransmission | ||
928 | f "TS" = ITorrentstorm | ||
929 | f "TT" = ITuoTu | ||
930 | f "UL" = IuLeecher | ||
931 | f "UT" = IuTorrent | ||
932 | f "VG" = IVagaa | ||
933 | f "WT" = IBitLet | ||
934 | f "WY" = IFireTorrent | ||
935 | f "XL" = IXunlei | ||
936 | f "XT" = IXanTorrent | ||
937 | f "XX" = IXtorrent | ||
938 | f "ZT" = IZipTorrent | ||
939 | f _ = IUnknown | ||
940 | |||
941 | -- | Used to represent a not recognized implementation | ||
942 | instance Default Software where | ||
943 | def = IUnknown | ||
944 | {-# INLINE def #-} | ||
945 | |||
946 | -- | Example: @\"BitLet\" == 'IBitLet'@ | ||
947 | instance IsString Software where | ||
948 | fromString str | ||
949 | | Just impl <- L.lookup str alist = impl | ||
950 | | otherwise = error $ "fromString: not recognized " ++ str | ||
951 | where | ||
952 | alist = L.map mk [minBound..maxBound] | ||
953 | mk x = (L.tail $ show x, x) | ||
954 | |||
955 | -- | Example: @pretty 'IBitLet' == \"IBitLet\"@ | ||
956 | instance Pretty Software where | ||
957 | pretty = text . L.tail . show | ||
958 | |||
959 | -- | Just the '0' version. | ||
960 | instance Default Version where | ||
961 | def = Version [0] [] | ||
962 | {-# INLINE def #-} | ||
963 | |||
964 | -- | For dot delimited version strings. | ||
965 | -- Example: @fromString \"0.1.0.2\" == Version [0, 1, 0, 2]@ | ||
966 | -- | ||
967 | instance IsString Version where | ||
968 | fromString str | ||
969 | | Just nums <- chunkNums str = Version nums [] | ||
970 | | otherwise = error $ "fromString: invalid version string " ++ str | ||
971 | where | ||
972 | chunkNums = sequence . L.map readMaybe . L.linesBy ('.' ==) | ||
973 | |||
974 | instance Pretty Version where | ||
975 | pretty = text . showVersion | ||
976 | |||
977 | -- | The all sensible infomation that can be obtained from a peer | ||
978 | -- identifier or torrent /createdBy/ field. | ||
979 | data Fingerprint = Fingerprint Software Version | ||
980 | deriving (Show, Eq, Ord) | ||
981 | |||
982 | -- | Unrecognized client implementation. | ||
983 | instance Default Fingerprint where | ||
984 | def = Fingerprint def def | ||
985 | {-# INLINE def #-} | ||
986 | |||
987 | -- | Example: @\"BitComet-1.2\" == ClientInfo IBitComet (Version [1, 2] [])@ | ||
988 | instance IsString Fingerprint where | ||
989 | fromString str | ||
990 | | _ : ver <- _ver = Fingerprint (fromString impl) (fromString ver) | ||
991 | | otherwise = error $ "fromString: invalid client info string" ++ str | ||
992 | where | ||
993 | (impl, _ver) = L.span ((/=) '-') str | ||
994 | |||
995 | instance Pretty Fingerprint where | ||
996 | pretty (Fingerprint s v) = pretty s <+> "version" <+> pretty v | ||
997 | |||
998 | -- | Fingerprint of this (the bittorrent library) package. Normally, | ||
999 | -- applications should introduce its own fingerprints, otherwise they | ||
1000 | -- can use 'libFingerprint' value. | ||
1001 | -- | ||
1002 | libFingerprint :: Fingerprint | ||
1003 | libFingerprint = Fingerprint IlibHSbittorrent version | ||
1004 | |||
1005 | -- | HTTP user agent of this (the bittorrent library) package. Can be | ||
1006 | -- used in HTTP tracker requests. | ||
1007 | libUserAgent :: String | ||
1008 | libUserAgent = render (pretty IlibHSbittorrent <> "/" <> pretty version) | ||
1009 | |||
1010 | {----------------------------------------------------------------------- | ||
1011 | -- For torrent file | ||
1012 | -----------------------------------------------------------------------} | ||
1013 | -- TODO collect information about createdBy torrent field | ||
1014 | {- | ||
1015 | renderImpl :: ClientImpl -> Text | ||
1016 | renderImpl = T.pack . L.tail . show | ||
1017 | |||
1018 | renderVersion :: Version -> Text | ||
1019 | renderVersion = undefined | ||
1020 | |||
1021 | renderClientInfo :: ClientInfo -> Text | ||
1022 | renderClientInfo ClientInfo {..} = renderImpl ciImpl <> "/" <> renderVersion ciVersion | ||
1023 | |||
1024 | parseClientInfo :: Text -> ClientImpl | ||
1025 | parseClientInfo t = undefined | ||
1026 | -} | ||
1027 | {- | ||
1028 | -- code used for generation; remove it later on | ||
1029 | |||
1030 | mkEnumTyDef :: NM -> String | ||
1031 | mkEnumTyDef = unlines . map (" | I" ++) . nub . map snd | ||
1032 | |||
1033 | mkPars :: NM -> String | ||
1034 | mkPars = unlines . map (\(code, impl) -> " f \"" ++ code ++ "\" = " ++ "I" ++ impl) | ||
1035 | |||
1036 | type NM = [(String, String)] | ||
1037 | nameMap :: NM | ||
1038 | nameMap = | ||
1039 | [ ("AG", "Ares") | ||
1040 | , ("A~", "Ares") | ||
1041 | , ("AR", "Arctic") | ||
1042 | , ("AV", "Avicora") | ||
1043 | , ("AX", "BitPump") | ||
1044 | , ("AZ", "Azureus") | ||
1045 | , ("BB", "BitBuddy") | ||
1046 | , ("BC", "BitComet") | ||
1047 | , ("BF", "Bitflu") | ||
1048 | , ("BG", "BTG") | ||
1049 | , ("BR", "BitRocket") | ||
1050 | , ("BS", "BTSlave") | ||
1051 | , ("BX", "BittorrentX") | ||
1052 | , ("CD", "EnhancedCTorrent") | ||
1053 | , ("CT", "CTorrent") | ||
1054 | , ("DE", "DelugeTorrent") | ||
1055 | , ("DP", "PropagateDataClient") | ||
1056 | , ("EB", "EBit") | ||
1057 | , ("ES", "ElectricSheep") | ||
1058 | , ("FT", "FoxTorrent") | ||
1059 | , ("GS", "GSTorrent") | ||
1060 | , ("HL", "Halite") | ||
1061 | , ("HS", "libHSnetwork_bittorrent") | ||
1062 | , ("HN", "Hydranode") | ||
1063 | , ("KG", "KGet") | ||
1064 | , ("KT", "KTorrent") | ||
1065 | , ("LH", "LH_ABC") | ||
1066 | , ("LP", "Lphant") | ||
1067 | , ("LT", "Libtorrent") | ||
1068 | , ("lt", "LibTorrent") | ||
1069 | , ("LW", "LimeWire") | ||
1070 | , ("MO", "MonoTorrent") | ||
1071 | , ("MP", "MooPolice") | ||
1072 | , ("MR", "Miro") | ||
1073 | , ("MT", "MoonlightTorrent") | ||
1074 | , ("NX", "NetTransport") | ||
1075 | , ("PD", "Pando") | ||
1076 | , ("qB", "qBittorrent") | ||
1077 | , ("QD", "QQDownload") | ||
1078 | , ("QT", "Qt4TorrentExample") | ||
1079 | , ("RT", "Retriever") | ||
1080 | , ("S~", "Shareaza") | ||
1081 | , ("SB", "Swiftbit") | ||
1082 | , ("SS", "SwarmScope") | ||
1083 | , ("ST", "SymTorrent") | ||
1084 | , ("st", "sharktorrent") | ||
1085 | , ("SZ", "Shareaza") | ||
1086 | , ("TN", "TorrentDotNET") | ||
1087 | , ("TR", "Transmission") | ||
1088 | , ("TS", "Torrentstorm") | ||
1089 | , ("TT", "TuoTu") | ||
1090 | , ("UL", "uLeecher") | ||
1091 | , ("UT", "uTorrent") | ||
1092 | , ("VG", "Vagaa") | ||
1093 | , ("WT", "BitLet") | ||
1094 | , ("WY", "FireTorrent") | ||
1095 | , ("XL", "Xunlei") | ||
1096 | , ("XT", "XanTorrent") | ||
1097 | , ("XX", "Xtorrent") | ||
1098 | , ("ZT", "ZipTorrent") | ||
1099 | ] | ||
1100 | -} | ||
1101 | |||
1102 | -- TODO use regexps | ||
1103 | |||
1104 | -- | Tries to extract meaningful information from peer ID bytes. If | ||
1105 | -- peer id uses unknown coding style then client info returned is | ||
1106 | -- 'def'. | ||
1107 | -- | ||
1108 | fingerprint :: PeerId -> Fingerprint | ||
1109 | fingerprint pid = either (const def) id $ runGet getCI (getPeerId pid) | ||
1110 | where | ||
1111 | getCI = do | ||
1112 | leading <- BS.w2c <$> getWord8 | ||
1113 | case leading of | ||
1114 | '-' -> Fingerprint <$> getAzureusImpl <*> getAzureusVersion | ||
1115 | 'M' -> Fingerprint <$> pure IMainline <*> getMainlineVersion | ||
1116 | 'e' -> Fingerprint <$> getBitCometImpl <*> getBitCometVersion | ||
1117 | 'F' -> Fingerprint <$> getBitCometImpl <*> getBitCometVersion | ||
1118 | c -> do | ||
1119 | c1 <- w2c <$> S.lookAhead getWord8 | ||
1120 | if c1 == 'P' | ||
1121 | then do | ||
1122 | _ <- getWord8 | ||
1123 | Fingerprint <$> pure IOpera <*> getOperaVersion | ||
1124 | else Fingerprint <$> pure (getShadowImpl c) <*> getShadowVersion | ||
1125 | |||
1126 | getMainlineVersion = do | ||
1127 | str <- BC.unpack <$> getByteString 7 | ||
1128 | let mnums = L.filter (not . L.null) $ L.linesBy ('-' ==) str | ||
1129 | return $ Version (fromMaybe [] $ sequence $ L.map readMaybe mnums) [] | ||
1130 | |||
1131 | getAzureusImpl = parseSoftware <$> getByteString 2 | ||
1132 | getAzureusVersion = mkVer <$> getByteString 4 | ||
1133 | where | ||
1134 | mkVer bs = Version [fromMaybe 0 $ readMaybe $ BC.unpack bs] [] | ||
1135 | |||
1136 | getBitCometImpl = do | ||
1137 | bs <- getByteString 3 | ||
1138 | S.lookAhead $ do | ||
1139 | _ <- getByteString 2 | ||
1140 | lr <- getByteString 4 | ||
1141 | return $ | ||
1142 | if lr == "LORD" then IBitLord else | ||
1143 | if bs == "UTB" then IBitComet else | ||
1144 | if bs == "xbc" then IBitComet else def | ||
1145 | |||
1146 | getBitCometVersion = do | ||
1147 | x <- getWord8 | ||
1148 | y <- getWord8 | ||
1149 | return $ Version [fromIntegral x, fromIntegral y] [] | ||
1150 | |||
1151 | getOperaVersion = do | ||
1152 | str <- BC.unpack <$> getByteString 4 | ||
1153 | return $ Version [fromMaybe 0 $ readMaybe str] [] | ||
1154 | |||
1155 | getShadowImpl 'A' = IABC | ||
1156 | getShadowImpl 'O' = IOspreyPermaseed | ||
1157 | getShadowImpl 'Q' = IBTQueue | ||
1158 | getShadowImpl 'R' = ITribler | ||
1159 | getShadowImpl 'S' = IShadow | ||
1160 | getShadowImpl 'T' = IBitTornado | ||
1161 | getShadowImpl _ = IUnknown | ||
1162 | |||
1163 | decodeShadowVerNr :: Char -> Maybe Int | ||
1164 | decodeShadowVerNr c | ||
1165 | | '0' < c && c <= '9' = Just (fromEnum c - fromEnum '0') | ||
1166 | | 'A' < c && c <= 'Z' = Just ((fromEnum c - fromEnum 'A') + 10) | ||
1167 | | 'a' < c && c <= 'z' = Just ((fromEnum c - fromEnum 'a') + 36) | ||
1168 | | otherwise = Nothing | ||
1169 | |||
1170 | getShadowVersion = do | ||
1171 | str <- BC.unpack <$> getByteString 5 | ||
1172 | return $ Version (catMaybes $ L.map decodeShadowVerNr str) [] | ||
diff --git a/src/Network/BitTorrent/Client.hs b/src/Network/BitTorrent/Client.hs index bf6740c3..d21b4d1e 100644 --- a/src/Network/BitTorrent/Client.hs +++ b/src/Network/BitTorrent/Client.hs | |||
@@ -61,11 +61,9 @@ import Data.Text | |||
61 | import Network | 61 | import Network |
62 | 62 | ||
63 | import Data.Torrent | 63 | import Data.Torrent |
64 | import Data.Torrent.InfoHash | 64 | import Network.BitTorrent.Address |
65 | import Data.Torrent.Magnet | ||
66 | import Network.BitTorrent.Client.Types | 65 | import Network.BitTorrent.Client.Types |
67 | import Network.BitTorrent.Client.Handle | 66 | import Network.BitTorrent.Client.Handle |
68 | import Network.BitTorrent.Core | ||
69 | import Network.BitTorrent.DHT as DHT hiding (Options) | 67 | import Network.BitTorrent.DHT as DHT hiding (Options) |
70 | import Network.BitTorrent.Tracker as Tracker hiding (Options) | 68 | import Network.BitTorrent.Tracker as Tracker hiding (Options) |
71 | import Network.BitTorrent.Exchange as Exchange hiding (Options) | 69 | import Network.BitTorrent.Exchange as Exchange hiding (Options) |
diff --git a/src/Network/BitTorrent/Client/Handle.hs b/src/Network/BitTorrent/Client/Handle.hs index 0d1b7f92..66baac48 100644 --- a/src/Network/BitTorrent/Client/Handle.hs +++ b/src/Network/BitTorrent/Client/Handle.hs | |||
@@ -26,8 +26,6 @@ import Data.List as L | |||
26 | import Data.HashMap.Strict as HM | 26 | import Data.HashMap.Strict as HM |
27 | 27 | ||
28 | import Data.Torrent | 28 | import Data.Torrent |
29 | import Data.Torrent.InfoHash | ||
30 | import Data.Torrent.Magnet | ||
31 | import Network.BitTorrent.Client.Types as Types | 29 | import Network.BitTorrent.Client.Types as Types |
32 | import Network.BitTorrent.DHT as DHT | 30 | import Network.BitTorrent.DHT as DHT |
33 | import Network.BitTorrent.Exchange as Exchange | 31 | import Network.BitTorrent.Exchange as Exchange |
diff --git a/src/Network/BitTorrent/Client/Types.hs b/src/Network/BitTorrent/Client/Types.hs index c019bc5f..9bae7dc3 100644 --- a/src/Network/BitTorrent/Client/Types.hs +++ b/src/Network/BitTorrent/Client/Types.hs | |||
@@ -34,9 +34,9 @@ import Data.Ord | |||
34 | import Network | 34 | import Network |
35 | import System.Log.FastLogger | 35 | import System.Log.FastLogger |
36 | 36 | ||
37 | import Data.Torrent.InfoHash | 37 | import Data.Torrent |
38 | import Network.BitTorrent.Address | ||
38 | import Network.BitTorrent.Internal.Types as Types | 39 | import Network.BitTorrent.Internal.Types as Types |
39 | import Network.BitTorrent.Core | ||
40 | import Network.BitTorrent.DHT as DHT | 40 | import Network.BitTorrent.DHT as DHT |
41 | import Network.BitTorrent.Exchange as Exchange | 41 | import Network.BitTorrent.Exchange as Exchange |
42 | import Network.BitTorrent.Tracker as Tracker hiding (Event) | 42 | import Network.BitTorrent.Tracker as Tracker hiding (Event) |
@@ -100,7 +100,7 @@ externalAddr Client {..} = PeerAddr | |||
100 | newtype BitTorrent a = BitTorrent | 100 | newtype BitTorrent a = BitTorrent |
101 | { unBitTorrent :: ReaderT Client IO a | 101 | { unBitTorrent :: ReaderT Client IO a |
102 | } deriving ( Functor, Applicative, Monad | 102 | } deriving ( Functor, Applicative, Monad |
103 | , MonadIO, MonadThrow, MonadUnsafeIO, MonadBase IO | 103 | , MonadIO, MonadThrow, MonadBase IO |
104 | ) | 104 | ) |
105 | 105 | ||
106 | class MonadBitTorrent m where | 106 | class MonadBitTorrent m where |
diff --git a/src/Network/BitTorrent/Core.hs b/src/Network/BitTorrent/Core.hs deleted file mode 100644 index b9b3c065..00000000 --- a/src/Network/BitTorrent/Core.hs +++ /dev/null | |||
@@ -1,88 +0,0 @@ | |||
1 | -- | | ||
2 | -- Copyright : (c) Sam Truzjan 2013 | ||
3 | -- License : BSD3 | ||
4 | -- Maintainer : pxqr.sta@gmail.com | ||
5 | -- Stability : experimental | ||
6 | -- Portability : portable | ||
7 | -- | ||
8 | -- Re-export every @Network.BitTorrent.Core.*@ module. | ||
9 | -- | ||
10 | module Network.BitTorrent.Core | ||
11 | ( module Core | ||
12 | |||
13 | -- * Address class | ||
14 | , Address (..) | ||
15 | , fromAddr | ||
16 | |||
17 | -- * Re-exports from Data.IP | ||
18 | , IPv4 | ||
19 | , IPv6 | ||
20 | , IP (..) | ||
21 | ) where | ||
22 | |||
23 | import Control.Applicative | ||
24 | import Data.IP | ||
25 | import Data.Hashable | ||
26 | import Data.Serialize | ||
27 | import Data.Time | ||
28 | import Data.Typeable | ||
29 | import Network.Socket (SockAddr (..), PortNumber) | ||
30 | import Text.PrettyPrint as PP hiding ((<>)) | ||
31 | import Text.PrettyPrint.Class | ||
32 | |||
33 | import Network.BitTorrent.Core.Fingerprint as Core | ||
34 | import Network.BitTorrent.Core.NodeInfo as Core | ||
35 | import Network.BitTorrent.Core.PeerId as Core | ||
36 | import Network.BitTorrent.Core.PeerAddr as Core | ||
37 | |||
38 | |||
39 | instance Pretty UTCTime where | ||
40 | pretty = PP.text . show | ||
41 | |||
42 | class (Eq a, Serialize a, Typeable a, Hashable a, Pretty a) | ||
43 | => Address a where | ||
44 | toSockAddr :: a -> SockAddr | ||
45 | fromSockAddr :: SockAddr -> Maybe a | ||
46 | |||
47 | fromAddr :: (Address a, Address b) => a -> Maybe b | ||
48 | fromAddr = fromSockAddr . toSockAddr | ||
49 | |||
50 | -- | Note that port is zeroed. | ||
51 | instance Address IPv4 where | ||
52 | toSockAddr = SockAddrInet 0 . toHostAddress | ||
53 | fromSockAddr (SockAddrInet _ h) = Just (fromHostAddress h) | ||
54 | fromSockAddr _ = Nothing | ||
55 | |||
56 | -- | Note that port is zeroed. | ||
57 | instance Address IPv6 where | ||
58 | toSockAddr h = SockAddrInet6 0 0 (toHostAddress6 h) 0 | ||
59 | fromSockAddr (SockAddrInet6 _ _ h _) = Just (fromHostAddress6 h) | ||
60 | fromSockAddr _ = Nothing | ||
61 | |||
62 | -- | Note that port is zeroed. | ||
63 | instance Address IP where | ||
64 | toSockAddr (IPv4 h) = toSockAddr h | ||
65 | toSockAddr (IPv6 h) = toSockAddr h | ||
66 | fromSockAddr sa = | ||
67 | IPv4 <$> fromSockAddr sa | ||
68 | <|> IPv6 <$> fromSockAddr sa | ||
69 | |||
70 | setPort :: PortNumber -> SockAddr -> SockAddr | ||
71 | setPort port (SockAddrInet _ h ) = SockAddrInet port h | ||
72 | setPort port (SockAddrInet6 _ f h s) = SockAddrInet6 port f h s | ||
73 | setPort _ (SockAddrUnix s ) = SockAddrUnix s | ||
74 | {-# INLINE setPort #-} | ||
75 | |||
76 | getPort :: SockAddr -> Maybe PortNumber | ||
77 | getPort (SockAddrInet p _ ) = Just p | ||
78 | getPort (SockAddrInet6 p _ _ _) = Just p | ||
79 | getPort (SockAddrUnix _ ) = Nothing | ||
80 | {-# INLINE getPort #-} | ||
81 | |||
82 | instance Address a => Address (NodeAddr a) where | ||
83 | toSockAddr NodeAddr {..} = setPort nodePort $ toSockAddr nodeHost | ||
84 | fromSockAddr sa = NodeAddr <$> fromSockAddr sa <*> getPort sa | ||
85 | |||
86 | instance Address a => Address (PeerAddr a) where | ||
87 | toSockAddr PeerAddr {..} = setPort peerPort $ toSockAddr peerHost | ||
88 | fromSockAddr sa = PeerAddr Nothing <$> fromSockAddr sa <*> getPort sa | ||
diff --git a/src/Network/BitTorrent/Core/Fingerprint.hs b/src/Network/BitTorrent/Core/Fingerprint.hs deleted file mode 100644 index d743acd0..00000000 --- a/src/Network/BitTorrent/Core/Fingerprint.hs +++ /dev/null | |||
@@ -1,290 +0,0 @@ | |||
1 | -- | | ||
2 | -- Copyright : (c) Sam Truzjan 2013 | ||
3 | -- License : BSD3 | ||
4 | -- Maintainer : pxqr.sta@gmail.com | ||
5 | -- Stability : experimental | ||
6 | -- Portability : portable | ||
7 | -- | ||
8 | -- 'Fingerprint' is used to identify the client implementation and | ||
9 | -- version which also contained in 'Peer'. For exsample first 6 | ||
10 | -- bytes of peer id of this this library are @-HS0100-@ while for | ||
11 | -- mainline we have @M4-3-6--@. We could extract this info and | ||
12 | -- print in human-friendly form: this is useful for debugging and | ||
13 | -- logging. | ||
14 | -- | ||
15 | -- For more information see: | ||
16 | -- <http://bittorrent.org/beps/bep_0020.html> | ||
17 | -- | ||
18 | -- | ||
19 | -- NOTE: Do /not/ use this information to control client | ||
20 | -- capabilities (such as supported enchancements), this should be | ||
21 | -- done using 'Network.BitTorrent.Extension'! | ||
22 | -- | ||
23 | {-# OPTIONS -fno-warn-orphans #-} | ||
24 | module Network.BitTorrent.Core.Fingerprint | ||
25 | ( ClientImpl (..) | ||
26 | , Fingerprint (..) | ||
27 | , libFingerprint | ||
28 | , libUserAgent | ||
29 | ) where | ||
30 | |||
31 | import Data.Default | ||
32 | import Data.List as L | ||
33 | import Data.List.Split as L | ||
34 | import Data.Monoid | ||
35 | import Data.String | ||
36 | import Data.Version | ||
37 | import Text.PrettyPrint hiding ((<>)) | ||
38 | import Text.PrettyPrint.Class | ||
39 | import Text.Read (readMaybe) | ||
40 | -- import Paths_bittorrent (version) | ||
41 | |||
42 | -- TODO FIXME | ||
43 | version :: Version | ||
44 | version = Version [0, 0, 0, 3] [] | ||
45 | |||
46 | -- | List of registered client versions + 'IlibHSbittorrent' (this | ||
47 | -- package) + 'IUnknown' (for not recognized software). All names are | ||
48 | -- prefixed by \"I\" because some of them starts from lowercase letter | ||
49 | -- but that is not a valid Haskell constructor name. | ||
50 | -- | ||
51 | data ClientImpl = | ||
52 | IUnknown | ||
53 | |||
54 | | IMainline | ||
55 | |||
56 | | IABC | ||
57 | | IOspreyPermaseed | ||
58 | | IBTQueue | ||
59 | | ITribler | ||
60 | | IShadow | ||
61 | | IBitTornado | ||
62 | |||
63 | -- UPnP(!) Bit Torrent !??? | ||
64 | -- 'U' - UPnP NAT Bit Torrent | ||
65 | | IBitLord | ||
66 | | IOpera | ||
67 | | IMLdonkey | ||
68 | |||
69 | | IAres | ||
70 | | IArctic | ||
71 | | IAvicora | ||
72 | | IBitPump | ||
73 | | IAzureus | ||
74 | | IBitBuddy | ||
75 | | IBitComet | ||
76 | | IBitflu | ||
77 | | IBTG | ||
78 | | IBitRocket | ||
79 | | IBTSlave | ||
80 | | IBittorrentX | ||
81 | | IEnhancedCTorrent | ||
82 | | ICTorrent | ||
83 | | IDelugeTorrent | ||
84 | | IPropagateDataClient | ||
85 | | IEBit | ||
86 | | IElectricSheep | ||
87 | | IFoxTorrent | ||
88 | | IGSTorrent | ||
89 | | IHalite | ||
90 | | IlibHSbittorrent | ||
91 | | IHydranode | ||
92 | | IKGet | ||
93 | | IKTorrent | ||
94 | | ILH_ABC | ||
95 | | ILphant | ||
96 | | ILibtorrent | ||
97 | | ILibTorrent | ||
98 | | ILimeWire | ||
99 | | IMonoTorrent | ||
100 | | IMooPolice | ||
101 | | IMiro | ||
102 | | IMoonlightTorrent | ||
103 | | INetTransport | ||
104 | | IPando | ||
105 | | IqBittorrent | ||
106 | | IQQDownload | ||
107 | | IQt4TorrentExample | ||
108 | | IRetriever | ||
109 | | IShareaza | ||
110 | | ISwiftbit | ||
111 | | ISwarmScope | ||
112 | | ISymTorrent | ||
113 | | Isharktorrent | ||
114 | | ITorrentDotNET | ||
115 | | ITransmission | ||
116 | | ITorrentstorm | ||
117 | | ITuoTu | ||
118 | | IuLeecher | ||
119 | | IuTorrent | ||
120 | | IVagaa | ||
121 | | IBitLet | ||
122 | | IFireTorrent | ||
123 | | IXunlei | ||
124 | | IXanTorrent | ||
125 | | IXtorrent | ||
126 | | IZipTorrent | ||
127 | deriving (Show, Eq, Ord, Enum, Bounded) | ||
128 | |||
129 | -- | Used to represent a not recognized implementation | ||
130 | instance Default ClientImpl where | ||
131 | def = IUnknown | ||
132 | {-# INLINE def #-} | ||
133 | |||
134 | -- | Example: @\"BitLet\" == 'IBitLet'@ | ||
135 | instance IsString ClientImpl where | ||
136 | fromString str | ||
137 | | Just impl <- L.lookup str alist = impl | ||
138 | | otherwise = error $ "fromString: not recognized " ++ str | ||
139 | where | ||
140 | alist = L.map mk [minBound..maxBound] | ||
141 | mk x = (L.tail $ show x, x) | ||
142 | |||
143 | -- | Example: @pretty 'IBitLet' == \"IBitLet\"@ | ||
144 | instance Pretty ClientImpl where | ||
145 | pretty = text . L.tail . show | ||
146 | |||
147 | -- | Just the '0' version. | ||
148 | instance Default Version where | ||
149 | def = Version [0] [] | ||
150 | {-# INLINE def #-} | ||
151 | |||
152 | -- | For dot delimited version strings. | ||
153 | -- Example: @fromString \"0.1.0.2\" == Version [0, 1, 0, 2]@ | ||
154 | -- | ||
155 | instance IsString Version where | ||
156 | fromString str | ||
157 | | Just nums <- chunkNums str = Version nums [] | ||
158 | | otherwise = error $ "fromString: invalid version string " ++ str | ||
159 | where | ||
160 | chunkNums = sequence . L.map readMaybe . L.linesBy ('.' ==) | ||
161 | |||
162 | instance Pretty Version where | ||
163 | pretty = text . showVersion | ||
164 | |||
165 | -- | The all sensible infomation that can be obtained from a peer | ||
166 | -- identifier or torrent /createdBy/ field. | ||
167 | data Fingerprint = Fingerprint | ||
168 | { ciImpl :: ClientImpl | ||
169 | , ciVersion :: Version | ||
170 | } deriving (Show, Eq, Ord) | ||
171 | |||
172 | -- | Unrecognized client implementation. | ||
173 | instance Default Fingerprint where | ||
174 | def = Fingerprint def def | ||
175 | {-# INLINE def #-} | ||
176 | |||
177 | -- | Example: @\"BitComet-1.2\" == ClientInfo IBitComet (Version [1, 2] [])@ | ||
178 | instance IsString Fingerprint where | ||
179 | fromString str | ||
180 | | _ : ver <- _ver = Fingerprint (fromString impl) (fromString ver) | ||
181 | | otherwise = error $ "fromString: invalid client info string" ++ str | ||
182 | where | ||
183 | (impl, _ver) = L.span ((/=) '-') str | ||
184 | |||
185 | instance Pretty Fingerprint where | ||
186 | pretty Fingerprint {..} = pretty ciImpl <+> "version" <+> pretty ciVersion | ||
187 | |||
188 | -- | Fingerprint of this (the bittorrent library) package. Normally, | ||
189 | -- applications should introduce its own fingerprints, otherwise they | ||
190 | -- can use 'libFingerprint' value. | ||
191 | -- | ||
192 | libFingerprint :: Fingerprint | ||
193 | libFingerprint = Fingerprint IlibHSbittorrent version | ||
194 | |||
195 | -- | HTTP user agent of this (the bittorrent library) package. Can be | ||
196 | -- used in HTTP tracker requests. | ||
197 | libUserAgent :: String | ||
198 | libUserAgent = render (pretty IlibHSbittorrent <> "/" <> pretty version) | ||
199 | |||
200 | {----------------------------------------------------------------------- | ||
201 | -- For torrent file | ||
202 | -----------------------------------------------------------------------} | ||
203 | -- TODO collect information about createdBy torrent field | ||
204 | {- | ||
205 | renderImpl :: ClientImpl -> Text | ||
206 | renderImpl = T.pack . L.tail . show | ||
207 | |||
208 | renderVersion :: Version -> Text | ||
209 | renderVersion = undefined | ||
210 | |||
211 | renderClientInfo :: ClientInfo -> Text | ||
212 | renderClientInfo ClientInfo {..} = renderImpl ciImpl <> "/" <> renderVersion ciVersion | ||
213 | |||
214 | parseClientInfo :: Text -> ClientImpl | ||
215 | parseClientInfo t = undefined | ||
216 | -} | ||
217 | {- | ||
218 | -- code used for generation; remove it later on | ||
219 | |||
220 | mkEnumTyDef :: NM -> String | ||
221 | mkEnumTyDef = unlines . map (" | I" ++) . nub . map snd | ||
222 | |||
223 | mkPars :: NM -> String | ||
224 | mkPars = unlines . map (\(code, impl) -> " f \"" ++ code ++ "\" = " ++ "I" ++ impl) | ||
225 | |||
226 | type NM = [(String, String)] | ||
227 | nameMap :: NM | ||
228 | nameMap = | ||
229 | [ ("AG", "Ares") | ||
230 | , ("A~", "Ares") | ||
231 | , ("AR", "Arctic") | ||
232 | , ("AV", "Avicora") | ||
233 | , ("AX", "BitPump") | ||
234 | , ("AZ", "Azureus") | ||
235 | , ("BB", "BitBuddy") | ||
236 | , ("BC", "BitComet") | ||
237 | , ("BF", "Bitflu") | ||
238 | , ("BG", "BTG") | ||
239 | , ("BR", "BitRocket") | ||
240 | , ("BS", "BTSlave") | ||
241 | , ("BX", "BittorrentX") | ||
242 | , ("CD", "EnhancedCTorrent") | ||
243 | , ("CT", "CTorrent") | ||
244 | , ("DE", "DelugeTorrent") | ||
245 | , ("DP", "PropagateDataClient") | ||
246 | , ("EB", "EBit") | ||
247 | , ("ES", "ElectricSheep") | ||
248 | , ("FT", "FoxTorrent") | ||
249 | , ("GS", "GSTorrent") | ||
250 | , ("HL", "Halite") | ||
251 | , ("HS", "libHSnetwork_bittorrent") | ||
252 | , ("HN", "Hydranode") | ||
253 | , ("KG", "KGet") | ||
254 | , ("KT", "KTorrent") | ||
255 | , ("LH", "LH_ABC") | ||
256 | , ("LP", "Lphant") | ||
257 | , ("LT", "Libtorrent") | ||
258 | , ("lt", "LibTorrent") | ||
259 | , ("LW", "LimeWire") | ||
260 | , ("MO", "MonoTorrent") | ||
261 | , ("MP", "MooPolice") | ||
262 | , ("MR", "Miro") | ||
263 | , ("MT", "MoonlightTorrent") | ||
264 | , ("NX", "NetTransport") | ||
265 | , ("PD", "Pando") | ||
266 | , ("qB", "qBittorrent") | ||
267 | , ("QD", "QQDownload") | ||
268 | , ("QT", "Qt4TorrentExample") | ||
269 | , ("RT", "Retriever") | ||
270 | , ("S~", "Shareaza") | ||
271 | , ("SB", "Swiftbit") | ||
272 | , ("SS", "SwarmScope") | ||
273 | , ("ST", "SymTorrent") | ||
274 | , ("st", "sharktorrent") | ||
275 | , ("SZ", "Shareaza") | ||
276 | , ("TN", "TorrentDotNET") | ||
277 | , ("TR", "Transmission") | ||
278 | , ("TS", "Torrentstorm") | ||
279 | , ("TT", "TuoTu") | ||
280 | , ("UL", "uLeecher") | ||
281 | , ("UT", "uTorrent") | ||
282 | , ("VG", "Vagaa") | ||
283 | , ("WT", "BitLet") | ||
284 | , ("WY", "FireTorrent") | ||
285 | , ("XL", "Xunlei") | ||
286 | , ("XT", "XanTorrent") | ||
287 | , ("XX", "Xtorrent") | ||
288 | , ("ZT", "ZipTorrent") | ||
289 | ] | ||
290 | -} | ||
diff --git a/src/Network/BitTorrent/Core/NodeInfo.hs b/src/Network/BitTorrent/Core/NodeInfo.hs deleted file mode 100644 index fe17c097..00000000 --- a/src/Network/BitTorrent/Core/NodeInfo.hs +++ /dev/null | |||
@@ -1,219 +0,0 @@ | |||
1 | -- | | ||
2 | -- Module : Network.BitTorrent.Core.Node | ||
3 | -- Copyright : (c) Sam Truzjan 2013 | ||
4 | -- (c) Daniel Gröber 2013 | ||
5 | -- License : BSD3 | ||
6 | -- Maintainer : pxqr.sta@gmail.com | ||
7 | -- Stability : experimental | ||
8 | -- Portability : portable | ||
9 | -- | ||
10 | -- A \"node\" is a client\/server listening on a UDP port | ||
11 | -- implementing the distributed hash table protocol. The DHT is | ||
12 | -- composed of nodes and stores the location of peers. BitTorrent | ||
13 | -- clients include a DHT node, which is used to contact other nodes | ||
14 | -- in the DHT to get the location of peers to download from using | ||
15 | -- the BitTorrent protocol. | ||
16 | -- | ||
17 | {-# LANGUAGE RecordWildCards #-} | ||
18 | {-# LANGUAGE FlexibleInstances #-} | ||
19 | {-# LANGUAGE TemplateHaskell #-} | ||
20 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
21 | {-# LANGUAGE DeriveDataTypeable #-} | ||
22 | {-# LANGUAGE DeriveFunctor #-} | ||
23 | module Network.BitTorrent.Core.NodeInfo | ||
24 | ( -- * Node ID | ||
25 | NodeId | ||
26 | , testIdBit | ||
27 | , genNodeId | ||
28 | |||
29 | -- ** Node distance | ||
30 | , NodeDistance | ||
31 | , distance | ||
32 | |||
33 | -- * Node address | ||
34 | , NodeAddr (..) | ||
35 | |||
36 | -- * Node info | ||
37 | , NodeInfo (..) | ||
38 | , rank | ||
39 | ) where | ||
40 | |||
41 | import Control.Applicative | ||
42 | import Data.Bits | ||
43 | import Data.ByteString as BS | ||
44 | import Data.ByteString.Char8 as BC | ||
45 | import Data.ByteString.Base16 as Base16 | ||
46 | import Data.BEncode as BE | ||
47 | import Data.Default | ||
48 | import Data.Hashable | ||
49 | import Data.Foldable | ||
50 | import Data.IP | ||
51 | import Data.List as L | ||
52 | import Data.Monoid | ||
53 | import Data.Ord | ||
54 | import Data.Serialize as S | ||
55 | import Data.String | ||
56 | import Data.Typeable | ||
57 | import Data.Word | ||
58 | import Network | ||
59 | import System.Entropy | ||
60 | import Text.PrettyPrint as PP hiding ((<>)) | ||
61 | import Text.PrettyPrint.Class | ||
62 | |||
63 | import Network.BitTorrent.Core.PeerAddr (PeerAddr (..)) | ||
64 | |||
65 | {----------------------------------------------------------------------- | ||
66 | -- Node id | ||
67 | -----------------------------------------------------------------------} | ||
68 | -- TODO more compact representation ('ShortByteString's?) | ||
69 | |||
70 | -- | Each node has a globally unique identifier known as the \"node | ||
71 | -- ID.\" | ||
72 | -- | ||
73 | -- Normally, /this/ node id should be saved between invocations | ||
74 | -- of the client software. | ||
75 | newtype NodeId = NodeId ByteString | ||
76 | deriving (Show, Eq, Ord, BEncode, Typeable) | ||
77 | |||
78 | nodeIdSize :: Int | ||
79 | nodeIdSize = 20 | ||
80 | |||
81 | -- | Meaningless node id, for testing purposes only. | ||
82 | instance Default NodeId where | ||
83 | def = NodeId (BS.replicate nodeIdSize 0) | ||
84 | |||
85 | instance Serialize NodeId where | ||
86 | get = NodeId <$> getByteString nodeIdSize | ||
87 | {-# INLINE get #-} | ||
88 | put (NodeId bs) = putByteString bs | ||
89 | {-# INLINE put #-} | ||
90 | |||
91 | -- | ASCII encoded. | ||
92 | instance IsString NodeId where | ||
93 | fromString str | ||
94 | | L.length str == nodeIdSize = NodeId (fromString str) | ||
95 | | otherwise = error "fromString: invalid NodeId length" | ||
96 | {-# INLINE fromString #-} | ||
97 | |||
98 | -- | base16 encoded. | ||
99 | instance Pretty NodeId where | ||
100 | pretty (NodeId nid) = PP.text $ BC.unpack $ Base16.encode nid | ||
101 | |||
102 | -- | Test if the nth bit is set. | ||
103 | testIdBit :: NodeId -> Word -> Bool | ||
104 | testIdBit (NodeId bs) i | ||
105 | | fromIntegral i < nodeIdSize * 8 | ||
106 | , (q, r) <- quotRem (fromIntegral i) 8 | ||
107 | = testBit (BS.index bs q) r | ||
108 | | otherwise = False | ||
109 | {-# INLINE testIdBit #-} | ||
110 | |||
111 | -- TODO WARN is the 'system' random suitable for this? | ||
112 | -- | Generate random NodeID used for the entire session. | ||
113 | -- Distribution of ID's should be as uniform as possible. | ||
114 | -- | ||
115 | genNodeId :: IO NodeId | ||
116 | genNodeId = NodeId <$> getEntropy nodeIdSize | ||
117 | |||
118 | {----------------------------------------------------------------------- | ||
119 | -- Node distance | ||
120 | -----------------------------------------------------------------------} | ||
121 | |||
122 | -- | In Kademlia, the distance metric is XOR and the result is | ||
123 | -- interpreted as an unsigned integer. | ||
124 | newtype NodeDistance = NodeDistance BS.ByteString | ||
125 | deriving (Eq, Ord) | ||
126 | |||
127 | instance Pretty NodeDistance where | ||
128 | pretty (NodeDistance bs) = foldMap bitseq $ BS.unpack bs | ||
129 | where | ||
130 | listBits w = L.map (testBit w) (L.reverse [0..bitSize w - 1]) | ||
131 | bitseq = foldMap (int . fromEnum) . listBits | ||
132 | |||
133 | -- | distance(A,B) = |A xor B| Smaller values are closer. | ||
134 | distance :: NodeId -> NodeId -> NodeDistance | ||
135 | distance (NodeId a) (NodeId b) = NodeDistance (BS.pack (BS.zipWith xor a b)) | ||
136 | |||
137 | {----------------------------------------------------------------------- | ||
138 | -- Node address | ||
139 | -----------------------------------------------------------------------} | ||
140 | |||
141 | data NodeAddr a = NodeAddr | ||
142 | { nodeHost :: !a | ||
143 | , nodePort :: {-# UNPACK #-} !PortNumber | ||
144 | } deriving (Eq, Typeable, Functor) | ||
145 | |||
146 | instance Show a => Show (NodeAddr a) where | ||
147 | showsPrec i NodeAddr {..} | ||
148 | = showsPrec i nodeHost <> showString ":" <> showsPrec i nodePort | ||
149 | |||
150 | instance Read (NodeAddr IPv4) where | ||
151 | readsPrec i x = [ (fromPeerAddr a, s) | (a, s) <- readsPrec i x ] | ||
152 | |||
153 | -- | @127.0.0.1:6882@ | ||
154 | instance Default (NodeAddr IPv4) where | ||
155 | def = "127.0.0.1:6882" | ||
156 | |||
157 | -- | KRPC compatible encoding. | ||
158 | instance Serialize a => Serialize (NodeAddr a) where | ||
159 | get = NodeAddr <$> get <*> get | ||
160 | {-# INLINE get #-} | ||
161 | put NodeAddr {..} = put nodeHost >> put nodePort | ||
162 | {-# INLINE put #-} | ||
163 | |||
164 | -- | Torrent file compatible encoding. | ||
165 | instance BEncode a => BEncode (NodeAddr a) where | ||
166 | toBEncode NodeAddr {..} = toBEncode (nodeHost, nodePort) | ||
167 | {-# INLINE toBEncode #-} | ||
168 | fromBEncode b = uncurry NodeAddr <$> fromBEncode b | ||
169 | {-# INLINE fromBEncode #-} | ||
170 | |||
171 | instance Hashable a => Hashable (NodeAddr a) where | ||
172 | hashWithSalt s NodeAddr {..} = hashWithSalt s (nodeHost, nodePort) | ||
173 | {-# INLINE hashWithSalt #-} | ||
174 | |||
175 | instance Pretty ip => Pretty (NodeAddr ip) where | ||
176 | pretty NodeAddr {..} = pretty nodeHost <> ":" <> pretty nodePort | ||
177 | |||
178 | -- | Example: | ||
179 | -- | ||
180 | -- @nodePort \"127.0.0.1:6881\" == 6881@ | ||
181 | -- | ||
182 | instance IsString (NodeAddr IPv4) where | ||
183 | fromString = fromPeerAddr . fromString | ||
184 | |||
185 | fromPeerAddr :: PeerAddr a -> NodeAddr a | ||
186 | fromPeerAddr PeerAddr {..} = NodeAddr | ||
187 | { nodeHost = peerHost | ||
188 | , nodePort = peerPort | ||
189 | } | ||
190 | |||
191 | {----------------------------------------------------------------------- | ||
192 | -- Node info | ||
193 | -----------------------------------------------------------------------} | ||
194 | |||
195 | data NodeInfo a = NodeInfo | ||
196 | { nodeId :: !NodeId | ||
197 | , nodeAddr :: !(NodeAddr a) | ||
198 | } deriving (Show, Eq, Functor) | ||
199 | |||
200 | instance Eq a => Ord (NodeInfo a) where | ||
201 | compare = comparing nodeId | ||
202 | |||
203 | -- | KRPC 'compact list' compatible encoding: contact information for | ||
204 | -- nodes is encoded as a 26-byte string. Also known as "Compact node | ||
205 | -- info" the 20-byte Node ID in network byte order has the compact | ||
206 | -- IP-address/port info concatenated to the end. | ||
207 | instance Serialize a => Serialize (NodeInfo a) where | ||
208 | get = NodeInfo <$> get <*> get | ||
209 | put NodeInfo {..} = put nodeId >> put nodeAddr | ||
210 | |||
211 | instance Pretty ip => Pretty (NodeInfo ip) where | ||
212 | pretty NodeInfo {..} = pretty nodeId <> "@(" <> pretty nodeAddr <> ")" | ||
213 | |||
214 | instance Pretty ip => Pretty [NodeInfo ip] where | ||
215 | pretty = PP.vcat . PP.punctuate "," . L.map pretty | ||
216 | |||
217 | -- | Order by closeness: nearest nodes first. | ||
218 | rank :: Eq ip => NodeId -> [NodeInfo ip] -> [NodeInfo ip] | ||
219 | rank nid = L.sortBy (comparing (distance nid . nodeId)) | ||
diff --git a/src/Network/BitTorrent/Core/PeerAddr.hs b/src/Network/BitTorrent/Core/PeerAddr.hs deleted file mode 100644 index 92fb83a7..00000000 --- a/src/Network/BitTorrent/Core/PeerAddr.hs +++ /dev/null | |||
@@ -1,354 +0,0 @@ | |||
1 | -- | | ||
2 | -- Module : Network.BitTorrent.Core.PeerAddr | ||
3 | -- Copyright : (c) Sam Truzjan 2013 | ||
4 | -- (c) Daniel Gröber 2013 | ||
5 | -- License : BSD3 | ||
6 | -- Maintainer : pxqr.sta@gmail.com | ||
7 | -- Stability : provisional | ||
8 | -- Portability : portable | ||
9 | -- | ||
10 | -- 'PeerAddr' is used to represent peer address. Currently it's | ||
11 | -- just peer IP and peer port but this might change in future. | ||
12 | -- | ||
13 | {-# LANGUAGE TemplateHaskell #-} | ||
14 | {-# LANGUAGE StandaloneDeriving #-} | ||
15 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
16 | {-# LANGUAGE DeriveDataTypeable #-} | ||
17 | {-# LANGUAGE FlexibleInstances #-} | ||
18 | {-# LANGUAGE DeriveFunctor #-} | ||
19 | {-# LANGUAGE ViewPatterns #-} | ||
20 | {-# OPTIONS -fno-warn-orphans #-} -- for PortNumber instances | ||
21 | module Network.BitTorrent.Core.PeerAddr | ||
22 | ( -- * Peer address | ||
23 | PeerAddr(..) | ||
24 | , defaultPorts | ||
25 | , peerSockAddr | ||
26 | , peerSocket | ||
27 | |||
28 | -- * Peer storage | ||
29 | , PeerStore | ||
30 | , Network.BitTorrent.Core.PeerAddr.lookup | ||
31 | , Network.BitTorrent.Core.PeerAddr.insert | ||
32 | ) where | ||
33 | |||
34 | import Control.Applicative | ||
35 | import Control.Monad | ||
36 | import Data.BEncode as BS | ||
37 | import Data.BEncode.BDict (BKey) | ||
38 | import Data.ByteString.Char8 as BS8 | ||
39 | import Data.Char | ||
40 | import Data.Default | ||
41 | import Data.Hashable | ||
42 | import Data.HashMap.Strict as HM | ||
43 | import Data.IP | ||
44 | import Data.List as L | ||
45 | import Data.List.Split | ||
46 | import Data.Maybe | ||
47 | import Data.Monoid | ||
48 | import Data.Serialize as S | ||
49 | import Data.String | ||
50 | import Data.Typeable | ||
51 | import Data.Word | ||
52 | import Network.Socket | ||
53 | import Text.PrettyPrint as PP hiding ((<>)) | ||
54 | import Text.PrettyPrint.Class | ||
55 | import Text.Read (readMaybe) | ||
56 | import qualified Text.ParserCombinators.ReadP as RP | ||
57 | |||
58 | import Data.Torrent.InfoHash | ||
59 | import Network.BitTorrent.Core.PeerId | ||
60 | |||
61 | |||
62 | {----------------------------------------------------------------------- | ||
63 | -- Port number | ||
64 | -----------------------------------------------------------------------} | ||
65 | |||
66 | instance BEncode PortNumber where | ||
67 | toBEncode = toBEncode . fromEnum | ||
68 | fromBEncode = fromBEncode >=> portNumber | ||
69 | where | ||
70 | portNumber :: Integer -> BS.Result PortNumber | ||
71 | portNumber n | ||
72 | | 0 <= n && n <= fromIntegral (maxBound :: Word16) | ||
73 | = pure $ fromIntegral n | ||
74 | | otherwise = decodingError $ "PortNumber: " ++ show n | ||
75 | |||
76 | instance Serialize PortNumber where | ||
77 | get = fromIntegral <$> getWord16be | ||
78 | {-# INLINE get #-} | ||
79 | put = putWord16be . fromIntegral | ||
80 | {-# INLINE put #-} | ||
81 | |||
82 | instance Hashable PortNumber where | ||
83 | hashWithSalt s = hashWithSalt s . fromEnum | ||
84 | {-# INLINE hashWithSalt #-} | ||
85 | |||
86 | instance Pretty PortNumber where | ||
87 | pretty = PP.int . fromEnum | ||
88 | {-# INLINE pretty #-} | ||
89 | |||
90 | {----------------------------------------------------------------------- | ||
91 | -- IP addr | ||
92 | -----------------------------------------------------------------------} | ||
93 | |||
94 | class IPAddress i where | ||
95 | toHostAddr :: i -> Either HostAddress HostAddress6 | ||
96 | |||
97 | instance IPAddress IPv4 where | ||
98 | toHostAddr = Left . toHostAddress | ||
99 | {-# INLINE toHostAddr #-} | ||
100 | |||
101 | instance IPAddress IPv6 where | ||
102 | toHostAddr = Right . toHostAddress6 | ||
103 | {-# INLINE toHostAddr #-} | ||
104 | |||
105 | instance IPAddress IP where | ||
106 | toHostAddr (IPv4 ip) = toHostAddr ip | ||
107 | toHostAddr (IPv6 ip) = toHostAddr ip | ||
108 | {-# INLINE toHostAddr #-} | ||
109 | |||
110 | deriving instance Typeable IP | ||
111 | deriving instance Typeable IPv4 | ||
112 | deriving instance Typeable IPv6 | ||
113 | |||
114 | ipToBEncode :: Show i => i -> BValue | ||
115 | ipToBEncode ip = BString $ BS8.pack $ show ip | ||
116 | {-# INLINE ipToBEncode #-} | ||
117 | |||
118 | ipFromBEncode :: Read a => BValue -> BS.Result a | ||
119 | ipFromBEncode (BString (BS8.unpack -> ipStr)) | ||
120 | | Just ip <- readMaybe (ipStr) = pure ip | ||
121 | | otherwise = decodingError $ "IP: " ++ ipStr | ||
122 | ipFromBEncode _ = decodingError $ "IP: addr should be a bstring" | ||
123 | |||
124 | instance BEncode IP where | ||
125 | toBEncode = ipToBEncode | ||
126 | {-# INLINE toBEncode #-} | ||
127 | fromBEncode = ipFromBEncode | ||
128 | {-# INLINE fromBEncode #-} | ||
129 | |||
130 | instance BEncode IPv4 where | ||
131 | toBEncode = ipToBEncode | ||
132 | {-# INLINE toBEncode #-} | ||
133 | fromBEncode = ipFromBEncode | ||
134 | {-# INLINE fromBEncode #-} | ||
135 | |||
136 | instance BEncode IPv6 where | ||
137 | toBEncode = ipToBEncode | ||
138 | {-# INLINE toBEncode #-} | ||
139 | fromBEncode = ipFromBEncode | ||
140 | {-# INLINE fromBEncode #-} | ||
141 | |||
142 | -- | When 'get'ing an IP it must be 'isolate'd to the appropriate | ||
143 | -- number of bytes since we have no other way of telling which | ||
144 | -- address type we are trying to parse | ||
145 | instance Serialize IP where | ||
146 | put (IPv4 ip) = put ip | ||
147 | put (IPv6 ip) = put ip | ||
148 | |||
149 | get = do | ||
150 | n <- remaining | ||
151 | case n of | ||
152 | 4 -> IPv4 <$> get | ||
153 | 16 -> IPv6 <$> get | ||
154 | _ -> fail "Wrong number of bytes remaining to parse IP" | ||
155 | |||
156 | instance Serialize IPv4 where | ||
157 | put = putWord32host . toHostAddress | ||
158 | get = fromHostAddress <$> getWord32host | ||
159 | |||
160 | instance Serialize IPv6 where | ||
161 | put ip = put $ toHostAddress6 ip | ||
162 | get = fromHostAddress6 <$> get | ||
163 | |||
164 | instance Pretty IPv4 where | ||
165 | pretty = PP.text . show | ||
166 | {-# INLINE pretty #-} | ||
167 | |||
168 | instance Pretty IPv6 where | ||
169 | pretty = PP.text . show | ||
170 | {-# INLINE pretty #-} | ||
171 | |||
172 | instance Pretty IP where | ||
173 | pretty = PP.text . show | ||
174 | {-# INLINE pretty #-} | ||
175 | |||
176 | instance Hashable IPv4 where | ||
177 | hashWithSalt = hashUsing toHostAddress | ||
178 | {-# INLINE hashWithSalt #-} | ||
179 | |||
180 | instance Hashable IPv6 where | ||
181 | hashWithSalt s a = hashWithSalt s (toHostAddress6 a) | ||
182 | |||
183 | instance Hashable IP where | ||
184 | hashWithSalt s (IPv4 h) = hashWithSalt s h | ||
185 | hashWithSalt s (IPv6 h) = hashWithSalt s h | ||
186 | |||
187 | {----------------------------------------------------------------------- | ||
188 | -- Peer addr | ||
189 | -----------------------------------------------------------------------} | ||
190 | -- TODO check semantic of ord and eq instances | ||
191 | |||
192 | -- | Peer address info normally extracted from peer list or peer | ||
193 | -- compact list encoding. | ||
194 | data PeerAddr a = PeerAddr | ||
195 | { peerId :: !(Maybe PeerId) | ||
196 | |||
197 | -- | This is usually 'IPv4', 'IPv6', 'IP' or unresolved | ||
198 | -- 'HostName'. | ||
199 | , peerHost :: !a | ||
200 | |||
201 | -- | The port the peer listenning for incoming P2P sessions. | ||
202 | , peerPort :: {-# UNPACK #-} !PortNumber | ||
203 | } deriving (Show, Eq, Ord, Typeable, Functor) | ||
204 | |||
205 | peer_ip_key, peer_id_key, peer_port_key :: BKey | ||
206 | peer_ip_key = "ip" | ||
207 | peer_id_key = "peer id" | ||
208 | peer_port_key = "port" | ||
209 | |||
210 | -- | The tracker's 'announce response' compatible encoding. | ||
211 | instance (Typeable a, BEncode a) => BEncode (PeerAddr a) where | ||
212 | toBEncode PeerAddr {..} = toDict $ | ||
213 | peer_ip_key .=! peerHost | ||
214 | .: peer_id_key .=? peerId | ||
215 | .: peer_port_key .=! peerPort | ||
216 | .: endDict | ||
217 | |||
218 | fromBEncode = fromDict $ do | ||
219 | peerAddr <$>! peer_ip_key | ||
220 | <*>? peer_id_key | ||
221 | <*>! peer_port_key | ||
222 | where | ||
223 | peerAddr = flip PeerAddr | ||
224 | |||
225 | -- | The tracker's 'compact peer list' compatible encoding. The | ||
226 | -- 'peerId' is always 'Nothing'. | ||
227 | -- | ||
228 | -- For more info see: <http://www.bittorrent.org/beps/bep_0023.html> | ||
229 | -- | ||
230 | -- TODO: test byte order | ||
231 | instance (Serialize a) => Serialize (PeerAddr a) where | ||
232 | put PeerAddr {..} = put peerHost >> put peerPort | ||
233 | get = PeerAddr Nothing <$> get <*> get | ||
234 | |||
235 | -- | @127.0.0.1:6881@ | ||
236 | instance Default (PeerAddr IPv4) where | ||
237 | def = "127.0.0.1:6881" | ||
238 | |||
239 | -- | @127.0.0.1:6881@ | ||
240 | instance Default (PeerAddr IP) where | ||
241 | def = IPv4 <$> def | ||
242 | |||
243 | -- | Example: | ||
244 | -- | ||
245 | -- @peerPort \"127.0.0.1:6881\" == 6881@ | ||
246 | -- | ||
247 | instance IsString (PeerAddr IPv4) where | ||
248 | fromString str | ||
249 | | [hostAddrStr, portStr] <- splitWhen (== ':') str | ||
250 | , Just hostAddr <- readMaybe hostAddrStr | ||
251 | , Just portNum <- toEnum <$> readMaybe portStr | ||
252 | = PeerAddr Nothing hostAddr portNum | ||
253 | | otherwise = error $ "fromString: unable to parse (PeerAddr IPv4): " ++ str | ||
254 | |||
255 | instance Read (PeerAddr IPv4) where | ||
256 | readsPrec i = RP.readP_to_S $ do | ||
257 | ipv4 <- RP.readS_to_P (readsPrec i) | ||
258 | _ <- RP.char ':' | ||
259 | port <- toEnum <$> RP.readS_to_P (readsPrec i) | ||
260 | return $ PeerAddr Nothing ipv4 port | ||
261 | |||
262 | readsIPv6_port :: String -> [((IPv6, PortNumber), String)] | ||
263 | readsIPv6_port = RP.readP_to_S $ do | ||
264 | ip <- RP.char '[' *> (RP.readS_to_P reads) <* RP.char ']' | ||
265 | _ <- RP.char ':' | ||
266 | port <- toEnum <$> read <$> (RP.many1 $ RP.satisfy isDigit) <* RP.eof | ||
267 | return (ip,port) | ||
268 | |||
269 | instance IsString (PeerAddr IPv6) where | ||
270 | fromString str | ||
271 | | [((ip,port),"")] <- readsIPv6_port str = | ||
272 | PeerAddr Nothing ip port | ||
273 | | otherwise = error $ "fromString: unable to parse (PeerAddr IPv6): " ++ str | ||
274 | |||
275 | instance IsString (PeerAddr IP) where | ||
276 | fromString str | ||
277 | | '[' `L.elem` str = IPv6 <$> fromString str | ||
278 | | otherwise = IPv4 <$> fromString str | ||
279 | |||
280 | -- | fingerprint + "at" + dotted.host.inet.addr:port | ||
281 | -- TODO: instances for IPv6, HostName | ||
282 | instance Pretty a => Pretty (PeerAddr a) where | ||
283 | pretty PeerAddr {..} | ||
284 | | Just pid <- peerId = pretty (fingerprint pid) <+> "at" <+> paddr | ||
285 | | otherwise = paddr | ||
286 | where | ||
287 | paddr = pretty peerHost <> ":" <> text (show peerPort) | ||
288 | |||
289 | instance Hashable a => Hashable (PeerAddr a) where | ||
290 | hashWithSalt s PeerAddr {..} = | ||
291 | s `hashWithSalt` peerId `hashWithSalt` peerHost `hashWithSalt` peerPort | ||
292 | |||
293 | -- | Ports typically reserved for bittorrent P2P listener. | ||
294 | defaultPorts :: [PortNumber] | ||
295 | defaultPorts = [6881..6889] | ||
296 | |||
297 | _resolvePeerAddr :: (IPAddress i) => PeerAddr HostName -> PeerAddr i | ||
298 | _resolvePeerAddr = undefined | ||
299 | |||
300 | _peerSockAddr :: PeerAddr IP -> (Family, SockAddr) | ||
301 | _peerSockAddr PeerAddr {..} = | ||
302 | case peerHost of | ||
303 | IPv4 ipv4 -> | ||
304 | (AF_INET, SockAddrInet peerPort (toHostAddress ipv4)) | ||
305 | IPv6 ipv6 -> | ||
306 | (AF_INET6, SockAddrInet6 peerPort 0 (toHostAddress6 ipv6) 0) | ||
307 | |||
308 | peerSockAddr :: PeerAddr IP -> SockAddr | ||
309 | peerSockAddr = snd . _peerSockAddr | ||
310 | |||
311 | -- | Create a socket connected to the address specified in a peerAddr | ||
312 | peerSocket :: SocketType -> PeerAddr IP -> IO Socket | ||
313 | peerSocket socketType pa = do | ||
314 | let (family, addr) = _peerSockAddr pa | ||
315 | sock <- socket family socketType defaultProtocol | ||
316 | connect sock addr | ||
317 | return sock | ||
318 | |||
319 | {----------------------------------------------------------------------- | ||
320 | -- Peer storage | ||
321 | -----------------------------------------------------------------------} | ||
322 | -- TODO use more memory efficient representation | ||
323 | |||
324 | -- | Storage used to keep track a set of known peers in client, | ||
325 | -- tracker or DHT sessions. | ||
326 | newtype PeerStore ip = PeerStore (HashMap InfoHash [PeerAddr ip]) | ||
327 | |||
328 | -- | Empty store. | ||
329 | instance Default (PeerStore a) where | ||
330 | def = PeerStore HM.empty | ||
331 | {-# INLINE def #-} | ||
332 | |||
333 | -- | Monoid under union operation. | ||
334 | instance Eq a => Monoid (PeerStore a) where | ||
335 | mempty = def | ||
336 | {-# INLINE mempty #-} | ||
337 | |||
338 | mappend (PeerStore a) (PeerStore b) = | ||
339 | PeerStore (HM.unionWith L.union a b) | ||
340 | {-# INLINE mappend #-} | ||
341 | |||
342 | -- | Can be used to store peers between invocations of the client | ||
343 | -- software. | ||
344 | instance Serialize (PeerStore a) where | ||
345 | get = undefined | ||
346 | put = undefined | ||
347 | |||
348 | -- | Used in 'get_peers' DHT queries. | ||
349 | lookup :: InfoHash -> PeerStore a -> [PeerAddr a] | ||
350 | lookup ih (PeerStore m) = fromMaybe [] $ HM.lookup ih m | ||
351 | |||
352 | -- | Used in 'announce_peer' DHT queries. | ||
353 | insert :: Eq a => InfoHash -> PeerAddr a -> PeerStore a -> PeerStore a | ||
354 | insert ih a (PeerStore m) = PeerStore (HM.insertWith L.union ih [a] m) | ||
diff --git a/src/Network/BitTorrent/Core/PeerId.hs b/src/Network/BitTorrent/Core/PeerId.hs deleted file mode 100644 index a180ff30..00000000 --- a/src/Network/BitTorrent/Core/PeerId.hs +++ /dev/null | |||
@@ -1,364 +0,0 @@ | |||
1 | -- | | ||
2 | -- Copyright : (c) Sam Truzjan 2013 | ||
3 | -- License : BSD3 | ||
4 | -- Maintainer : pxqr.sta@gmail.com | ||
5 | -- Stability : experimental | ||
6 | -- Portability : portable | ||
7 | -- | ||
8 | -- 'PeerID' represent self assigned peer identificator. Ideally each | ||
9 | -- host in the network should have unique peer id to avoid | ||
10 | -- collisions, therefore for peer ID generation we use good entropy | ||
11 | -- source. Peer ID is sent in /tracker request/, sent and received in | ||
12 | -- /peer handshakes/ and used in DHT queries. | ||
13 | -- | ||
14 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
15 | {-# LANGUAGE MultiParamTypeClasses #-} | ||
16 | {-# LANGUAGE DeriveDataTypeable #-} | ||
17 | module Network.BitTorrent.Core.PeerId | ||
18 | ( -- * PeerId | ||
19 | PeerId | ||
20 | |||
21 | -- * Generation | ||
22 | , genPeerId | ||
23 | , timestamp | ||
24 | , entropy | ||
25 | |||
26 | -- * Encoding | ||
27 | , azureusStyle | ||
28 | , shadowStyle | ||
29 | , defaultClientId | ||
30 | , defaultVersionNumber | ||
31 | |||
32 | -- * Decoding | ||
33 | , fingerprint | ||
34 | ) where | ||
35 | |||
36 | import Control.Applicative | ||
37 | import Data.BEncode as BE | ||
38 | import Data.ByteString as BS | ||
39 | import Data.ByteString.Internal as BS | ||
40 | import Data.ByteString.Char8 as BC | ||
41 | import qualified Data.ByteString.Lazy as BL | ||
42 | import qualified Data.ByteString.Lazy.Builder as BS | ||
43 | import Data.Convertible | ||
44 | import Data.Default | ||
45 | import Data.Foldable (foldMap) | ||
46 | import Data.List as L | ||
47 | import Data.List.Split as L | ||
48 | import Data.Maybe (fromMaybe, catMaybes) | ||
49 | import Data.Monoid | ||
50 | import Data.Hashable | ||
51 | import Data.Serialize as S | ||
52 | import Data.String | ||
53 | import Data.Time.Clock (getCurrentTime) | ||
54 | import Data.Time.Format (formatTime) | ||
55 | import Data.Typeable | ||
56 | import Data.Version (Version(Version), versionBranch) | ||
57 | import Network.HTTP.Types.QueryLike | ||
58 | import System.Entropy (getEntropy) | ||
59 | import System.Locale (defaultTimeLocale) | ||
60 | import Text.PrettyPrint hiding ((<>)) | ||
61 | import Text.PrettyPrint.Class | ||
62 | import Text.Read (readMaybe) | ||
63 | |||
64 | import Network.BitTorrent.Core.Fingerprint | ||
65 | |||
66 | -- TODO use unpacked Word160 form (length is known statically) | ||
67 | |||
68 | -- | Peer identifier is exactly 20 bytes long bytestring. | ||
69 | newtype PeerId = PeerId { getPeerId :: ByteString } | ||
70 | deriving (Show, Eq, Ord, BEncode, Typeable) | ||
71 | |||
72 | peerIdLen :: Int | ||
73 | peerIdLen = 20 | ||
74 | |||
75 | -- | For testing purposes only. | ||
76 | instance Default PeerId where | ||
77 | def = azureusStyle defaultClientId defaultVersionNumber "" | ||
78 | |||
79 | instance Hashable PeerId where | ||
80 | hashWithSalt = hashUsing getPeerId | ||
81 | {-# INLINE hashWithSalt #-} | ||
82 | |||
83 | instance Serialize PeerId where | ||
84 | put = putByteString . getPeerId | ||
85 | get = PeerId <$> getBytes peerIdLen | ||
86 | |||
87 | instance QueryValueLike PeerId where | ||
88 | toQueryValue (PeerId pid) = Just pid | ||
89 | {-# INLINE toQueryValue #-} | ||
90 | |||
91 | instance IsString PeerId where | ||
92 | fromString str | ||
93 | | BS.length bs == peerIdLen = PeerId bs | ||
94 | | otherwise = error $ "Peer id should be 20 bytes long: " ++ show str | ||
95 | where | ||
96 | bs = fromString str | ||
97 | |||
98 | instance Pretty PeerId where | ||
99 | pretty = text . BC.unpack . getPeerId | ||
100 | |||
101 | instance Convertible BS.ByteString PeerId where | ||
102 | safeConvert bs | ||
103 | | BS.length bs == peerIdLen = pure (PeerId bs) | ||
104 | | otherwise = convError "invalid length" bs | ||
105 | |||
106 | {----------------------------------------------------------------------- | ||
107 | -- Encoding | ||
108 | -----------------------------------------------------------------------} | ||
109 | |||
110 | -- | Pad bytestring so it's becomes exactly request length. Conversion | ||
111 | -- is done like so: | ||
112 | -- | ||
113 | -- * length < size: Complete bytestring by given charaters. | ||
114 | -- | ||
115 | -- * length = size: Output bytestring as is. | ||
116 | -- | ||
117 | -- * length > size: Drop last (length - size) charaters from a | ||
118 | -- given bytestring. | ||
119 | -- | ||
120 | byteStringPadded :: ByteString -- ^ bytestring to be padded. | ||
121 | -> Int -- ^ size of result builder. | ||
122 | -> Char -- ^ character used for padding. | ||
123 | -> BS.Builder | ||
124 | byteStringPadded bs s c = | ||
125 | BS.byteString (BS.take s bs) <> | ||
126 | BS.byteString (BC.replicate padLen c) | ||
127 | where | ||
128 | padLen = s - min (BS.length bs) s | ||
129 | |||
130 | -- | Azureus-style encoding have the following layout: | ||
131 | -- | ||
132 | -- * 1 byte : '-' | ||
133 | -- | ||
134 | -- * 2 bytes: client id | ||
135 | -- | ||
136 | -- * 4 bytes: version number | ||
137 | -- | ||
138 | -- * 1 byte : '-' | ||
139 | -- | ||
140 | -- * 12 bytes: random number | ||
141 | -- | ||
142 | azureusStyle :: ByteString -- ^ 2 character client ID, padded with 'H'. | ||
143 | -> ByteString -- ^ Version number, padded with 'X'. | ||
144 | -> ByteString -- ^ Random number, padded with '0'. | ||
145 | -> PeerId -- ^ Azureus-style encoded peer ID. | ||
146 | azureusStyle cid ver rnd = PeerId $ BL.toStrict $ BS.toLazyByteString $ | ||
147 | BS.char8 '-' <> | ||
148 | byteStringPadded cid 2 'H' <> | ||
149 | byteStringPadded ver 4 'X' <> | ||
150 | BS.char8 '-' <> | ||
151 | byteStringPadded rnd 12 '0' | ||
152 | |||
153 | -- | Shadow-style encoding have the following layout: | ||
154 | -- | ||
155 | -- * 1 byte : client id. | ||
156 | -- | ||
157 | -- * 0-4 bytes: version number. If less than 4 then padded with | ||
158 | -- '-' char. | ||
159 | -- | ||
160 | -- * 15 bytes : random number. If length is less than 15 then | ||
161 | -- padded with '0' char. | ||
162 | -- | ||
163 | shadowStyle :: Char -- ^ Client ID. | ||
164 | -> ByteString -- ^ Version number. | ||
165 | -> ByteString -- ^ Random number. | ||
166 | -> PeerId -- ^ Shadow style encoded peer ID. | ||
167 | shadowStyle cid ver rnd = PeerId $ BL.toStrict $ BS.toLazyByteString $ | ||
168 | BS.char8 cid <> | ||
169 | byteStringPadded ver 4 '-' <> | ||
170 | byteStringPadded rnd 15 '0' | ||
171 | |||
172 | |||
173 | -- | 'HS'- 2 bytes long client identifier. | ||
174 | defaultClientId :: ByteString | ||
175 | defaultClientId = "HS" | ||
176 | |||
177 | -- | Gives exactly 4 bytes long version number for any version of the | ||
178 | -- package. Version is taken from .cabal file. | ||
179 | defaultVersionNumber :: ByteString | ||
180 | defaultVersionNumber = BS.take 4 $ BC.pack $ foldMap show $ | ||
181 | versionBranch $ ciVersion libFingerprint | ||
182 | |||
183 | {----------------------------------------------------------------------- | ||
184 | -- Generation | ||
185 | -----------------------------------------------------------------------} | ||
186 | |||
187 | -- | Gives 15 characters long decimal timestamp such that: | ||
188 | -- | ||
189 | -- * 6 bytes : first 6 characters from picoseconds obtained with %q. | ||
190 | -- | ||
191 | -- * 1 byte : character \'.\' for readability. | ||
192 | -- | ||
193 | -- * 9..* bytes: number of whole seconds since the Unix epoch | ||
194 | -- (!)REVERSED. | ||
195 | -- | ||
196 | -- Can be used both with shadow and azureus style encoding. This | ||
197 | -- format is used to make the ID's readable for debugging purposes. | ||
198 | -- | ||
199 | timestamp :: IO ByteString | ||
200 | timestamp = (BC.pack . format) <$> getCurrentTime | ||
201 | where | ||
202 | format t = L.take 6 (formatTime defaultTimeLocale "%q" t) ++ "." ++ | ||
203 | L.take 9 (L.reverse (formatTime defaultTimeLocale "%s" t)) | ||
204 | |||
205 | -- | Gives 15 character long random bytestring. This is more robust | ||
206 | -- method for generation of random part of peer ID than 'timestamp'. | ||
207 | entropy :: IO ByteString | ||
208 | entropy = getEntropy 15 | ||
209 | |||
210 | -- NOTE: entropy generates incorrrect peer id | ||
211 | |||
212 | -- | Here we use 'azureusStyle' encoding with the following args: | ||
213 | -- | ||
214 | -- * 'HS' for the client id; ('defaultClientId') | ||
215 | -- | ||
216 | -- * Version of the package for the version number; | ||
217 | -- ('defaultVersionNumber') | ||
218 | -- | ||
219 | -- * UTC time day ++ day time for the random number. ('timestamp') | ||
220 | -- | ||
221 | genPeerId :: IO PeerId | ||
222 | genPeerId = azureusStyle defaultClientId defaultVersionNumber <$> timestamp | ||
223 | |||
224 | {----------------------------------------------------------------------- | ||
225 | -- Decoding | ||
226 | -----------------------------------------------------------------------} | ||
227 | |||
228 | parseImpl :: ByteString -> ClientImpl | ||
229 | parseImpl = f . BC.unpack | ||
230 | where | ||
231 | f "AG" = IAres | ||
232 | f "A~" = IAres | ||
233 | f "AR" = IArctic | ||
234 | f "AV" = IAvicora | ||
235 | f "AX" = IBitPump | ||
236 | f "AZ" = IAzureus | ||
237 | f "BB" = IBitBuddy | ||
238 | f "BC" = IBitComet | ||
239 | f "BF" = IBitflu | ||
240 | f "BG" = IBTG | ||
241 | f "BR" = IBitRocket | ||
242 | f "BS" = IBTSlave | ||
243 | f "BX" = IBittorrentX | ||
244 | f "CD" = IEnhancedCTorrent | ||
245 | f "CT" = ICTorrent | ||
246 | f "DE" = IDelugeTorrent | ||
247 | f "DP" = IPropagateDataClient | ||
248 | f "EB" = IEBit | ||
249 | f "ES" = IElectricSheep | ||
250 | f "FT" = IFoxTorrent | ||
251 | f "GS" = IGSTorrent | ||
252 | f "HL" = IHalite | ||
253 | f "HS" = IlibHSbittorrent | ||
254 | f "HN" = IHydranode | ||
255 | f "KG" = IKGet | ||
256 | f "KT" = IKTorrent | ||
257 | f "LH" = ILH_ABC | ||
258 | f "LP" = ILphant | ||
259 | f "LT" = ILibtorrent | ||
260 | f "lt" = ILibTorrent | ||
261 | f "LW" = ILimeWire | ||
262 | f "MO" = IMonoTorrent | ||
263 | f "MP" = IMooPolice | ||
264 | f "MR" = IMiro | ||
265 | f "ML" = IMLdonkey | ||
266 | f "MT" = IMoonlightTorrent | ||
267 | f "NX" = INetTransport | ||
268 | f "PD" = IPando | ||
269 | f "qB" = IqBittorrent | ||
270 | f "QD" = IQQDownload | ||
271 | f "QT" = IQt4TorrentExample | ||
272 | f "RT" = IRetriever | ||
273 | f "S~" = IShareaza | ||
274 | f "SB" = ISwiftbit | ||
275 | f "SS" = ISwarmScope | ||
276 | f "ST" = ISymTorrent | ||
277 | f "st" = Isharktorrent | ||
278 | f "SZ" = IShareaza | ||
279 | f "TN" = ITorrentDotNET | ||
280 | f "TR" = ITransmission | ||
281 | f "TS" = ITorrentstorm | ||
282 | f "TT" = ITuoTu | ||
283 | f "UL" = IuLeecher | ||
284 | f "UT" = IuTorrent | ||
285 | f "VG" = IVagaa | ||
286 | f "WT" = IBitLet | ||
287 | f "WY" = IFireTorrent | ||
288 | f "XL" = IXunlei | ||
289 | f "XT" = IXanTorrent | ||
290 | f "XX" = IXtorrent | ||
291 | f "ZT" = IZipTorrent | ||
292 | f _ = IUnknown | ||
293 | |||
294 | -- TODO use regexps | ||
295 | |||
296 | -- | Tries to extract meaningful information from peer ID bytes. If | ||
297 | -- peer id uses unknown coding style then client info returned is | ||
298 | -- 'def'. | ||
299 | -- | ||
300 | fingerprint :: PeerId -> Fingerprint | ||
301 | fingerprint pid = either (const def) id $ runGet getCI (getPeerId pid) | ||
302 | where | ||
303 | getCI = do | ||
304 | leading <- BS.w2c <$> getWord8 | ||
305 | case leading of | ||
306 | '-' -> Fingerprint <$> getAzureusImpl <*> getAzureusVersion | ||
307 | 'M' -> Fingerprint <$> pure IMainline <*> getMainlineVersion | ||
308 | 'e' -> Fingerprint <$> getBitCometImpl <*> getBitCometVersion | ||
309 | 'F' -> Fingerprint <$> getBitCometImpl <*> getBitCometVersion | ||
310 | c -> do | ||
311 | c1 <- w2c <$> S.lookAhead getWord8 | ||
312 | if c1 == 'P' | ||
313 | then do | ||
314 | _ <- getWord8 | ||
315 | Fingerprint <$> pure IOpera <*> getOperaVersion | ||
316 | else Fingerprint <$> pure (getShadowImpl c) <*> getShadowVersion | ||
317 | |||
318 | getMainlineVersion = do | ||
319 | str <- BC.unpack <$> getByteString 7 | ||
320 | let mnums = L.filter (not . L.null) $ L.linesBy ('-' ==) str | ||
321 | return $ Version (fromMaybe [] $ sequence $ L.map readMaybe mnums) [] | ||
322 | |||
323 | getAzureusImpl = parseImpl <$> getByteString 2 | ||
324 | getAzureusVersion = mkVer <$> getByteString 4 | ||
325 | where | ||
326 | mkVer bs = Version [fromMaybe 0 $ readMaybe $ BC.unpack bs] [] | ||
327 | |||
328 | getBitCometImpl = do | ||
329 | bs <- getByteString 3 | ||
330 | S.lookAhead $ do | ||
331 | _ <- getByteString 2 | ||
332 | lr <- getByteString 4 | ||
333 | return $ | ||
334 | if lr == "LORD" then IBitLord else | ||
335 | if bs == "UTB" then IBitComet else | ||
336 | if bs == "xbc" then IBitComet else def | ||
337 | |||
338 | getBitCometVersion = do | ||
339 | x <- getWord8 | ||
340 | y <- getWord8 | ||
341 | return $ Version [fromIntegral x, fromIntegral y] [] | ||
342 | |||
343 | getOperaVersion = do | ||
344 | str <- BC.unpack <$> getByteString 4 | ||
345 | return $ Version [fromMaybe 0 $ readMaybe str] [] | ||
346 | |||
347 | getShadowImpl 'A' = IABC | ||
348 | getShadowImpl 'O' = IOspreyPermaseed | ||
349 | getShadowImpl 'Q' = IBTQueue | ||
350 | getShadowImpl 'R' = ITribler | ||
351 | getShadowImpl 'S' = IShadow | ||
352 | getShadowImpl 'T' = IBitTornado | ||
353 | getShadowImpl _ = IUnknown | ||
354 | |||
355 | decodeShadowVerNr :: Char -> Maybe Int | ||
356 | decodeShadowVerNr c | ||
357 | | '0' < c && c <= '9' = Just (fromEnum c - fromEnum '0') | ||
358 | | 'A' < c && c <= 'Z' = Just ((fromEnum c - fromEnum 'A') + 10) | ||
359 | | 'a' < c && c <= 'z' = Just ((fromEnum c - fromEnum 'a') + 36) | ||
360 | | otherwise = Nothing | ||
361 | |||
362 | getShadowVersion = do | ||
363 | str <- BC.unpack <$> getByteString 5 | ||
364 | return $ Version (catMaybes $ L.map decodeShadowVerNr str) [] | ||
diff --git a/src/Network/BitTorrent/DHT.hs b/src/Network/BitTorrent/DHT.hs index f587f7c8..39b33478 100644 --- a/src/Network/BitTorrent/DHT.hs +++ b/src/Network/BitTorrent/DHT.hs | |||
@@ -62,9 +62,8 @@ import Data.Conduit as C | |||
62 | import Data.Conduit.List as C | 62 | import Data.Conduit.List as C |
63 | import Network.Socket | 63 | import Network.Socket |
64 | 64 | ||
65 | import Data.Torrent (tNodes) | 65 | import Data.Torrent |
66 | import Data.Torrent.InfoHash | 66 | import Network.BitTorrent.Address |
67 | import Network.BitTorrent.Core | ||
68 | import Network.BitTorrent.DHT.Query | 67 | import Network.BitTorrent.DHT.Query |
69 | import Network.BitTorrent.DHT.Session | 68 | import Network.BitTorrent.DHT.Session |
70 | import Network.BitTorrent.DHT.Routing as T | 69 | import Network.BitTorrent.DHT.Routing as T |
diff --git a/src/Network/BitTorrent/DHT/ContactInfo.hs b/src/Network/BitTorrent/DHT/ContactInfo.hs index 028a4214..baa240b4 100644 --- a/src/Network/BitTorrent/DHT/ContactInfo.hs +++ b/src/Network/BitTorrent/DHT/ContactInfo.hs | |||
@@ -1,10 +1,24 @@ | |||
1 | module Network.BitTorrent.DHT.ContactInfo | 1 | module Network.BitTorrent.DHT.ContactInfo |
2 | ( ) where | 2 | ( PeerStore |
3 | , Network.BitTorrent.DHT.ContactInfo.lookup | ||
4 | , Network.BitTorrent.DHT.ContactInfo.insert | ||
5 | ) where | ||
6 | |||
7 | import Data.Default | ||
8 | import Data.List as L | ||
9 | import Data.Maybe | ||
10 | import Data.Monoid | ||
11 | import Data.HashMap.Strict as HM | ||
12 | import Data.Serialize | ||
13 | |||
14 | import Data.Torrent | ||
15 | import Network.BitTorrent.Address | ||
16 | |||
3 | {- | 17 | {- |
4 | import Data.HashMap.Strict as HM | 18 | import Data.HashMap.Strict as HM |
5 | 19 | ||
6 | import Data.Torrent.InfoHash | 20 | import Data.Torrent.InfoHash |
7 | import Network.BitTorrent.Core | 21 | import Network.BitTorrent.Address |
8 | 22 | ||
9 | -- increase prefix when table is too large | 23 | -- increase prefix when table is too large |
10 | -- decrease prefix when table is too small | 24 | -- decrease prefix when table is too small |
@@ -90,4 +104,36 @@ prune pref targetSize (Tip _ _) = undefined | |||
90 | -- | Remove expired entries. | 104 | -- | Remove expired entries. |
91 | splitGT :: Timestamp -> ContactInfo ip -> ContactInfo ip | 105 | splitGT :: Timestamp -> ContactInfo ip -> ContactInfo ip |
92 | splitGT = undefined | 106 | splitGT = undefined |
93 | -} \ No newline at end of file | 107 | -} |
108 | |||
109 | -- | Storage used to keep track a set of known peers in client, | ||
110 | -- tracker or DHT sessions. | ||
111 | newtype PeerStore ip = PeerStore (HashMap InfoHash [PeerAddr ip]) | ||
112 | |||
113 | -- | Empty store. | ||
114 | instance Default (PeerStore a) where | ||
115 | def = PeerStore HM.empty | ||
116 | {-# INLINE def #-} | ||
117 | |||
118 | -- | Monoid under union operation. | ||
119 | instance Eq a => Monoid (PeerStore a) where | ||
120 | mempty = def | ||
121 | {-# INLINE mempty #-} | ||
122 | |||
123 | mappend (PeerStore a) (PeerStore b) = | ||
124 | PeerStore (HM.unionWith L.union a b) | ||
125 | {-# INLINE mappend #-} | ||
126 | |||
127 | -- | Can be used to store peers between invocations of the client | ||
128 | -- software. | ||
129 | instance Serialize (PeerStore a) where | ||
130 | get = undefined | ||
131 | put = undefined | ||
132 | |||
133 | -- | Used in 'get_peers' DHT queries. | ||
134 | lookup :: InfoHash -> PeerStore a -> [PeerAddr a] | ||
135 | lookup ih (PeerStore m) = fromMaybe [] $ HM.lookup ih m | ||
136 | |||
137 | -- | Used in 'announce_peer' DHT queries. | ||
138 | insert :: Eq a => InfoHash -> PeerAddr a -> PeerStore a -> PeerStore a | ||
139 | insert ih a (PeerStore m) = PeerStore (HM.insertWith L.union ih [a] m) | ||
diff --git a/src/Network/BitTorrent/DHT/Message.hs b/src/Network/BitTorrent/DHT/Message.hs index 7bcd00f0..145141ee 100644 --- a/src/Network/BitTorrent/DHT/Message.hs +++ b/src/Network/BitTorrent/DHT/Message.hs | |||
@@ -92,8 +92,8 @@ import Data.Typeable | |||
92 | import Network | 92 | import Network |
93 | import Network.KRPC | 93 | import Network.KRPC |
94 | 94 | ||
95 | import Data.Torrent.InfoHash | 95 | import Data.Torrent |
96 | import Network.BitTorrent.Core | 96 | import Network.BitTorrent.Address |
97 | import Network.BitTorrent.DHT.Token | 97 | import Network.BitTorrent.DHT.Token |
98 | import Network.KRPC () | 98 | import Network.KRPC () |
99 | 99 | ||
diff --git a/src/Network/BitTorrent/DHT/Query.hs b/src/Network/BitTorrent/DHT/Query.hs index 48dfc15a..d4710ecf 100644 --- a/src/Network/BitTorrent/DHT/Query.hs +++ b/src/Network/BitTorrent/DHT/Query.hs | |||
@@ -56,8 +56,8 @@ import Text.PrettyPrint as PP hiding ((<>), ($$)) | |||
56 | import Text.PrettyPrint.Class | 56 | import Text.PrettyPrint.Class |
57 | 57 | ||
58 | import Network.KRPC hiding (Options, def) | 58 | import Network.KRPC hiding (Options, def) |
59 | import Data.Torrent.InfoHash | 59 | import Data.Torrent |
60 | import Network.BitTorrent.Core | 60 | import Network.BitTorrent.Address |
61 | import Network.BitTorrent.DHT.Message | 61 | import Network.BitTorrent.DHT.Message |
62 | import Network.BitTorrent.DHT.Routing | 62 | import Network.BitTorrent.DHT.Routing |
63 | import Network.BitTorrent.DHT.Session | 63 | import Network.BitTorrent.DHT.Session |
diff --git a/src/Network/BitTorrent/DHT/Routing.hs b/src/Network/BitTorrent/DHT/Routing.hs index 106aec31..ee295125 100644 --- a/src/Network/BitTorrent/DHT/Routing.hs +++ b/src/Network/BitTorrent/DHT/Routing.hs | |||
@@ -73,8 +73,8 @@ import GHC.Generics | |||
73 | import Text.PrettyPrint as PP hiding ((<>)) | 73 | import Text.PrettyPrint as PP hiding ((<>)) |
74 | import Text.PrettyPrint.Class | 74 | import Text.PrettyPrint.Class |
75 | 75 | ||
76 | import Data.Torrent.InfoHash | 76 | import Data.Torrent |
77 | import Network.BitTorrent.Core | 77 | import Network.BitTorrent.Address |
78 | 78 | ||
79 | {----------------------------------------------------------------------- | 79 | {----------------------------------------------------------------------- |
80 | -- Routing monad | 80 | -- Routing monad |
diff --git a/src/Network/BitTorrent/DHT/Session.hs b/src/Network/BitTorrent/DHT/Session.hs index e770b1d3..208f8ec8 100644 --- a/src/Network/BitTorrent/DHT/Session.hs +++ b/src/Network/BitTorrent/DHT/Session.hs | |||
@@ -75,6 +75,7 @@ import Control.Monad.Logger | |||
75 | import Control.Monad.Reader | 75 | import Control.Monad.Reader |
76 | import Control.Monad.Trans.Control | 76 | import Control.Monad.Trans.Control |
77 | import Control.Monad.Trans.Resource | 77 | import Control.Monad.Trans.Resource |
78 | import Data.Conduit.Lazy | ||
78 | import Data.Default | 79 | import Data.Default |
79 | import Data.Fixed | 80 | import Data.Fixed |
80 | import Data.Hashable | 81 | import Data.Hashable |
@@ -91,11 +92,11 @@ import System.Random (randomIO) | |||
91 | import Text.PrettyPrint as PP hiding ((<>), ($$)) | 92 | import Text.PrettyPrint as PP hiding ((<>), ($$)) |
92 | import Text.PrettyPrint.Class | 93 | import Text.PrettyPrint.Class |
93 | 94 | ||
94 | import Data.Torrent.InfoHash | 95 | import Data.Torrent as Torrent |
95 | import Network.KRPC hiding (Options, def) | 96 | import Network.KRPC hiding (Options, def) |
96 | import qualified Network.KRPC as KRPC (def) | 97 | import qualified Network.KRPC as KRPC (def) |
97 | import Network.BitTorrent.Core | 98 | import Network.BitTorrent.Address |
98 | import Network.BitTorrent.Core.PeerAddr as P | 99 | import Network.BitTorrent.DHT.ContactInfo as P |
99 | import Network.BitTorrent.DHT.Message | 100 | import Network.BitTorrent.DHT.Message |
100 | import Network.BitTorrent.DHT.Routing as R | 101 | import Network.BitTorrent.DHT.Routing as R |
101 | import Network.BitTorrent.DHT.Token as T | 102 | import Network.BitTorrent.DHT.Token as T |
@@ -253,10 +254,8 @@ data Node ip = Node | |||
253 | -- | DHT keep track current session and proper resource allocation for | 254 | -- | DHT keep track current session and proper resource allocation for |
254 | -- safe multithreading. | 255 | -- safe multithreading. |
255 | newtype DHT ip a = DHT { unDHT :: ReaderT (Node ip) IO a } | 256 | newtype DHT ip a = DHT { unDHT :: ReaderT (Node ip) IO a } |
256 | deriving ( Functor, Applicative, Monad | 257 | deriving ( Functor, Applicative, Monad, MonadIO |
257 | , MonadIO, MonadBase IO | 258 | , MonadBase IO, MonadReader (Node ip), MonadThrow |
258 | , MonadReader (Node ip) | ||
259 | , MonadThrow, MonadUnsafeIO | ||
260 | ) | 259 | ) |
261 | 260 | ||
262 | instance MonadBaseControl IO (DHT ip) where | 261 | instance MonadBaseControl IO (DHT ip) where |
diff --git a/src/Network/BitTorrent/DHT/Token.hs b/src/Network/BitTorrent/DHT/Token.hs index a38456fd..a0ed428b 100644 --- a/src/Network/BitTorrent/DHT/Token.hs +++ b/src/Network/BitTorrent/DHT/Token.hs | |||
@@ -50,7 +50,7 @@ import Data.String | |||
50 | import Data.Time | 50 | import Data.Time |
51 | import System.Random | 51 | import System.Random |
52 | 52 | ||
53 | import Network.BitTorrent.Core | 53 | import Network.BitTorrent.Address |
54 | 54 | ||
55 | -- TODO use ShortByteString | 55 | -- TODO use ShortByteString |
56 | 56 | ||
diff --git a/src/Network/BitTorrent/Exchange/Assembler.hs b/src/Network/BitTorrent/Exchange/Assembler.hs deleted file mode 100644 index e5834948..00000000 --- a/src/Network/BitTorrent/Exchange/Assembler.hs +++ /dev/null | |||
@@ -1,168 +0,0 @@ | |||
1 | -- | | ||
2 | -- Copyright : (c) Sam Truzjan 2013 | ||
3 | -- License : BSD3 | ||
4 | -- Maintainer : pxqr.sta@gmail.com | ||
5 | -- Stability : experimental | ||
6 | -- Portability : portable | ||
7 | -- | ||
8 | -- Assembler is used to build pieces from blocks. In general | ||
9 | -- 'Assembler' should be used to handle 'Transfer' messages when | ||
10 | -- | ||
11 | -- A block can have one of the following status: | ||
12 | -- | ||
13 | -- 1) /not allowed/: Piece is not in download set. 'null' and 'empty'. | ||
14 | -- | ||
15 | -- | ||
16 | -- 2) /waiting/: (allowed?) Block have been allowed to download, | ||
17 | -- but /this/ peer did not send any 'Request' message for this | ||
18 | -- block. To allow some piece use | ||
19 | -- 'Network.BitTorrent.Exchange.Selector' and then 'allowedSet' | ||
20 | -- and 'allowPiece'. | ||
21 | -- | ||
22 | -- 3) /inflight/: (pending?) Block have been requested but | ||
23 | -- /remote/ peer did not send any 'Piece' message for this block. | ||
24 | -- Related functions 'markInflight' | ||
25 | -- | ||
26 | -- 4) /pending/: (stalled?) Block have have been downloaded | ||
27 | -- Related functions 'insertBlock'. | ||
28 | -- | ||
29 | -- Piece status: | ||
30 | -- | ||
31 | -- 1) /assembled/: (downloaded?) All blocks in piece have been | ||
32 | -- downloaded but the piece did not verified yet. | ||
33 | -- | ||
34 | -- * Valid: go to completed; | ||
35 | -- | ||
36 | -- * Invalid: go to waiting. | ||
37 | -- | ||
38 | -- 2) /corrupted/: | ||
39 | -- | ||
40 | -- 3) /downloaded/: (verified?) A piece have been successfully | ||
41 | -- verified via the hash. Usually the piece should be stored to | ||
42 | -- the 'System.Torrent.Storage' and /this/ peer should send 'Have' | ||
43 | -- messages to the /remote/ peers. | ||
44 | -- | ||
45 | {-# LANGUAGE TemplateHaskell #-} | ||
46 | module Network.BitTorrent.Exchange.Assembler | ||
47 | ( -- * Assembler | ||
48 | Assembler | ||
49 | |||
50 | -- * Query | ||
51 | , Network.BitTorrent.Exchange.Assembler.null | ||
52 | , Network.BitTorrent.Exchange.Assembler.size | ||
53 | |||
54 | -- * | ||
55 | , Network.BitTorrent.Exchange.Assembler.empty | ||
56 | , allowPiece | ||
57 | |||
58 | -- * Debugging | ||
59 | , Network.BitTorrent.Exchange.Assembler.valid | ||
60 | ) where | ||
61 | |||
62 | import Control.Applicative | ||
63 | import Control.Lens | ||
64 | import Data.IntMap.Strict as IM | ||
65 | import Data.List as L | ||
66 | import Data.Map as M | ||
67 | import Data.Maybe | ||
68 | import Data.IP | ||
69 | |||
70 | import Data.Torrent.Piece | ||
71 | import Network.BitTorrent.Core | ||
72 | import Network.BitTorrent.Exchange.Block as B | ||
73 | |||
74 | {----------------------------------------------------------------------- | ||
75 | -- Assembler | ||
76 | -----------------------------------------------------------------------} | ||
77 | |||
78 | type Timestamp = () | ||
79 | {- | ||
80 | data BlockRequest = BlockRequest | ||
81 | { requestSent :: Timestamp | ||
82 | , requestedPeer :: PeerAddr IP | ||
83 | , requestedBlock :: BlockIx | ||
84 | } | ||
85 | -} | ||
86 | type BlockRange = (BlockOffset, BlockSize) | ||
87 | type PieceMap = IntMap | ||
88 | |||
89 | data Assembler = Assembler | ||
90 | { -- | A set of blocks that have been 'Request'ed but not yet acked. | ||
91 | _inflight :: Map (PeerAddr IP) (PieceMap [BlockRange]) | ||
92 | |||
93 | -- | A set of blocks that but not yet assembled. | ||
94 | , _pending :: PieceMap Bucket | ||
95 | |||
96 | -- | Used for validation of assembled pieces. | ||
97 | , info :: PieceInfo | ||
98 | } | ||
99 | |||
100 | $(makeLenses ''Assembler) | ||
101 | |||
102 | |||
103 | valid :: Assembler -> Bool | ||
104 | valid = undefined | ||
105 | |||
106 | data Result a | ||
107 | = Completed (Piece a) | ||
108 | | Corrupted PieceIx | ||
109 | | NotRequested PieceIx | ||
110 | | Overlapped BlockIx | ||
111 | |||
112 | null :: Assembler -> Bool | ||
113 | null = undefined | ||
114 | |||
115 | size :: Assembler -> Bool | ||
116 | size = undefined | ||
117 | |||
118 | empty :: PieceInfo -> Assembler | ||
119 | empty = Assembler M.empty IM.empty | ||
120 | |||
121 | allowPiece :: PieceIx -> Assembler -> Assembler | ||
122 | allowPiece pix a @ Assembler {..} = over pending (IM.insert pix bkt) a | ||
123 | where | ||
124 | bkt = B.empty (piPieceLength info) | ||
125 | |||
126 | allowedSet :: (PeerAddr IP) -> Assembler -> [BlockIx] | ||
127 | allowedSet = undefined | ||
128 | |||
129 | --inflight :: PeerAddr -> BlockIx -> Assembler -> Assembler | ||
130 | --inflight = undefined | ||
131 | |||
132 | -- You should check if a returned by peer block is actually have | ||
133 | -- been requested and in-flight. This is needed to avoid "I send | ||
134 | -- random corrupted block" attacks. | ||
135 | insert :: PeerAddr IP -> Block a -> Assembler -> Assembler | ||
136 | insert = undefined | ||
137 | |||
138 | {- | ||
139 | insert :: Block a -> Assembler a -> (Assembler a, Maybe (Result a)) | ||
140 | insert blk @ Block {..} a @ Assembler {..} = undefined | ||
141 | {- | ||
142 | = let (pending, mpiece) = inserta blk piecePending | ||
143 | in (Assembler inflightSet pending pieceInfo, f <$> mpiece) | ||
144 | where | ||
145 | f p = undefined | ||
146 | -- | checkPieceLazy pieceInfo p = Assembled p | ||
147 | -- | otherwise = Corrupted ixPiece | ||
148 | -} | ||
149 | |||
150 | |||
151 | inflightPieces :: Assembler a -> [PieceIx] | ||
152 | inflightPieces Assembler {..} = IM.keys piecePending | ||
153 | |||
154 | completeBlocks :: PieceIx -> Assembler a -> [Block a] | ||
155 | completeBlocks pix Assembler {..} = fromMaybe [] $ IM.lookup pix piecePending | ||
156 | |||
157 | incompleteBlocks :: PieceIx -> Assembler a -> [BlockIx] | ||
158 | incompleteBlocks = undefined | ||
159 | |||
160 | nextBlock :: Assembler a -> Maybe (Assembler a, BlockIx) | ||
161 | nextBlock Assembler {..} = undefined | ||
162 | |||
163 | inserta :: Block a | ||
164 | -> PieceMap [Block a] | ||
165 | -> (PieceMap [Block a], Maybe (Piece a)) | ||
166 | inserta = undefined | ||
167 | |||
168 | -} | ||
diff --git a/src/Network/BitTorrent/Exchange/Bitfield.hs b/src/Network/BitTorrent/Exchange/Bitfield.hs new file mode 100644 index 00000000..eca11d83 --- /dev/null +++ b/src/Network/BitTorrent/Exchange/Bitfield.hs | |||
@@ -0,0 +1,398 @@ | |||
1 | -- | | ||
2 | -- Copyright : (c) Sam Truzjan 2013 | ||
3 | -- License : BSD3 | ||
4 | -- Maintainer : pxqr.sta@gmail.com | ||
5 | -- Stability : experimental | ||
6 | -- Portability : portable | ||
7 | -- | ||
8 | -- This modules provides all necessary machinery to work with | ||
9 | -- bitfields. Bitfields are used to keep track indices of complete | ||
10 | -- pieces either peer have or client have. | ||
11 | -- | ||
12 | -- There are also commonly used piece seletion algorithms | ||
13 | -- which used to find out which one next piece to download. | ||
14 | -- Selectors considered to be used in the following order: | ||
15 | -- | ||
16 | -- * Random first - at the start. | ||
17 | -- | ||
18 | -- * Rarest first selection - performed to avoid situation when | ||
19 | -- rarest piece is unaccessible. | ||
20 | -- | ||
21 | -- * /End game/ seletion - performed after a peer has requested all | ||
22 | -- the subpieces of the content. | ||
23 | -- | ||
24 | -- Note that BitTorrent applies the strict priority policy for | ||
25 | -- /subpiece/ or /blocks/ selection. | ||
26 | -- | ||
27 | {-# LANGUAGE CPP #-} | ||
28 | {-# LANGUAGE BangPatterns #-} | ||
29 | {-# LANGUAGE RecordWildCards #-} | ||
30 | module Network.BitTorrent.Exchange.Bitfield | ||
31 | ( -- * Bitfield | ||
32 | PieceIx | ||
33 | , PieceCount | ||
34 | , Bitfield | ||
35 | |||
36 | -- * Construction | ||
37 | , haveAll | ||
38 | , haveNone | ||
39 | , have | ||
40 | , singleton | ||
41 | , interval | ||
42 | , adjustSize | ||
43 | |||
44 | -- * Query | ||
45 | -- ** Cardinality | ||
46 | , Network.BitTorrent.Exchange.Bitfield.null | ||
47 | , Network.BitTorrent.Exchange.Bitfield.full | ||
48 | , haveCount | ||
49 | , totalCount | ||
50 | , completeness | ||
51 | |||
52 | -- ** Membership | ||
53 | , member | ||
54 | , notMember | ||
55 | , findMin | ||
56 | , findMax | ||
57 | , isSubsetOf | ||
58 | |||
59 | -- ** Availability | ||
60 | , complement | ||
61 | , Frequency | ||
62 | , frequencies | ||
63 | , rarest | ||
64 | |||
65 | -- * Combine | ||
66 | , insert | ||
67 | , union | ||
68 | , intersection | ||
69 | , difference | ||
70 | |||
71 | -- * Conversion | ||
72 | , toList | ||
73 | , fromList | ||
74 | |||
75 | -- * Serialization | ||
76 | , fromBitmap | ||
77 | , toBitmap | ||
78 | |||
79 | -- * Piece selection | ||
80 | , Selector | ||
81 | , selector | ||
82 | , strategyClass | ||
83 | |||
84 | , strictFirst | ||
85 | , strictLast | ||
86 | , rarestFirst | ||
87 | , randomFirst | ||
88 | , endGame | ||
89 | ) where | ||
90 | |||
91 | import Control.Monad | ||
92 | import Control.Monad.ST | ||
93 | import Data.ByteString (ByteString) | ||
94 | import qualified Data.ByteString as B | ||
95 | import qualified Data.ByteString.Lazy as Lazy | ||
96 | import Data.Vector.Unboxed (Vector) | ||
97 | import qualified Data.Vector.Unboxed as V | ||
98 | import qualified Data.Vector.Unboxed.Mutable as VM | ||
99 | import Data.IntervalSet (IntSet) | ||
100 | import qualified Data.IntervalSet as S | ||
101 | import qualified Data.IntervalSet.ByteString as S | ||
102 | import Data.List (foldl') | ||
103 | import Data.Monoid | ||
104 | import Data.Ratio | ||
105 | |||
106 | import Data.Torrent | ||
107 | |||
108 | -- TODO cache some operations | ||
109 | |||
110 | -- | Bitfields are represented just as integer sets but with | ||
111 | -- restriction: the each set should be within given interval (or | ||
112 | -- subset of the specified interval). Size is used to specify | ||
113 | -- interval, so bitfield of size 10 might contain only indices in | ||
114 | -- interval [0..9]. | ||
115 | -- | ||
116 | data Bitfield = Bitfield { | ||
117 | bfSize :: !PieceCount | ||
118 | , bfSet :: !IntSet | ||
119 | } deriving (Show, Read, Eq) | ||
120 | |||
121 | -- Invariants: all elements of bfSet lie in [0..bfSize - 1]; | ||
122 | |||
123 | instance Monoid Bitfield where | ||
124 | {-# SPECIALIZE instance Monoid Bitfield #-} | ||
125 | mempty = haveNone 0 | ||
126 | mappend = union | ||
127 | mconcat = unions | ||
128 | |||
129 | {----------------------------------------------------------------------- | ||
130 | Construction | ||
131 | -----------------------------------------------------------------------} | ||
132 | |||
133 | -- | The empty bitfield of the given size. | ||
134 | haveNone :: PieceCount -> Bitfield | ||
135 | haveNone s = Bitfield s S.empty | ||
136 | |||
137 | -- | The full bitfield containing all piece indices for the given size. | ||
138 | haveAll :: PieceCount -> Bitfield | ||
139 | haveAll s = Bitfield s (S.interval 0 (s - 1)) | ||
140 | |||
141 | -- | Insert the index in the set ignoring out of range indices. | ||
142 | have :: PieceIx -> Bitfield -> Bitfield | ||
143 | have ix Bitfield {..} | ||
144 | | 0 <= ix && ix < bfSize = Bitfield bfSize (S.insert ix bfSet) | ||
145 | | otherwise = Bitfield bfSize bfSet | ||
146 | |||
147 | singleton :: PieceIx -> PieceCount -> Bitfield | ||
148 | singleton ix pc = have ix (haveNone pc) | ||
149 | |||
150 | -- | Assign new size to bitfield. FIXME Normally, size should be only | ||
151 | -- decreased, otherwise exception raised. | ||
152 | adjustSize :: PieceCount -> Bitfield -> Bitfield | ||
153 | adjustSize s Bitfield {..} = Bitfield s bfSet | ||
154 | |||
155 | -- | NOTE: for internal use only | ||
156 | interval :: PieceCount -> PieceIx -> PieceIx -> Bitfield | ||
157 | interval pc a b = Bitfield pc (S.interval a b) | ||
158 | |||
159 | {----------------------------------------------------------------------- | ||
160 | Query | ||
161 | -----------------------------------------------------------------------} | ||
162 | |||
163 | -- | Test if bitifield have no one index: peer do not have anything. | ||
164 | null :: Bitfield -> Bool | ||
165 | null Bitfield {..} = S.null bfSet | ||
166 | |||
167 | -- | Test if bitfield have all pieces. | ||
168 | full :: Bitfield -> Bool | ||
169 | full Bitfield {..} = S.size bfSet == bfSize | ||
170 | |||
171 | -- | Count of peer have pieces. | ||
172 | haveCount :: Bitfield -> PieceCount | ||
173 | haveCount = S.size . bfSet | ||
174 | |||
175 | -- | Total count of pieces and its indices. | ||
176 | totalCount :: Bitfield -> PieceCount | ||
177 | totalCount = bfSize | ||
178 | |||
179 | -- | Ratio of /have/ piece count to the /total/ piece count. | ||
180 | -- | ||
181 | -- > forall bf. 0 <= completeness bf <= 1 | ||
182 | -- | ||
183 | completeness :: Bitfield -> Ratio PieceCount | ||
184 | completeness b = haveCount b % totalCount b | ||
185 | |||
186 | inRange :: PieceIx -> Bitfield -> Bool | ||
187 | inRange ix Bitfield {..} = 0 <= ix && ix < bfSize | ||
188 | |||
189 | member :: PieceIx -> Bitfield -> Bool | ||
190 | member ix bf @ Bitfield {..} | ||
191 | | ix `inRange` bf = ix `S.member` bfSet | ||
192 | | otherwise = False | ||
193 | |||
194 | notMember :: PieceIx -> Bitfield -> Bool | ||
195 | notMember ix bf @ Bitfield {..} | ||
196 | | ix `inRange` bf = ix `S.notMember` bfSet | ||
197 | | otherwise = True | ||
198 | |||
199 | -- | Find first available piece index. | ||
200 | findMin :: Bitfield -> PieceIx | ||
201 | findMin = S.findMin . bfSet | ||
202 | {-# INLINE findMin #-} | ||
203 | |||
204 | -- | Find last available piece index. | ||
205 | findMax :: Bitfield -> PieceIx | ||
206 | findMax = S.findMax . bfSet | ||
207 | {-# INLINE findMax #-} | ||
208 | |||
209 | -- | Check if all pieces from first bitfield present if the second bitfield | ||
210 | isSubsetOf :: Bitfield -> Bitfield -> Bool | ||
211 | isSubsetOf a b = bfSet a `S.isSubsetOf` bfSet b | ||
212 | {-# INLINE isSubsetOf #-} | ||
213 | |||
214 | -- | Resulting bitfield includes only missing pieces. | ||
215 | complement :: Bitfield -> Bitfield | ||
216 | complement Bitfield {..} = Bitfield | ||
217 | { bfSet = uni `S.difference` bfSet | ||
218 | , bfSize = bfSize | ||
219 | } | ||
220 | where | ||
221 | Bitfield _ uni = haveAll bfSize | ||
222 | {-# INLINE complement #-} | ||
223 | |||
224 | {----------------------------------------------------------------------- | ||
225 | -- Availability | ||
226 | -----------------------------------------------------------------------} | ||
227 | |||
228 | -- | Frequencies are needed in piece selection startegies which use | ||
229 | -- availability quantity to find out the optimal next piece index to | ||
230 | -- download. | ||
231 | type Frequency = Int | ||
232 | |||
233 | -- TODO rename to availability | ||
234 | -- | How many times each piece index occur in the given bitfield set. | ||
235 | frequencies :: [Bitfield] -> Vector Frequency | ||
236 | frequencies [] = V.fromList [] | ||
237 | frequencies xs = runST $ do | ||
238 | v <- VM.new size | ||
239 | VM.set v 0 | ||
240 | forM_ xs $ \ Bitfield {..} -> do | ||
241 | forM_ (S.toList bfSet) $ \ x -> do | ||
242 | fr <- VM.read v x | ||
243 | VM.write v x (succ fr) | ||
244 | V.unsafeFreeze v | ||
245 | where | ||
246 | size = maximum (map bfSize xs) | ||
247 | |||
248 | -- TODO it seems like this operation is veeery slow | ||
249 | |||
250 | -- | Find least available piece index. If no piece available return | ||
251 | -- 'Nothing'. | ||
252 | rarest :: [Bitfield] -> Maybe PieceIx | ||
253 | rarest xs | ||
254 | | V.null freqMap = Nothing | ||
255 | | otherwise | ||
256 | = Just $ fst $ V.ifoldr' minIx (0, freqMap V.! 0) freqMap | ||
257 | where | ||
258 | freqMap = frequencies xs | ||
259 | |||
260 | minIx :: PieceIx -> Frequency | ||
261 | -> (PieceIx, Frequency) | ||
262 | -> (PieceIx, Frequency) | ||
263 | minIx ix fr acc@(_, fra) | ||
264 | | fr < fra && fr > 0 = (ix, fr) | ||
265 | | otherwise = acc | ||
266 | |||
267 | |||
268 | {----------------------------------------------------------------------- | ||
269 | Combine | ||
270 | -----------------------------------------------------------------------} | ||
271 | |||
272 | insert :: PieceIx -> Bitfield -> Bitfield | ||
273 | insert pix bf @ Bitfield {..} | ||
274 | | 0 <= pix && pix < bfSize = Bitfield | ||
275 | { bfSet = S.insert pix bfSet | ||
276 | , bfSize = bfSize | ||
277 | } | ||
278 | | otherwise = bf | ||
279 | |||
280 | -- | Find indices at least one peer have. | ||
281 | union :: Bitfield -> Bitfield -> Bitfield | ||
282 | union a b = {-# SCC union #-} Bitfield { | ||
283 | bfSize = bfSize a `max` bfSize b | ||
284 | , bfSet = bfSet a `S.union` bfSet b | ||
285 | } | ||
286 | |||
287 | -- | Find indices both peers have. | ||
288 | intersection :: Bitfield -> Bitfield -> Bitfield | ||
289 | intersection a b = {-# SCC intersection #-} Bitfield { | ||
290 | bfSize = bfSize a `min` bfSize b | ||
291 | , bfSet = bfSet a `S.intersection` bfSet b | ||
292 | } | ||
293 | |||
294 | -- | Find indices which have first peer but do not have the second peer. | ||
295 | difference :: Bitfield -> Bitfield -> Bitfield | ||
296 | difference a b = {-# SCC difference #-} Bitfield { | ||
297 | bfSize = bfSize a -- FIXME is it reasonable? | ||
298 | , bfSet = bfSet a `S.difference` bfSet b | ||
299 | } | ||
300 | |||
301 | -- | Find indices the any of the peers have. | ||
302 | unions :: [Bitfield] -> Bitfield | ||
303 | unions = {-# SCC unions #-} foldl' union (haveNone 0) | ||
304 | |||
305 | {----------------------------------------------------------------------- | ||
306 | Serialization | ||
307 | -----------------------------------------------------------------------} | ||
308 | |||
309 | -- | List all /have/ indexes. | ||
310 | toList :: Bitfield -> [PieceIx] | ||
311 | toList Bitfield {..} = S.toList bfSet | ||
312 | |||
313 | -- | Make bitfield from list of /have/ indexes. | ||
314 | fromList :: PieceCount -> [PieceIx] -> Bitfield | ||
315 | fromList s ixs = Bitfield { | ||
316 | bfSize = s | ||
317 | , bfSet = S.splitGT (-1) $ S.splitLT s $ S.fromList ixs | ||
318 | } | ||
319 | |||
320 | -- | Unpack 'Bitfield' from tightly packed bit array. Note resulting | ||
321 | -- size might be more than real bitfield size, use 'adjustSize'. | ||
322 | fromBitmap :: ByteString -> Bitfield | ||
323 | fromBitmap bs = {-# SCC fromBitmap #-} Bitfield { | ||
324 | bfSize = B.length bs * 8 | ||
325 | , bfSet = S.fromByteString bs | ||
326 | } | ||
327 | {-# INLINE fromBitmap #-} | ||
328 | |||
329 | -- | Pack a 'Bitfield' to tightly packed bit array. | ||
330 | toBitmap :: Bitfield -> Lazy.ByteString | ||
331 | toBitmap Bitfield {..} = {-# SCC toBitmap #-} Lazy.fromChunks [intsetBM, alignment] | ||
332 | where | ||
333 | byteSize = bfSize `div` 8 + if bfSize `mod` 8 == 0 then 0 else 1 | ||
334 | alignment = B.replicate (byteSize - B.length intsetBM) 0 | ||
335 | intsetBM = S.toByteString bfSet | ||
336 | |||
337 | {----------------------------------------------------------------------- | ||
338 | -- Piece selection | ||
339 | -----------------------------------------------------------------------} | ||
340 | |||
341 | type Selector = Bitfield -- ^ Indices of client /have/ pieces. | ||
342 | -> Bitfield -- ^ Indices of peer /have/ pieces. | ||
343 | -> [Bitfield] -- ^ Indices of other peers /have/ pieces. | ||
344 | -> Maybe PieceIx -- ^ Zero-based index of piece to request | ||
345 | -- to, if any. | ||
346 | |||
347 | selector :: Selector -- ^ Selector to use at the start. | ||
348 | -> Ratio PieceCount | ||
349 | -> Selector -- ^ Selector to use after the client have | ||
350 | -- the C pieces. | ||
351 | -> Selector -- ^ Selector that changes behaviour based | ||
352 | -- on completeness. | ||
353 | selector start pt ready h a xs = | ||
354 | case strategyClass pt h of | ||
355 | SCBeginning -> start h a xs | ||
356 | SCReady -> ready h a xs | ||
357 | SCEnd -> endGame h a xs | ||
358 | |||
359 | data StartegyClass | ||
360 | = SCBeginning | ||
361 | | SCReady | ||
362 | | SCEnd | ||
363 | deriving (Show, Eq, Ord, Enum, Bounded) | ||
364 | |||
365 | |||
366 | strategyClass :: Ratio PieceCount -> Bitfield -> StartegyClass | ||
367 | strategyClass threshold = classify . completeness | ||
368 | where | ||
369 | classify c | ||
370 | | c < threshold = SCBeginning | ||
371 | | c + 1 % numerator c < 1 = SCReady | ||
372 | -- FIXME numerator have is not total count | ||
373 | | otherwise = SCEnd | ||
374 | |||
375 | |||
376 | -- | Select the first available piece. | ||
377 | strictFirst :: Selector | ||
378 | strictFirst h a _ = Just $ findMin (difference a h) | ||
379 | |||
380 | -- | Select the last available piece. | ||
381 | strictLast :: Selector | ||
382 | strictLast h a _ = Just $ findMax (difference a h) | ||
383 | |||
384 | -- | | ||
385 | rarestFirst :: Selector | ||
386 | rarestFirst h a xs = rarest (map (intersection want) xs) | ||
387 | where | ||
388 | want = difference h a | ||
389 | |||
390 | -- | In average random first is faster than rarest first strategy but | ||
391 | -- only if all pieces are available. | ||
392 | randomFirst :: Selector | ||
393 | randomFirst = do | ||
394 | -- randomIO | ||
395 | error "randomFirst" | ||
396 | |||
397 | endGame :: Selector | ||
398 | endGame = strictLast | ||
diff --git a/src/Network/BitTorrent/Exchange/Block.hs b/src/Network/BitTorrent/Exchange/Block.hs index 16c124e9..ccc7a0a9 100644 --- a/src/Network/BitTorrent/Exchange/Block.hs +++ b/src/Network/BitTorrent/Exchange/Block.hs | |||
@@ -69,7 +69,7 @@ import Numeric | |||
69 | import Text.PrettyPrint as PP hiding ((<>)) | 69 | import Text.PrettyPrint as PP hiding ((<>)) |
70 | import Text.PrettyPrint.Class | 70 | import Text.PrettyPrint.Class |
71 | 71 | ||
72 | import Data.Torrent.Piece | 72 | import Data.Torrent |
73 | 73 | ||
74 | {----------------------------------------------------------------------- | 74 | {----------------------------------------------------------------------- |
75 | -- Block attributes | 75 | -- Block attributes |
diff --git a/src/Network/BitTorrent/Exchange/Connection.hs b/src/Network/BitTorrent/Exchange/Connection.hs index fd9022da..2d5f39bf 100644 --- a/src/Network/BitTorrent/Exchange/Connection.hs +++ b/src/Network/BitTorrent/Exchange/Connection.hs | |||
@@ -112,6 +112,7 @@ import Control.Concurrent hiding (yield) | |||
112 | import Control.Exception | 112 | import Control.Exception |
113 | import Control.Monad.Reader | 113 | import Control.Monad.Reader |
114 | import Control.Monad.State | 114 | import Control.Monad.State |
115 | import Control.Monad.Trans.Resource | ||
115 | import Control.Lens | 116 | import Control.Lens |
116 | import Data.ByteString as BS | 117 | import Data.ByteString as BS |
117 | import Data.ByteString.Lazy as BSL | 118 | import Data.ByteString.Lazy as BSL |
@@ -135,10 +136,10 @@ import Text.Show.Functions () | |||
135 | import System.Log.FastLogger (ToLogStr(..)) | 136 | import System.Log.FastLogger (ToLogStr(..)) |
136 | import System.Timeout | 137 | import System.Timeout |
137 | 138 | ||
138 | import Data.Torrent.Bitfield as BF | 139 | import Data.Torrent |
139 | import Data.Torrent.InfoHash | 140 | import Network.BitTorrent.Address |
140 | import Network.BitTorrent.Core | 141 | import Network.BitTorrent.Exchange.Bitfield as BF |
141 | import Network.BitTorrent.Exchange.Message as Msg | 142 | import Network.BitTorrent.Exchange.Message as Msg |
142 | 143 | ||
143 | -- TODO handle port message? | 144 | -- TODO handle port message? |
144 | -- TODO handle limits? | 145 | -- TODO handle limits? |
diff --git a/src/Network/BitTorrent/Exchange/Download.hs b/src/Network/BitTorrent/Exchange/Download.hs new file mode 100644 index 00000000..9a6b5f91 --- /dev/null +++ b/src/Network/BitTorrent/Exchange/Download.hs | |||
@@ -0,0 +1,295 @@ | |||
1 | -- | | ||
2 | -- Copyright : (c) Sam Truzjan 2013 | ||
3 | -- License : BSD3 | ||
4 | -- Maintainer : pxqr.sta@gmail.com | ||
5 | -- Stability : experimental | ||
6 | -- Portability : portable | ||
7 | -- | ||
8 | -- | ||
9 | -- | ||
10 | {-# LANGUAGE FlexibleInstances #-} | ||
11 | {-# LANGUAGE MultiParamTypeClasses #-} | ||
12 | {-# LANGUAGE FunctionalDependencies #-} | ||
13 | {-# LANGUAGE TemplateHaskell #-} | ||
14 | module Network.BitTorrent.Exchange.Download | ||
15 | ( -- * Downloading | ||
16 | Download (..) | ||
17 | , Updates | ||
18 | , runDownloadUpdates | ||
19 | |||
20 | -- ** Metadata | ||
21 | -- $metadata-download | ||
22 | , MetadataDownload | ||
23 | , metadataDownload | ||
24 | |||
25 | -- ** Content | ||
26 | -- $content-download | ||
27 | , ContentDownload | ||
28 | , contentDownload | ||
29 | ) where | ||
30 | |||
31 | import Control.Applicative | ||
32 | import Control.Concurrent | ||
33 | import Control.Lens | ||
34 | import Control.Monad.State | ||
35 | import Data.BEncode as BE | ||
36 | import Data.ByteString as BS | ||
37 | import Data.ByteString.Lazy as BL | ||
38 | import Data.Default | ||
39 | import Data.List as L | ||
40 | import Data.Maybe | ||
41 | import Data.Map as M | ||
42 | import Data.Tuple | ||
43 | |||
44 | import Data.Torrent as Torrent | ||
45 | import Network.BitTorrent.Address | ||
46 | import Network.BitTorrent.Exchange.Bitfield as BF | ||
47 | import Network.BitTorrent.Exchange.Block as Block | ||
48 | import Network.BitTorrent.Exchange.Message as Msg | ||
49 | import System.Torrent.Storage (Storage, writePiece) | ||
50 | |||
51 | |||
52 | {----------------------------------------------------------------------- | ||
53 | -- Class | ||
54 | -----------------------------------------------------------------------} | ||
55 | |||
56 | type Updates s a = StateT s IO a | ||
57 | |||
58 | runDownloadUpdates :: MVar s -> Updates s a -> IO a | ||
59 | runDownloadUpdates var m = modifyMVar var (fmap swap . runStateT m) | ||
60 | |||
61 | class Download s chunk | s -> chunk where | ||
62 | scheduleBlocks :: Int -> PeerAddr IP -> Bitfield -> Updates s [BlockIx] | ||
63 | |||
64 | -- | | ||
65 | scheduleBlock :: PeerAddr IP -> Bitfield -> Updates s (Maybe BlockIx) | ||
66 | scheduleBlock addr bf = listToMaybe <$> scheduleBlocks 1 addr bf | ||
67 | |||
68 | -- | Get number of sent requests to this peer. | ||
69 | getRequestQueueLength :: PeerAddr IP -> Updates s Int | ||
70 | |||
71 | -- | Remove all pending block requests to the remote peer. May be used | ||
72 | -- when: | ||
73 | -- | ||
74 | -- * a peer closes connection; | ||
75 | -- | ||
76 | -- * remote peer choked this peer; | ||
77 | -- | ||
78 | -- * timeout expired. | ||
79 | -- | ||
80 | resetPending :: PeerAddr IP -> Updates s () | ||
81 | |||
82 | -- | MAY write to storage, if a new piece have been completed. | ||
83 | -- | ||
84 | -- You should check if a returned by peer block is actually have | ||
85 | -- been requested and in-flight. This is needed to avoid "I send | ||
86 | -- random corrupted block" attacks. | ||
87 | pushBlock :: PeerAddr IP -> chunk -> Updates s (Maybe Bool) | ||
88 | |||
89 | {----------------------------------------------------------------------- | ||
90 | -- Metadata download | ||
91 | -----------------------------------------------------------------------} | ||
92 | -- $metadata-download | ||
93 | -- TODO | ||
94 | |||
95 | data MetadataDownload = MetadataDownload | ||
96 | { _pendingPieces :: [(PeerAddr IP, PieceIx)] | ||
97 | , _bucket :: Bucket | ||
98 | , _topic :: InfoHash | ||
99 | } | ||
100 | |||
101 | makeLenses ''MetadataDownload | ||
102 | |||
103 | -- | Create a new scheduler for infodict of the given size. | ||
104 | metadataDownload :: Int -> InfoHash -> MetadataDownload | ||
105 | metadataDownload ps = MetadataDownload [] (Block.empty ps) | ||
106 | |||
107 | instance Default MetadataDownload where | ||
108 | def = error "instance Default MetadataDownload" | ||
109 | |||
110 | --cancelPending :: PieceIx -> Updates () | ||
111 | cancelPending pix = pendingPieces %= L.filter ((pix ==) . snd) | ||
112 | |||
113 | instance Download MetadataDownload (Piece BS.ByteString) where | ||
114 | scheduleBlock addr bf = do | ||
115 | bkt <- use bucket | ||
116 | case spans metadataPieceSize bkt of | ||
117 | [] -> return Nothing | ||
118 | ((off, _ ) : _) -> do | ||
119 | let pix = off `div` metadataPieceSize | ||
120 | pendingPieces %= ((addr, pix) :) | ||
121 | return (Just (BlockIx pix 0 metadataPieceSize)) | ||
122 | |||
123 | resetPending addr = pendingPieces %= L.filter ((addr ==) . fst) | ||
124 | |||
125 | pushBlock addr Torrent.Piece {..} = do | ||
126 | p <- use pendingPieces | ||
127 | when ((addr, pieceIndex) `L.notElem` p) $ | ||
128 | error "not requested" | ||
129 | cancelPending pieceIndex | ||
130 | |||
131 | bucket %= Block.insert (metadataPieceSize * pieceIndex) pieceData | ||
132 | b <- use bucket | ||
133 | case toPiece b of | ||
134 | Nothing -> return Nothing | ||
135 | Just chunks -> do | ||
136 | t <- use topic | ||
137 | case parseInfoDict (BL.toStrict chunks) t of | ||
138 | Right x -> do | ||
139 | pendingPieces .= [] | ||
140 | return undefined -- (Just x) | ||
141 | Left e -> do | ||
142 | pendingPieces .= [] | ||
143 | bucket .= Block.empty (Block.size b) | ||
144 | return undefined -- Nothing | ||
145 | where | ||
146 | -- todo use incremental parsing to avoid BS.concat call | ||
147 | parseInfoDict :: BS.ByteString -> InfoHash -> Result InfoDict | ||
148 | parseInfoDict chunk topic = | ||
149 | case BE.decode chunk of | ||
150 | Right (infodict @ InfoDict {..}) | ||
151 | | topic == idInfoHash -> return infodict | ||
152 | | otherwise -> Left "broken infodict" | ||
153 | Left err -> Left $ "unable to parse infodict " ++ err | ||
154 | |||
155 | {----------------------------------------------------------------------- | ||
156 | -- Content download | ||
157 | -----------------------------------------------------------------------} | ||
158 | -- $content-download | ||
159 | -- | ||
160 | -- A block can have one of the following status: | ||
161 | -- | ||
162 | -- 1) /not allowed/: Piece is not in download set. | ||
163 | -- | ||
164 | -- 2) /waiting/: (allowed?) Block have been allowed to download, | ||
165 | -- but /this/ peer did not send any 'Request' message for this | ||
166 | -- block. To allow some piece use | ||
167 | -- 'Network.BitTorrent.Exchange.Selector' and then 'allowedSet' | ||
168 | -- and 'allowPiece'. | ||
169 | -- | ||
170 | -- 3) /inflight/: (pending?) Block have been requested but | ||
171 | -- /remote/ peer did not send any 'Piece' message for this block. | ||
172 | -- Related functions 'markInflight' | ||
173 | -- | ||
174 | -- 4) /pending/: (stalled?) Block have have been downloaded | ||
175 | -- Related functions 'insertBlock'. | ||
176 | -- | ||
177 | -- Piece status: | ||
178 | -- | ||
179 | -- 1) /assembled/: (downloaded?) All blocks in piece have been | ||
180 | -- downloaded but the piece did not verified yet. | ||
181 | -- | ||
182 | -- * Valid: go to completed; | ||
183 | -- | ||
184 | -- * Invalid: go to waiting. | ||
185 | -- | ||
186 | -- 2) /corrupted/: | ||
187 | -- | ||
188 | -- 3) /downloaded/: (verified?) A piece have been successfully | ||
189 | -- verified via the hash. Usually the piece should be stored to | ||
190 | -- the 'System.Torrent.Storage' and /this/ peer should send 'Have' | ||
191 | -- messages to the /remote/ peers. | ||
192 | -- | ||
193 | |||
194 | data PieceEntry = PieceEntry | ||
195 | { pending :: [(PeerAddr IP, BlockIx)] | ||
196 | , stalled :: Bucket | ||
197 | } | ||
198 | |||
199 | pieceEntry :: PieceSize -> PieceEntry | ||
200 | pieceEntry s = PieceEntry [] (Block.empty s) | ||
201 | |||
202 | isEmpty :: PieceEntry -> Bool | ||
203 | isEmpty PieceEntry {..} = L.null pending && Block.null stalled | ||
204 | |||
205 | _holes :: PieceIx -> PieceEntry -> [BlockIx] | ||
206 | _holes pix PieceEntry {..} = fmap mkBlockIx (spans defaultTransferSize stalled) | ||
207 | where | ||
208 | mkBlockIx (off, sz) = BlockIx pix off sz | ||
209 | |||
210 | data ContentDownload = ContentDownload | ||
211 | { inprogress :: !(Map PieceIx PieceEntry) | ||
212 | , bitfield :: !Bitfield | ||
213 | , pieceSize :: !PieceSize | ||
214 | , contentStorage :: Storage | ||
215 | } | ||
216 | |||
217 | contentDownload :: Bitfield -> PieceSize -> Storage -> ContentDownload | ||
218 | contentDownload = ContentDownload M.empty | ||
219 | |||
220 | --modifyEntry :: PieceIx -> (PieceEntry -> PieceEntry) -> DownloadUpdates () | ||
221 | modifyEntry pix f = modify $ \ s @ ContentDownload {..} -> s | ||
222 | { inprogress = alter (g pieceSize) pix inprogress } | ||
223 | where | ||
224 | g s = h . f . fromMaybe (pieceEntry s) | ||
225 | h e | ||
226 | | isEmpty e = Nothing | ||
227 | | otherwise = Just e | ||
228 | |||
229 | instance Download ContentDownload (Block BL.ByteString) where | ||
230 | scheduleBlocks n addr maskBF = do | ||
231 | ContentDownload {..} <- get | ||
232 | let wantPieces = maskBF `BF.difference` bitfield | ||
233 | let wantBlocks = L.concat $ M.elems $ M.mapWithKey _holes $ | ||
234 | M.filterWithKey (\ pix _ -> pix `BF.member` wantPieces) | ||
235 | inprogress | ||
236 | |||
237 | bixs <- if L.null wantBlocks | ||
238 | then do | ||
239 | mpix <- choosePiece wantPieces | ||
240 | case mpix of -- TODO return 'n' blocks | ||
241 | Nothing -> return [] | ||
242 | Just pix -> return [leadingBlock pix defaultTransferSize] | ||
243 | else chooseBlocks wantBlocks n | ||
244 | |||
245 | forM_ bixs $ \ bix -> do | ||
246 | modifyEntry (ixPiece bix) $ \ e @ PieceEntry {..} -> e | ||
247 | { pending = (addr, bix) : pending } | ||
248 | |||
249 | return bixs | ||
250 | where | ||
251 | -- TODO choose block nearest to pending or stalled sets to reduce disk | ||
252 | -- seeks on remote machines | ||
253 | --chooseBlocks :: [BlockIx] -> Int -> DownloadUpdates [BlockIx] | ||
254 | chooseBlocks xs n = return (L.take n xs) | ||
255 | |||
256 | -- TODO use selection strategies from Exchange.Selector | ||
257 | --choosePiece :: Bitfield -> DownloadUpdates (Maybe PieceIx) | ||
258 | choosePiece bf | ||
259 | | BF.null bf = return $ Nothing | ||
260 | | otherwise = return $ Just $ BF.findMin bf | ||
261 | |||
262 | getRequestQueueLength addr = do | ||
263 | m <- gets (M.map (L.filter ((==) addr . fst) . pending) . inprogress) | ||
264 | return $ L.sum $ L.map L.length $ M.elems m | ||
265 | |||
266 | resetPending addr = modify $ \ s -> s { inprogress = reset (inprogress s) } | ||
267 | where | ||
268 | reset = fmap $ \ e -> e | ||
269 | { pending = L.filter (not . (==) addr . fst) (pending e) } | ||
270 | |||
271 | pushBlock addr blk @ Block {..} = do | ||
272 | mpe <- gets (M.lookup blkPiece . inprogress) | ||
273 | case mpe of | ||
274 | Nothing -> return Nothing | ||
275 | Just (pe @ PieceEntry {..}) | ||
276 | | blockIx blk `L.notElem` fmap snd pending -> return Nothing | ||
277 | | otherwise -> do | ||
278 | let bkt' = Block.insertLazy blkOffset blkData stalled | ||
279 | case toPiece bkt' of | ||
280 | Nothing -> do | ||
281 | modifyEntry blkPiece $ \ e @ PieceEntry {..} -> e | ||
282 | { pending = L.filter ((==) (blockIx blk) . snd) pending | ||
283 | , stalled = bkt' | ||
284 | } | ||
285 | return (Just False) | ||
286 | |||
287 | Just pieceData -> do | ||
288 | -- TODO verify | ||
289 | storage <- gets contentStorage | ||
290 | liftIO $ writePiece (Torrent.Piece blkPiece pieceData) storage | ||
291 | modify $ \ s @ ContentDownload {..} -> s | ||
292 | { inprogress = M.delete blkPiece inprogress | ||
293 | , bitfield = BF.insert blkPiece bitfield | ||
294 | } | ||
295 | return (Just True) | ||
diff --git a/src/Network/BitTorrent/Exchange/Manager.hs b/src/Network/BitTorrent/Exchange/Manager.hs index b9aaa818..54727805 100644 --- a/src/Network/BitTorrent/Exchange/Manager.hs +++ b/src/Network/BitTorrent/Exchange/Manager.hs | |||
@@ -12,8 +12,8 @@ import Control.Monad | |||
12 | import Data.Default | 12 | import Data.Default |
13 | import Network.Socket | 13 | import Network.Socket |
14 | 14 | ||
15 | import Data.Torrent.InfoHash | 15 | import Data.Torrent |
16 | import Network.BitTorrent.Core | 16 | import Network.BitTorrent.Address |
17 | import Network.BitTorrent.Exchange.Connection hiding (Options) | 17 | import Network.BitTorrent.Exchange.Connection hiding (Options) |
18 | import Network.BitTorrent.Exchange.Session | 18 | import Network.BitTorrent.Exchange.Session |
19 | 19 | ||
diff --git a/src/Network/BitTorrent/Exchange/Message.hs b/src/Network/BitTorrent/Exchange/Message.hs index d8873f95..f8b76186 100644 --- a/src/Network/BitTorrent/Exchange/Message.hs +++ b/src/Network/BitTorrent/Exchange/Message.hs | |||
@@ -117,10 +117,10 @@ import Network.Socket hiding (KeepAlive) | |||
117 | import Text.PrettyPrint as PP hiding ((<>)) | 117 | import Text.PrettyPrint as PP hiding ((<>)) |
118 | import Text.PrettyPrint.Class | 118 | import Text.PrettyPrint.Class |
119 | 119 | ||
120 | import Data.Torrent.Bitfield | 120 | import Data.Torrent hiding (Piece (..)) |
121 | import Data.Torrent.InfoHash | 121 | import qualified Data.Torrent as P (Piece (..)) |
122 | import qualified Data.Torrent.Piece as P | 122 | import Network.BitTorrent.Address |
123 | import Network.BitTorrent.Core | 123 | import Network.BitTorrent.Exchange.Bitfield |
124 | import Network.BitTorrent.Exchange.Block | 124 | import Network.BitTorrent.Exchange.Block |
125 | 125 | ||
126 | {----------------------------------------------------------------------- | 126 | {----------------------------------------------------------------------- |
@@ -864,7 +864,7 @@ instance PeerMessage ExtendedMetadata where | |||
864 | 864 | ||
865 | -- | All 'Piece's in 'MetadataData' messages MUST have size equal to | 865 | -- | All 'Piece's in 'MetadataData' messages MUST have size equal to |
866 | -- this value. The last trailing piece can be shorter. | 866 | -- this value. The last trailing piece can be shorter. |
867 | metadataPieceSize :: P.PieceSize | 867 | metadataPieceSize :: PieceSize |
868 | metadataPieceSize = 16 * 1024 | 868 | metadataPieceSize = 16 * 1024 |
869 | 869 | ||
870 | isLastPiece :: P.Piece a -> Int -> Bool | 870 | isLastPiece :: P.Piece a -> Int -> Bool |
@@ -877,8 +877,8 @@ isLastPiece P.Piece {..} total = succ pieceIndex == pcnt | |||
877 | -- length; otherwise serialization MUST fail. | 877 | -- length; otherwise serialization MUST fail. |
878 | isValidPiece :: P.Piece BL.ByteString -> Int -> Bool | 878 | isValidPiece :: P.Piece BL.ByteString -> Int -> Bool |
879 | isValidPiece p @ P.Piece {..} total | 879 | isValidPiece p @ P.Piece {..} total |
880 | | isLastPiece p total = P.pieceSize p <= metadataPieceSize | 880 | | isLastPiece p total = pieceSize p <= metadataPieceSize |
881 | | otherwise = P.pieceSize p == metadataPieceSize | 881 | | otherwise = pieceSize p == metadataPieceSize |
882 | 882 | ||
883 | setMetadataPayload :: BS.ByteString -> ExtendedMetadata -> ExtendedMetadata | 883 | setMetadataPayload :: BS.ByteString -> ExtendedMetadata -> ExtendedMetadata |
884 | setMetadataPayload bs (MetadataData (P.Piece pix _) t) = | 884 | setMetadataPayload bs (MetadataData (P.Piece pix _) t) = |
diff --git a/src/Network/BitTorrent/Exchange/Selection.hs b/src/Network/BitTorrent/Exchange/Selection.hs deleted file mode 100644 index 2724fabc..00000000 --- a/src/Network/BitTorrent/Exchange/Selection.hs +++ /dev/null | |||
@@ -1,85 +0,0 @@ | |||
1 | -- | | ||
2 | -- Copyright : (c) Sam Truzjan 2013 | ||
3 | -- License : BSD3 | ||
4 | -- Maintainer : pxqr.sta@gmail.com | ||
5 | -- Stability : experimental | ||
6 | -- Portability : portable | ||
7 | -- | ||
8 | -- Piece selection algorithms. | ||
9 | -- | ||
10 | module Network.BitTorrent.Exchange.Selection | ||
11 | ( -- * Selection | ||
12 | Selector | ||
13 | , selector | ||
14 | , strategyClass | ||
15 | |||
16 | , strictFirst | ||
17 | , strictLast | ||
18 | , rarestFirst | ||
19 | , randomFirst | ||
20 | , endGame | ||
21 | ) where | ||
22 | |||
23 | import Data.Ratio | ||
24 | |||
25 | import Data.Torrent.Bitfield | ||
26 | |||
27 | |||
28 | type Selector = Bitfield -- ^ Indices of client /have/ pieces. | ||
29 | -> Bitfield -- ^ Indices of peer /have/ pieces. | ||
30 | -> [Bitfield] -- ^ Indices of other peers /have/ pieces. | ||
31 | -> Maybe PieceIx -- ^ Zero-based index of piece to request | ||
32 | -- to, if any. | ||
33 | |||
34 | selector :: Selector -- ^ Selector to use at the start. | ||
35 | -> Ratio PieceCount | ||
36 | -> Selector -- ^ Selector to use after the client have | ||
37 | -- the C pieces. | ||
38 | -> Selector -- ^ Selector that changes behaviour based | ||
39 | -- on completeness. | ||
40 | selector start pt ready h a xs = | ||
41 | case strategyClass pt h of | ||
42 | SCBeginning -> start h a xs | ||
43 | SCReady -> ready h a xs | ||
44 | SCEnd -> endGame h a xs | ||
45 | |||
46 | data StartegyClass | ||
47 | = SCBeginning | ||
48 | | SCReady | ||
49 | | SCEnd | ||
50 | deriving (Show, Eq, Ord, Enum, Bounded) | ||
51 | |||
52 | |||
53 | strategyClass :: Ratio PieceCount -> Bitfield -> StartegyClass | ||
54 | strategyClass threshold = classify . completeness | ||
55 | where | ||
56 | classify c | ||
57 | | c < threshold = SCBeginning | ||
58 | | c + 1 % numerator c < 1 = SCReady | ||
59 | -- FIXME numerator have is not total count | ||
60 | | otherwise = SCEnd | ||
61 | |||
62 | |||
63 | -- | Select the first available piece. | ||
64 | strictFirst :: Selector | ||
65 | strictFirst h a _ = Just $ findMin (difference a h) | ||
66 | |||
67 | -- | Select the last available piece. | ||
68 | strictLast :: Selector | ||
69 | strictLast h a _ = Just $ findMax (difference a h) | ||
70 | |||
71 | -- | | ||
72 | rarestFirst :: Selector | ||
73 | rarestFirst h a xs = rarest (map (intersection want) xs) | ||
74 | where | ||
75 | want = difference h a | ||
76 | |||
77 | -- | In average random first is faster than rarest first strategy but | ||
78 | -- only if all pieces are available. | ||
79 | randomFirst :: Selector | ||
80 | randomFirst = do | ||
81 | -- randomIO | ||
82 | error "randomFirst" | ||
83 | |||
84 | endGame :: Selector | ||
85 | endGame = strictLast | ||
diff --git a/src/Network/BitTorrent/Exchange/Session.hs b/src/Network/BitTorrent/Exchange/Session.hs index 6f480ce4..30b7ed0e 100644 --- a/src/Network/BitTorrent/Exchange/Session.hs +++ b/src/Network/BitTorrent/Exchange/Session.hs | |||
@@ -45,18 +45,14 @@ import Text.PrettyPrint.Class | |||
45 | import System.Log.FastLogger (LogStr, ToLogStr (..)) | 45 | import System.Log.FastLogger (LogStr, ToLogStr (..)) |
46 | 46 | ||
47 | import Data.BEncode as BE | 47 | import Data.BEncode as BE |
48 | import Data.Torrent (InfoDict (..)) | 48 | import Data.Torrent as Torrent |
49 | import Data.Torrent.Bitfield as BF | ||
50 | import Data.Torrent.InfoHash | ||
51 | import Data.Torrent.Piece | ||
52 | import qualified Data.Torrent.Piece as Torrent (Piece ()) | ||
53 | import Network.BitTorrent.Internal.Types | 49 | import Network.BitTorrent.Internal.Types |
54 | import Network.BitTorrent.Core | 50 | import Network.BitTorrent.Address |
51 | import Network.BitTorrent.Exchange.Bitfield as BF | ||
55 | import Network.BitTorrent.Exchange.Block as Block | 52 | import Network.BitTorrent.Exchange.Block as Block |
56 | import Network.BitTorrent.Exchange.Connection | 53 | import Network.BitTorrent.Exchange.Connection |
54 | import Network.BitTorrent.Exchange.Download as D | ||
57 | import Network.BitTorrent.Exchange.Message as Message | 55 | import Network.BitTorrent.Exchange.Message as Message |
58 | import Network.BitTorrent.Exchange.Session.Metadata as Metadata | ||
59 | import Network.BitTorrent.Exchange.Session.Status as SS | ||
60 | import System.Torrent.Storage | 56 | import System.Torrent.Storage |
61 | 57 | ||
62 | {----------------------------------------------------------------------- | 58 | {----------------------------------------------------------------------- |
@@ -93,13 +89,13 @@ type LogFun = Loc -> LogSource -> LogLevel -> LogStr -> IO () | |||
93 | 89 | ||
94 | data SessionState | 90 | data SessionState |
95 | = WaitingMetadata | 91 | = WaitingMetadata |
96 | { metadataDownload :: MVar Metadata.Status | 92 | { metadataDownload :: MVar MetadataDownload |
97 | , metadataCompleted :: MVar InfoDict -- ^ used to unblock waiters | 93 | , metadataCompleted :: MVar InfoDict -- ^ used to unblock waiters |
98 | , contentRootPath :: FilePath | 94 | , contentRootPath :: FilePath |
99 | } | 95 | } |
100 | | HavingMetadata | 96 | | HavingMetadata |
101 | { metadataCache :: Cached InfoDict | 97 | { metadataCache :: Cached InfoDict |
102 | , contentDownload :: MVar SessionStatus | 98 | , contentDownload :: MVar ContentDownload |
103 | , contentStorage :: Storage | 99 | , contentStorage :: Storage |
104 | } | 100 | } |
105 | 101 | ||
@@ -108,8 +104,9 @@ newSessionState rootPath (Left ih ) = do | |||
108 | WaitingMetadata <$> newMVar def <*> newEmptyMVar <*> pure rootPath | 104 | WaitingMetadata <$> newMVar def <*> newEmptyMVar <*> pure rootPath |
109 | newSessionState rootPath (Right dict) = do | 105 | newSessionState rootPath (Right dict) = do |
110 | storage <- openInfoDict ReadWriteEx rootPath dict | 106 | storage <- openInfoDict ReadWriteEx rootPath dict |
111 | download <- newMVar $ sessionStatus (BF.haveNone (totalPieces storage)) | 107 | download <- newMVar $ D.contentDownload (BF.haveNone (totalPieces storage)) |
112 | (piPieceLength (idPieceInfo dict)) | 108 | (piPieceLength (idPieceInfo dict)) |
109 | storage | ||
113 | return $ HavingMetadata (cache dict) download storage | 110 | return $ HavingMetadata (cache dict) download storage |
114 | 111 | ||
115 | closeSessionState :: SessionState -> IO () | 112 | closeSessionState :: SessionState -> IO () |
@@ -119,8 +116,9 @@ closeSessionState HavingMetadata {..} = close contentStorage | |||
119 | haveMetadata :: InfoDict -> SessionState -> IO SessionState | 116 | haveMetadata :: InfoDict -> SessionState -> IO SessionState |
120 | haveMetadata dict WaitingMetadata {..} = do | 117 | haveMetadata dict WaitingMetadata {..} = do |
121 | storage <- openInfoDict ReadWriteEx contentRootPath dict | 118 | storage <- openInfoDict ReadWriteEx contentRootPath dict |
122 | download <- newMVar $ sessionStatus (BF.haveNone (totalPieces storage)) | 119 | download <- newMVar $ D.contentDownload (BF.haveNone (totalPieces storage)) |
123 | (piPieceLength (idPieceInfo dict)) | 120 | (piPieceLength (idPieceInfo dict)) |
121 | storage | ||
124 | return HavingMetadata | 122 | return HavingMetadata |
125 | { metadataCache = cache dict | 123 | { metadataCache = cache dict |
126 | , contentDownload = download | 124 | , contentDownload = download |
diff --git a/src/Network/BitTorrent/Exchange/Session/Metadata.hs b/src/Network/BitTorrent/Exchange/Session/Metadata.hs deleted file mode 100644 index 79156e2e..00000000 --- a/src/Network/BitTorrent/Exchange/Session/Metadata.hs +++ /dev/null | |||
@@ -1,104 +0,0 @@ | |||
1 | {-# LANGUAGE TemplateHaskell #-} | ||
2 | module Network.BitTorrent.Exchange.Session.Metadata | ||
3 | ( -- * Transfer state | ||
4 | Status | ||
5 | , nullStatus | ||
6 | |||
7 | -- * State updates | ||
8 | , Updates | ||
9 | , runUpdates | ||
10 | |||
11 | -- * Piece transfer control | ||
12 | , scheduleBlock | ||
13 | , resetPending | ||
14 | , cancelPending | ||
15 | , pushBlock | ||
16 | ) where | ||
17 | |||
18 | import Control.Concurrent | ||
19 | import Control.Lens | ||
20 | import Control.Monad.Reader | ||
21 | import Control.Monad.State | ||
22 | import Data.ByteString as BS | ||
23 | import Data.ByteString.Lazy as BL | ||
24 | import Data.Default | ||
25 | import Data.List as L | ||
26 | import Data.Tuple | ||
27 | |||
28 | import Data.BEncode as BE | ||
29 | import Data.Torrent | ||
30 | import Data.Torrent.InfoHash | ||
31 | import Data.Torrent.Piece as Torrent | ||
32 | import Network.BitTorrent.Core | ||
33 | import Network.BitTorrent.Exchange.Block as Block | ||
34 | import Network.BitTorrent.Exchange.Message as Message hiding (Status) | ||
35 | |||
36 | |||
37 | -- | Current transfer status. | ||
38 | data Status = Status | ||
39 | { _pending :: [(PeerAddr IP, PieceIx)] | ||
40 | , _bucket :: Bucket | ||
41 | } | ||
42 | |||
43 | makeLenses ''Status | ||
44 | |||
45 | instance Default Status where | ||
46 | def = error "default status" | ||
47 | |||
48 | -- | Create a new scheduler for infodict of the given size. | ||
49 | nullStatus :: Int -> Status | ||
50 | nullStatus ps = Status [] (Block.empty ps) | ||
51 | |||
52 | type Updates = ReaderT (PeerAddr IP) (State Status) | ||
53 | |||
54 | runUpdates :: MVar Status -> PeerAddr IP -> Updates a -> IO a | ||
55 | runUpdates v a m = modifyMVar v (return . swap . runState (runReaderT m a)) | ||
56 | |||
57 | scheduleBlock :: Updates (Maybe PieceIx) | ||
58 | scheduleBlock = do | ||
59 | addr <- ask | ||
60 | bkt <- use bucket | ||
61 | case spans metadataPieceSize bkt of | ||
62 | [] -> return Nothing | ||
63 | ((off, _ ) : _) -> do | ||
64 | let pix = off `div` metadataPieceSize | ||
65 | pending %= ((addr, pix) :) | ||
66 | return (Just pix) | ||
67 | |||
68 | cancelPending :: PieceIx -> Updates () | ||
69 | cancelPending pix = pending %= L.filter ((pix ==) . snd) | ||
70 | |||
71 | resetPending :: Updates () | ||
72 | resetPending = do | ||
73 | addr <- ask | ||
74 | pending %= L.filter ((addr ==) . fst) | ||
75 | |||
76 | parseInfoDict :: BS.ByteString -> InfoHash -> Result InfoDict | ||
77 | parseInfoDict chunk topic = | ||
78 | case BE.decode chunk of | ||
79 | Right (infodict @ InfoDict {..}) | ||
80 | | topic == idInfoHash -> return infodict | ||
81 | | otherwise -> Left "broken infodict" | ||
82 | Left err -> Left $ "unable to parse infodict " ++ err | ||
83 | |||
84 | -- todo use incremental parsing to avoid BS.concat call | ||
85 | pushBlock :: Torrent.Piece BS.ByteString -> InfoHash -> Updates (Maybe InfoDict) | ||
86 | pushBlock Torrent.Piece {..} topic = do | ||
87 | addr <- ask | ||
88 | p <- use pending | ||
89 | when ((addr, pieceIndex) `L.notElem` p) $ error "not requested" | ||
90 | cancelPending pieceIndex | ||
91 | |||
92 | bucket %= Block.insert (metadataPieceSize * pieceIndex) pieceData | ||
93 | b <- use bucket | ||
94 | case toPiece b of | ||
95 | Nothing -> return Nothing | ||
96 | Just chunks -> | ||
97 | case parseInfoDict (BL.toStrict chunks) topic of | ||
98 | Right x -> do | ||
99 | pending .= [] | ||
100 | return (Just x) | ||
101 | Left e -> do | ||
102 | pending .= [] | ||
103 | bucket .= Block.empty (Block.size b) | ||
104 | return Nothing | ||
diff --git a/src/Network/BitTorrent/Exchange/Session/Status.hs b/src/Network/BitTorrent/Exchange/Session/Status.hs deleted file mode 100644 index 565c3bf3..00000000 --- a/src/Network/BitTorrent/Exchange/Session/Status.hs +++ /dev/null | |||
@@ -1,175 +0,0 @@ | |||
1 | module Network.BitTorrent.Exchange.Session.Status | ||
2 | ( -- * Environment | ||
3 | StatusUpdates | ||
4 | , runStatusUpdates | ||
5 | |||
6 | -- * Status | ||
7 | , SessionStatus | ||
8 | , sessionStatus | ||
9 | |||
10 | -- * Query | ||
11 | , getBitfield | ||
12 | , getRequestQueueLength | ||
13 | |||
14 | -- * Control | ||
15 | , scheduleBlocks | ||
16 | , resetPending | ||
17 | , pushBlock | ||
18 | ) where | ||
19 | |||
20 | import Control.Applicative | ||
21 | import Control.Concurrent | ||
22 | import Control.Monad.State | ||
23 | import Data.ByteString.Lazy as BL | ||
24 | import Data.Default | ||
25 | import Data.List as L | ||
26 | import Data.Maybe | ||
27 | import Data.Map as M | ||
28 | import Data.Set as S | ||
29 | import Data.Tuple | ||
30 | |||
31 | import Data.Torrent.Piece | ||
32 | import Data.Torrent.Bitfield as BF | ||
33 | import Network.BitTorrent.Core | ||
34 | import Network.BitTorrent.Exchange.Block as Block | ||
35 | import System.Torrent.Storage (Storage, writePiece) | ||
36 | |||
37 | |||
38 | {----------------------------------------------------------------------- | ||
39 | -- Piece entry | ||
40 | -----------------------------------------------------------------------} | ||
41 | |||
42 | data PieceEntry = PieceEntry | ||
43 | { pending :: [(PeerAddr IP, BlockIx)] | ||
44 | , stalled :: Bucket | ||
45 | } | ||
46 | |||
47 | pieceEntry :: PieceSize -> PieceEntry | ||
48 | pieceEntry s = PieceEntry [] (Block.empty s) | ||
49 | |||
50 | isEmpty :: PieceEntry -> Bool | ||
51 | isEmpty PieceEntry {..} = L.null pending && Block.null stalled | ||
52 | |||
53 | holes :: PieceIx -> PieceEntry -> [BlockIx] | ||
54 | holes pix PieceEntry {..} = fmap mkBlockIx (spans defaultTransferSize stalled) | ||
55 | where | ||
56 | mkBlockIx (off, sz) = BlockIx pix off sz | ||
57 | |||
58 | {----------------------------------------------------------------------- | ||
59 | -- Session status | ||
60 | -----------------------------------------------------------------------} | ||
61 | |||
62 | data SessionStatus = SessionStatus | ||
63 | { inprogress :: !(Map PieceIx PieceEntry) | ||
64 | , bitfield :: !Bitfield | ||
65 | , pieceSize :: !PieceSize | ||
66 | } | ||
67 | |||
68 | sessionStatus :: Bitfield -> PieceSize -> SessionStatus | ||
69 | sessionStatus bf ps = SessionStatus | ||
70 | { inprogress = M.empty | ||
71 | , bitfield = bf | ||
72 | , pieceSize = ps | ||
73 | } | ||
74 | |||
75 | type StatusUpdates a = StateT SessionStatus IO a | ||
76 | |||
77 | -- | | ||
78 | runStatusUpdates :: MVar SessionStatus -> StatusUpdates a -> IO a | ||
79 | runStatusUpdates var m = modifyMVar var (fmap swap . runStateT m) | ||
80 | |||
81 | getBitfield :: MVar SessionStatus -> IO Bitfield | ||
82 | getBitfield var = bitfield <$> readMVar var | ||
83 | |||
84 | getRequestQueueLength :: PeerAddr IP -> StatusUpdates Int | ||
85 | getRequestQueueLength addr = do | ||
86 | m <- gets (M.elems . M.map (L.filter ((==) addr . fst) . pending) . inprogress) | ||
87 | return $ L.sum $ L.map L.length m | ||
88 | |||
89 | modifyEntry :: PieceIx -> (PieceEntry -> PieceEntry) -> StatusUpdates () | ||
90 | modifyEntry pix f = modify $ \ s @ SessionStatus {..} -> s | ||
91 | { inprogress = alter (g pieceSize) pix inprogress } | ||
92 | where | ||
93 | g s = h . f . fromMaybe (pieceEntry s) | ||
94 | h e | ||
95 | | isEmpty e = Nothing | ||
96 | | otherwise = Just e | ||
97 | |||
98 | {----------------------------------------------------------------------- | ||
99 | -- Piece download | ||
100 | -----------------------------------------------------------------------} | ||
101 | |||
102 | -- TODO choose block nearest to pending or stalled sets to reduce disk | ||
103 | -- seeks on remote machines | ||
104 | chooseBlocks :: [BlockIx] -> Int -> StatusUpdates [BlockIx] | ||
105 | chooseBlocks xs n = return (L.take n xs) | ||
106 | |||
107 | -- TODO use selection strategies from Exchange.Selector | ||
108 | choosePiece :: Bitfield -> StatusUpdates (Maybe PieceIx) | ||
109 | choosePiece bf | ||
110 | | BF.null bf = return $ Nothing | ||
111 | | otherwise = return $ Just $ BF.findMin bf | ||
112 | |||
113 | scheduleBlocks :: PeerAddr IP -> Bitfield -> Int -> StatusUpdates [BlockIx] | ||
114 | scheduleBlocks addr maskBF n = do | ||
115 | SessionStatus {..} <- get | ||
116 | let wantPieces = maskBF `BF.difference` bitfield | ||
117 | let wantBlocks = L.concat $ M.elems $ M.mapWithKey holes $ | ||
118 | M.filterWithKey (\ pix _ -> pix `BF.member` wantPieces) inprogress | ||
119 | |||
120 | bixs <- if L.null wantBlocks | ||
121 | then do | ||
122 | mpix <- choosePiece wantPieces | ||
123 | case mpix of -- TODO return 'n' blocks | ||
124 | Nothing -> return [] | ||
125 | Just pix -> return [leadingBlock pix defaultTransferSize] | ||
126 | else chooseBlocks wantBlocks n | ||
127 | |||
128 | forM_ bixs $ \ bix -> do | ||
129 | modifyEntry (ixPiece bix) $ \ e @ PieceEntry {..} -> e | ||
130 | { pending = (addr, bix) : pending } | ||
131 | |||
132 | return bixs | ||
133 | |||
134 | |||
135 | -- | Remove all pending block requests to the remote peer. May be used | ||
136 | -- when: | ||
137 | -- | ||
138 | -- * a peer closes connection; | ||
139 | -- | ||
140 | -- * remote peer choked this peer; | ||
141 | -- | ||
142 | -- * timeout expired. | ||
143 | -- | ||
144 | resetPending :: PeerAddr IP -> StatusUpdates () | ||
145 | resetPending addr = modify $ \ s -> s { inprogress = reset (inprogress s) } | ||
146 | where | ||
147 | reset = fmap $ \ e -> e | ||
148 | { pending = L.filter (not . (==) addr . fst) (pending e) } | ||
149 | |||
150 | -- | MAY write to storage, if a new piece have been completed. | ||
151 | pushBlock :: Block BL.ByteString -> Storage -> StatusUpdates (Maybe Bool) | ||
152 | pushBlock blk @ Block {..} storage = do | ||
153 | mpe <- gets (M.lookup blkPiece . inprogress) | ||
154 | case mpe of | ||
155 | Nothing -> return Nothing | ||
156 | Just (pe @ PieceEntry {..}) | ||
157 | | blockIx blk `L.notElem` fmap snd pending -> return Nothing | ||
158 | | otherwise -> do | ||
159 | let bkt' = Block.insertLazy blkOffset blkData stalled | ||
160 | case toPiece bkt' of | ||
161 | Nothing -> do | ||
162 | modifyEntry blkPiece $ \ e @ PieceEntry {..} -> e | ||
163 | { pending = L.filter ((==) (blockIx blk) . snd) pending | ||
164 | , stalled = bkt' | ||
165 | } | ||
166 | return (Just False) | ||
167 | |||
168 | Just pieceData -> do | ||
169 | -- TODO verify | ||
170 | liftIO $ writePiece (Piece blkPiece pieceData) storage | ||
171 | modify $ \ s @ SessionStatus {..} -> s | ||
172 | { inprogress = M.delete blkPiece inprogress | ||
173 | , bitfield = BF.insert blkPiece bitfield | ||
174 | } | ||
175 | return (Just True) | ||
diff --git a/src/Network/BitTorrent/Internal/Progress.hs b/src/Network/BitTorrent/Internal/Progress.hs new file mode 100644 index 00000000..9aff9935 --- /dev/null +++ b/src/Network/BitTorrent/Internal/Progress.hs | |||
@@ -0,0 +1,154 @@ | |||
1 | -- | | ||
2 | -- Copyright : (c) Sam Truzjan 2013 | ||
3 | -- License : BSD3 | ||
4 | -- Maintainer : pxqr.sta@gmail.com | ||
5 | -- Stability : experimental | ||
6 | -- Portability : portable | ||
7 | -- | ||
8 | -- 'Progress' used to track amount downloaded\/left\/upload bytes | ||
9 | -- either on per client or per torrent basis. This value is used to | ||
10 | -- notify the tracker and usually shown to the user. To aggregate | ||
11 | -- total progress you can use the Monoid instance. | ||
12 | -- | ||
13 | {-# LANGUAGE TemplateHaskell #-} | ||
14 | {-# LANGUAGE ViewPatterns #-} | ||
15 | {-# OPTIONS -fno-warn-orphans #-} | ||
16 | module Network.BitTorrent.Internal.Progress | ||
17 | ( -- * Progress | ||
18 | Progress (..) | ||
19 | |||
20 | -- * Lens | ||
21 | , left | ||
22 | , uploaded | ||
23 | , downloaded | ||
24 | |||
25 | -- * Construction | ||
26 | , startProgress | ||
27 | , downloadedProgress | ||
28 | , enqueuedProgress | ||
29 | , uploadedProgress | ||
30 | , dequeuedProgress | ||
31 | |||
32 | -- * Query | ||
33 | , canDownload | ||
34 | , canUpload | ||
35 | ) where | ||
36 | |||
37 | import Control.Applicative | ||
38 | import Control.Lens hiding ((%=)) | ||
39 | import Data.ByteString.Lazy.Builder as BS | ||
40 | import Data.ByteString.Lazy.Builder.ASCII as BS | ||
41 | import Data.Default | ||
42 | import Data.Monoid | ||
43 | import Data.Serialize as S | ||
44 | import Data.Ratio | ||
45 | import Data.Word | ||
46 | import Network.HTTP.Types.QueryLike | ||
47 | import Text.PrettyPrint as PP | ||
48 | import Text.PrettyPrint.Class | ||
49 | |||
50 | |||
51 | -- | Progress data is considered as dynamic within one client | ||
52 | -- session. This data also should be shared across client application | ||
53 | -- sessions (e.g. files), otherwise use 'startProgress' to get initial | ||
54 | -- 'Progress' value. | ||
55 | -- | ||
56 | data Progress = Progress | ||
57 | { _downloaded :: {-# UNPACK #-} !Word64 -- ^ Total amount of bytes downloaded; | ||
58 | , _left :: {-# UNPACK #-} !Word64 -- ^ Total amount of bytes left; | ||
59 | , _uploaded :: {-# UNPACK #-} !Word64 -- ^ Total amount of bytes uploaded. | ||
60 | } deriving (Show, Read, Eq) | ||
61 | |||
62 | $(makeLenses ''Progress) | ||
63 | |||
64 | -- | UDP tracker compatible encoding. | ||
65 | instance Serialize Progress where | ||
66 | put Progress {..} = do | ||
67 | putWord64be $ fromIntegral _downloaded | ||
68 | putWord64be $ fromIntegral _left | ||
69 | putWord64be $ fromIntegral _uploaded | ||
70 | |||
71 | get = Progress | ||
72 | <$> (fromIntegral <$> getWord64be) | ||
73 | <*> (fromIntegral <$> getWord64be) | ||
74 | <*> (fromIntegral <$> getWord64be) | ||
75 | |||
76 | instance Default Progress where | ||
77 | def = Progress 0 0 0 | ||
78 | {-# INLINE def #-} | ||
79 | |||
80 | -- | Can be used to aggregate total progress. | ||
81 | instance Monoid Progress where | ||
82 | mempty = def | ||
83 | {-# INLINE mempty #-} | ||
84 | |||
85 | mappend (Progress da la ua) (Progress db lb ub) = Progress | ||
86 | { _downloaded = da + db | ||
87 | , _left = la + lb | ||
88 | , _uploaded = ua + ub | ||
89 | } | ||
90 | {-# INLINE mappend #-} | ||
91 | |||
92 | instance QueryValueLike Builder where | ||
93 | toQueryValue = toQueryValue . BS.toLazyByteString | ||
94 | |||
95 | instance QueryValueLike Word64 where | ||
96 | toQueryValue = toQueryValue . BS.word64Dec | ||
97 | |||
98 | -- | HTTP Tracker protocol compatible encoding. | ||
99 | instance QueryLike Progress where | ||
100 | toQuery Progress {..} = | ||
101 | [ ("uploaded" , toQueryValue _uploaded) | ||
102 | , ("left" , toQueryValue _left) | ||
103 | , ("downloaded", toQueryValue _downloaded) | ||
104 | ] | ||
105 | |||
106 | instance Pretty Progress where | ||
107 | pretty Progress {..} = | ||
108 | "/\\" <+> PP.text (show _uploaded) $$ | ||
109 | "\\/" <+> PP.text (show _downloaded) $$ | ||
110 | "left" <+> PP.text (show _left) | ||
111 | |||
112 | -- | Initial progress is used when there are no session before. | ||
113 | -- | ||
114 | -- Please note that tracker might penalize client some way if the do | ||
115 | -- not accumulate progress. If possible and save 'Progress' between | ||
116 | -- client sessions to avoid that. | ||
117 | -- | ||
118 | startProgress :: Integer -> Progress | ||
119 | startProgress = Progress 0 0 . fromIntegral | ||
120 | {-# INLINE startProgress #-} | ||
121 | |||
122 | -- | Used when the client download some data from /any/ peer. | ||
123 | downloadedProgress :: Int -> Progress -> Progress | ||
124 | downloadedProgress (fromIntegral -> amount) | ||
125 | = (left -~ amount) | ||
126 | . (downloaded +~ amount) | ||
127 | {-# INLINE downloadedProgress #-} | ||
128 | |||
129 | -- | Used when the client upload some data to /any/ peer. | ||
130 | uploadedProgress :: Int -> Progress -> Progress | ||
131 | uploadedProgress (fromIntegral -> amount) = uploaded +~ amount | ||
132 | {-# INLINE uploadedProgress #-} | ||
133 | |||
134 | -- | Used when leecher join client session. | ||
135 | enqueuedProgress :: Integer -> Progress -> Progress | ||
136 | enqueuedProgress amount = left +~ fromIntegral amount | ||
137 | {-# INLINE enqueuedProgress #-} | ||
138 | |||
139 | -- | Used when leecher leave client session. | ||
140 | -- (e.g. user deletes not completed torrent) | ||
141 | dequeuedProgress :: Integer -> Progress -> Progress | ||
142 | dequeuedProgress amount = left -~ fromIntegral amount | ||
143 | {-# INLINE dequeuedProgress #-} | ||
144 | |||
145 | ri2rw64 :: Ratio Int -> Ratio Word64 | ||
146 | ri2rw64 x = fromIntegral (numerator x) % fromIntegral (denominator x) | ||
147 | |||
148 | -- | Check global /download/ limit by uploaded \/ downloaded ratio. | ||
149 | canDownload :: Ratio Int -> Progress -> Bool | ||
150 | canDownload limit Progress {..} = _uploaded % _downloaded > ri2rw64 limit | ||
151 | |||
152 | -- | Check global /upload/ limit by downloaded \/ uploaded ratio. | ||
153 | canUpload :: Ratio Int -> Progress -> Bool | ||
154 | canUpload limit Progress {..} = _downloaded % _uploaded > ri2rw64 limit | ||
diff --git a/src/Network/BitTorrent/Tracker/Message.hs b/src/Network/BitTorrent/Tracker/Message.hs index cdc07af8..e4a41045 100644 --- a/src/Network/BitTorrent/Tracker/Message.hs +++ b/src/Network/BitTorrent/Tracker/Message.hs | |||
@@ -124,10 +124,9 @@ import Numeric | |||
124 | import System.Entropy | 124 | import System.Entropy |
125 | import Text.Read (readMaybe) | 125 | import Text.Read (readMaybe) |
126 | 126 | ||
127 | import Data.Torrent.InfoHash | 127 | import Data.Torrent |
128 | import Data.Torrent.Progress | 128 | import Network.BitTorrent.Address |
129 | import Network.BitTorrent.Core | 129 | import Network.BitTorrent.Internal.Progress |
130 | |||
131 | 130 | ||
132 | {----------------------------------------------------------------------- | 131 | {----------------------------------------------------------------------- |
133 | -- Events | 132 | -- Events |
diff --git a/src/Network/BitTorrent/Tracker/RPC.hs b/src/Network/BitTorrent/Tracker/RPC.hs index dc1bd4ec..6fd22b25 100644 --- a/src/Network/BitTorrent/Tracker/RPC.hs +++ b/src/Network/BitTorrent/Tracker/RPC.hs | |||
@@ -25,7 +25,7 @@ module Network.BitTorrent.Tracker.RPC | |||
25 | -- * RPC | 25 | -- * RPC |
26 | , SAnnounceQuery (..) | 26 | , SAnnounceQuery (..) |
27 | , RpcException (..) | 27 | , RpcException (..) |
28 | , announce | 28 | , Network.BitTorrent.Tracker.RPC.announce |
29 | , scrape | 29 | , scrape |
30 | ) where | 30 | ) where |
31 | 31 | ||
@@ -36,9 +36,9 @@ import Network | |||
36 | import Network.URI | 36 | import Network.URI |
37 | import Network.Socket (HostAddress) | 37 | import Network.Socket (HostAddress) |
38 | 38 | ||
39 | import Data.Torrent.InfoHash | 39 | import Data.Torrent |
40 | import Data.Torrent.Progress | 40 | import Network.BitTorrent.Address |
41 | import Network.BitTorrent.Core | 41 | import Network.BitTorrent.Internal.Progress |
42 | import Network.BitTorrent.Tracker.Message | 42 | import Network.BitTorrent.Tracker.Message |
43 | import qualified Network.BitTorrent.Tracker.RPC.HTTP as HTTP | 43 | import qualified Network.BitTorrent.Tracker.RPC.HTTP as HTTP |
44 | import qualified Network.BitTorrent.Tracker.RPC.UDP as UDP | 44 | import qualified Network.BitTorrent.Tracker.RPC.UDP as UDP |
diff --git a/src/Network/BitTorrent/Tracker/RPC/HTTP.hs b/src/Network/BitTorrent/Tracker/RPC/HTTP.hs index 4a8e5f79..6e55eb04 100644 --- a/src/Network/BitTorrent/Tracker/RPC/HTTP.hs +++ b/src/Network/BitTorrent/Tracker/RPC/HTTP.hs | |||
@@ -47,8 +47,8 @@ import qualified Network.HTTP.Conduit as HTTP | |||
47 | import Network.HTTP.Types.Header (hUserAgent) | 47 | import Network.HTTP.Types.Header (hUserAgent) |
48 | import Network.HTTP.Types.URI (SimpleQuery, renderSimpleQuery) | 48 | import Network.HTTP.Types.URI (SimpleQuery, renderSimpleQuery) |
49 | 49 | ||
50 | import Data.Torrent.InfoHash (InfoHash) | 50 | import Data.Torrent (InfoHash) |
51 | import Network.BitTorrent.Core.Fingerprint (libUserAgent) | 51 | import Network.BitTorrent.Address (libUserAgent) |
52 | import Network.BitTorrent.Tracker.Message hiding (Request, Response) | 52 | import Network.BitTorrent.Tracker.Message hiding (Request, Response) |
53 | 53 | ||
54 | {----------------------------------------------------------------------- | 54 | {----------------------------------------------------------------------- |
diff --git a/src/Network/BitTorrent/Tracker/Session.hs b/src/Network/BitTorrent/Tracker/Session.hs index 560acf84..cef7d665 100644 --- a/src/Network/BitTorrent/Tracker/Session.hs +++ b/src/Network/BitTorrent/Tracker/Session.hs | |||
@@ -57,8 +57,8 @@ import Data.Time | |||
57 | import Data.Traversable | 57 | import Data.Traversable |
58 | import Network.URI | 58 | import Network.URI |
59 | 59 | ||
60 | import Data.Torrent.InfoHash | 60 | import Data.Torrent |
61 | import Network.BitTorrent.Core | 61 | import Network.BitTorrent.Address |
62 | import Network.BitTorrent.Internal.Cache | 62 | import Network.BitTorrent.Internal.Cache |
63 | import Network.BitTorrent.Internal.Types | 63 | import Network.BitTorrent.Internal.Types |
64 | import Network.BitTorrent.Tracker.List as TL | 64 | import Network.BitTorrent.Tracker.List as TL |