summaryrefslogtreecommitdiff
path: root/src/Network/BitTorrent/Peer.hs
diff options
context:
space:
mode:
authorSam Truzjan <pxqr.sta@gmail.com>2013-11-20 22:01:34 +0400
committerSam Truzjan <pxqr.sta@gmail.com>2013-11-20 22:01:34 +0400
commitcdd1782b0d55ed0119ac905904437ab8209f7cf2 (patch)
tree54dfd5d6fe0fe4de32c964718e8ae3859d42b46e /src/Network/BitTorrent/Peer.hs
parentc45c87c587046fcc7f2656bc1eb7302286c0ef96 (diff)
Refactor Network.BitTorrent.Peer module
Diffstat (limited to 'src/Network/BitTorrent/Peer.hs')
-rw-r--r--src/Network/BitTorrent/Peer.hs661
1 files changed, 0 insertions, 661 deletions
diff --git a/src/Network/BitTorrent/Peer.hs b/src/Network/BitTorrent/Peer.hs
deleted file mode 100644
index f2148eda..00000000
--- a/src/Network/BitTorrent/Peer.hs
+++ /dev/null
@@ -1,661 +0,0 @@
1-- |
2-- Copyright : (c) Sam Truzjan 2013
3-- License : BSD3
4-- Maintainer : pxqr.sta@gmail.com
5-- Stability : experimental
6-- Portability : non-portable
7--
8-- This modules provides three datatypes related to a peer as a host:
9--
10-- * 'PeerID' represent self assigned peer identificator. Ideally
11-- each host in the network should have unique peer id to avoid
12-- collisions, therefor for peer ID generation we use good entropy
13-- source. (FIX not really) Peer ID is sent in /tracker request/,
14-- sent and received in /peer handshakes/ and used in /distributed
15-- hash table/ queries.
16--
17-- * 'PeerAddr' is used to represent peer location. Currently it's
18-- just peer IP and peer port but this might be changed later.
19--
20-- * 'ClientInfo' is used to identify the client implementation and
21-- version which also contained in 'Peer'. For exsample first
22-- 6 bytes of peer id of this this library are @-HS0100-@ while
23-- for mainline we have @M4-3-6--@.
24-- We could extract this info and print in human frienly form: this
25-- is useful for debugging and logging. For more information see:
26-- <http://bittorrent.org/beps/bep_0020.html>
27-- NOTE: Do _not_ use this information to control client
28-- capabilities (such as supported enchancements), this should be
29-- done using 'Network.BitTorrent.Extension'!
30--
31{-# LANGUAGE ViewPatterns #-}
32{-# LANGUAGE GeneralizedNewtypeDeriving #-}
33{-# LANGUAGE StandaloneDeriving #-}
34{-# LANGUAGE TemplateHaskell #-}
35{-# OPTIONS -fno-warn-orphans #-}
36module Network.BitTorrent.Peer
37 ( -- * Peer identificators
38 PeerId (getPeerId), ppPeerId
39
40 -- ** Encoding styles
41 , azureusStyle, shadowStyle
42
43 -- ** Defaults
44 , defaultClientId, defaultVersionNumber
45
46 -- ** Generation
47 , genPeerId
48 , timestamp, entropy
49
50 -- ** Extra
51 , byteStringPadded
52
53 -- * Peer address
54 , PeerAddr(..)
55 , getCompactPeerList
56 , peerSockAddr
57 , connectToPeer
58 , ppPeer
59
60 -- * Peer progress
61 , Progress (..)
62 , left
63 , uploaded
64 , downloaded
65
66 , startProgress
67
68 , downloadedProgress
69 , enqueuedProgress
70 , uploadedProgress
71 , dequeuedProgress
72
73 -- * Client version detection
74 -- ** Info
75 , ClientInfo(..), clientInfo, ppClientInfo, unknownClient
76
77 -- ** Version
78 , ClientVersion, ppClientVersion
79
80 -- ** Implementation
81 , ClientImpl(..), ppClientImpl
82
83 ) where
84
85
86import Control.Applicative
87import Control.Lens
88import Data.Aeson
89import Data.Aeson.TH
90import Data.BEncode
91import Data.Bits
92import Data.ByteString (ByteString)
93import qualified Data.ByteString as B
94import qualified Data.ByteString.Char8 as BC
95import qualified Data.ByteString.Lazy as BL
96import qualified Data.ByteString.Lazy.Builder as B
97import Data.Char
98import Data.List as L
99import Data.Word
100import Data.Foldable (foldMap)
101import Data.Monoid ((<>))
102import Data.Serialize
103import Data.URLEncoded
104import Data.Version (Version(Version), versionBranch)
105import Data.Time.Clock (getCurrentTime)
106import Data.Time.Format (formatTime)
107import Text.PrettyPrint (text, Doc, (<+>))
108import System.Locale (defaultTimeLocale)
109import System.Entropy (getEntropy)
110import Network hiding (accept)
111import Network.Socket
112
113
114-- TODO we have linker error here, so manually hardcoded version for a
115-- while.
116
117-- import Paths_network_bittorrent (version)
118
119version :: Version
120version = Version [0, 10, 0, 0] []
121
122{-----------------------------------------------------------------------
123 Peer identification
124-----------------------------------------------------------------------}
125
126-- | Peer identifier is exactly 20 bytes long bytestring.
127newtype PeerId = PeerId { getPeerId :: ByteString }
128 deriving (Show, Eq, Ord, BEncodable, ToJSON, FromJSON)
129
130instance Serialize PeerId where
131 put = putByteString . getPeerId
132 get = PeerId <$> getBytes 20
133
134instance URLShow PeerId where
135 urlShow = BC.unpack . getPeerId
136
137-- | Format peer id in human readable form.
138ppPeerId :: PeerId -> Doc
139ppPeerId = text . BC.unpack . getPeerId
140
141
142-- | Azureus-style encoding have the following layout:
143--
144-- * 1 byte : '-'
145--
146-- * 2 bytes: client id
147--
148-- * 4 bytes: version number
149--
150-- * 1 byte : '-'
151--
152-- * 12 bytes: random number
153--
154azureusStyle :: ByteString -- ^ 2 character client ID, padded with 'H'.
155 -> ByteString -- ^ Version number, padded with 'X'.
156 -> ByteString -- ^ Random number, padded with '0'.
157 -> PeerId -- ^ Azureus-style encoded peer ID.
158azureusStyle cid ver rnd = PeerId $ BL.toStrict $ B.toLazyByteString $
159 B.char8 '-' <>
160 byteStringPadded cid 2 'H' <>
161 byteStringPadded ver 4 'X' <>
162 B.char8 '-' <>
163 byteStringPadded rnd 12 '0'
164
165-- | Shadow-style encoding have the following layout:
166--
167-- * 1 byte : client id.
168--
169-- * 0-4 bytes: version number. If less than 4 then padded with
170-- '-' char.
171--
172-- * 15 bytes : random number. If length is less than 15 then
173-- padded with '0' char.
174--
175shadowStyle :: Char -- ^ Client ID.
176 -> ByteString -- ^ Version number.
177 -> ByteString -- ^ Random number.
178 -> PeerId -- ^ Shadow style encoded peer ID.
179shadowStyle cid ver rnd = PeerId $ BL.toStrict $ B.toLazyByteString $
180 B.char8 cid <>
181 byteStringPadded ver 4 '-' <>
182 byteStringPadded rnd 15 '0'
183
184
185-- | "HS" - 2 bytes long client identifier.
186defaultClientId :: ByteString
187defaultClientId = "HS"
188
189-- | Gives exactly 4 bytes long version number for any version of the
190-- package. Version is taken from .cabal.
191defaultVersionNumber :: ByteString
192defaultVersionNumber = B.take 4 $ BC.pack $ foldMap show $
193 versionBranch version
194
195-- | Gives 15 characters long decimal timestamp such that:
196--
197-- * 6 bytes : first 6 characters from picoseconds obtained with %q.
198--
199-- * 1 bytes : character '.' for readability.
200--
201-- * 9..* bytes: number of whole seconds since the Unix epoch
202-- (!)REVERSED.
203--
204-- Can be used both with shadow and azureus style encoding. This
205-- format is used to make the ID's readable(for debugging) and more
206-- or less random.
207--
208timestamp :: IO ByteString
209timestamp = (BC.pack . format) <$> getCurrentTime
210 where
211 format t = take 6 (formatTime defaultTimeLocale "%q" t) ++ "." ++
212 take 9 (reverse (formatTime defaultTimeLocale "%s" t))
213
214-- | Gives 15 character long random bytestring. This is more robust
215-- method for generation of random part of peer ID than timestamp.
216entropy :: IO ByteString
217entropy = getEntropy 15
218
219-- NOTE: entropy generates incorrrect peer id
220
221-- | Here we use Azureus-style encoding with the following args:
222--
223-- * 'HS' for the client id.
224--
225-- * Version of the package for the version number
226--
227-- * UTC time day ++ day time for the random number.
228--
229genPeerId :: IO PeerId
230genPeerId = azureusStyle defaultClientId defaultVersionNumber <$> timestamp
231
232-- | Pad bytestring so it's becomes exactly request length. Conversion
233-- is done like so:
234--
235-- * length < size: Complete bytestring by given charaters.
236--
237-- * length = size: Output bytestring as is.
238--
239-- * length > size: Drop last (length - size) charaters from a
240-- given bytestring.
241--
242byteStringPadded :: ByteString -- ^ bytestring to be padded.
243 -> Int -- ^ size of result builder.
244 -> Char -- ^ character used for padding.
245 -> B.Builder
246byteStringPadded bs s c =
247 B.byteString (B.take s bs) <>
248 B.byteString (BC.replicate padLen c)
249 where
250 padLen = s - min (B.length bs) s
251
252
253{-----------------------------------------------------------------------
254 Client detection
255-----------------------------------------------------------------------}
256
257-- | All known client versions.
258data ClientImpl =
259 IUnknown
260 | IAres
261 | IArctic
262 | IAvicora
263 | IBitPump
264 | IAzureus
265 | IBitBuddy
266 | IBitComet
267 | IBitflu
268 | IBTG
269 | IBitRocket
270 | IBTSlave
271 | IBittorrentX
272 | IEnhancedCTorrent
273 | ICTorrent
274 | IDelugeTorrent
275 | IPropagateDataClient
276 | IEBit
277 | IElectricSheep
278 | IFoxTorrent
279 | IGSTorrent
280 | IHalite
281 | IlibHSbittorrent
282 | IHydranode
283 | IKGet
284 | IKTorrent
285 | ILH_ABC
286 | ILphant
287 | ILibtorrent
288 | ILibTorrent
289 | ILimeWire
290 | IMonoTorrent
291 | IMooPolice
292 | IMiro
293 | IMoonlightTorrent
294 | INetTransport
295 | IPando
296 | IqBittorrent
297 | IQQDownload
298 | IQt4TorrentExample
299 | IRetriever
300 | IShareaza
301 | ISwiftbit
302 | ISwarmScope
303 | ISymTorrent
304 | Isharktorrent
305 | ITorrentDotNET
306 | ITransmission
307 | ITorrentstorm
308 | ITuoTu
309 | IuLeecher
310 | IuTorrent
311 | IVagaa
312 | IBitLet
313 | IFireTorrent
314 | IXunlei
315 | IXanTorrent
316 | IXtorrent
317 | IZipTorrent
318 deriving (Show, Eq, Ord)
319
320parseImpl :: ByteString -> ClientImpl
321parseImpl = f . BC.unpack
322 where
323 f "AG" = IAres
324 f "A~" = IAres
325 f "AR" = IArctic
326 f "AV" = IAvicora
327 f "AX" = IBitPump
328 f "AZ" = IAzureus
329 f "BB" = IBitBuddy
330 f "BC" = IBitComet
331 f "BF" = IBitflu
332 f "BG" = IBTG
333 f "BR" = IBitRocket
334 f "BS" = IBTSlave
335 f "BX" = IBittorrentX
336 f "CD" = IEnhancedCTorrent
337 f "CT" = ICTorrent
338 f "DE" = IDelugeTorrent
339 f "DP" = IPropagateDataClient
340 f "EB" = IEBit
341 f "ES" = IElectricSheep
342 f "FT" = IFoxTorrent
343 f "GS" = IGSTorrent
344 f "HL" = IHalite
345 f "HS" = IlibHSbittorrent
346 f "HN" = IHydranode
347 f "KG" = IKGet
348 f "KT" = IKTorrent
349 f "LH" = ILH_ABC
350 f "LP" = ILphant
351 f "LT" = ILibtorrent
352 f "lt" = ILibTorrent
353 f "LW" = ILimeWire
354 f "MO" = IMonoTorrent
355 f "MP" = IMooPolice
356 f "MR" = IMiro
357 f "MT" = IMoonlightTorrent
358 f "NX" = INetTransport
359 f "PD" = IPando
360 f "qB" = IqBittorrent
361 f "QD" = IQQDownload
362 f "QT" = IQt4TorrentExample
363 f "RT" = IRetriever
364 f "S~" = IShareaza
365 f "SB" = ISwiftbit
366 f "SS" = ISwarmScope
367 f "ST" = ISymTorrent
368 f "st" = Isharktorrent
369 f "SZ" = IShareaza
370 f "TN" = ITorrentDotNET
371 f "TR" = ITransmission
372 f "TS" = ITorrentstorm
373 f "TT" = ITuoTu
374 f "UL" = IuLeecher
375 f "UT" = IuTorrent
376 f "VG" = IVagaa
377 f "WT" = IBitLet
378 f "WY" = IFireTorrent
379 f "XL" = IXunlei
380 f "XT" = IXanTorrent
381 f "XX" = IXtorrent
382 f "ZT" = IZipTorrent
383 f _ = IUnknown
384
385-- | Format client implementation info in human readable form.
386ppClientImpl :: ClientImpl -> Doc
387ppClientImpl = text . tail . show
388
389-- | Used to represent not recognized implementation
390unknownImpl :: ClientImpl
391unknownImpl = IUnknown
392
393-- TODO use Data.Version
394
395-- | Raw version of client, normally extracted from peer id.
396type ClientVersion = ByteString
397
398-- | Format client implementation version in human readable form.
399ppClientVersion :: ClientVersion -> Doc
400ppClientVersion = text . BC.unpack
401
402unknownVersion :: ClientVersion
403unknownVersion = "0000"
404
405
406-- | All useful infomation that can be obtained from a peer
407-- identifier.
408data ClientInfo = ClientInfo {
409 ciImpl :: ClientImpl
410 , ciVersion :: ClientVersion
411 } deriving (Show, Eq, Ord)
412
413-- | Format client implementation in human readable form.
414ppClientInfo :: ClientInfo -> Doc
415ppClientInfo ClientInfo {..} =
416 ppClientImpl ciImpl <+> "version" <+> ppClientVersion ciVersion
417
418
419-- | Unrecognized client implementation.
420unknownClient :: ClientInfo
421unknownClient = ClientInfo unknownImpl unknownVersion
422
423-- | Tries to extract meaningful information from peer ID bytes. If
424-- peer id uses unknown coding style then client info returned is
425-- 'unknownClient'.
426--
427clientInfo :: PeerId -> ClientInfo
428clientInfo pid = either (const unknownClient) id $
429 runGet getCI (getPeerId pid)
430 where -- TODO other styles
431 getCI = do
432 _ <- getWord8
433 ClientInfo <$> (parseImpl <$> getByteString 2) <*> getByteString 4
434
435
436{-
437-- code used for generation; remove it later on
438
439mkEnumTyDef :: NM -> String
440mkEnumTyDef = unlines . map (" | I" ++) . nub . map snd
441
442mkPars :: NM -> String
443mkPars = unlines . map (\(code, impl) -> " f \"" ++ code ++ "\" = " ++ "I" ++ impl)
444
445type NM = [(String, String)]
446nameMap :: NM
447nameMap =
448 [ ("AG", "Ares")
449 , ("A~", "Ares")
450 , ("AR", "Arctic")
451 , ("AV", "Avicora")
452 , ("AX", "BitPump")
453 , ("AZ", "Azureus")
454 , ("BB", "BitBuddy")
455 , ("BC", "BitComet")
456 , ("BF", "Bitflu")
457 , ("BG", "BTG")
458 , ("BR", "BitRocket")
459 , ("BS", "BTSlave")
460 , ("BX", "BittorrentX")
461 , ("CD", "EnhancedCTorrent")
462 , ("CT", "CTorrent")
463 , ("DE", "DelugeTorrent")
464 , ("DP", "PropagateDataClient")
465 , ("EB", "EBit")
466 , ("ES", "ElectricSheep")
467 , ("FT", "FoxTorrent")
468 , ("GS", "GSTorrent")
469 , ("HL", "Halite")
470 , ("HS", "libHSnetwork_bittorrent")
471 , ("HN", "Hydranode")
472 , ("KG", "KGet")
473 , ("KT", "KTorrent")
474 , ("LH", "LH_ABC")
475 , ("LP", "Lphant")
476 , ("LT", "Libtorrent")
477 , ("lt", "LibTorrent")
478 , ("LW", "LimeWire")
479 , ("MO", "MonoTorrent")
480 , ("MP", "MooPolice")
481 , ("MR", "Miro")
482 , ("MT", "MoonlightTorrent")
483 , ("NX", "NetTransport")
484 , ("PD", "Pando")
485 , ("qB", "qBittorrent")
486 , ("QD", "QQDownload")
487 , ("QT", "Qt4TorrentExample")
488 , ("RT", "Retriever")
489 , ("S~", "Shareaza")
490 , ("SB", "Swiftbit")
491 , ("SS", "SwarmScope")
492 , ("ST", "SymTorrent")
493 , ("st", "sharktorrent")
494 , ("SZ", "Shareaza")
495 , ("TN", "TorrentDotNET")
496 , ("TR", "Transmission")
497 , ("TS", "Torrentstorm")
498 , ("TT", "TuoTu")
499 , ("UL", "uLeecher")
500 , ("UT", "uTorrent")
501 , ("VG", "Vagaa")
502 , ("WT", "BitLet")
503 , ("WY", "FireTorrent")
504 , ("XL", "Xunlei")
505 , ("XT", "XanTorrent")
506 , ("XX", "Xtorrent")
507 , ("ZT", "ZipTorrent")
508 ]
509-}
510
511{-----------------------------------------------------------------------
512 Peer address
513-----------------------------------------------------------------------}
514deriving instance ToJSON PortNumber
515deriving instance FromJSON PortNumber
516
517instance BEncodable PortNumber where
518 toBEncode = toBEncode . fromEnum
519 fromBEncode b = toEnum <$> fromBEncode b
520
521instance Serialize PortNumber where
522 get = fromIntegral <$> getWord16be
523 {-# INLINE get #-}
524 put = putWord16be . fromIntegral
525 {-# INLINE put #-}
526
527-- TODO check semantic of ord and eq instances
528
529
530-- | Peer address info normally extracted from peer list or peer
531-- compact list encoding.
532data PeerAddr = PeerAddr {
533 peerID :: Maybe PeerId
534 , peerIP :: {-# UNPACK #-} !HostAddress
535 , peerPort :: {-# UNPACK #-} !PortNumber
536 } deriving (Show, Eq, Ord)
537
538$(deriveJSON (L.map toLower . L.dropWhile isLower) ''PeerAddr)
539
540instance BEncodable PeerAddr where
541 toBEncode (PeerAddr pid pip pport) = fromAssocs
542 [ "peer id" -->? pid
543 , "ip" --> pip
544 , "port" --> pport
545 ]
546
547 fromBEncode (BDict d) =
548 PeerAddr <$> d >--? "peer id"
549 <*> d >-- "ip"
550 <*> d >-- "port"
551
552 fromBEncode _ = decodingError "PeerAddr"
553
554instance Serialize PeerAddr where
555 put PeerAddr {..} = put peerID >> put peerPort
556 {-# INLINE put #-}
557 get = PeerAddr Nothing <$> get <*> get
558 {-# INLINE get #-}
559
560getCompactPeerList :: Get [PeerAddr]
561getCompactPeerList = many get
562
563-- TODO make platform independent, clarify htonl
564
565-- | Convert peer info from tracker response to socket address. Used
566-- for establish connection between peers.
567--
568peerSockAddr :: PeerAddr -> SockAddr
569peerSockAddr = SockAddrInet <$> (g . peerPort) <*> (htonl . peerIP)
570 where
571 htonl :: Word32 -> Word32
572 htonl d =
573 ((d .&. 0xff) `shiftL` 24) .|.
574 (((d `shiftR` 8 ) .&. 0xff) `shiftL` 16) .|.
575 (((d `shiftR` 16) .&. 0xff) `shiftL` 8) .|.
576 ((d `shiftR` 24) .&. 0xff)
577
578 g :: PortNumber -> PortNumber
579 g = id
580
581-- | Tries to connect to peer using reasonable default parameters.
582connectToPeer :: PeerAddr -> IO Socket
583connectToPeer p = do
584 sock <- socket AF_INET Stream Network.Socket.defaultProtocol
585 connect sock (peerSockAddr p)
586 return sock
587
588-- | Pretty print peer address in human readable form.
589ppPeer :: PeerAddr -> Doc
590ppPeer p @ PeerAddr {..} = case peerID of
591 Just pid -> ppClientInfo (clientInfo pid) <+> "at" <+> paddr
592 Nothing -> paddr
593 where
594 paddr = text (show (peerSockAddr p))
595
596{-----------------------------------------------------------------------
597 Progress
598-----------------------------------------------------------------------}
599
600-- TODO: Use Word64?
601-- TODO: Use atomic bits?
602
603-- | 'Progress' contains upload/download/left stats about
604-- current client state and used to notify the tracker.
605--
606-- Progress data is considered as dynamic within one client
607-- session. This data also should be shared across client application
608-- sessions (e.g. files), otherwise use 'startProgress' to get initial
609-- 'Progress'.
610--
611data Progress = Progress
612 { _downloaded :: !Integer -- ^ Total amount of bytes downloaded;
613 , _left :: !Integer -- ^ Total amount of bytes left;
614 , _uploaded :: !Integer -- ^ Total amount of bytes uploaded.
615 } deriving (Show, Read, Eq)
616
617$(makeLenses ''Progress)
618$(deriveJSON (L.tail) ''Progress)
619
620instance Serialize Progress where
621 put Progress {..} = do
622 putWord64be $ fromIntegral _downloaded
623 putWord64be $ fromIntegral _left
624 putWord64be $ fromIntegral _uploaded
625
626 get = Progress
627 <$> (fromIntegral <$> getWord64be)
628 <*> (fromIntegral <$> getWord64be)
629 <*> (fromIntegral <$> getWord64be)
630
631-- | Initial progress is used when there are no session before.
632--
633-- Please note that tracker might penalize client some way if the do
634-- not accumulate progress. If possible and save 'Progress' between
635-- client sessions to avoid that.
636--
637startProgress :: Integer -> Progress
638startProgress = Progress 0 0
639
640-- | Used when the client download some data from /any/ peer.
641downloadedProgress :: Int -> Progress -> Progress
642downloadedProgress (fromIntegral -> amount)
643 = (left -~ amount)
644 . (downloaded +~ amount)
645{-# INLINE downloadedProgress #-}
646
647-- | Used when the client upload some data to /any/ peer.
648uploadedProgress :: Int -> Progress -> Progress
649uploadedProgress (fromIntegral -> amount) = uploaded +~ amount
650{-# INLINE uploadedProgress #-}
651
652-- | Used when leecher join client session.
653enqueuedProgress :: Integer -> Progress -> Progress
654enqueuedProgress amount = left +~ amount
655{-# INLINE enqueuedProgress #-}
656
657-- | Used when leecher leave client session.
658-- (e.g. user deletes not completed torrent)
659dequeuedProgress :: Integer -> Progress -> Progress
660dequeuedProgress amount = left -~ amount
661{-# INLINE dequeuedProgress #-}
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 19:13:45 +0000