summaryrefslogtreecommitdiff
path: root/src/Network/Address.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/Address.hs')
-rw-r--r--src/Network/Address.hs1051
1 files changed, 1051 insertions, 0 deletions
diff --git a/src/Network/Address.hs b/src/Network/Address.hs
new file mode 100644
index 00000000..19bf29d6
--- /dev/null
+++ b/src/Network/Address.hs
@@ -0,0 +1,1051 @@
1-- |
2-- Module : Network.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 CPP #-}
13{-# LANGUAGE FlexibleInstances #-}
14{-# LANGUAGE FlexibleContexts #-}
15{-# LANGUAGE RecordWildCards #-}
16{-# LANGUAGE ScopedTypeVariables #-}
17{-# LANGUAGE StandaloneDeriving #-}
18{-# LANGUAGE ViewPatterns #-}
19{-# LANGUAGE GeneralizedNewtypeDeriving #-}
20{-# LANGUAGE MultiParamTypeClasses #-}
21{-# LANGUAGE DeriveDataTypeable #-}
22{-# LANGUAGE DeriveFunctor #-}
23{-# LANGUAGE DeriveFoldable #-}
24{-# LANGUAGE DeriveTraversable #-}
25{-# LANGUAGE TemplateHaskell #-}
26{-# OPTIONS -fno-warn-orphans #-}
27module Network.Address
28 ( -- * Address
29 Address (..)
30 , fromAddr
31 , PortNumber
32 , SockAddr
33
34 -- ** IP
35 , IPv4
36 , IPv6
37 , IP (..)
38
39 -- * PeerId
40 -- $peer-id
41 , PeerId
42
43 -- ** Generation
44 , genPeerId
45 , timestamp
46 , entropy
47
48 -- ** Encoding
49 , azureusStyle
50 , shadowStyle
51 , defaultClientId
52 , defaultVersionNumber
53
54 -- * PeerAddr
55 -- $peer-addr
56 , PeerAddr(..)
57 , defaultPorts
58 , peerSockAddr
59 , peerSocket
60
61 -- * Node
62 -- ** Id
63 , NodeId
64 , testIdBit
65 , genNodeId
66 , bucketRange
67 , genBucketSample
68
69 -- ** Info
70 , NodeAddr (..)
71 , NodeInfo (..)
72 , mapAddress
73 , traverseAddress
74 , rank
75
76 -- * Fingerprint
77 -- $fingerprint
78 , Software (..)
79 , Fingerprint (..)
80 , libFingerprint
81 , fingerprint
82
83 -- * Utils
84 , libUserAgent
85 , sockAddrPort
86 , getBindAddress
87 ) where
88
89import Control.Applicative
90import Control.Monad
91import Control.Exception (onException)
92#ifdef VERSION_bencoding
93import Data.BEncode as BE
94import Data.BEncode.BDict (BKey)
95#endif
96import Data.Bits
97import qualified Data.ByteString as BS
98import qualified Data.ByteString.Internal as BS
99import Data.ByteString.Char8 as BC
100import Data.ByteString.Char8 as BS8
101import qualified Data.ByteString.Lazy as BL
102import qualified Data.ByteString.Lazy.Builder as BS
103import Data.Char
104import Data.Convertible
105import Data.Default
106import Data.IP
107import Data.List as L
108import Data.List.Split as L
109import Data.Maybe (fromMaybe, catMaybes, mapMaybe)
110import Data.Monoid
111import Data.Hashable
112import Data.Ord
113import Data.Serialize as S
114import Data.String
115import Data.Time
116import Data.Typeable
117import Data.Version
118import Data.Word
119import qualified Text.ParserCombinators.ReadP as RP
120import Text.Read (readMaybe)
121import Network.HTTP.Types.QueryLike
122import Network.Socket
123import Text.PrettyPrint as PP hiding ((<>))
124import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
125#if !MIN_VERSION_time(1,5,0)
126import System.Locale (defaultTimeLocale)
127#endif
128import System.Entropy
129import Data.Digest.CRC32C
130import Network.DatagramServer.Types as RPC
131-- import Network.DHT.Mainline
132
133-- import Paths_bittorrent (version)
134
135instance Pretty UTCTime where
136 pPrint = PP.text . show
137
138setPort :: PortNumber -> SockAddr -> SockAddr
139setPort port (SockAddrInet _ h ) = SockAddrInet port h
140setPort port (SockAddrInet6 _ f h s) = SockAddrInet6 port f h s
141setPort _ addr = addr
142{-# INLINE setPort #-}
143
144-- | Obtains the port associated with a socket address
145-- if one is associated with it.
146sockAddrPort :: SockAddr -> Maybe PortNumber
147sockAddrPort (SockAddrInet p _ ) = Just p
148sockAddrPort (SockAddrInet6 p _ _ _) = Just p
149sockAddrPort _ = Nothing
150{-# INLINE sockAddrPort #-}
151
152instance Address a => Address (NodeAddr a) where
153 toSockAddr NodeAddr {..} = setPort nodePort $ toSockAddr nodeHost
154 fromSockAddr sa = NodeAddr <$> fromSockAddr sa <*> sockAddrPort sa
155
156instance Address a => Address (PeerAddr a) where
157 toSockAddr PeerAddr {..} = setPort peerPort $ toSockAddr peerHost
158 fromSockAddr sa = PeerAddr Nothing <$> fromSockAddr sa <*> sockAddrPort sa
159
160{-----------------------------------------------------------------------
161-- Peer id
162-----------------------------------------------------------------------}
163-- $peer-id
164--
165-- 'PeerID' represent self assigned peer identificator. Ideally each
166-- host in the network should have unique peer id to avoid
167-- collisions, therefore for peer ID generation we use good entropy
168-- source. Peer ID is sent in /tracker request/, sent and received in
169-- /peer handshakes/ and used in DHT queries.
170--
171
172-- TODO use unpacked Word160 form (length is known statically)
173
174-- | Peer identifier is exactly 20 bytes long bytestring.
175newtype PeerId = PeerId { getPeerId :: ByteString }
176 deriving ( Show, Eq, Ord, Typeable
177#ifdef VERSION_bencoding
178 , BEncode
179#endif
180 )
181
182peerIdLen :: Int
183peerIdLen = 20
184
185-- | For testing purposes only.
186instance Default PeerId where
187 def = azureusStyle defaultClientId defaultVersionNumber ""
188
189instance Hashable PeerId where
190 hashWithSalt = hashUsing getPeerId
191 {-# INLINE hashWithSalt #-}
192
193instance Serialize PeerId where
194 put = putByteString . getPeerId
195 get = PeerId <$> getBytes peerIdLen
196
197instance QueryValueLike PeerId where
198 toQueryValue (PeerId pid) = Just pid
199 {-# INLINE toQueryValue #-}
200
201instance IsString PeerId where
202 fromString str
203 | BS.length bs == peerIdLen = PeerId bs
204 | otherwise = error $ "Peer id should be 20 bytes long: " ++ show str
205 where
206 bs = fromString str
207
208instance Pretty PeerId where
209 pPrint = text . BC.unpack . getPeerId
210
211instance Convertible BS.ByteString PeerId where
212 safeConvert bs
213 | BS.length bs == peerIdLen = pure (PeerId bs)
214 | otherwise = convError "invalid length" bs
215
216------------------------------------------------------------------------
217
218-- | Pad bytestring so it's becomes exactly request length. Conversion
219-- is done like so:
220--
221-- * length < size: Complete bytestring by given charaters.
222--
223-- * length = size: Output bytestring as is.
224--
225-- * length > size: Drop last (length - size) charaters from a
226-- given bytestring.
227--
228byteStringPadded :: ByteString -- ^ bytestring to be padded.
229 -> Int -- ^ size of result builder.
230 -> Char -- ^ character used for padding.
231 -> BS.Builder
232byteStringPadded bs s c =
233 BS.byteString (BS.take s bs) <>
234 BS.byteString (BC.replicate padLen c)
235 where
236 padLen = s - min (BS.length bs) s
237
238-- | Azureus-style encoding have the following layout:
239--
240-- * 1 byte : '-'
241--
242-- * 2 bytes: client id
243--
244-- * 4 bytes: version number
245--
246-- * 1 byte : '-'
247--
248-- * 12 bytes: random number
249--
250azureusStyle :: ByteString -- ^ 2 character client ID, padded with 'H'.
251 -> ByteString -- ^ Version number, padded with 'X'.
252 -> ByteString -- ^ Random number, padded with '0'.
253 -> PeerId -- ^ Azureus-style encoded peer ID.
254azureusStyle cid ver rnd = PeerId $ BL.toStrict $ BS.toLazyByteString $
255 BS.char8 '-' <>
256 byteStringPadded cid 2 'H' <>
257 byteStringPadded ver 4 'X' <>
258 BS.char8 '-' <>
259 byteStringPadded rnd 12 '0'
260
261-- | Shadow-style encoding have the following layout:
262--
263-- * 1 byte : client id.
264--
265-- * 0-4 bytes: version number. If less than 4 then padded with
266-- '-' char.
267--
268-- * 15 bytes : random number. If length is less than 15 then
269-- padded with '0' char.
270--
271shadowStyle :: Char -- ^ Client ID.
272 -> ByteString -- ^ Version number.
273 -> ByteString -- ^ Random number.
274 -> PeerId -- ^ Shadow style encoded peer ID.
275shadowStyle cid ver rnd = PeerId $ BL.toStrict $ BS.toLazyByteString $
276 BS.char8 cid <>
277 byteStringPadded ver 4 '-' <>
278 byteStringPadded rnd 15 '0'
279
280
281-- | 'HS'- 2 bytes long client identifier.
282defaultClientId :: ByteString
283defaultClientId = "HS"
284
285-- | Gives exactly 4 bytes long version number for any version of the
286-- package. Version is taken from .cabal file.
287defaultVersionNumber :: ByteString
288defaultVersionNumber = BS.take 4 $ BC.pack $ foldMap show $
289 versionBranch myVersion
290 where
291 Fingerprint _ myVersion = libFingerprint
292
293------------------------------------------------------------------------
294
295-- | Gives 15 characters long decimal timestamp such that:
296--
297-- * 6 bytes : first 6 characters from picoseconds obtained with %q.
298--
299-- * 1 byte : character \'.\' for readability.
300--
301-- * 9..* bytes: number of whole seconds since the Unix epoch
302-- (!)REVERSED.
303--
304-- Can be used both with shadow and azureus style encoding. This
305-- format is used to make the ID's readable for debugging purposes.
306--
307timestamp :: IO ByteString
308timestamp = (BC.pack . format) <$> getCurrentTime
309 where
310 format t = L.take 6 (formatTime defaultTimeLocale "%q" t) ++ "." ++
311 L.take 9 (L.reverse (formatTime defaultTimeLocale "%s" t))
312
313-- | Gives 15 character long random bytestring. This is more robust
314-- method for generation of random part of peer ID than 'timestamp'.
315entropy :: IO ByteString
316entropy = getEntropy 15
317
318-- NOTE: entropy generates incorrrect peer id
319
320-- | Here we use 'azureusStyle' encoding with the following args:
321--
322-- * 'HS' for the client id; ('defaultClientId')
323--
324-- * Version of the package for the version number;
325-- ('defaultVersionNumber')
326--
327-- * UTC time day ++ day time for the random number. ('timestamp')
328--
329genPeerId :: IO PeerId
330genPeerId = azureusStyle defaultClientId defaultVersionNumber <$> timestamp
331
332{-----------------------------------------------------------------------
333-- Peer Addr
334-----------------------------------------------------------------------}
335-- $peer-addr
336--
337-- 'PeerAddr' is used to represent peer address. Currently it's
338-- just peer IP and peer port but this might change in future.
339--
340
341{-----------------------------------------------------------------------
342-- Port number
343-----------------------------------------------------------------------}
344
345#ifdef VERSION_bencoding
346instance BEncode PortNumber where
347 toBEncode = toBEncode . fromEnum
348 fromBEncode = fromBEncode >=> portNumber
349 where
350 portNumber :: Integer -> BE.Result PortNumber
351 portNumber n
352 | 0 <= n && n <= fromIntegral (maxBound :: Word16)
353 = pure $ fromIntegral n
354 | otherwise = decodingError $ "PortNumber: " ++ show n
355#endif
356{-----------------------------------------------------------------------
357-- IP addr
358-----------------------------------------------------------------------}
359
360class IPAddress i where
361 toHostAddr :: i -> Either HostAddress HostAddress6
362
363instance IPAddress IPv4 where
364 toHostAddr = Left . toHostAddress
365 {-# INLINE toHostAddr #-}
366
367instance IPAddress IPv6 where
368 toHostAddr = Right . toHostAddress6
369 {-# INLINE toHostAddr #-}
370
371instance IPAddress IP where
372 toHostAddr (IPv4 ip) = toHostAddr ip
373 toHostAddr (IPv6 ip) = toHostAddr ip
374 {-# INLINE toHostAddr #-}
375
376deriving instance Typeable IP
377deriving instance Typeable IPv4
378deriving instance Typeable IPv6
379
380#ifdef VERSION_bencoding
381ipToBEncode :: Show i => i -> BValue
382ipToBEncode ip = BString $ BS8.pack $ show ip
383{-# INLINE ipToBEncode #-}
384
385ipFromBEncode :: Read a => BValue -> BE.Result a
386ipFromBEncode (BString (BS8.unpack -> ipStr))
387 | Just ip <- readMaybe (ipStr) = pure ip
388 | otherwise = decodingError $ "IP: " ++ ipStr
389ipFromBEncode _ = decodingError $ "IP: addr should be a bstring"
390
391instance BEncode IP where
392 toBEncode = ipToBEncode
393 {-# INLINE toBEncode #-}
394 fromBEncode = ipFromBEncode
395 {-# INLINE fromBEncode #-}
396
397instance BEncode IPv4 where
398 toBEncode = ipToBEncode
399 {-# INLINE toBEncode #-}
400 fromBEncode = ipFromBEncode
401 {-# INLINE fromBEncode #-}
402
403instance BEncode IPv6 where
404 toBEncode = ipToBEncode
405 {-# INLINE toBEncode #-}
406 fromBEncode = ipFromBEncode
407 {-# INLINE fromBEncode #-}
408#endif
409
410{-----------------------------------------------------------------------
411-- Peer addr
412-----------------------------------------------------------------------}
413-- TODO check semantic of ord and eq instances
414
415-- | Peer address info normally extracted from peer list or peer
416-- compact list encoding.
417data PeerAddr a = PeerAddr
418 { peerId :: !(Maybe PeerId)
419
420 -- | This is usually 'IPv4', 'IPv6', 'IP' or unresolved
421 -- 'HostName'.
422 , peerHost :: !a
423
424 -- | The port the peer listenning for incoming P2P sessions.
425 , peerPort :: {-# UNPACK #-} !PortNumber
426 } deriving (Show, Eq, Ord, Typeable, Functor)
427
428#ifdef VERSION_bencoding
429peer_ip_key, peer_id_key, peer_port_key :: BKey
430peer_ip_key = "ip"
431peer_id_key = "peer id"
432peer_port_key = "port"
433
434-- | The tracker's 'announce response' compatible encoding.
435instance (Typeable a, BEncode a) => BEncode (PeerAddr a) where
436 toBEncode PeerAddr {..} = toDict $
437 peer_ip_key .=! peerHost
438 .: peer_id_key .=? peerId
439 .: peer_port_key .=! peerPort
440 .: endDict
441
442 fromBEncode = fromDict $ do
443 peerAddr <$>! peer_ip_key
444 <*>? peer_id_key
445 <*>! peer_port_key
446 where
447 peerAddr = flip PeerAddr
448#endif
449
450-- | The tracker's 'compact peer list' compatible encoding. The
451-- 'peerId' is always 'Nothing'.
452--
453-- For more info see: <http://www.bittorrent.org/beps/bep_0023.html>
454--
455-- TODO: test byte order
456instance (Serialize a) => Serialize (PeerAddr a) where
457 put PeerAddr {..} = put peerHost >> put peerPort
458 get = PeerAddr Nothing <$> get <*> get
459
460-- | @127.0.0.1:6881@
461instance Default (PeerAddr IPv4) where
462 def = "127.0.0.1:6881"
463
464-- | @127.0.0.1:6881@
465instance Default (PeerAddr IP) where
466 def = IPv4 <$> def
467
468-- | Example:
469--
470-- @peerPort \"127.0.0.1:6881\" == 6881@
471--
472instance IsString (PeerAddr IPv4) where
473 fromString str
474 | [hostAddrStr, portStr] <- splitWhen (== ':') str
475 , Just hostAddr <- readMaybe hostAddrStr
476 , Just portNum <- toEnum <$> readMaybe portStr
477 = PeerAddr Nothing hostAddr portNum
478 | otherwise = error $ "fromString: unable to parse (PeerAddr IPv4): " ++ str
479
480instance Read (PeerAddr IPv4) where
481 readsPrec i = RP.readP_to_S $ do
482 ipv4 <- RP.readS_to_P (readsPrec i)
483 _ <- RP.char ':'
484 port <- toEnum <$> RP.readS_to_P (readsPrec i)
485 return $ PeerAddr Nothing ipv4 port
486
487readsIPv6_port :: String -> [((IPv6, PortNumber), String)]
488readsIPv6_port = RP.readP_to_S $ do
489 ip <- RP.char '[' *> (RP.readS_to_P reads) <* RP.char ']'
490 _ <- RP.char ':'
491 port <- toEnum <$> read <$> (RP.many1 $ RP.satisfy isDigit) <* RP.eof
492 return (ip,port)
493
494instance IsString (PeerAddr IPv6) where
495 fromString str
496 | [((ip,port),"")] <- readsIPv6_port str =
497 PeerAddr Nothing ip port
498 | otherwise = error $ "fromString: unable to parse (PeerAddr IPv6): " ++ str
499
500instance IsString (PeerAddr IP) where
501 fromString str
502 | '[' `L.elem` str = IPv6 <$> fromString str
503 | otherwise = IPv4 <$> fromString str
504
505-- | fingerprint + "at" + dotted.host.inet.addr:port
506-- TODO: instances for IPv6, HostName
507instance Pretty a => Pretty (PeerAddr a) where
508 pPrint PeerAddr {..}
509 | Just pid <- peerId = pPrint (fingerprint pid) <+> "at" <+> paddr
510 | otherwise = paddr
511 where
512 paddr = pPrint peerHost <> ":" <> text (show peerPort)
513
514instance Hashable a => Hashable (PeerAddr a) where
515 hashWithSalt s PeerAddr {..} =
516 s `hashWithSalt` peerId `hashWithSalt` peerHost `hashWithSalt` peerPort
517
518-- | Ports typically reserved for bittorrent P2P listener.
519defaultPorts :: [PortNumber]
520defaultPorts = [6881..6889]
521
522_resolvePeerAddr :: (IPAddress i) => PeerAddr HostName -> PeerAddr i
523_resolvePeerAddr = undefined
524
525_peerSockAddr :: PeerAddr IP -> (Family, SockAddr)
526_peerSockAddr PeerAddr {..} =
527 case peerHost of
528 IPv4 ipv4 ->
529 (AF_INET, SockAddrInet peerPort (toHostAddress ipv4))
530 IPv6 ipv6 ->
531 (AF_INET6, SockAddrInet6 peerPort 0 (toHostAddress6 ipv6) 0)
532
533peerSockAddr :: PeerAddr IP -> SockAddr
534peerSockAddr = snd . _peerSockAddr
535
536-- | Create a socket connected to the address specified in a peerAddr
537peerSocket :: SocketType -> PeerAddr IP -> IO Socket
538peerSocket socketType pa = do
539 let (family, addr) = _peerSockAddr pa
540 sock <- socket family socketType defaultProtocol
541 connect sock addr
542 return sock
543
544{-----------------------------------------------------------------------
545-- Node info
546-----------------------------------------------------------------------}
547-- $node-info
548--
549-- A \"node\" is a client\/server listening on a UDP port
550-- implementing the distributed hash table protocol. The DHT is
551-- composed of nodes and stores the location of peers. BitTorrent
552-- clients include a DHT node, which is used to contact other nodes
553-- in the DHT to get the location of peers to download from using
554-- the BitTorrent protocol.
555
556-- asNodeId :: ByteString -> NodeId
557-- asNodeId bs = NodeId $ BS.take nodeIdSize bs
558
559{-
560
561-- | Test if the nth bit is set.
562testIdBit :: NodeId -> Word -> Bool
563testIdBit (NodeId bs) i
564 | fromIntegral i < nodeIdSize * 8
565 , (q, r) <- quotRem (fromIntegral i) 8
566 = testBit (BS.index bs q) (7 - r)
567 | otherwise = False
568-}
569
570testIdBit :: FiniteBits bs => bs -> Word -> Bool
571testIdBit bs i = testBit bs (fromIntegral (finiteBitSize bs - fromIntegral i))
572{-# INLINE testIdBit #-}
573
574------------------------------------------------------------------------
575
576-- | Accepts a depth/index of a bucket and whether or not it is the last one,
577-- yields:
578--
579-- count of leading bytes to be copied from your node id.
580--
581-- mask to clear the extra bits of the last copied byte
582--
583-- mask to toggle the last copied bit if it is not the last bucket
584--
585-- Normally this is used with 'genBucketSample' to obtain a random id suitable
586-- for refreshing a particular bucket.
587bucketRange :: Int -> Bool -> (Int, Word8, Word8)
588bucketRange depth is_last = (q,m,b)
589 where
590 (q,r) = divMod ((if is_last then (+7) else (+8)) depth) 8
591 m = 2^(7-r) - 1
592 b = if is_last then 0 else 2^(7-r)
593
594------------------------------------------------------------------------
595
596#ifdef VERSION_bencoding
597-- | Torrent file compatible encoding.
598instance BEncode a => BEncode (NodeAddr a) where
599 toBEncode NodeAddr {..} = toBEncode (nodeHost, nodePort)
600 {-# INLINE toBEncode #-}
601 fromBEncode b = uncurry NodeAddr <$> fromBEncode b
602 {-# INLINE fromBEncode #-}
603#endif
604
605fromPeerAddr :: PeerAddr a -> NodeAddr a
606fromPeerAddr PeerAddr {..} = NodeAddr
607 { nodeHost = peerHost
608 , nodePort = peerPort
609 }
610
611------------------------------------------------------------------------
612
613-- | Order by closeness: nearest nodes first.
614rank :: ( Ord (NodeId dht)
615 , Bits (NodeId dht)
616 ) => (x -> NodeId dht) -> NodeId dht -> [x] -> [x]
617rank f nid = L.sortBy (comparing (RPC.distance nid . f))
618
619{-----------------------------------------------------------------------
620-- Fingerprint
621-----------------------------------------------------------------------}
622-- $fingerprint
623--
624-- 'Fingerprint' is used to identify the client implementation and
625-- version which also contained in 'Peer'. For exsample first 6
626-- bytes of peer id of this this library are @-HS0100-@ while for
627-- mainline we have @M4-3-6--@. We could extract this info and
628-- print in human-friendly form: this is useful for debugging and
629-- logging.
630--
631-- For more information see:
632-- <http://bittorrent.org/beps/bep_0020.html>
633--
634--
635-- NOTE: Do /not/ use this information to control client
636-- capabilities (such as supported enchancements), this should be
637-- done using 'Network.BitTorrent.Extension'!
638--
639
640-- TODO FIXME
641version :: Version
642version = Version [0, 0, 0, 3] []
643
644-- | List of registered client versions + 'IlibHSbittorrent' (this
645-- package) + 'IUnknown' (for not recognized software). All names are
646-- prefixed by \"I\" because some of them starts from lowercase letter
647-- but that is not a valid Haskell constructor name.
648--
649data Software =
650 IUnknown
651
652 | IMainline
653
654 | IABC
655 | IOspreyPermaseed
656 | IBTQueue
657 | ITribler
658 | IShadow
659 | IBitTornado
660
661-- UPnP(!) Bit Torrent !???
662-- 'U' - UPnP NAT Bit Torrent
663 | IBitLord
664 | IOpera
665 | IMLdonkey
666
667 | IAres
668 | IArctic
669 | IAvicora
670 | IBitPump
671 | IAzureus
672 | IBitBuddy
673 | IBitComet
674 | IBitflu
675 | IBTG
676 | IBitRocket
677 | IBTSlave
678 | IBittorrentX
679 | IEnhancedCTorrent
680 | ICTorrent
681 | IDelugeTorrent
682 | IPropagateDataClient
683 | IEBit
684 | IElectricSheep
685 | IFoxTorrent
686 | IGSTorrent
687 | IHalite
688 | IlibHSbittorrent
689 | IHydranode
690 | IKGet
691 | IKTorrent
692 | ILH_ABC
693 | ILphant
694 | ILibtorrent
695 | ILibTorrent
696 | ILimeWire
697 | IMonoTorrent
698 | IMooPolice
699 | IMiro
700 | IMoonlightTorrent
701 | INetTransport
702 | IPando
703 | IqBittorrent
704 | IQQDownload
705 | IQt4TorrentExample
706 | IRetriever
707 | IShareaza
708 | ISwiftbit
709 | ISwarmScope
710 | ISymTorrent
711 | Isharktorrent
712 | ITorrentDotNET
713 | ITransmission
714 | ITorrentstorm
715 | ITuoTu
716 | IuLeecher
717 | IuTorrent
718 | IVagaa
719 | IBitLet
720 | IFireTorrent
721 | IXunlei
722 | IXanTorrent
723 | IXtorrent
724 | IZipTorrent
725 deriving (Show, Eq, Ord, Enum, Bounded)
726
727parseSoftware :: ByteString -> Software
728parseSoftware = f . BC.unpack
729 where
730 f "AG" = IAres
731 f "A~" = IAres
732 f "AR" = IArctic
733 f "AV" = IAvicora
734 f "AX" = IBitPump
735 f "AZ" = IAzureus
736 f "BB" = IBitBuddy
737 f "BC" = IBitComet
738 f "BF" = IBitflu
739 f "BG" = IBTG
740 f "BR" = IBitRocket
741 f "BS" = IBTSlave
742 f "BX" = IBittorrentX
743 f "CD" = IEnhancedCTorrent
744 f "CT" = ICTorrent
745 f "DE" = IDelugeTorrent
746 f "DP" = IPropagateDataClient
747 f "EB" = IEBit
748 f "ES" = IElectricSheep
749 f "FT" = IFoxTorrent
750 f "GS" = IGSTorrent
751 f "HL" = IHalite
752 f "HS" = IlibHSbittorrent
753 f "HN" = IHydranode
754 f "KG" = IKGet
755 f "KT" = IKTorrent
756 f "LH" = ILH_ABC
757 f "LP" = ILphant
758 f "LT" = ILibtorrent
759 f "lt" = ILibTorrent
760 f "LW" = ILimeWire
761 f "MO" = IMonoTorrent
762 f "MP" = IMooPolice
763 f "MR" = IMiro
764 f "ML" = IMLdonkey
765 f "MT" = IMoonlightTorrent
766 f "NX" = INetTransport
767 f "PD" = IPando
768 f "qB" = IqBittorrent
769 f "QD" = IQQDownload
770 f "QT" = IQt4TorrentExample
771 f "RT" = IRetriever
772 f "S~" = IShareaza
773 f "SB" = ISwiftbit
774 f "SS" = ISwarmScope
775 f "ST" = ISymTorrent
776 f "st" = Isharktorrent
777 f "SZ" = IShareaza
778 f "TN" = ITorrentDotNET
779 f "TR" = ITransmission
780 f "TS" = ITorrentstorm
781 f "TT" = ITuoTu
782 f "UL" = IuLeecher
783 f "UT" = IuTorrent
784 f "VG" = IVagaa
785 f "WT" = IBitLet
786 f "WY" = IFireTorrent
787 f "XL" = IXunlei
788 f "XT" = IXanTorrent
789 f "XX" = IXtorrent
790 f "ZT" = IZipTorrent
791 f _ = IUnknown
792
793-- | Used to represent a not recognized implementation
794instance Default Software where
795 def = IUnknown
796 {-# INLINE def #-}
797
798-- | Example: @\"BitLet\" == 'IBitLet'@
799instance IsString Software where
800 fromString str
801 | Just impl <- L.lookup str alist = impl
802 | otherwise = error $ "fromString: not recognized " ++ str
803 where
804 alist = L.map mk [minBound..maxBound]
805 mk x = (L.tail $ show x, x)
806
807-- | Example: @pPrint 'IBitLet' == \"IBitLet\"@
808instance Pretty Software where
809 pPrint = text . L.tail . show
810
811-- | Just the '0' version.
812instance Default Version where
813 def = Version [0] []
814 {-# INLINE def #-}
815
816-- | For dot delimited version strings.
817-- Example: @fromString \"0.1.0.2\" == Version [0, 1, 0, 2]@
818--
819instance IsString Version where
820 fromString str
821 | Just nums <- chunkNums str = Version nums []
822 | otherwise = error $ "fromString: invalid version string " ++ str
823 where
824 chunkNums = sequence . L.map readMaybe . L.linesBy ('.' ==)
825
826instance Pretty Version where
827 pPrint = text . showVersion
828
829-- | The all sensible infomation that can be obtained from a peer
830-- identifier or torrent /createdBy/ field.
831data Fingerprint = Fingerprint Software Version
832 deriving (Show, Eq, Ord)
833
834-- | Unrecognized client implementation.
835instance Default Fingerprint where
836 def = Fingerprint def def
837 {-# INLINE def #-}
838
839-- | Example: @\"BitComet-1.2\" == ClientInfo IBitComet (Version [1, 2] [])@
840instance IsString Fingerprint where
841 fromString str
842 | _ : ver <- _ver = Fingerprint (fromString impl) (fromString ver)
843 | otherwise = error $ "fromString: invalid client info string" ++ str
844 where
845 (impl, _ver) = L.span ((/=) '-') str
846
847instance Pretty Fingerprint where
848 pPrint (Fingerprint s v) = pPrint s <+> "version" <+> pPrint v
849
850-- | Fingerprint of this (the bittorrent library) package. Normally,
851-- applications should introduce its own fingerprints, otherwise they
852-- can use 'libFingerprint' value.
853--
854libFingerprint :: Fingerprint
855libFingerprint = Fingerprint IlibHSbittorrent version
856
857-- | HTTP user agent of this (the bittorrent library) package. Can be
858-- used in HTTP tracker requests.
859libUserAgent :: String
860libUserAgent = render (pPrint IlibHSbittorrent <> "/" <> pPrint version)
861
862{-----------------------------------------------------------------------
863-- For torrent file
864-----------------------------------------------------------------------}
865-- TODO collect information about createdBy torrent field
866-- renderImpl :: ClientImpl -> Text
867-- renderImpl = T.pack . L.tail . show
868--
869-- renderVersion :: Version -> Text
870-- renderVersion = undefined
871--
872-- renderClientInfo :: ClientInfo -> Text
873-- renderClientInfo ClientInfo {..} = renderImpl ciImpl <> "/" <> renderVersion ciVersion
874--
875-- parseClientInfo :: Text -> ClientImpl
876-- parseClientInfo t = undefined
877
878
879-- code used for generation; remove it later on
880--
881-- mkEnumTyDef :: NM -> String
882-- mkEnumTyDef = unlines . map (" | I" ++) . nub . map snd
883--
884-- mkPars :: NM -> String
885-- mkPars = unlines . map (\(code, impl) -> " f \"" ++ code ++ "\" = " ++ "I" ++ impl)
886--
887-- type NM = [(String, String)]
888-- nameMap :: NM
889-- nameMap =
890-- [ ("AG", "Ares")
891-- , ("A~", "Ares")
892-- , ("AR", "Arctic")
893-- , ("AV", "Avicora")
894-- , ("AX", "BitPump")
895-- , ("AZ", "Azureus")
896-- , ("BB", "BitBuddy")
897-- , ("BC", "BitComet")
898-- , ("BF", "Bitflu")
899-- , ("BG", "BTG")
900-- , ("BR", "BitRocket")
901-- , ("BS", "BTSlave")
902-- , ("BX", "BittorrentX")
903-- , ("CD", "EnhancedCTorrent")
904-- , ("CT", "CTorrent")
905-- , ("DE", "DelugeTorrent")
906-- , ("DP", "PropagateDataClient")
907-- , ("EB", "EBit")
908-- , ("ES", "ElectricSheep")
909-- , ("FT", "FoxTorrent")
910-- , ("GS", "GSTorrent")
911-- , ("HL", "Halite")
912-- , ("HS", "libHSnetwork_bittorrent")
913-- , ("HN", "Hydranode")
914-- , ("KG", "KGet")
915-- , ("KT", "KTorrent")
916-- , ("LH", "LH_ABC")
917-- , ("LP", "Lphant")
918-- , ("LT", "Libtorrent")
919-- , ("lt", "LibTorrent")
920-- , ("LW", "LimeWire")
921-- , ("MO", "MonoTorrent")
922-- , ("MP", "MooPolice")
923-- , ("MR", "Miro")
924-- , ("MT", "MoonlightTorrent")
925-- , ("NX", "NetTransport")
926-- , ("PD", "Pando")
927-- , ("qB", "qBittorrent")
928-- , ("QD", "QQDownload")
929-- , ("QT", "Qt4TorrentExample")
930-- , ("RT", "Retriever")
931-- , ("S~", "Shareaza")
932-- , ("SB", "Swiftbit")
933-- , ("SS", "SwarmScope")
934-- , ("ST", "SymTorrent")
935-- , ("st", "sharktorrent")
936-- , ("SZ", "Shareaza")
937-- , ("TN", "TorrentDotNET")
938-- , ("TR", "Transmission")
939-- , ("TS", "Torrentstorm")
940-- , ("TT", "TuoTu")
941-- , ("UL", "uLeecher")
942-- , ("UT", "uTorrent")
943-- , ("VG", "Vagaa")
944-- , ("WT", "BitLet")
945-- , ("WY", "FireTorrent")
946-- , ("XL", "Xunlei")
947-- , ("XT", "XanTorrent")
948-- , ("XX", "Xtorrent")
949-- , ("ZT", "ZipTorrent")
950-- ]
951
952-- TODO use regexps
953
954-- | Tries to extract meaningful information from peer ID bytes. If
955-- peer id uses unknown coding style then client info returned is
956-- 'def'.
957--
958fingerprint :: PeerId -> Fingerprint
959fingerprint pid = either (const def) id $ runGet getCI (getPeerId pid)
960 where
961 getCI = do
962 leading <- BS.w2c <$> getWord8
963 case leading of
964 '-' -> Fingerprint <$> getAzureusImpl <*> getAzureusVersion
965 'M' -> Fingerprint <$> pure IMainline <*> getMainlineVersion
966 'e' -> Fingerprint <$> getBitCometImpl <*> getBitCometVersion
967 'F' -> Fingerprint <$> getBitCometImpl <*> getBitCometVersion
968 c -> do
969 c1 <- BS.w2c <$> S.lookAhead getWord8
970 if c1 == 'P'
971 then do
972 _ <- getWord8
973 Fingerprint <$> pure IOpera <*> getOperaVersion
974 else Fingerprint <$> pure (getShadowImpl c) <*> getShadowVersion
975
976 getMainlineVersion = do
977 str <- BC.unpack <$> getByteString 7
978 let mnums = L.filter (not . L.null) $ L.linesBy ('-' ==) str
979 return $ Version (fromMaybe [] $ sequence $ L.map readMaybe mnums) []
980
981 getAzureusImpl = parseSoftware <$> getByteString 2
982 getAzureusVersion = mkVer <$> getByteString 4
983 where
984 mkVer bs = Version [fromMaybe 0 $ readMaybe $ BC.unpack bs] []
985
986 getBitCometImpl = do
987 bs <- getByteString 3
988 S.lookAhead $ do
989 _ <- getByteString 2
990 lr <- getByteString 4
991 return $
992 if lr == "LORD" then IBitLord else
993 if bs == "UTB" then IBitComet else
994 if bs == "xbc" then IBitComet else def
995
996 getBitCometVersion = do
997 x <- getWord8
998 y <- getWord8
999 return $ Version [fromIntegral x, fromIntegral y] []
1000
1001 getOperaVersion = do
1002 str <- BC.unpack <$> getByteString 4
1003 return $ Version [fromMaybe 0 $ readMaybe str] []
1004
1005 getShadowImpl 'A' = IABC
1006 getShadowImpl 'O' = IOspreyPermaseed
1007 getShadowImpl 'Q' = IBTQueue
1008 getShadowImpl 'R' = ITribler
1009 getShadowImpl 'S' = IShadow
1010 getShadowImpl 'T' = IBitTornado
1011 getShadowImpl _ = IUnknown
1012
1013 decodeShadowVerNr :: Char -> Maybe Int
1014 decodeShadowVerNr c
1015 | '0' < c && c <= '9' = Just (fromEnum c - fromEnum '0')
1016 | 'A' < c && c <= 'Z' = Just ((fromEnum c - fromEnum 'A') + 10)
1017 | 'a' < c && c <= 'z' = Just ((fromEnum c - fromEnum 'a') + 36)
1018 | otherwise = Nothing
1019
1020 getShadowVersion = do
1021 str <- BC.unpack <$> getByteString 5
1022 return $ Version (catMaybes $ L.map decodeShadowVerNr str) []
1023
1024
1025
1026-- | Given a string specifying a port (numeric or service name)
1027-- and a flag indicating whether you want to support IPv6, this
1028-- function will return a SockAddr to bind to. If the input
1029-- is not understood as a port number, zero will be set in order
1030-- to ask the system for an unused port.
1031--
1032-- TODO: Also interpret local ip address specifications in the input
1033-- string.
1034getBindAddress :: String -> Bool -> IO SockAddr
1035getBindAddress listenPortString enabled6 = do
1036 -- Bind addresses for localhost
1037 xs <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE] }))
1038 Nothing
1039 (Just listenPortString)
1040 `onException` return []
1041 -- We prefer IPv6 because that can also handle connections from IPv4
1042 -- clients...
1043 let (x6s,x4s) = partition (\s -> addrFamily s == AF_INET6) xs
1044 listenAddr =
1045 case if enabled6 then x6s++x4s else x4s of
1046 AddrInfo { addrAddress = addr } : _ -> addr
1047 _ -> if enabled6
1048 then SockAddrInet6 (parsePort listenPortString) 0 iN6ADDR_ANY 0
1049 else SockAddrInet (parsePort listenPortString) iNADDR_ANY
1050 where parsePort s = fromMaybe 0 $ readMaybe s
1051 return listenAddr
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 16:06:04 +0000