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