summaryrefslogtreecommitdiff
path: root/src/Network
diff options
context:
space:
mode:
authorSam Truzjan <pxqr.sta@gmail.com>2014-04-26 07:42:57 +0400
committerSam Truzjan <pxqr.sta@gmail.com>2014-04-26 07:42:57 +0400
commita7fda9d39ed82cb9d3ad0c28e76e88e59539a492 (patch)
tree925183a691bbb57ca5f7140614e1fdbc610b3b1e /src/Network
parent4587ffd5406162bb06a6549ffd2ff277e0a93916 (diff)
parent85bf8475bbbce79b1bedde641192fa945614283d (diff)
Merge branch 'tidy' into dev
Diffstat (limited to 'src/Network')
-rw-r--r--src/Network/BitTorrent.hs2
-rw-r--r--src/Network/BitTorrent/Address.hs1172
-rw-r--r--src/Network/BitTorrent/Client.hs4
-rw-r--r--src/Network/BitTorrent/Client/Handle.hs2
-rw-r--r--src/Network/BitTorrent/Client/Types.hs6
-rw-r--r--src/Network/BitTorrent/Core.hs88
-rw-r--r--src/Network/BitTorrent/Core/Fingerprint.hs290
-rw-r--r--src/Network/BitTorrent/Core/NodeInfo.hs219
-rw-r--r--src/Network/BitTorrent/Core/PeerAddr.hs354
-rw-r--r--src/Network/BitTorrent/Core/PeerId.hs364
-rw-r--r--src/Network/BitTorrent/DHT.hs5
-rw-r--r--src/Network/BitTorrent/DHT/ContactInfo.hs52
-rw-r--r--src/Network/BitTorrent/DHT/Message.hs4
-rw-r--r--src/Network/BitTorrent/DHT/Query.hs4
-rw-r--r--src/Network/BitTorrent/DHT/Routing.hs4
-rw-r--r--src/Network/BitTorrent/DHT/Session.hs13
-rw-r--r--src/Network/BitTorrent/DHT/Token.hs2
-rw-r--r--src/Network/BitTorrent/Exchange/Assembler.hs168
-rw-r--r--src/Network/BitTorrent/Exchange/Bitfield.hs398
-rw-r--r--src/Network/BitTorrent/Exchange/Block.hs2
-rw-r--r--src/Network/BitTorrent/Exchange/Connection.hs9
-rw-r--r--src/Network/BitTorrent/Exchange/Download.hs295
-rw-r--r--src/Network/BitTorrent/Exchange/Manager.hs4
-rw-r--r--src/Network/BitTorrent/Exchange/Message.hs14
-rw-r--r--src/Network/BitTorrent/Exchange/Selection.hs85
-rw-r--r--src/Network/BitTorrent/Exchange/Session.hs26
-rw-r--r--src/Network/BitTorrent/Exchange/Session/Metadata.hs104
-rw-r--r--src/Network/BitTorrent/Exchange/Session/Status.hs175
-rw-r--r--src/Network/BitTorrent/Internal/Progress.hs154
-rw-r--r--src/Network/BitTorrent/Tracker/Message.hs7
-rw-r--r--src/Network/BitTorrent/Tracker/RPC.hs8
-rw-r--r--src/Network/BitTorrent/Tracker/RPC/HTTP.hs4
-rw-r--r--src/Network/BitTorrent/Tracker/Session.hs4
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
59import Data.Torrent 59import Data.Torrent
60import Data.Torrent.InfoHash
61import Data.Torrent.Magnet
62import Network.BitTorrent.Client 60import Network.BitTorrent.Client
63import Network.BitTorrent.Internal.Types \ No newline at end of file 61import 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 #-}
22module 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
78import Control.Applicative
79import Control.Monad
80import Data.BEncode as BE
81import Data.BEncode as BS
82import Data.BEncode.BDict (BKey)
83import Data.Bits
84import Data.ByteString as BS
85import Data.ByteString.Internal as BS
86import Data.ByteString.Base16 as Base16
87import Data.ByteString.Char8 as BC
88import Data.ByteString.Char8 as BS8
89import qualified Data.ByteString.Lazy as BL
90import qualified Data.ByteString.Lazy.Builder as BS
91import Data.Char
92import Data.Convertible
93import Data.Default
94import Data.Foldable
95import Data.IP
96import Data.List as L
97import Data.List.Split as L
98import Data.Maybe (fromMaybe, catMaybes)
99import Data.Monoid
100import Data.Hashable
101import Data.Ord
102import Data.Serialize as S
103import Data.String
104import Data.Time
105import Data.Typeable
106import Data.Version
107import Data.Word
108import qualified Text.ParserCombinators.ReadP as RP
109import Text.Read (readMaybe)
110import Network.HTTP.Types.QueryLike
111import Network.Socket
112import Text.PrettyPrint as PP hiding ((<>))
113import Text.PrettyPrint.Class
114import System.Locale (defaultTimeLocale)
115import System.Entropy
116
117-- import Paths_bittorrent (version)
118
119{-----------------------------------------------------------------------
120-- Address
121-----------------------------------------------------------------------}
122
123instance Pretty UTCTime where
124 pretty = PP.text . show
125
126class (Eq a, Serialize a, Typeable a, Hashable a, Pretty a)
127 => Address a where
128 toSockAddr :: a -> SockAddr
129 fromSockAddr :: SockAddr -> Maybe a
130
131fromAddr :: (Address a, Address b) => a -> Maybe b
132fromAddr = fromSockAddr . toSockAddr
133
134-- | Note that port is zeroed.
135instance 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.
141instance 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.
147instance 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
154setPort :: PortNumber -> SockAddr -> SockAddr
155setPort port (SockAddrInet _ h ) = SockAddrInet port h
156setPort port (SockAddrInet6 _ f h s) = SockAddrInet6 port f h s
157setPort _ (SockAddrUnix s ) = SockAddrUnix s
158{-# INLINE setPort #-}
159
160getPort :: SockAddr -> Maybe PortNumber
161getPort (SockAddrInet p _ ) = Just p
162getPort (SockAddrInet6 p _ _ _) = Just p
163getPort (SockAddrUnix _ ) = Nothing
164{-# INLINE getPort #-}
165
166instance Address a => Address (NodeAddr a) where
167 toSockAddr NodeAddr {..} = setPort nodePort $ toSockAddr nodeHost
168 fromSockAddr sa = NodeAddr <$> fromSockAddr sa <*> getPort sa
169
170instance 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.
189newtype PeerId = PeerId { getPeerId :: ByteString }
190 deriving (Show, Eq, Ord, BEncode, Typeable)
191
192peerIdLen :: Int
193peerIdLen = 20
194
195-- | For testing purposes only.
196instance Default PeerId where
197 def = azureusStyle defaultClientId defaultVersionNumber ""
198
199instance Hashable PeerId where
200 hashWithSalt = hashUsing getPeerId
201 {-# INLINE hashWithSalt #-}
202
203instance Serialize PeerId where
204 put = putByteString . getPeerId
205 get = PeerId <$> getBytes peerIdLen
206
207instance QueryValueLike PeerId where
208 toQueryValue (PeerId pid) = Just pid
209 {-# INLINE toQueryValue #-}
210
211instance 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
218instance Pretty PeerId where
219 pretty = text . BC.unpack . getPeerId
220
221instance 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--
238byteStringPadded :: ByteString -- ^ bytestring to be padded.
239 -> Int -- ^ size of result builder.
240 -> Char -- ^ character used for padding.
241 -> BS.Builder
242byteStringPadded 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--
260azureusStyle :: 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.
264azureusStyle 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--
281shadowStyle :: Char -- ^ Client ID.
282 -> ByteString -- ^ Version number.
283 -> ByteString -- ^ Random number.
284 -> PeerId -- ^ Shadow style encoded peer ID.
285shadowStyle 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.
292defaultClientId :: ByteString
293defaultClientId = "HS"
294
295-- | Gives exactly 4 bytes long version number for any version of the
296-- package. Version is taken from .cabal file.
297defaultVersionNumber :: ByteString
298defaultVersionNumber = 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--
317timestamp :: IO ByteString
318timestamp = (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'.
325entropy :: IO ByteString
326entropy = 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--
339genPeerId :: IO PeerId
340genPeerId = 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
355instance 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
365instance Serialize PortNumber where
366 get = fromIntegral <$> getWord16be
367 {-# INLINE get #-}
368 put = putWord16be . fromIntegral
369 {-# INLINE put #-}
370
371instance Hashable PortNumber where
372 hashWithSalt s = hashWithSalt s . fromEnum
373 {-# INLINE hashWithSalt #-}
374
375instance Pretty PortNumber where
376 pretty = PP.int . fromEnum
377 {-# INLINE pretty #-}
378
379{-----------------------------------------------------------------------
380-- IP addr
381-----------------------------------------------------------------------}
382
383class IPAddress i where
384 toHostAddr :: i -> Either HostAddress HostAddress6
385
386instance IPAddress IPv4 where
387 toHostAddr = Left . toHostAddress
388 {-# INLINE toHostAddr #-}
389
390instance IPAddress IPv6 where
391 toHostAddr = Right . toHostAddress6
392 {-# INLINE toHostAddr #-}
393
394instance IPAddress IP where
395 toHostAddr (IPv4 ip) = toHostAddr ip
396 toHostAddr (IPv6 ip) = toHostAddr ip
397 {-# INLINE toHostAddr #-}
398
399deriving instance Typeable IP
400deriving instance Typeable IPv4
401deriving instance Typeable IPv6
402
403ipToBEncode :: Show i => i -> BValue
404ipToBEncode ip = BString $ BS8.pack $ show ip
405{-# INLINE ipToBEncode #-}
406
407ipFromBEncode :: Read a => BValue -> BS.Result a
408ipFromBEncode (BString (BS8.unpack -> ipStr))
409 | Just ip <- readMaybe (ipStr) = pure ip
410 | otherwise = decodingError $ "IP: " ++ ipStr
411ipFromBEncode _ = decodingError $ "IP: addr should be a bstring"
412
413instance BEncode IP where
414 toBEncode = ipToBEncode
415 {-# INLINE toBEncode #-}
416 fromBEncode = ipFromBEncode
417 {-# INLINE fromBEncode #-}
418
419instance BEncode IPv4 where
420 toBEncode = ipToBEncode
421 {-# INLINE toBEncode #-}
422 fromBEncode = ipFromBEncode
423 {-# INLINE fromBEncode #-}
424
425instance 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
434instance 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
445instance Serialize IPv4 where
446 put = putWord32host . toHostAddress
447 get = fromHostAddress <$> getWord32host
448
449instance Serialize IPv6 where
450 put ip = put $ toHostAddress6 ip
451 get = fromHostAddress6 <$> get
452
453instance Pretty IPv4 where
454 pretty = PP.text . show
455 {-# INLINE pretty #-}
456
457instance Pretty IPv6 where
458 pretty = PP.text . show
459 {-# INLINE pretty #-}
460
461instance Pretty IP where
462 pretty = PP.text . show
463 {-# INLINE pretty #-}
464
465instance Hashable IPv4 where
466 hashWithSalt = hashUsing toHostAddress
467 {-# INLINE hashWithSalt #-}
468
469instance Hashable IPv6 where
470 hashWithSalt s a = hashWithSalt s (toHostAddress6 a)
471
472instance 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.
483data 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
494peer_ip_key, peer_id_key, peer_port_key :: BKey
495peer_ip_key = "ip"
496peer_id_key = "peer id"
497peer_port_key = "port"
498
499-- | The tracker's 'announce response' compatible encoding.
500instance (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
520instance (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@
525instance Default (PeerAddr IPv4) where
526 def = "127.0.0.1:6881"
527
528-- | @127.0.0.1:6881@
529instance Default (PeerAddr IP) where
530 def = IPv4 <$> def
531
532-- | Example:
533--
534-- @peerPort \"127.0.0.1:6881\" == 6881@
535--
536instance 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
544instance 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
551readsIPv6_port :: String -> [((IPv6, PortNumber), String)]
552readsIPv6_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
558instance 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
564instance 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
571instance 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
578instance 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.
583defaultPorts :: [PortNumber]
584defaultPorts = [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
597peerSockAddr :: PeerAddr IP -> SockAddr
598peerSockAddr = snd . _peerSockAddr
599
600-- | Create a socket connected to the address specified in a peerAddr
601peerSocket :: SocketType -> PeerAddr IP -> IO Socket
602peerSocket 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.
627newtype NodeId = NodeId ByteString
628 deriving (Show, Eq, Ord, BEncode, Typeable)
629
630nodeIdSize :: Int
631nodeIdSize = 20
632
633-- | Meaningless node id, for testing purposes only.
634instance Default NodeId where
635 def = NodeId (BS.replicate nodeIdSize 0)
636
637instance Serialize NodeId where
638 get = NodeId <$> getByteString nodeIdSize
639 {-# INLINE get #-}
640 put (NodeId bs) = putByteString bs
641 {-# INLINE put #-}
642
643-- | ASCII encoded.
644instance 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.
651instance Pretty NodeId where
652 pretty (NodeId nid) = PP.text $ BC.unpack $ Base16.encode nid
653
654-- | Test if the nth bit is set.
655testIdBit :: NodeId -> Word -> Bool
656testIdBit (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--
667genNodeId :: IO NodeId
668genNodeId = NodeId <$> getEntropy nodeIdSize
669
670------------------------------------------------------------------------
671
672-- | In Kademlia, the distance metric is XOR and the result is
673-- interpreted as an unsigned integer.
674newtype NodeDistance = NodeDistance BS.ByteString
675 deriving (Eq, Ord)
676
677instance 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.
684distance :: NodeId -> NodeId -> NodeDistance
685distance (NodeId a) (NodeId b) = NodeDistance (BS.pack (BS.zipWith xor a b))
686
687------------------------------------------------------------------------
688
689data NodeAddr a = NodeAddr
690 { nodeHost :: !a
691 , nodePort :: {-# UNPACK #-} !PortNumber
692 } deriving (Eq, Typeable, Functor)
693
694instance Show a => Show (NodeAddr a) where
695 showsPrec i NodeAddr {..}
696 = showsPrec i nodeHost <> showString ":" <> showsPrec i nodePort
697
698instance Read (NodeAddr IPv4) where
699 readsPrec i x = [ (fromPeerAddr a, s) | (a, s) <- readsPrec i x ]
700
701-- | @127.0.0.1:6882@
702instance Default (NodeAddr IPv4) where
703 def = "127.0.0.1:6882"
704
705-- | KRPC compatible encoding.
706instance 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.
713instance 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
719instance Hashable a => Hashable (NodeAddr a) where
720 hashWithSalt s NodeAddr {..} = hashWithSalt s (nodeHost, nodePort)
721 {-# INLINE hashWithSalt #-}
722
723instance 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--
730instance IsString (NodeAddr IPv4) where
731 fromString = fromPeerAddr . fromString
732
733fromPeerAddr :: PeerAddr a -> NodeAddr a
734fromPeerAddr PeerAddr {..} = NodeAddr
735 { nodeHost = peerHost
736 , nodePort = peerPort
737 }
738
739------------------------------------------------------------------------
740
741data NodeInfo a = NodeInfo
742 { nodeId :: !NodeId
743 , nodeAddr :: !(NodeAddr a)
744 } deriving (Show, Eq, Functor)
745
746instance 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.
753instance Serialize a => Serialize (NodeInfo a) where
754 get = NodeInfo <$> get <*> get
755 put NodeInfo {..} = put nodeId >> put nodeAddr
756
757instance Pretty ip => Pretty (NodeInfo ip) where
758 pretty NodeInfo {..} = pretty nodeId <> "@(" <> pretty nodeAddr <> ")"
759
760instance Pretty ip => Pretty [NodeInfo ip] where
761 pretty = PP.vcat . PP.punctuate "," . L.map pretty
762
763-- | Order by closeness: nearest nodes first.
764rank :: Eq ip => NodeId -> [NodeInfo ip] -> [NodeInfo ip]
765rank 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
789version :: Version
790version = 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--
797data 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
875parseSoftware :: ByteString -> Software
876parseSoftware = 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
942instance Default Software where
943 def = IUnknown
944 {-# INLINE def #-}
945
946-- | Example: @\"BitLet\" == 'IBitLet'@
947instance 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\"@
956instance Pretty Software where
957 pretty = text . L.tail . show
958
959-- | Just the '0' version.
960instance 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--
967instance 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
974instance 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.
979data Fingerprint = Fingerprint Software Version
980 deriving (Show, Eq, Ord)
981
982-- | Unrecognized client implementation.
983instance Default Fingerprint where
984 def = Fingerprint def def
985 {-# INLINE def #-}
986
987-- | Example: @\"BitComet-1.2\" == ClientInfo IBitComet (Version [1, 2] [])@
988instance 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
995instance 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--
1002libFingerprint :: Fingerprint
1003libFingerprint = Fingerprint IlibHSbittorrent version
1004
1005-- | HTTP user agent of this (the bittorrent library) package. Can be
1006-- used in HTTP tracker requests.
1007libUserAgent :: String
1008libUserAgent = render (pretty IlibHSbittorrent <> "/" <> pretty version)
1009
1010{-----------------------------------------------------------------------
1011-- For torrent file
1012-----------------------------------------------------------------------}
1013-- TODO collect information about createdBy torrent field
1014{-
1015renderImpl :: ClientImpl -> Text
1016renderImpl = T.pack . L.tail . show
1017
1018renderVersion :: Version -> Text
1019renderVersion = undefined
1020
1021renderClientInfo :: ClientInfo -> Text
1022renderClientInfo ClientInfo {..} = renderImpl ciImpl <> "/" <> renderVersion ciVersion
1023
1024parseClientInfo :: Text -> ClientImpl
1025parseClientInfo t = undefined
1026-}
1027{-
1028-- code used for generation; remove it later on
1029
1030mkEnumTyDef :: NM -> String
1031mkEnumTyDef = unlines . map (" | I" ++) . nub . map snd
1032
1033mkPars :: NM -> String
1034mkPars = unlines . map (\(code, impl) -> " f \"" ++ code ++ "\" = " ++ "I" ++ impl)
1035
1036type NM = [(String, String)]
1037nameMap :: NM
1038nameMap =
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--
1108fingerprint :: PeerId -> Fingerprint
1109fingerprint 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
61import Network 61import Network
62 62
63import Data.Torrent 63import Data.Torrent
64import Data.Torrent.InfoHash 64import Network.BitTorrent.Address
65import Data.Torrent.Magnet
66import Network.BitTorrent.Client.Types 65import Network.BitTorrent.Client.Types
67import Network.BitTorrent.Client.Handle 66import Network.BitTorrent.Client.Handle
68import Network.BitTorrent.Core
69import Network.BitTorrent.DHT as DHT hiding (Options) 67import Network.BitTorrent.DHT as DHT hiding (Options)
70import Network.BitTorrent.Tracker as Tracker hiding (Options) 68import Network.BitTorrent.Tracker as Tracker hiding (Options)
71import Network.BitTorrent.Exchange as Exchange hiding (Options) 69import 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
26import Data.HashMap.Strict as HM 26import Data.HashMap.Strict as HM
27 27
28import Data.Torrent 28import Data.Torrent
29import Data.Torrent.InfoHash
30import Data.Torrent.Magnet
31import Network.BitTorrent.Client.Types as Types 29import Network.BitTorrent.Client.Types as Types
32import Network.BitTorrent.DHT as DHT 30import Network.BitTorrent.DHT as DHT
33import Network.BitTorrent.Exchange as Exchange 31import 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
34import Network 34import Network
35import System.Log.FastLogger 35import System.Log.FastLogger
36 36
37import Data.Torrent.InfoHash 37import Data.Torrent
38import Network.BitTorrent.Address
38import Network.BitTorrent.Internal.Types as Types 39import Network.BitTorrent.Internal.Types as Types
39import Network.BitTorrent.Core
40import Network.BitTorrent.DHT as DHT 40import Network.BitTorrent.DHT as DHT
41import Network.BitTorrent.Exchange as Exchange 41import Network.BitTorrent.Exchange as Exchange
42import Network.BitTorrent.Tracker as Tracker hiding (Event) 42import Network.BitTorrent.Tracker as Tracker hiding (Event)
@@ -100,7 +100,7 @@ externalAddr Client {..} = PeerAddr
100newtype BitTorrent a = BitTorrent 100newtype 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
106class MonadBitTorrent m where 106class 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--
10module 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
23import Control.Applicative
24import Data.IP
25import Data.Hashable
26import Data.Serialize
27import Data.Time
28import Data.Typeable
29import Network.Socket (SockAddr (..), PortNumber)
30import Text.PrettyPrint as PP hiding ((<>))
31import Text.PrettyPrint.Class
32
33import Network.BitTorrent.Core.Fingerprint as Core
34import Network.BitTorrent.Core.NodeInfo as Core
35import Network.BitTorrent.Core.PeerId as Core
36import Network.BitTorrent.Core.PeerAddr as Core
37
38
39instance Pretty UTCTime where
40 pretty = PP.text . show
41
42class (Eq a, Serialize a, Typeable a, Hashable a, Pretty a)
43 => Address a where
44 toSockAddr :: a -> SockAddr
45 fromSockAddr :: SockAddr -> Maybe a
46
47fromAddr :: (Address a, Address b) => a -> Maybe b
48fromAddr = fromSockAddr . toSockAddr
49
50-- | Note that port is zeroed.
51instance 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.
57instance 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.
63instance 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
70setPort :: PortNumber -> SockAddr -> SockAddr
71setPort port (SockAddrInet _ h ) = SockAddrInet port h
72setPort port (SockAddrInet6 _ f h s) = SockAddrInet6 port f h s
73setPort _ (SockAddrUnix s ) = SockAddrUnix s
74{-# INLINE setPort #-}
75
76getPort :: SockAddr -> Maybe PortNumber
77getPort (SockAddrInet p _ ) = Just p
78getPort (SockAddrInet6 p _ _ _) = Just p
79getPort (SockAddrUnix _ ) = Nothing
80{-# INLINE getPort #-}
81
82instance Address a => Address (NodeAddr a) where
83 toSockAddr NodeAddr {..} = setPort nodePort $ toSockAddr nodeHost
84 fromSockAddr sa = NodeAddr <$> fromSockAddr sa <*> getPort sa
85
86instance 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 #-}
24module Network.BitTorrent.Core.Fingerprint
25 ( ClientImpl (..)
26 , Fingerprint (..)
27 , libFingerprint
28 , libUserAgent
29 ) where
30
31import Data.Default
32import Data.List as L
33import Data.List.Split as L
34import Data.Monoid
35import Data.String
36import Data.Version
37import Text.PrettyPrint hiding ((<>))
38import Text.PrettyPrint.Class
39import Text.Read (readMaybe)
40-- import Paths_bittorrent (version)
41
42-- TODO FIXME
43version :: Version
44version = 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--
51data 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
130instance Default ClientImpl where
131 def = IUnknown
132 {-# INLINE def #-}
133
134-- | Example: @\"BitLet\" == 'IBitLet'@
135instance 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\"@
144instance Pretty ClientImpl where
145 pretty = text . L.tail . show
146
147-- | Just the '0' version.
148instance 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--
155instance 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
162instance 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.
167data Fingerprint = Fingerprint
168 { ciImpl :: ClientImpl
169 , ciVersion :: Version
170 } deriving (Show, Eq, Ord)
171
172-- | Unrecognized client implementation.
173instance Default Fingerprint where
174 def = Fingerprint def def
175 {-# INLINE def #-}
176
177-- | Example: @\"BitComet-1.2\" == ClientInfo IBitComet (Version [1, 2] [])@
178instance 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
185instance 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--
192libFingerprint :: Fingerprint
193libFingerprint = Fingerprint IlibHSbittorrent version
194
195-- | HTTP user agent of this (the bittorrent library) package. Can be
196-- used in HTTP tracker requests.
197libUserAgent :: String
198libUserAgent = render (pretty IlibHSbittorrent <> "/" <> pretty version)
199
200{-----------------------------------------------------------------------
201-- For torrent file
202-----------------------------------------------------------------------}
203-- TODO collect information about createdBy torrent field
204{-
205renderImpl :: ClientImpl -> Text
206renderImpl = T.pack . L.tail . show
207
208renderVersion :: Version -> Text
209renderVersion = undefined
210
211renderClientInfo :: ClientInfo -> Text
212renderClientInfo ClientInfo {..} = renderImpl ciImpl <> "/" <> renderVersion ciVersion
213
214parseClientInfo :: Text -> ClientImpl
215parseClientInfo t = undefined
216-}
217{-
218-- code used for generation; remove it later on
219
220mkEnumTyDef :: NM -> String
221mkEnumTyDef = unlines . map (" | I" ++) . nub . map snd
222
223mkPars :: NM -> String
224mkPars = unlines . map (\(code, impl) -> " f \"" ++ code ++ "\" = " ++ "I" ++ impl)
225
226type NM = [(String, String)]
227nameMap :: NM
228nameMap =
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 #-}
23module 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
41import Control.Applicative
42import Data.Bits
43import Data.ByteString as BS
44import Data.ByteString.Char8 as BC
45import Data.ByteString.Base16 as Base16
46import Data.BEncode as BE
47import Data.Default
48import Data.Hashable
49import Data.Foldable
50import Data.IP
51import Data.List as L
52import Data.Monoid
53import Data.Ord
54import Data.Serialize as S
55import Data.String
56import Data.Typeable
57import Data.Word
58import Network
59import System.Entropy
60import Text.PrettyPrint as PP hiding ((<>))
61import Text.PrettyPrint.Class
62
63import 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.
75newtype NodeId = NodeId ByteString
76 deriving (Show, Eq, Ord, BEncode, Typeable)
77
78nodeIdSize :: Int
79nodeIdSize = 20
80
81-- | Meaningless node id, for testing purposes only.
82instance Default NodeId where
83 def = NodeId (BS.replicate nodeIdSize 0)
84
85instance Serialize NodeId where
86 get = NodeId <$> getByteString nodeIdSize
87 {-# INLINE get #-}
88 put (NodeId bs) = putByteString bs
89 {-# INLINE put #-}
90
91-- | ASCII encoded.
92instance 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.
99instance Pretty NodeId where
100 pretty (NodeId nid) = PP.text $ BC.unpack $ Base16.encode nid
101
102-- | Test if the nth bit is set.
103testIdBit :: NodeId -> Word -> Bool
104testIdBit (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--
115genNodeId :: IO NodeId
116genNodeId = 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.
124newtype NodeDistance = NodeDistance BS.ByteString
125 deriving (Eq, Ord)
126
127instance 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.
134distance :: NodeId -> NodeId -> NodeDistance
135distance (NodeId a) (NodeId b) = NodeDistance (BS.pack (BS.zipWith xor a b))
136
137{-----------------------------------------------------------------------
138-- Node address
139-----------------------------------------------------------------------}
140
141data NodeAddr a = NodeAddr
142 { nodeHost :: !a
143 , nodePort :: {-# UNPACK #-} !PortNumber
144 } deriving (Eq, Typeable, Functor)
145
146instance Show a => Show (NodeAddr a) where
147 showsPrec i NodeAddr {..}
148 = showsPrec i nodeHost <> showString ":" <> showsPrec i nodePort
149
150instance Read (NodeAddr IPv4) where
151 readsPrec i x = [ (fromPeerAddr a, s) | (a, s) <- readsPrec i x ]
152
153-- | @127.0.0.1:6882@
154instance Default (NodeAddr IPv4) where
155 def = "127.0.0.1:6882"
156
157-- | KRPC compatible encoding.
158instance 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.
165instance 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
171instance Hashable a => Hashable (NodeAddr a) where
172 hashWithSalt s NodeAddr {..} = hashWithSalt s (nodeHost, nodePort)
173 {-# INLINE hashWithSalt #-}
174
175instance 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--
182instance IsString (NodeAddr IPv4) where
183 fromString = fromPeerAddr . fromString
184
185fromPeerAddr :: PeerAddr a -> NodeAddr a
186fromPeerAddr PeerAddr {..} = NodeAddr
187 { nodeHost = peerHost
188 , nodePort = peerPort
189 }
190
191{-----------------------------------------------------------------------
192-- Node info
193-----------------------------------------------------------------------}
194
195data NodeInfo a = NodeInfo
196 { nodeId :: !NodeId
197 , nodeAddr :: !(NodeAddr a)
198 } deriving (Show, Eq, Functor)
199
200instance 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.
207instance Serialize a => Serialize (NodeInfo a) where
208 get = NodeInfo <$> get <*> get
209 put NodeInfo {..} = put nodeId >> put nodeAddr
210
211instance Pretty ip => Pretty (NodeInfo ip) where
212 pretty NodeInfo {..} = pretty nodeId <> "@(" <> pretty nodeAddr <> ")"
213
214instance Pretty ip => Pretty [NodeInfo ip] where
215 pretty = PP.vcat . PP.punctuate "," . L.map pretty
216
217-- | Order by closeness: nearest nodes first.
218rank :: Eq ip => NodeId -> [NodeInfo ip] -> [NodeInfo ip]
219rank 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
21module 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
34import Control.Applicative
35import Control.Monad
36import Data.BEncode as BS
37import Data.BEncode.BDict (BKey)
38import Data.ByteString.Char8 as BS8
39import Data.Char
40import Data.Default
41import Data.Hashable
42import Data.HashMap.Strict as HM
43import Data.IP
44import Data.List as L
45import Data.List.Split
46import Data.Maybe
47import Data.Monoid
48import Data.Serialize as S
49import Data.String
50import Data.Typeable
51import Data.Word
52import Network.Socket
53import Text.PrettyPrint as PP hiding ((<>))
54import Text.PrettyPrint.Class
55import Text.Read (readMaybe)
56import qualified Text.ParserCombinators.ReadP as RP
57
58import Data.Torrent.InfoHash
59import Network.BitTorrent.Core.PeerId
60
61
62{-----------------------------------------------------------------------
63-- Port number
64-----------------------------------------------------------------------}
65
66instance 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
76instance Serialize PortNumber where
77 get = fromIntegral <$> getWord16be
78 {-# INLINE get #-}
79 put = putWord16be . fromIntegral
80 {-# INLINE put #-}
81
82instance Hashable PortNumber where
83 hashWithSalt s = hashWithSalt s . fromEnum
84 {-# INLINE hashWithSalt #-}
85
86instance Pretty PortNumber where
87 pretty = PP.int . fromEnum
88 {-# INLINE pretty #-}
89
90{-----------------------------------------------------------------------
91-- IP addr
92-----------------------------------------------------------------------}
93
94class IPAddress i where
95 toHostAddr :: i -> Either HostAddress HostAddress6
96
97instance IPAddress IPv4 where
98 toHostAddr = Left . toHostAddress
99 {-# INLINE toHostAddr #-}
100
101instance IPAddress IPv6 where
102 toHostAddr = Right . toHostAddress6
103 {-# INLINE toHostAddr #-}
104
105instance IPAddress IP where
106 toHostAddr (IPv4 ip) = toHostAddr ip
107 toHostAddr (IPv6 ip) = toHostAddr ip
108 {-# INLINE toHostAddr #-}
109
110deriving instance Typeable IP
111deriving instance Typeable IPv4
112deriving instance Typeable IPv6
113
114ipToBEncode :: Show i => i -> BValue
115ipToBEncode ip = BString $ BS8.pack $ show ip
116{-# INLINE ipToBEncode #-}
117
118ipFromBEncode :: Read a => BValue -> BS.Result a
119ipFromBEncode (BString (BS8.unpack -> ipStr))
120 | Just ip <- readMaybe (ipStr) = pure ip
121 | otherwise = decodingError $ "IP: " ++ ipStr
122ipFromBEncode _ = decodingError $ "IP: addr should be a bstring"
123
124instance BEncode IP where
125 toBEncode = ipToBEncode
126 {-# INLINE toBEncode #-}
127 fromBEncode = ipFromBEncode
128 {-# INLINE fromBEncode #-}
129
130instance BEncode IPv4 where
131 toBEncode = ipToBEncode
132 {-# INLINE toBEncode #-}
133 fromBEncode = ipFromBEncode
134 {-# INLINE fromBEncode #-}
135
136instance 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
145instance 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
156instance Serialize IPv4 where
157 put = putWord32host . toHostAddress
158 get = fromHostAddress <$> getWord32host
159
160instance Serialize IPv6 where
161 put ip = put $ toHostAddress6 ip
162 get = fromHostAddress6 <$> get
163
164instance Pretty IPv4 where
165 pretty = PP.text . show
166 {-# INLINE pretty #-}
167
168instance Pretty IPv6 where
169 pretty = PP.text . show
170 {-# INLINE pretty #-}
171
172instance Pretty IP where
173 pretty = PP.text . show
174 {-# INLINE pretty #-}
175
176instance Hashable IPv4 where
177 hashWithSalt = hashUsing toHostAddress
178 {-# INLINE hashWithSalt #-}
179
180instance Hashable IPv6 where
181 hashWithSalt s a = hashWithSalt s (toHostAddress6 a)
182
183instance 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.
194data 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
205peer_ip_key, peer_id_key, peer_port_key :: BKey
206peer_ip_key = "ip"
207peer_id_key = "peer id"
208peer_port_key = "port"
209
210-- | The tracker's 'announce response' compatible encoding.
211instance (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
231instance (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@
236instance Default (PeerAddr IPv4) where
237 def = "127.0.0.1:6881"
238
239-- | @127.0.0.1:6881@
240instance Default (PeerAddr IP) where
241 def = IPv4 <$> def
242
243-- | Example:
244--
245-- @peerPort \"127.0.0.1:6881\" == 6881@
246--
247instance 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
255instance 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
262readsIPv6_port :: String -> [((IPv6, PortNumber), String)]
263readsIPv6_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
269instance 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
275instance 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
282instance 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
289instance 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.
294defaultPorts :: [PortNumber]
295defaultPorts = [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
308peerSockAddr :: PeerAddr IP -> SockAddr
309peerSockAddr = snd . _peerSockAddr
310
311-- | Create a socket connected to the address specified in a peerAddr
312peerSocket :: SocketType -> PeerAddr IP -> IO Socket
313peerSocket 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.
326newtype PeerStore ip = PeerStore (HashMap InfoHash [PeerAddr ip])
327
328-- | Empty store.
329instance Default (PeerStore a) where
330 def = PeerStore HM.empty
331 {-# INLINE def #-}
332
333-- | Monoid under union operation.
334instance 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.
344instance Serialize (PeerStore a) where
345 get = undefined
346 put = undefined
347
348-- | Used in 'get_peers' DHT queries.
349lookup :: InfoHash -> PeerStore a -> [PeerAddr a]
350lookup ih (PeerStore m) = fromMaybe [] $ HM.lookup ih m
351
352-- | Used in 'announce_peer' DHT queries.
353insert :: Eq a => InfoHash -> PeerAddr a -> PeerStore a -> PeerStore a
354insert 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 #-}
17module 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
36import Control.Applicative
37import Data.BEncode as BE
38import Data.ByteString as BS
39import Data.ByteString.Internal as BS
40import Data.ByteString.Char8 as BC
41import qualified Data.ByteString.Lazy as BL
42import qualified Data.ByteString.Lazy.Builder as BS
43import Data.Convertible
44import Data.Default
45import Data.Foldable (foldMap)
46import Data.List as L
47import Data.List.Split as L
48import Data.Maybe (fromMaybe, catMaybes)
49import Data.Monoid
50import Data.Hashable
51import Data.Serialize as S
52import Data.String
53import Data.Time.Clock (getCurrentTime)
54import Data.Time.Format (formatTime)
55import Data.Typeable
56import Data.Version (Version(Version), versionBranch)
57import Network.HTTP.Types.QueryLike
58import System.Entropy (getEntropy)
59import System.Locale (defaultTimeLocale)
60import Text.PrettyPrint hiding ((<>))
61import Text.PrettyPrint.Class
62import Text.Read (readMaybe)
63
64import 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.
69newtype PeerId = PeerId { getPeerId :: ByteString }
70 deriving (Show, Eq, Ord, BEncode, Typeable)
71
72peerIdLen :: Int
73peerIdLen = 20
74
75-- | For testing purposes only.
76instance Default PeerId where
77 def = azureusStyle defaultClientId defaultVersionNumber ""
78
79instance Hashable PeerId where
80 hashWithSalt = hashUsing getPeerId
81 {-# INLINE hashWithSalt #-}
82
83instance Serialize PeerId where
84 put = putByteString . getPeerId
85 get = PeerId <$> getBytes peerIdLen
86
87instance QueryValueLike PeerId where
88 toQueryValue (PeerId pid) = Just pid
89 {-# INLINE toQueryValue #-}
90
91instance 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
98instance Pretty PeerId where
99 pretty = text . BC.unpack . getPeerId
100
101instance 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--
120byteStringPadded :: ByteString -- ^ bytestring to be padded.
121 -> Int -- ^ size of result builder.
122 -> Char -- ^ character used for padding.
123 -> BS.Builder
124byteStringPadded 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--
142azureusStyle :: 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.
146azureusStyle 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--
163shadowStyle :: Char -- ^ Client ID.
164 -> ByteString -- ^ Version number.
165 -> ByteString -- ^ Random number.
166 -> PeerId -- ^ Shadow style encoded peer ID.
167shadowStyle 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.
174defaultClientId :: ByteString
175defaultClientId = "HS"
176
177-- | Gives exactly 4 bytes long version number for any version of the
178-- package. Version is taken from .cabal file.
179defaultVersionNumber :: ByteString
180defaultVersionNumber = 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--
199timestamp :: IO ByteString
200timestamp = (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'.
207entropy :: IO ByteString
208entropy = 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--
221genPeerId :: IO PeerId
222genPeerId = azureusStyle defaultClientId defaultVersionNumber <$> timestamp
223
224{-----------------------------------------------------------------------
225-- Decoding
226-----------------------------------------------------------------------}
227
228parseImpl :: ByteString -> ClientImpl
229parseImpl = 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--
300fingerprint :: PeerId -> Fingerprint
301fingerprint 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
62import Data.Conduit.List as C 62import Data.Conduit.List as C
63import Network.Socket 63import Network.Socket
64 64
65import Data.Torrent (tNodes) 65import Data.Torrent
66import Data.Torrent.InfoHash 66import Network.BitTorrent.Address
67import Network.BitTorrent.Core
68import Network.BitTorrent.DHT.Query 67import Network.BitTorrent.DHT.Query
69import Network.BitTorrent.DHT.Session 68import Network.BitTorrent.DHT.Session
70import Network.BitTorrent.DHT.Routing as T 69import 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 @@
1module Network.BitTorrent.DHT.ContactInfo 1module Network.BitTorrent.DHT.ContactInfo
2 ( ) where 2 ( PeerStore
3 , Network.BitTorrent.DHT.ContactInfo.lookup
4 , Network.BitTorrent.DHT.ContactInfo.insert
5 ) where
6
7import Data.Default
8import Data.List as L
9import Data.Maybe
10import Data.Monoid
11import Data.HashMap.Strict as HM
12import Data.Serialize
13
14import Data.Torrent
15import Network.BitTorrent.Address
16
3{- 17{-
4import Data.HashMap.Strict as HM 18import Data.HashMap.Strict as HM
5 19
6import Data.Torrent.InfoHash 20import Data.Torrent.InfoHash
7import Network.BitTorrent.Core 21import 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.
91splitGT :: Timestamp -> ContactInfo ip -> ContactInfo ip 105splitGT :: Timestamp -> ContactInfo ip -> ContactInfo ip
92splitGT = undefined 106splitGT = 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.
111newtype PeerStore ip = PeerStore (HashMap InfoHash [PeerAddr ip])
112
113-- | Empty store.
114instance Default (PeerStore a) where
115 def = PeerStore HM.empty
116 {-# INLINE def #-}
117
118-- | Monoid under union operation.
119instance 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.
129instance Serialize (PeerStore a) where
130 get = undefined
131 put = undefined
132
133-- | Used in 'get_peers' DHT queries.
134lookup :: InfoHash -> PeerStore a -> [PeerAddr a]
135lookup ih (PeerStore m) = fromMaybe [] $ HM.lookup ih m
136
137-- | Used in 'announce_peer' DHT queries.
138insert :: Eq a => InfoHash -> PeerAddr a -> PeerStore a -> PeerStore a
139insert 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
92import Network 92import Network
93import Network.KRPC 93import Network.KRPC
94 94
95import Data.Torrent.InfoHash 95import Data.Torrent
96import Network.BitTorrent.Core 96import Network.BitTorrent.Address
97import Network.BitTorrent.DHT.Token 97import Network.BitTorrent.DHT.Token
98import Network.KRPC () 98import 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 ((<>), ($$))
56import Text.PrettyPrint.Class 56import Text.PrettyPrint.Class
57 57
58import Network.KRPC hiding (Options, def) 58import Network.KRPC hiding (Options, def)
59import Data.Torrent.InfoHash 59import Data.Torrent
60import Network.BitTorrent.Core 60import Network.BitTorrent.Address
61import Network.BitTorrent.DHT.Message 61import Network.BitTorrent.DHT.Message
62import Network.BitTorrent.DHT.Routing 62import Network.BitTorrent.DHT.Routing
63import Network.BitTorrent.DHT.Session 63import 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
73import Text.PrettyPrint as PP hiding ((<>)) 73import Text.PrettyPrint as PP hiding ((<>))
74import Text.PrettyPrint.Class 74import Text.PrettyPrint.Class
75 75
76import Data.Torrent.InfoHash 76import Data.Torrent
77import Network.BitTorrent.Core 77import 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
75import Control.Monad.Reader 75import Control.Monad.Reader
76import Control.Monad.Trans.Control 76import Control.Monad.Trans.Control
77import Control.Monad.Trans.Resource 77import Control.Monad.Trans.Resource
78import Data.Conduit.Lazy
78import Data.Default 79import Data.Default
79import Data.Fixed 80import Data.Fixed
80import Data.Hashable 81import Data.Hashable
@@ -91,11 +92,11 @@ import System.Random (randomIO)
91import Text.PrettyPrint as PP hiding ((<>), ($$)) 92import Text.PrettyPrint as PP hiding ((<>), ($$))
92import Text.PrettyPrint.Class 93import Text.PrettyPrint.Class
93 94
94import Data.Torrent.InfoHash 95import Data.Torrent as Torrent
95import Network.KRPC hiding (Options, def) 96import Network.KRPC hiding (Options, def)
96import qualified Network.KRPC as KRPC (def) 97import qualified Network.KRPC as KRPC (def)
97import Network.BitTorrent.Core 98import Network.BitTorrent.Address
98import Network.BitTorrent.Core.PeerAddr as P 99import Network.BitTorrent.DHT.ContactInfo as P
99import Network.BitTorrent.DHT.Message 100import Network.BitTorrent.DHT.Message
100import Network.BitTorrent.DHT.Routing as R 101import Network.BitTorrent.DHT.Routing as R
101import Network.BitTorrent.DHT.Token as T 102import 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.
255newtype DHT ip a = DHT { unDHT :: ReaderT (Node ip) IO a } 256newtype 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
262instance MonadBaseControl IO (DHT ip) where 261instance 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
50import Data.Time 50import Data.Time
51import System.Random 51import System.Random
52 52
53import Network.BitTorrent.Core 53import 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 #-}
46module 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
62import Control.Applicative
63import Control.Lens
64import Data.IntMap.Strict as IM
65import Data.List as L
66import Data.Map as M
67import Data.Maybe
68import Data.IP
69
70import Data.Torrent.Piece
71import Network.BitTorrent.Core
72import Network.BitTorrent.Exchange.Block as B
73
74{-----------------------------------------------------------------------
75-- Assembler
76-----------------------------------------------------------------------}
77
78type Timestamp = ()
79{-
80data BlockRequest = BlockRequest
81 { requestSent :: Timestamp
82 , requestedPeer :: PeerAddr IP
83 , requestedBlock :: BlockIx
84 }
85-}
86type BlockRange = (BlockOffset, BlockSize)
87type PieceMap = IntMap
88
89data 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
103valid :: Assembler -> Bool
104valid = undefined
105
106data Result a
107 = Completed (Piece a)
108 | Corrupted PieceIx
109 | NotRequested PieceIx
110 | Overlapped BlockIx
111
112null :: Assembler -> Bool
113null = undefined
114
115size :: Assembler -> Bool
116size = undefined
117
118empty :: PieceInfo -> Assembler
119empty = Assembler M.empty IM.empty
120
121allowPiece :: PieceIx -> Assembler -> Assembler
122allowPiece pix a @ Assembler {..} = over pending (IM.insert pix bkt) a
123 where
124 bkt = B.empty (piPieceLength info)
125
126allowedSet :: (PeerAddr IP) -> Assembler -> [BlockIx]
127allowedSet = 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.
135insert :: PeerAddr IP -> Block a -> Assembler -> Assembler
136insert = undefined
137
138{-
139insert :: Block a -> Assembler a -> (Assembler a, Maybe (Result a))
140insert 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
151inflightPieces :: Assembler a -> [PieceIx]
152inflightPieces Assembler {..} = IM.keys piecePending
153
154completeBlocks :: PieceIx -> Assembler a -> [Block a]
155completeBlocks pix Assembler {..} = fromMaybe [] $ IM.lookup pix piecePending
156
157incompleteBlocks :: PieceIx -> Assembler a -> [BlockIx]
158incompleteBlocks = undefined
159
160nextBlock :: Assembler a -> Maybe (Assembler a, BlockIx)
161nextBlock Assembler {..} = undefined
162
163inserta :: Block a
164 -> PieceMap [Block a]
165 -> (PieceMap [Block a], Maybe (Piece a))
166inserta = 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 #-}
30module 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
91import Control.Monad
92import Control.Monad.ST
93import Data.ByteString (ByteString)
94import qualified Data.ByteString as B
95import qualified Data.ByteString.Lazy as Lazy
96import Data.Vector.Unboxed (Vector)
97import qualified Data.Vector.Unboxed as V
98import qualified Data.Vector.Unboxed.Mutable as VM
99import Data.IntervalSet (IntSet)
100import qualified Data.IntervalSet as S
101import qualified Data.IntervalSet.ByteString as S
102import Data.List (foldl')
103import Data.Monoid
104import Data.Ratio
105
106import 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--
116data 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
123instance 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.
134haveNone :: PieceCount -> Bitfield
135haveNone s = Bitfield s S.empty
136
137-- | The full bitfield containing all piece indices for the given size.
138haveAll :: PieceCount -> Bitfield
139haveAll s = Bitfield s (S.interval 0 (s - 1))
140
141-- | Insert the index in the set ignoring out of range indices.
142have :: PieceIx -> Bitfield -> Bitfield
143have ix Bitfield {..}
144 | 0 <= ix && ix < bfSize = Bitfield bfSize (S.insert ix bfSet)
145 | otherwise = Bitfield bfSize bfSet
146
147singleton :: PieceIx -> PieceCount -> Bitfield
148singleton ix pc = have ix (haveNone pc)
149
150-- | Assign new size to bitfield. FIXME Normally, size should be only
151-- decreased, otherwise exception raised.
152adjustSize :: PieceCount -> Bitfield -> Bitfield
153adjustSize s Bitfield {..} = Bitfield s bfSet
154
155-- | NOTE: for internal use only
156interval :: PieceCount -> PieceIx -> PieceIx -> Bitfield
157interval 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.
164null :: Bitfield -> Bool
165null Bitfield {..} = S.null bfSet
166
167-- | Test if bitfield have all pieces.
168full :: Bitfield -> Bool
169full Bitfield {..} = S.size bfSet == bfSize
170
171-- | Count of peer have pieces.
172haveCount :: Bitfield -> PieceCount
173haveCount = S.size . bfSet
174
175-- | Total count of pieces and its indices.
176totalCount :: Bitfield -> PieceCount
177totalCount = bfSize
178
179-- | Ratio of /have/ piece count to the /total/ piece count.
180--
181-- > forall bf. 0 <= completeness bf <= 1
182--
183completeness :: Bitfield -> Ratio PieceCount
184completeness b = haveCount b % totalCount b
185
186inRange :: PieceIx -> Bitfield -> Bool
187inRange ix Bitfield {..} = 0 <= ix && ix < bfSize
188
189member :: PieceIx -> Bitfield -> Bool
190member ix bf @ Bitfield {..}
191 | ix `inRange` bf = ix `S.member` bfSet
192 | otherwise = False
193
194notMember :: PieceIx -> Bitfield -> Bool
195notMember ix bf @ Bitfield {..}
196 | ix `inRange` bf = ix `S.notMember` bfSet
197 | otherwise = True
198
199-- | Find first available piece index.
200findMin :: Bitfield -> PieceIx
201findMin = S.findMin . bfSet
202{-# INLINE findMin #-}
203
204-- | Find last available piece index.
205findMax :: Bitfield -> PieceIx
206findMax = S.findMax . bfSet
207{-# INLINE findMax #-}
208
209-- | Check if all pieces from first bitfield present if the second bitfield
210isSubsetOf :: Bitfield -> Bitfield -> Bool
211isSubsetOf a b = bfSet a `S.isSubsetOf` bfSet b
212{-# INLINE isSubsetOf #-}
213
214-- | Resulting bitfield includes only missing pieces.
215complement :: Bitfield -> Bitfield
216complement 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.
231type Frequency = Int
232
233-- TODO rename to availability
234-- | How many times each piece index occur in the given bitfield set.
235frequencies :: [Bitfield] -> Vector Frequency
236frequencies [] = V.fromList []
237frequencies 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'.
252rarest :: [Bitfield] -> Maybe PieceIx
253rarest 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
272insert :: PieceIx -> Bitfield -> Bitfield
273insert 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.
281union :: Bitfield -> Bitfield -> Bitfield
282union 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.
288intersection :: Bitfield -> Bitfield -> Bitfield
289intersection 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.
295difference :: Bitfield -> Bitfield -> Bitfield
296difference 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.
302unions :: [Bitfield] -> Bitfield
303unions = {-# SCC unions #-} foldl' union (haveNone 0)
304
305{-----------------------------------------------------------------------
306 Serialization
307-----------------------------------------------------------------------}
308
309-- | List all /have/ indexes.
310toList :: Bitfield -> [PieceIx]
311toList Bitfield {..} = S.toList bfSet
312
313-- | Make bitfield from list of /have/ indexes.
314fromList :: PieceCount -> [PieceIx] -> Bitfield
315fromList 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'.
322fromBitmap :: ByteString -> Bitfield
323fromBitmap 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.
330toBitmap :: Bitfield -> Lazy.ByteString
331toBitmap 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
341type 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
347selector :: 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.
353selector 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
359data StartegyClass
360 = SCBeginning
361 | SCReady
362 | SCEnd
363 deriving (Show, Eq, Ord, Enum, Bounded)
364
365
366strategyClass :: Ratio PieceCount -> Bitfield -> StartegyClass
367strategyClass 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.
377strictFirst :: Selector
378strictFirst h a _ = Just $ findMin (difference a h)
379
380-- | Select the last available piece.
381strictLast :: Selector
382strictLast h a _ = Just $ findMax (difference a h)
383
384-- |
385rarestFirst :: Selector
386rarestFirst 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.
392randomFirst :: Selector
393randomFirst = do
394-- randomIO
395 error "randomFirst"
396
397endGame :: Selector
398endGame = 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
69import Text.PrettyPrint as PP hiding ((<>)) 69import Text.PrettyPrint as PP hiding ((<>))
70import Text.PrettyPrint.Class 70import Text.PrettyPrint.Class
71 71
72import Data.Torrent.Piece 72import 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)
112import Control.Exception 112import Control.Exception
113import Control.Monad.Reader 113import Control.Monad.Reader
114import Control.Monad.State 114import Control.Monad.State
115import Control.Monad.Trans.Resource
115import Control.Lens 116import Control.Lens
116import Data.ByteString as BS 117import Data.ByteString as BS
117import Data.ByteString.Lazy as BSL 118import Data.ByteString.Lazy as BSL
@@ -135,10 +136,10 @@ import Text.Show.Functions ()
135import System.Log.FastLogger (ToLogStr(..)) 136import System.Log.FastLogger (ToLogStr(..))
136import System.Timeout 137import System.Timeout
137 138
138import Data.Torrent.Bitfield as BF 139import Data.Torrent
139import Data.Torrent.InfoHash 140import Network.BitTorrent.Address
140import Network.BitTorrent.Core 141import Network.BitTorrent.Exchange.Bitfield as BF
141import Network.BitTorrent.Exchange.Message as Msg 142import 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 #-}
14module 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
31import Control.Applicative
32import Control.Concurrent
33import Control.Lens
34import Control.Monad.State
35import Data.BEncode as BE
36import Data.ByteString as BS
37import Data.ByteString.Lazy as BL
38import Data.Default
39import Data.List as L
40import Data.Maybe
41import Data.Map as M
42import Data.Tuple
43
44import Data.Torrent as Torrent
45import Network.BitTorrent.Address
46import Network.BitTorrent.Exchange.Bitfield as BF
47import Network.BitTorrent.Exchange.Block as Block
48import Network.BitTorrent.Exchange.Message as Msg
49import System.Torrent.Storage (Storage, writePiece)
50
51
52{-----------------------------------------------------------------------
53-- Class
54-----------------------------------------------------------------------}
55
56type Updates s a = StateT s IO a
57
58runDownloadUpdates :: MVar s -> Updates s a -> IO a
59runDownloadUpdates var m = modifyMVar var (fmap swap . runStateT m)
60
61class 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
95data MetadataDownload = MetadataDownload
96 { _pendingPieces :: [(PeerAddr IP, PieceIx)]
97 , _bucket :: Bucket
98 , _topic :: InfoHash
99 }
100
101makeLenses ''MetadataDownload
102
103-- | Create a new scheduler for infodict of the given size.
104metadataDownload :: Int -> InfoHash -> MetadataDownload
105metadataDownload ps = MetadataDownload [] (Block.empty ps)
106
107instance Default MetadataDownload where
108 def = error "instance Default MetadataDownload"
109
110--cancelPending :: PieceIx -> Updates ()
111cancelPending pix = pendingPieces %= L.filter ((pix ==) . snd)
112
113instance 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
194data PieceEntry = PieceEntry
195 { pending :: [(PeerAddr IP, BlockIx)]
196 , stalled :: Bucket
197 }
198
199pieceEntry :: PieceSize -> PieceEntry
200pieceEntry s = PieceEntry [] (Block.empty s)
201
202isEmpty :: PieceEntry -> Bool
203isEmpty 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
210data ContentDownload = ContentDownload
211 { inprogress :: !(Map PieceIx PieceEntry)
212 , bitfield :: !Bitfield
213 , pieceSize :: !PieceSize
214 , contentStorage :: Storage
215 }
216
217contentDownload :: Bitfield -> PieceSize -> Storage -> ContentDownload
218contentDownload = ContentDownload M.empty
219
220--modifyEntry :: PieceIx -> (PieceEntry -> PieceEntry) -> DownloadUpdates ()
221modifyEntry 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
229instance 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
12import Data.Default 12import Data.Default
13import Network.Socket 13import Network.Socket
14 14
15import Data.Torrent.InfoHash 15import Data.Torrent
16import Network.BitTorrent.Core 16import Network.BitTorrent.Address
17import Network.BitTorrent.Exchange.Connection hiding (Options) 17import Network.BitTorrent.Exchange.Connection hiding (Options)
18import Network.BitTorrent.Exchange.Session 18import 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)
117import Text.PrettyPrint as PP hiding ((<>)) 117import Text.PrettyPrint as PP hiding ((<>))
118import Text.PrettyPrint.Class 118import Text.PrettyPrint.Class
119 119
120import Data.Torrent.Bitfield 120import Data.Torrent hiding (Piece (..))
121import Data.Torrent.InfoHash 121import qualified Data.Torrent as P (Piece (..))
122import qualified Data.Torrent.Piece as P 122import Network.BitTorrent.Address
123import Network.BitTorrent.Core 123import Network.BitTorrent.Exchange.Bitfield
124import Network.BitTorrent.Exchange.Block 124import 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.
867metadataPieceSize :: P.PieceSize 867metadataPieceSize :: PieceSize
868metadataPieceSize = 16 * 1024 868metadataPieceSize = 16 * 1024
869 869
870isLastPiece :: P.Piece a -> Int -> Bool 870isLastPiece :: 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.
878isValidPiece :: P.Piece BL.ByteString -> Int -> Bool 878isValidPiece :: P.Piece BL.ByteString -> Int -> Bool
879isValidPiece p @ P.Piece {..} total 879isValidPiece 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
883setMetadataPayload :: BS.ByteString -> ExtendedMetadata -> ExtendedMetadata 883setMetadataPayload :: BS.ByteString -> ExtendedMetadata -> ExtendedMetadata
884setMetadataPayload bs (MetadataData (P.Piece pix _) t) = 884setMetadataPayload 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--
10module 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
23import Data.Ratio
24
25import Data.Torrent.Bitfield
26
27
28type 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
34selector :: 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.
40selector 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
46data StartegyClass
47 = SCBeginning
48 | SCReady
49 | SCEnd
50 deriving (Show, Eq, Ord, Enum, Bounded)
51
52
53strategyClass :: Ratio PieceCount -> Bitfield -> StartegyClass
54strategyClass 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.
64strictFirst :: Selector
65strictFirst h a _ = Just $ findMin (difference a h)
66
67-- | Select the last available piece.
68strictLast :: Selector
69strictLast h a _ = Just $ findMax (difference a h)
70
71-- |
72rarestFirst :: Selector
73rarestFirst 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.
79randomFirst :: Selector
80randomFirst = do
81-- randomIO
82 error "randomFirst"
83
84endGame :: Selector
85endGame = 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
45import System.Log.FastLogger (LogStr, ToLogStr (..)) 45import System.Log.FastLogger (LogStr, ToLogStr (..))
46 46
47import Data.BEncode as BE 47import Data.BEncode as BE
48import Data.Torrent (InfoDict (..)) 48import Data.Torrent as Torrent
49import Data.Torrent.Bitfield as BF
50import Data.Torrent.InfoHash
51import Data.Torrent.Piece
52import qualified Data.Torrent.Piece as Torrent (Piece ())
53import Network.BitTorrent.Internal.Types 49import Network.BitTorrent.Internal.Types
54import Network.BitTorrent.Core 50import Network.BitTorrent.Address
51import Network.BitTorrent.Exchange.Bitfield as BF
55import Network.BitTorrent.Exchange.Block as Block 52import Network.BitTorrent.Exchange.Block as Block
56import Network.BitTorrent.Exchange.Connection 53import Network.BitTorrent.Exchange.Connection
54import Network.BitTorrent.Exchange.Download as D
57import Network.BitTorrent.Exchange.Message as Message 55import Network.BitTorrent.Exchange.Message as Message
58import Network.BitTorrent.Exchange.Session.Metadata as Metadata
59import Network.BitTorrent.Exchange.Session.Status as SS
60import System.Torrent.Storage 56import System.Torrent.Storage
61 57
62{----------------------------------------------------------------------- 58{-----------------------------------------------------------------------
@@ -93,13 +89,13 @@ type LogFun = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
93 89
94data SessionState 90data 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
109newSessionState rootPath (Right dict) = do 105newSessionState 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
115closeSessionState :: SessionState -> IO () 112closeSessionState :: SessionState -> IO ()
@@ -119,8 +116,9 @@ closeSessionState HavingMetadata {..} = close contentStorage
119haveMetadata :: InfoDict -> SessionState -> IO SessionState 116haveMetadata :: InfoDict -> SessionState -> IO SessionState
120haveMetadata dict WaitingMetadata {..} = do 117haveMetadata 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 #-}
2module 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
18import Control.Concurrent
19import Control.Lens
20import Control.Monad.Reader
21import Control.Monad.State
22import Data.ByteString as BS
23import Data.ByteString.Lazy as BL
24import Data.Default
25import Data.List as L
26import Data.Tuple
27
28import Data.BEncode as BE
29import Data.Torrent
30import Data.Torrent.InfoHash
31import Data.Torrent.Piece as Torrent
32import Network.BitTorrent.Core
33import Network.BitTorrent.Exchange.Block as Block
34import Network.BitTorrent.Exchange.Message as Message hiding (Status)
35
36
37-- | Current transfer status.
38data Status = Status
39 { _pending :: [(PeerAddr IP, PieceIx)]
40 , _bucket :: Bucket
41 }
42
43makeLenses ''Status
44
45instance Default Status where
46 def = error "default status"
47
48-- | Create a new scheduler for infodict of the given size.
49nullStatus :: Int -> Status
50nullStatus ps = Status [] (Block.empty ps)
51
52type Updates = ReaderT (PeerAddr IP) (State Status)
53
54runUpdates :: MVar Status -> PeerAddr IP -> Updates a -> IO a
55runUpdates v a m = modifyMVar v (return . swap . runState (runReaderT m a))
56
57scheduleBlock :: Updates (Maybe PieceIx)
58scheduleBlock = 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
68cancelPending :: PieceIx -> Updates ()
69cancelPending pix = pending %= L.filter ((pix ==) . snd)
70
71resetPending :: Updates ()
72resetPending = do
73 addr <- ask
74 pending %= L.filter ((addr ==) . fst)
75
76parseInfoDict :: BS.ByteString -> InfoHash -> Result InfoDict
77parseInfoDict 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
85pushBlock :: Torrent.Piece BS.ByteString -> InfoHash -> Updates (Maybe InfoDict)
86pushBlock 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 @@
1module 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
20import Control.Applicative
21import Control.Concurrent
22import Control.Monad.State
23import Data.ByteString.Lazy as BL
24import Data.Default
25import Data.List as L
26import Data.Maybe
27import Data.Map as M
28import Data.Set as S
29import Data.Tuple
30
31import Data.Torrent.Piece
32import Data.Torrent.Bitfield as BF
33import Network.BitTorrent.Core
34import Network.BitTorrent.Exchange.Block as Block
35import System.Torrent.Storage (Storage, writePiece)
36
37
38{-----------------------------------------------------------------------
39-- Piece entry
40-----------------------------------------------------------------------}
41
42data PieceEntry = PieceEntry
43 { pending :: [(PeerAddr IP, BlockIx)]
44 , stalled :: Bucket
45 }
46
47pieceEntry :: PieceSize -> PieceEntry
48pieceEntry s = PieceEntry [] (Block.empty s)
49
50isEmpty :: PieceEntry -> Bool
51isEmpty PieceEntry {..} = L.null pending && Block.null stalled
52
53holes :: PieceIx -> PieceEntry -> [BlockIx]
54holes pix PieceEntry {..} = fmap mkBlockIx (spans defaultTransferSize stalled)
55 where
56 mkBlockIx (off, sz) = BlockIx pix off sz
57
58{-----------------------------------------------------------------------
59-- Session status
60-----------------------------------------------------------------------}
61
62data SessionStatus = SessionStatus
63 { inprogress :: !(Map PieceIx PieceEntry)
64 , bitfield :: !Bitfield
65 , pieceSize :: !PieceSize
66 }
67
68sessionStatus :: Bitfield -> PieceSize -> SessionStatus
69sessionStatus bf ps = SessionStatus
70 { inprogress = M.empty
71 , bitfield = bf
72 , pieceSize = ps
73 }
74
75type StatusUpdates a = StateT SessionStatus IO a
76
77-- |
78runStatusUpdates :: MVar SessionStatus -> StatusUpdates a -> IO a
79runStatusUpdates var m = modifyMVar var (fmap swap . runStateT m)
80
81getBitfield :: MVar SessionStatus -> IO Bitfield
82getBitfield var = bitfield <$> readMVar var
83
84getRequestQueueLength :: PeerAddr IP -> StatusUpdates Int
85getRequestQueueLength 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
89modifyEntry :: PieceIx -> (PieceEntry -> PieceEntry) -> StatusUpdates ()
90modifyEntry 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
104chooseBlocks :: [BlockIx] -> Int -> StatusUpdates [BlockIx]
105chooseBlocks xs n = return (L.take n xs)
106
107-- TODO use selection strategies from Exchange.Selector
108choosePiece :: Bitfield -> StatusUpdates (Maybe PieceIx)
109choosePiece bf
110 | BF.null bf = return $ Nothing
111 | otherwise = return $ Just $ BF.findMin bf
112
113scheduleBlocks :: PeerAddr IP -> Bitfield -> Int -> StatusUpdates [BlockIx]
114scheduleBlocks 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--
144resetPending :: PeerAddr IP -> StatusUpdates ()
145resetPending 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.
151pushBlock :: Block BL.ByteString -> Storage -> StatusUpdates (Maybe Bool)
152pushBlock 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 #-}
16module 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
37import Control.Applicative
38import Control.Lens hiding ((%=))
39import Data.ByteString.Lazy.Builder as BS
40import Data.ByteString.Lazy.Builder.ASCII as BS
41import Data.Default
42import Data.Monoid
43import Data.Serialize as S
44import Data.Ratio
45import Data.Word
46import Network.HTTP.Types.QueryLike
47import Text.PrettyPrint as PP
48import 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--
56data 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.
65instance 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
76instance Default Progress where
77 def = Progress 0 0 0
78 {-# INLINE def #-}
79
80-- | Can be used to aggregate total progress.
81instance 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
92instance QueryValueLike Builder where
93 toQueryValue = toQueryValue . BS.toLazyByteString
94
95instance QueryValueLike Word64 where
96 toQueryValue = toQueryValue . BS.word64Dec
97
98-- | HTTP Tracker protocol compatible encoding.
99instance QueryLike Progress where
100 toQuery Progress {..} =
101 [ ("uploaded" , toQueryValue _uploaded)
102 , ("left" , toQueryValue _left)
103 , ("downloaded", toQueryValue _downloaded)
104 ]
105
106instance 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--
118startProgress :: Integer -> Progress
119startProgress = Progress 0 0 . fromIntegral
120{-# INLINE startProgress #-}
121
122-- | Used when the client download some data from /any/ peer.
123downloadedProgress :: Int -> Progress -> Progress
124downloadedProgress (fromIntegral -> amount)
125 = (left -~ amount)
126 . (downloaded +~ amount)
127{-# INLINE downloadedProgress #-}
128
129-- | Used when the client upload some data to /any/ peer.
130uploadedProgress :: Int -> Progress -> Progress
131uploadedProgress (fromIntegral -> amount) = uploaded +~ amount
132{-# INLINE uploadedProgress #-}
133
134-- | Used when leecher join client session.
135enqueuedProgress :: Integer -> Progress -> Progress
136enqueuedProgress amount = left +~ fromIntegral amount
137{-# INLINE enqueuedProgress #-}
138
139-- | Used when leecher leave client session.
140-- (e.g. user deletes not completed torrent)
141dequeuedProgress :: Integer -> Progress -> Progress
142dequeuedProgress amount = left -~ fromIntegral amount
143{-# INLINE dequeuedProgress #-}
144
145ri2rw64 :: Ratio Int -> Ratio Word64
146ri2rw64 x = fromIntegral (numerator x) % fromIntegral (denominator x)
147
148-- | Check global /download/ limit by uploaded \/ downloaded ratio.
149canDownload :: Ratio Int -> Progress -> Bool
150canDownload limit Progress {..} = _uploaded % _downloaded > ri2rw64 limit
151
152-- | Check global /upload/ limit by downloaded \/ uploaded ratio.
153canUpload :: Ratio Int -> Progress -> Bool
154canUpload 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
124import System.Entropy 124import System.Entropy
125import Text.Read (readMaybe) 125import Text.Read (readMaybe)
126 126
127import Data.Torrent.InfoHash 127import Data.Torrent
128import Data.Torrent.Progress 128import Network.BitTorrent.Address
129import Network.BitTorrent.Core 129import 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
36import Network.URI 36import Network.URI
37import Network.Socket (HostAddress) 37import Network.Socket (HostAddress)
38 38
39import Data.Torrent.InfoHash 39import Data.Torrent
40import Data.Torrent.Progress 40import Network.BitTorrent.Address
41import Network.BitTorrent.Core 41import Network.BitTorrent.Internal.Progress
42import Network.BitTorrent.Tracker.Message 42import Network.BitTorrent.Tracker.Message
43import qualified Network.BitTorrent.Tracker.RPC.HTTP as HTTP 43import qualified Network.BitTorrent.Tracker.RPC.HTTP as HTTP
44import qualified Network.BitTorrent.Tracker.RPC.UDP as UDP 44import 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
47import Network.HTTP.Types.Header (hUserAgent) 47import Network.HTTP.Types.Header (hUserAgent)
48import Network.HTTP.Types.URI (SimpleQuery, renderSimpleQuery) 48import Network.HTTP.Types.URI (SimpleQuery, renderSimpleQuery)
49 49
50import Data.Torrent.InfoHash (InfoHash) 50import Data.Torrent (InfoHash)
51import Network.BitTorrent.Core.Fingerprint (libUserAgent) 51import Network.BitTorrent.Address (libUserAgent)
52import Network.BitTorrent.Tracker.Message hiding (Request, Response) 52import 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
57import Data.Traversable 57import Data.Traversable
58import Network.URI 58import Network.URI
59 59
60import Data.Torrent.InfoHash 60import Data.Torrent
61import Network.BitTorrent.Core 61import Network.BitTorrent.Address
62import Network.BitTorrent.Internal.Cache 62import Network.BitTorrent.Internal.Cache
63import Network.BitTorrent.Internal.Types 63import Network.BitTorrent.Internal.Types
64import Network.BitTorrent.Tracker.List as TL 64import Network.BitTorrent.Tracker.List as TL