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