summaryrefslogtreecommitdiff
path: root/src/Network/BitTorrent/Core
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/BitTorrent/Core')
-rw-r--r--src/Network/BitTorrent/Core/Fingerprint.hs290
-rw-r--r--src/Network/BitTorrent/Core/NodeInfo.hs219
-rw-r--r--src/Network/BitTorrent/Core/PeerAddr.hs312
-rw-r--r--src/Network/BitTorrent/Core/PeerId.hs364
4 files changed, 0 insertions, 1185 deletions
diff --git a/src/Network/BitTorrent/Core/Fingerprint.hs b/src/Network/BitTorrent/Core/Fingerprint.hs
deleted file mode 100644
index d743acd0..00000000
--- a/src/Network/BitTorrent/Core/Fingerprint.hs
+++ /dev/null
@@ -1,290 +0,0 @@
1-- |
2-- Copyright : (c) Sam Truzjan 2013
3-- License : BSD3
4-- Maintainer : pxqr.sta@gmail.com
5-- Stability : experimental
6-- Portability : portable
7--
8-- 'Fingerprint' is used to identify the client implementation and
9-- version which also contained in 'Peer'. For exsample first 6
10-- bytes of peer id of this this library are @-HS0100-@ while for
11-- mainline we have @M4-3-6--@. We could extract this info and
12-- print in human-friendly form: this is useful for debugging and
13-- logging.
14--
15-- For more information see:
16-- <http://bittorrent.org/beps/bep_0020.html>
17--
18--
19-- NOTE: Do /not/ use this information to control client
20-- capabilities (such as supported enchancements), this should be
21-- done using 'Network.BitTorrent.Extension'!
22--
23{-# OPTIONS -fno-warn-orphans #-}
24module Network.BitTorrent.Core.Fingerprint
25 ( ClientImpl (..)
26 , Fingerprint (..)
27 , libFingerprint
28 , libUserAgent
29 ) where
30
31import Data.Default
32import Data.List as L
33import Data.List.Split as L
34import Data.Monoid
35import Data.String
36import Data.Version
37import Text.PrettyPrint hiding ((<>))
38import Text.PrettyPrint.Class
39import Text.Read (readMaybe)
40-- import Paths_bittorrent (version)
41
42-- TODO FIXME
43version :: Version
44version = Version [0, 0, 0, 3] []
45
46-- | List of registered client versions + 'IlibHSbittorrent' (this
47-- package) + 'IUnknown' (for not recognized software). All names are
48-- prefixed by \"I\" because some of them starts from lowercase letter
49-- but that is not a valid Haskell constructor name.
50--
51data ClientImpl =
52 IUnknown
53
54 | IMainline
55
56 | IABC
57 | IOspreyPermaseed
58 | IBTQueue
59 | ITribler
60 | IShadow
61 | IBitTornado
62
63-- UPnP(!) Bit Torrent !???
64-- 'U' - UPnP NAT Bit Torrent
65 | IBitLord
66 | IOpera
67 | IMLdonkey
68
69 | IAres
70 | IArctic
71 | IAvicora
72 | IBitPump
73 | IAzureus
74 | IBitBuddy
75 | IBitComet
76 | IBitflu
77 | IBTG
78 | IBitRocket
79 | IBTSlave
80 | IBittorrentX
81 | IEnhancedCTorrent
82 | ICTorrent
83 | IDelugeTorrent
84 | IPropagateDataClient
85 | IEBit
86 | IElectricSheep
87 | IFoxTorrent
88 | IGSTorrent
89 | IHalite
90 | IlibHSbittorrent
91 | IHydranode
92 | IKGet
93 | IKTorrent
94 | ILH_ABC
95 | ILphant
96 | ILibtorrent
97 | ILibTorrent
98 | ILimeWire
99 | IMonoTorrent
100 | IMooPolice
101 | IMiro
102 | IMoonlightTorrent
103 | INetTransport
104 | IPando
105 | IqBittorrent
106 | IQQDownload
107 | IQt4TorrentExample
108 | IRetriever
109 | IShareaza
110 | ISwiftbit
111 | ISwarmScope
112 | ISymTorrent
113 | Isharktorrent
114 | ITorrentDotNET
115 | ITransmission
116 | ITorrentstorm
117 | ITuoTu
118 | IuLeecher
119 | IuTorrent
120 | IVagaa
121 | IBitLet
122 | IFireTorrent
123 | IXunlei
124 | IXanTorrent
125 | IXtorrent
126 | IZipTorrent
127 deriving (Show, Eq, Ord, Enum, Bounded)
128
129-- | Used to represent a not recognized implementation
130instance Default ClientImpl where
131 def = IUnknown
132 {-# INLINE def #-}
133
134-- | Example: @\"BitLet\" == 'IBitLet'@
135instance IsString ClientImpl where
136 fromString str
137 | Just impl <- L.lookup str alist = impl
138 | otherwise = error $ "fromString: not recognized " ++ str
139 where
140 alist = L.map mk [minBound..maxBound]
141 mk x = (L.tail $ show x, x)
142
143-- | Example: @pretty 'IBitLet' == \"IBitLet\"@
144instance Pretty ClientImpl where
145 pretty = text . L.tail . show
146
147-- | Just the '0' version.
148instance Default Version where
149 def = Version [0] []
150 {-# INLINE def #-}
151
152-- | For dot delimited version strings.
153-- Example: @fromString \"0.1.0.2\" == Version [0, 1, 0, 2]@
154--
155instance IsString Version where
156 fromString str
157 | Just nums <- chunkNums str = Version nums []
158 | otherwise = error $ "fromString: invalid version string " ++ str
159 where
160 chunkNums = sequence . L.map readMaybe . L.linesBy ('.' ==)
161
162instance Pretty Version where
163 pretty = text . showVersion
164
165-- | The all sensible infomation that can be obtained from a peer
166-- identifier or torrent /createdBy/ field.
167data Fingerprint = Fingerprint
168 { ciImpl :: ClientImpl
169 , ciVersion :: Version
170 } deriving (Show, Eq, Ord)
171
172-- | Unrecognized client implementation.
173instance Default Fingerprint where
174 def = Fingerprint def def
175 {-# INLINE def #-}
176
177-- | Example: @\"BitComet-1.2\" == ClientInfo IBitComet (Version [1, 2] [])@
178instance IsString Fingerprint where
179 fromString str
180 | _ : ver <- _ver = Fingerprint (fromString impl) (fromString ver)
181 | otherwise = error $ "fromString: invalid client info string" ++ str
182 where
183 (impl, _ver) = L.span ((/=) '-') str
184
185instance Pretty Fingerprint where
186 pretty Fingerprint {..} = pretty ciImpl <+> "version" <+> pretty ciVersion
187
188-- | Fingerprint of this (the bittorrent library) package. Normally,
189-- applications should introduce its own fingerprints, otherwise they
190-- can use 'libFingerprint' value.
191--
192libFingerprint :: Fingerprint
193libFingerprint = Fingerprint IlibHSbittorrent version
194
195-- | HTTP user agent of this (the bittorrent library) package. Can be
196-- used in HTTP tracker requests.
197libUserAgent :: String
198libUserAgent = render (pretty IlibHSbittorrent <> "/" <> pretty version)
199
200{-----------------------------------------------------------------------
201-- For torrent file
202-----------------------------------------------------------------------}
203-- TODO collect information about createdBy torrent field
204{-
205renderImpl :: ClientImpl -> Text
206renderImpl = T.pack . L.tail . show
207
208renderVersion :: Version -> Text
209renderVersion = undefined
210
211renderClientInfo :: ClientInfo -> Text
212renderClientInfo ClientInfo {..} = renderImpl ciImpl <> "/" <> renderVersion ciVersion
213
214parseClientInfo :: Text -> ClientImpl
215parseClientInfo t = undefined
216-}
217{-
218-- code used for generation; remove it later on
219
220mkEnumTyDef :: NM -> String
221mkEnumTyDef = unlines . map (" | I" ++) . nub . map snd
222
223mkPars :: NM -> String
224mkPars = unlines . map (\(code, impl) -> " f \"" ++ code ++ "\" = " ++ "I" ++ impl)
225
226type NM = [(String, String)]
227nameMap :: NM
228nameMap =
229 [ ("AG", "Ares")
230 , ("A~", "Ares")
231 , ("AR", "Arctic")
232 , ("AV", "Avicora")
233 , ("AX", "BitPump")
234 , ("AZ", "Azureus")
235 , ("BB", "BitBuddy")
236 , ("BC", "BitComet")
237 , ("BF", "Bitflu")
238 , ("BG", "BTG")
239 , ("BR", "BitRocket")
240 , ("BS", "BTSlave")
241 , ("BX", "BittorrentX")
242 , ("CD", "EnhancedCTorrent")
243 , ("CT", "CTorrent")
244 , ("DE", "DelugeTorrent")
245 , ("DP", "PropagateDataClient")
246 , ("EB", "EBit")
247 , ("ES", "ElectricSheep")
248 , ("FT", "FoxTorrent")
249 , ("GS", "GSTorrent")
250 , ("HL", "Halite")
251 , ("HS", "libHSnetwork_bittorrent")
252 , ("HN", "Hydranode")
253 , ("KG", "KGet")
254 , ("KT", "KTorrent")
255 , ("LH", "LH_ABC")
256 , ("LP", "Lphant")
257 , ("LT", "Libtorrent")
258 , ("lt", "LibTorrent")
259 , ("LW", "LimeWire")
260 , ("MO", "MonoTorrent")
261 , ("MP", "MooPolice")
262 , ("MR", "Miro")
263 , ("MT", "MoonlightTorrent")
264 , ("NX", "NetTransport")
265 , ("PD", "Pando")
266 , ("qB", "qBittorrent")
267 , ("QD", "QQDownload")
268 , ("QT", "Qt4TorrentExample")
269 , ("RT", "Retriever")
270 , ("S~", "Shareaza")
271 , ("SB", "Swiftbit")
272 , ("SS", "SwarmScope")
273 , ("ST", "SymTorrent")
274 , ("st", "sharktorrent")
275 , ("SZ", "Shareaza")
276 , ("TN", "TorrentDotNET")
277 , ("TR", "Transmission")
278 , ("TS", "Torrentstorm")
279 , ("TT", "TuoTu")
280 , ("UL", "uLeecher")
281 , ("UT", "uTorrent")
282 , ("VG", "Vagaa")
283 , ("WT", "BitLet")
284 , ("WY", "FireTorrent")
285 , ("XL", "Xunlei")
286 , ("XT", "XanTorrent")
287 , ("XX", "Xtorrent")
288 , ("ZT", "ZipTorrent")
289 ]
290-}
diff --git a/src/Network/BitTorrent/Core/NodeInfo.hs b/src/Network/BitTorrent/Core/NodeInfo.hs
deleted file mode 100644
index fe17c097..00000000
--- a/src/Network/BitTorrent/Core/NodeInfo.hs
+++ /dev/null
@@ -1,219 +0,0 @@
1-- |
2-- Module : Network.BitTorrent.Core.Node
3-- Copyright : (c) Sam Truzjan 2013
4-- (c) Daniel Gröber 2013
5-- License : BSD3
6-- Maintainer : pxqr.sta@gmail.com
7-- Stability : experimental
8-- Portability : portable
9--
10-- A \"node\" is a client\/server listening on a UDP port
11-- implementing the distributed hash table protocol. The DHT is
12-- composed of nodes and stores the location of peers. BitTorrent
13-- clients include a DHT node, which is used to contact other nodes
14-- in the DHT to get the location of peers to download from using
15-- the BitTorrent protocol.
16--
17{-# LANGUAGE RecordWildCards #-}
18{-# LANGUAGE FlexibleInstances #-}
19{-# LANGUAGE TemplateHaskell #-}
20{-# LANGUAGE GeneralizedNewtypeDeriving #-}
21{-# LANGUAGE DeriveDataTypeable #-}
22{-# LANGUAGE DeriveFunctor #-}
23module Network.BitTorrent.Core.NodeInfo
24 ( -- * Node ID
25 NodeId
26 , testIdBit
27 , genNodeId
28
29 -- ** Node distance
30 , NodeDistance
31 , distance
32
33 -- * Node address
34 , NodeAddr (..)
35
36 -- * Node info
37 , NodeInfo (..)
38 , rank
39 ) where
40
41import Control.Applicative
42import Data.Bits
43import Data.ByteString as BS
44import Data.ByteString.Char8 as BC
45import Data.ByteString.Base16 as Base16
46import Data.BEncode as BE
47import Data.Default
48import Data.Hashable
49import Data.Foldable
50import Data.IP
51import Data.List as L
52import Data.Monoid
53import Data.Ord
54import Data.Serialize as S
55import Data.String
56import Data.Typeable
57import Data.Word
58import Network
59import System.Entropy
60import Text.PrettyPrint as PP hiding ((<>))
61import Text.PrettyPrint.Class
62
63import Network.BitTorrent.Core.PeerAddr (PeerAddr (..))
64
65{-----------------------------------------------------------------------
66-- Node id
67-----------------------------------------------------------------------}
68-- TODO more compact representation ('ShortByteString's?)
69
70-- | Each node has a globally unique identifier known as the \"node
71-- ID.\"
72--
73-- Normally, /this/ node id should be saved between invocations
74-- of the client software.
75newtype NodeId = NodeId ByteString
76 deriving (Show, Eq, Ord, BEncode, Typeable)
77
78nodeIdSize :: Int
79nodeIdSize = 20
80
81-- | Meaningless node id, for testing purposes only.
82instance Default NodeId where
83 def = NodeId (BS.replicate nodeIdSize 0)
84
85instance Serialize NodeId where
86 get = NodeId <$> getByteString nodeIdSize
87 {-# INLINE get #-}
88 put (NodeId bs) = putByteString bs
89 {-# INLINE put #-}
90
91-- | ASCII encoded.
92instance IsString NodeId where
93 fromString str
94 | L.length str == nodeIdSize = NodeId (fromString str)
95 | otherwise = error "fromString: invalid NodeId length"
96 {-# INLINE fromString #-}
97
98-- | base16 encoded.
99instance Pretty NodeId where
100 pretty (NodeId nid) = PP.text $ BC.unpack $ Base16.encode nid
101
102-- | Test if the nth bit is set.
103testIdBit :: NodeId -> Word -> Bool
104testIdBit (NodeId bs) i
105 | fromIntegral i < nodeIdSize * 8
106 , (q, r) <- quotRem (fromIntegral i) 8
107 = testBit (BS.index bs q) r
108 | otherwise = False
109{-# INLINE testIdBit #-}
110
111-- TODO WARN is the 'system' random suitable for this?
112-- | Generate random NodeID used for the entire session.
113-- Distribution of ID's should be as uniform as possible.
114--
115genNodeId :: IO NodeId
116genNodeId = NodeId <$> getEntropy nodeIdSize
117
118{-----------------------------------------------------------------------
119-- Node distance
120-----------------------------------------------------------------------}
121
122-- | In Kademlia, the distance metric is XOR and the result is
123-- interpreted as an unsigned integer.
124newtype NodeDistance = NodeDistance BS.ByteString
125 deriving (Eq, Ord)
126
127instance Pretty NodeDistance where
128 pretty (NodeDistance bs) = foldMap bitseq $ BS.unpack bs
129 where
130 listBits w = L.map (testBit w) (L.reverse [0..bitSize w - 1])
131 bitseq = foldMap (int . fromEnum) . listBits
132
133-- | distance(A,B) = |A xor B| Smaller values are closer.
134distance :: NodeId -> NodeId -> NodeDistance
135distance (NodeId a) (NodeId b) = NodeDistance (BS.pack (BS.zipWith xor a b))
136
137{-----------------------------------------------------------------------
138-- Node address
139-----------------------------------------------------------------------}
140
141data NodeAddr a = NodeAddr
142 { nodeHost :: !a
143 , nodePort :: {-# UNPACK #-} !PortNumber
144 } deriving (Eq, Typeable, Functor)
145
146instance Show a => Show (NodeAddr a) where
147 showsPrec i NodeAddr {..}
148 = showsPrec i nodeHost <> showString ":" <> showsPrec i nodePort
149
150instance Read (NodeAddr IPv4) where
151 readsPrec i x = [ (fromPeerAddr a, s) | (a, s) <- readsPrec i x ]
152
153-- | @127.0.0.1:6882@
154instance Default (NodeAddr IPv4) where
155 def = "127.0.0.1:6882"
156
157-- | KRPC compatible encoding.
158instance Serialize a => Serialize (NodeAddr a) where
159 get = NodeAddr <$> get <*> get
160 {-# INLINE get #-}
161 put NodeAddr {..} = put nodeHost >> put nodePort
162 {-# INLINE put #-}
163
164-- | Torrent file compatible encoding.
165instance BEncode a => BEncode (NodeAddr a) where
166 toBEncode NodeAddr {..} = toBEncode (nodeHost, nodePort)
167 {-# INLINE toBEncode #-}
168 fromBEncode b = uncurry NodeAddr <$> fromBEncode b
169 {-# INLINE fromBEncode #-}
170
171instance Hashable a => Hashable (NodeAddr a) where
172 hashWithSalt s NodeAddr {..} = hashWithSalt s (nodeHost, nodePort)
173 {-# INLINE hashWithSalt #-}
174
175instance Pretty ip => Pretty (NodeAddr ip) where
176 pretty NodeAddr {..} = pretty nodeHost <> ":" <> pretty nodePort
177
178-- | Example:
179--
180-- @nodePort \"127.0.0.1:6881\" == 6881@
181--
182instance IsString (NodeAddr IPv4) where
183 fromString = fromPeerAddr . fromString
184
185fromPeerAddr :: PeerAddr a -> NodeAddr a
186fromPeerAddr PeerAddr {..} = NodeAddr
187 { nodeHost = peerHost
188 , nodePort = peerPort
189 }
190
191{-----------------------------------------------------------------------
192-- Node info
193-----------------------------------------------------------------------}
194
195data NodeInfo a = NodeInfo
196 { nodeId :: !NodeId
197 , nodeAddr :: !(NodeAddr a)
198 } deriving (Show, Eq, Functor)
199
200instance Eq a => Ord (NodeInfo a) where
201 compare = comparing nodeId
202
203-- | KRPC 'compact list' compatible encoding: contact information for
204-- nodes is encoded as a 26-byte string. Also known as "Compact node
205-- info" the 20-byte Node ID in network byte order has the compact
206-- IP-address/port info concatenated to the end.
207instance Serialize a => Serialize (NodeInfo a) where
208 get = NodeInfo <$> get <*> get
209 put NodeInfo {..} = put nodeId >> put nodeAddr
210
211instance Pretty ip => Pretty (NodeInfo ip) where
212 pretty NodeInfo {..} = pretty nodeId <> "@(" <> pretty nodeAddr <> ")"
213
214instance Pretty ip => Pretty [NodeInfo ip] where
215 pretty = PP.vcat . PP.punctuate "," . L.map pretty
216
217-- | Order by closeness: nearest nodes first.
218rank :: Eq ip => NodeId -> [NodeInfo ip] -> [NodeInfo ip]
219rank nid = L.sortBy (comparing (distance nid . nodeId))
diff --git a/src/Network/BitTorrent/Core/PeerAddr.hs b/src/Network/BitTorrent/Core/PeerAddr.hs
deleted file mode 100644
index e9ad7c96..00000000
--- a/src/Network/BitTorrent/Core/PeerAddr.hs
+++ /dev/null
@@ -1,312 +0,0 @@
1-- |
2-- Module : Network.BitTorrent.Core.PeerAddr
3-- Copyright : (c) Sam Truzjan 2013
4-- (c) Daniel Gröber 2013
5-- License : BSD3
6-- Maintainer : pxqr.sta@gmail.com
7-- Stability : provisional
8-- Portability : portable
9--
10-- 'PeerAddr' is used to represent peer address. Currently it's
11-- just peer IP and peer port but this might change in future.
12--
13{-# LANGUAGE TemplateHaskell #-}
14{-# LANGUAGE StandaloneDeriving #-}
15{-# LANGUAGE GeneralizedNewtypeDeriving #-}
16{-# LANGUAGE DeriveDataTypeable #-}
17{-# LANGUAGE FlexibleInstances #-}
18{-# LANGUAGE DeriveFunctor #-}
19{-# LANGUAGE ViewPatterns #-}
20{-# OPTIONS -fno-warn-orphans #-} -- for PortNumber instances
21module Network.BitTorrent.Core.PeerAddr
22 ( -- * Peer address
23 PeerAddr(..)
24 , defaultPorts
25 , peerSockAddr
26 , peerSocket
27
28 -- * Peer storage
29 ) where
30
31import Control.Applicative
32import Control.Monad
33import Data.BEncode as BS
34import Data.BEncode.BDict (BKey)
35import Data.ByteString.Char8 as BS8
36import Data.Char
37import Data.Default
38import Data.Hashable
39import Data.IP
40import Data.List as L
41import Data.List.Split
42import Data.Monoid
43import Data.Serialize as S
44import Data.String
45import Data.Typeable
46import Data.Word
47import Network.Socket
48import Text.PrettyPrint as PP hiding ((<>))
49import Text.PrettyPrint.Class
50import Text.Read (readMaybe)
51import qualified Text.ParserCombinators.ReadP as RP
52
53--import Data.Torrent
54import Network.BitTorrent.Core.PeerId
55
56
57{-----------------------------------------------------------------------
58-- Port number
59-----------------------------------------------------------------------}
60
61instance BEncode PortNumber where
62 toBEncode = toBEncode . fromEnum
63 fromBEncode = fromBEncode >=> portNumber
64 where
65 portNumber :: Integer -> BS.Result PortNumber
66 portNumber n
67 | 0 <= n && n <= fromIntegral (maxBound :: Word16)
68 = pure $ fromIntegral n
69 | otherwise = decodingError $ "PortNumber: " ++ show n
70
71instance Serialize PortNumber where
72 get = fromIntegral <$> getWord16be
73 {-# INLINE get #-}
74 put = putWord16be . fromIntegral
75 {-# INLINE put #-}
76
77instance Hashable PortNumber where
78 hashWithSalt s = hashWithSalt s . fromEnum
79 {-# INLINE hashWithSalt #-}
80
81instance Pretty PortNumber where
82 pretty = PP.int . fromEnum
83 {-# INLINE pretty #-}
84
85{-----------------------------------------------------------------------
86-- IP addr
87-----------------------------------------------------------------------}
88
89class IPAddress i where
90 toHostAddr :: i -> Either HostAddress HostAddress6
91
92instance IPAddress IPv4 where
93 toHostAddr = Left . toHostAddress
94 {-# INLINE toHostAddr #-}
95
96instance IPAddress IPv6 where
97 toHostAddr = Right . toHostAddress6
98 {-# INLINE toHostAddr #-}
99
100instance IPAddress IP where
101 toHostAddr (IPv4 ip) = toHostAddr ip
102 toHostAddr (IPv6 ip) = toHostAddr ip
103 {-# INLINE toHostAddr #-}
104
105deriving instance Typeable IP
106deriving instance Typeable IPv4
107deriving instance Typeable IPv6
108
109ipToBEncode :: Show i => i -> BValue
110ipToBEncode ip = BString $ BS8.pack $ show ip
111{-# INLINE ipToBEncode #-}
112
113ipFromBEncode :: Read a => BValue -> BS.Result a
114ipFromBEncode (BString (BS8.unpack -> ipStr))
115 | Just ip <- readMaybe (ipStr) = pure ip
116 | otherwise = decodingError $ "IP: " ++ ipStr
117ipFromBEncode _ = decodingError $ "IP: addr should be a bstring"
118
119instance BEncode IP where
120 toBEncode = ipToBEncode
121 {-# INLINE toBEncode #-}
122 fromBEncode = ipFromBEncode
123 {-# INLINE fromBEncode #-}
124
125instance BEncode IPv4 where
126 toBEncode = ipToBEncode
127 {-# INLINE toBEncode #-}
128 fromBEncode = ipFromBEncode
129 {-# INLINE fromBEncode #-}
130
131instance BEncode IPv6 where
132 toBEncode = ipToBEncode
133 {-# INLINE toBEncode #-}
134 fromBEncode = ipFromBEncode
135 {-# INLINE fromBEncode #-}
136
137-- | When 'get'ing an IP it must be 'isolate'd to the appropriate
138-- number of bytes since we have no other way of telling which
139-- address type we are trying to parse
140instance Serialize IP where
141 put (IPv4 ip) = put ip
142 put (IPv6 ip) = put ip
143
144 get = do
145 n <- remaining
146 case n of
147 4 -> IPv4 <$> get
148 16 -> IPv6 <$> get
149 _ -> fail "Wrong number of bytes remaining to parse IP"
150
151instance Serialize IPv4 where
152 put = putWord32host . toHostAddress
153 get = fromHostAddress <$> getWord32host
154
155instance Serialize IPv6 where
156 put ip = put $ toHostAddress6 ip
157 get = fromHostAddress6 <$> get
158
159instance Pretty IPv4 where
160 pretty = PP.text . show
161 {-# INLINE pretty #-}
162
163instance Pretty IPv6 where
164 pretty = PP.text . show
165 {-# INLINE pretty #-}
166
167instance Pretty IP where
168 pretty = PP.text . show
169 {-# INLINE pretty #-}
170
171instance Hashable IPv4 where
172 hashWithSalt = hashUsing toHostAddress
173 {-# INLINE hashWithSalt #-}
174
175instance Hashable IPv6 where
176 hashWithSalt s a = hashWithSalt s (toHostAddress6 a)
177
178instance Hashable IP where
179 hashWithSalt s (IPv4 h) = hashWithSalt s h
180 hashWithSalt s (IPv6 h) = hashWithSalt s h
181
182{-----------------------------------------------------------------------
183-- Peer addr
184-----------------------------------------------------------------------}
185-- TODO check semantic of ord and eq instances
186
187-- | Peer address info normally extracted from peer list or peer
188-- compact list encoding.
189data PeerAddr a = PeerAddr
190 { peerId :: !(Maybe PeerId)
191
192 -- | This is usually 'IPv4', 'IPv6', 'IP' or unresolved
193 -- 'HostName'.
194 , peerHost :: !a
195
196 -- | The port the peer listenning for incoming P2P sessions.
197 , peerPort :: {-# UNPACK #-} !PortNumber
198 } deriving (Show, Eq, Ord, Typeable, Functor)
199
200peer_ip_key, peer_id_key, peer_port_key :: BKey
201peer_ip_key = "ip"
202peer_id_key = "peer id"
203peer_port_key = "port"
204
205-- | The tracker's 'announce response' compatible encoding.
206instance (Typeable a, BEncode a) => BEncode (PeerAddr a) where
207 toBEncode PeerAddr {..} = toDict $
208 peer_ip_key .=! peerHost
209 .: peer_id_key .=? peerId
210 .: peer_port_key .=! peerPort
211 .: endDict
212
213 fromBEncode = fromDict $ do
214 peerAddr <$>! peer_ip_key
215 <*>? peer_id_key
216 <*>! peer_port_key
217 where
218 peerAddr = flip PeerAddr
219
220-- | The tracker's 'compact peer list' compatible encoding. The
221-- 'peerId' is always 'Nothing'.
222--
223-- For more info see: <http://www.bittorrent.org/beps/bep_0023.html>
224--
225-- TODO: test byte order
226instance (Serialize a) => Serialize (PeerAddr a) where
227 put PeerAddr {..} = put peerHost >> put peerPort
228 get = PeerAddr Nothing <$> get <*> get
229
230-- | @127.0.0.1:6881@
231instance Default (PeerAddr IPv4) where
232 def = "127.0.0.1:6881"
233
234-- | @127.0.0.1:6881@
235instance Default (PeerAddr IP) where
236 def = IPv4 <$> def
237
238-- | Example:
239--
240-- @peerPort \"127.0.0.1:6881\" == 6881@
241--
242instance IsString (PeerAddr IPv4) where
243 fromString str
244 | [hostAddrStr, portStr] <- splitWhen (== ':') str
245 , Just hostAddr <- readMaybe hostAddrStr
246 , Just portNum <- toEnum <$> readMaybe portStr
247 = PeerAddr Nothing hostAddr portNum
248 | otherwise = error $ "fromString: unable to parse (PeerAddr IPv4): " ++ str
249
250instance Read (PeerAddr IPv4) where
251 readsPrec i = RP.readP_to_S $ do
252 ipv4 <- RP.readS_to_P (readsPrec i)
253 _ <- RP.char ':'
254 port <- toEnum <$> RP.readS_to_P (readsPrec i)
255 return $ PeerAddr Nothing ipv4 port
256
257readsIPv6_port :: String -> [((IPv6, PortNumber), String)]
258readsIPv6_port = RP.readP_to_S $ do
259 ip <- RP.char '[' *> (RP.readS_to_P reads) <* RP.char ']'
260 _ <- RP.char ':'
261 port <- toEnum <$> read <$> (RP.many1 $ RP.satisfy isDigit) <* RP.eof
262 return (ip,port)
263
264instance IsString (PeerAddr IPv6) where
265 fromString str
266 | [((ip,port),"")] <- readsIPv6_port str =
267 PeerAddr Nothing ip port
268 | otherwise = error $ "fromString: unable to parse (PeerAddr IPv6): " ++ str
269
270instance IsString (PeerAddr IP) where
271 fromString str
272 | '[' `L.elem` str = IPv6 <$> fromString str
273 | otherwise = IPv4 <$> fromString str
274
275-- | fingerprint + "at" + dotted.host.inet.addr:port
276-- TODO: instances for IPv6, HostName
277instance Pretty a => Pretty (PeerAddr a) where
278 pretty PeerAddr {..}
279 | Just pid <- peerId = pretty (fingerprint pid) <+> "at" <+> paddr
280 | otherwise = paddr
281 where
282 paddr = pretty peerHost <> ":" <> text (show peerPort)
283
284instance Hashable a => Hashable (PeerAddr a) where
285 hashWithSalt s PeerAddr {..} =
286 s `hashWithSalt` peerId `hashWithSalt` peerHost `hashWithSalt` peerPort
287
288-- | Ports typically reserved for bittorrent P2P listener.
289defaultPorts :: [PortNumber]
290defaultPorts = [6881..6889]
291
292_resolvePeerAddr :: (IPAddress i) => PeerAddr HostName -> PeerAddr i
293_resolvePeerAddr = undefined
294
295_peerSockAddr :: PeerAddr IP -> (Family, SockAddr)
296_peerSockAddr PeerAddr {..} =
297 case peerHost of
298 IPv4 ipv4 ->
299 (AF_INET, SockAddrInet peerPort (toHostAddress ipv4))
300 IPv6 ipv6 ->
301 (AF_INET6, SockAddrInet6 peerPort 0 (toHostAddress6 ipv6) 0)
302
303peerSockAddr :: PeerAddr IP -> SockAddr
304peerSockAddr = snd . _peerSockAddr
305
306-- | Create a socket connected to the address specified in a peerAddr
307peerSocket :: SocketType -> PeerAddr IP -> IO Socket
308peerSocket socketType pa = do
309 let (family, addr) = _peerSockAddr pa
310 sock <- socket family socketType defaultProtocol
311 connect sock addr
312 return sock
diff --git a/src/Network/BitTorrent/Core/PeerId.hs b/src/Network/BitTorrent/Core/PeerId.hs
deleted file mode 100644
index a180ff30..00000000
--- a/src/Network/BitTorrent/Core/PeerId.hs
+++ /dev/null
@@ -1,364 +0,0 @@
1-- |
2-- Copyright : (c) Sam Truzjan 2013
3-- License : BSD3
4-- Maintainer : pxqr.sta@gmail.com
5-- Stability : experimental
6-- Portability : portable
7--
8-- 'PeerID' represent self assigned peer identificator. Ideally each
9-- host in the network should have unique peer id to avoid
10-- collisions, therefore for peer ID generation we use good entropy
11-- source. Peer ID is sent in /tracker request/, sent and received in
12-- /peer handshakes/ and used in DHT queries.
13--
14{-# LANGUAGE GeneralizedNewtypeDeriving #-}
15{-# LANGUAGE MultiParamTypeClasses #-}
16{-# LANGUAGE DeriveDataTypeable #-}
17module Network.BitTorrent.Core.PeerId
18 ( -- * PeerId
19 PeerId
20
21 -- * Generation
22 , genPeerId
23 , timestamp
24 , entropy
25
26 -- * Encoding
27 , azureusStyle
28 , shadowStyle
29 , defaultClientId
30 , defaultVersionNumber
31
32 -- * Decoding
33 , fingerprint
34 ) where
35
36import Control.Applicative
37import Data.BEncode as BE
38import Data.ByteString as BS
39import Data.ByteString.Internal as BS
40import Data.ByteString.Char8 as BC
41import qualified Data.ByteString.Lazy as BL
42import qualified Data.ByteString.Lazy.Builder as BS
43import Data.Convertible
44import Data.Default
45import Data.Foldable (foldMap)
46import Data.List as L
47import Data.List.Split as L
48import Data.Maybe (fromMaybe, catMaybes)
49import Data.Monoid
50import Data.Hashable
51import Data.Serialize as S
52import Data.String
53import Data.Time.Clock (getCurrentTime)
54import Data.Time.Format (formatTime)
55import Data.Typeable
56import Data.Version (Version(Version), versionBranch)
57import Network.HTTP.Types.QueryLike
58import System.Entropy (getEntropy)
59import System.Locale (defaultTimeLocale)
60import Text.PrettyPrint hiding ((<>))
61import Text.PrettyPrint.Class
62import Text.Read (readMaybe)
63
64import Network.BitTorrent.Core.Fingerprint
65
66-- TODO use unpacked Word160 form (length is known statically)
67
68-- | Peer identifier is exactly 20 bytes long bytestring.
69newtype PeerId = PeerId { getPeerId :: ByteString }
70 deriving (Show, Eq, Ord, BEncode, Typeable)
71
72peerIdLen :: Int
73peerIdLen = 20
74
75-- | For testing purposes only.
76instance Default PeerId where
77 def = azureusStyle defaultClientId defaultVersionNumber ""
78
79instance Hashable PeerId where
80 hashWithSalt = hashUsing getPeerId
81 {-# INLINE hashWithSalt #-}
82
83instance Serialize PeerId where
84 put = putByteString . getPeerId
85 get = PeerId <$> getBytes peerIdLen
86
87instance QueryValueLike PeerId where
88 toQueryValue (PeerId pid) = Just pid
89 {-# INLINE toQueryValue #-}
90
91instance IsString PeerId where
92 fromString str
93 | BS.length bs == peerIdLen = PeerId bs
94 | otherwise = error $ "Peer id should be 20 bytes long: " ++ show str
95 where
96 bs = fromString str
97
98instance Pretty PeerId where
99 pretty = text . BC.unpack . getPeerId
100
101instance Convertible BS.ByteString PeerId where
102 safeConvert bs
103 | BS.length bs == peerIdLen = pure (PeerId bs)
104 | otherwise = convError "invalid length" bs
105
106{-----------------------------------------------------------------------
107-- Encoding
108-----------------------------------------------------------------------}
109
110-- | Pad bytestring so it's becomes exactly request length. Conversion
111-- is done like so:
112--
113-- * length < size: Complete bytestring by given charaters.
114--
115-- * length = size: Output bytestring as is.
116--
117-- * length > size: Drop last (length - size) charaters from a
118-- given bytestring.
119--
120byteStringPadded :: ByteString -- ^ bytestring to be padded.
121 -> Int -- ^ size of result builder.
122 -> Char -- ^ character used for padding.
123 -> BS.Builder
124byteStringPadded bs s c =
125 BS.byteString (BS.take s bs) <>
126 BS.byteString (BC.replicate padLen c)
127 where
128 padLen = s - min (BS.length bs) s
129
130-- | Azureus-style encoding have the following layout:
131--
132-- * 1 byte : '-'
133--
134-- * 2 bytes: client id
135--
136-- * 4 bytes: version number
137--
138-- * 1 byte : '-'
139--
140-- * 12 bytes: random number
141--
142azureusStyle :: ByteString -- ^ 2 character client ID, padded with 'H'.
143 -> ByteString -- ^ Version number, padded with 'X'.
144 -> ByteString -- ^ Random number, padded with '0'.
145 -> PeerId -- ^ Azureus-style encoded peer ID.
146azureusStyle cid ver rnd = PeerId $ BL.toStrict $ BS.toLazyByteString $
147 BS.char8 '-' <>
148 byteStringPadded cid 2 'H' <>
149 byteStringPadded ver 4 'X' <>
150 BS.char8 '-' <>
151 byteStringPadded rnd 12 '0'
152
153-- | Shadow-style encoding have the following layout:
154--
155-- * 1 byte : client id.
156--
157-- * 0-4 bytes: version number. If less than 4 then padded with
158-- '-' char.
159--
160-- * 15 bytes : random number. If length is less than 15 then
161-- padded with '0' char.
162--
163shadowStyle :: Char -- ^ Client ID.
164 -> ByteString -- ^ Version number.
165 -> ByteString -- ^ Random number.
166 -> PeerId -- ^ Shadow style encoded peer ID.
167shadowStyle cid ver rnd = PeerId $ BL.toStrict $ BS.toLazyByteString $
168 BS.char8 cid <>
169 byteStringPadded ver 4 '-' <>
170 byteStringPadded rnd 15 '0'
171
172
173-- | 'HS'- 2 bytes long client identifier.
174defaultClientId :: ByteString
175defaultClientId = "HS"
176
177-- | Gives exactly 4 bytes long version number for any version of the
178-- package. Version is taken from .cabal file.
179defaultVersionNumber :: ByteString
180defaultVersionNumber = BS.take 4 $ BC.pack $ foldMap show $
181 versionBranch $ ciVersion libFingerprint
182
183{-----------------------------------------------------------------------
184-- Generation
185-----------------------------------------------------------------------}
186
187-- | Gives 15 characters long decimal timestamp such that:
188--
189-- * 6 bytes : first 6 characters from picoseconds obtained with %q.
190--
191-- * 1 byte : character \'.\' for readability.
192--
193-- * 9..* bytes: number of whole seconds since the Unix epoch
194-- (!)REVERSED.
195--
196-- Can be used both with shadow and azureus style encoding. This
197-- format is used to make the ID's readable for debugging purposes.
198--
199timestamp :: IO ByteString
200timestamp = (BC.pack . format) <$> getCurrentTime
201 where
202 format t = L.take 6 (formatTime defaultTimeLocale "%q" t) ++ "." ++
203 L.take 9 (L.reverse (formatTime defaultTimeLocale "%s" t))
204
205-- | Gives 15 character long random bytestring. This is more robust
206-- method for generation of random part of peer ID than 'timestamp'.
207entropy :: IO ByteString
208entropy = getEntropy 15
209
210-- NOTE: entropy generates incorrrect peer id
211
212-- | Here we use 'azureusStyle' encoding with the following args:
213--
214-- * 'HS' for the client id; ('defaultClientId')
215--
216-- * Version of the package for the version number;
217-- ('defaultVersionNumber')
218--
219-- * UTC time day ++ day time for the random number. ('timestamp')
220--
221genPeerId :: IO PeerId
222genPeerId = azureusStyle defaultClientId defaultVersionNumber <$> timestamp
223
224{-----------------------------------------------------------------------
225-- Decoding
226-----------------------------------------------------------------------}
227
228parseImpl :: ByteString -> ClientImpl
229parseImpl = f . BC.unpack
230 where
231 f "AG" = IAres
232 f "A~" = IAres
233 f "AR" = IArctic
234 f "AV" = IAvicora
235 f "AX" = IBitPump
236 f "AZ" = IAzureus
237 f "BB" = IBitBuddy
238 f "BC" = IBitComet
239 f "BF" = IBitflu
240 f "BG" = IBTG
241 f "BR" = IBitRocket
242 f "BS" = IBTSlave
243 f "BX" = IBittorrentX
244 f "CD" = IEnhancedCTorrent
245 f "CT" = ICTorrent
246 f "DE" = IDelugeTorrent
247 f "DP" = IPropagateDataClient
248 f "EB" = IEBit
249 f "ES" = IElectricSheep
250 f "FT" = IFoxTorrent
251 f "GS" = IGSTorrent
252 f "HL" = IHalite
253 f "HS" = IlibHSbittorrent
254 f "HN" = IHydranode
255 f "KG" = IKGet
256 f "KT" = IKTorrent
257 f "LH" = ILH_ABC
258 f "LP" = ILphant
259 f "LT" = ILibtorrent
260 f "lt" = ILibTorrent
261 f "LW" = ILimeWire
262 f "MO" = IMonoTorrent
263 f "MP" = IMooPolice
264 f "MR" = IMiro
265 f "ML" = IMLdonkey
266 f "MT" = IMoonlightTorrent
267 f "NX" = INetTransport
268 f "PD" = IPando
269 f "qB" = IqBittorrent
270 f "QD" = IQQDownload
271 f "QT" = IQt4TorrentExample
272 f "RT" = IRetriever
273 f "S~" = IShareaza
274 f "SB" = ISwiftbit
275 f "SS" = ISwarmScope
276 f "ST" = ISymTorrent
277 f "st" = Isharktorrent
278 f "SZ" = IShareaza
279 f "TN" = ITorrentDotNET
280 f "TR" = ITransmission
281 f "TS" = ITorrentstorm
282 f "TT" = ITuoTu
283 f "UL" = IuLeecher
284 f "UT" = IuTorrent
285 f "VG" = IVagaa
286 f "WT" = IBitLet
287 f "WY" = IFireTorrent
288 f "XL" = IXunlei
289 f "XT" = IXanTorrent
290 f "XX" = IXtorrent
291 f "ZT" = IZipTorrent
292 f _ = IUnknown
293
294-- TODO use regexps
295
296-- | Tries to extract meaningful information from peer ID bytes. If
297-- peer id uses unknown coding style then client info returned is
298-- 'def'.
299--
300fingerprint :: PeerId -> Fingerprint
301fingerprint pid = either (const def) id $ runGet getCI (getPeerId pid)
302 where
303 getCI = do
304 leading <- BS.w2c <$> getWord8
305 case leading of
306 '-' -> Fingerprint <$> getAzureusImpl <*> getAzureusVersion
307 'M' -> Fingerprint <$> pure IMainline <*> getMainlineVersion
308 'e' -> Fingerprint <$> getBitCometImpl <*> getBitCometVersion
309 'F' -> Fingerprint <$> getBitCometImpl <*> getBitCometVersion
310 c -> do
311 c1 <- w2c <$> S.lookAhead getWord8
312 if c1 == 'P'
313 then do
314 _ <- getWord8
315 Fingerprint <$> pure IOpera <*> getOperaVersion
316 else Fingerprint <$> pure (getShadowImpl c) <*> getShadowVersion
317
318 getMainlineVersion = do
319 str <- BC.unpack <$> getByteString 7
320 let mnums = L.filter (not . L.null) $ L.linesBy ('-' ==) str
321 return $ Version (fromMaybe [] $ sequence $ L.map readMaybe mnums) []
322
323 getAzureusImpl = parseImpl <$> getByteString 2
324 getAzureusVersion = mkVer <$> getByteString 4
325 where
326 mkVer bs = Version [fromMaybe 0 $ readMaybe $ BC.unpack bs] []
327
328 getBitCometImpl = do
329 bs <- getByteString 3
330 S.lookAhead $ do
331 _ <- getByteString 2
332 lr <- getByteString 4
333 return $
334 if lr == "LORD" then IBitLord else
335 if bs == "UTB" then IBitComet else
336 if bs == "xbc" then IBitComet else def
337
338 getBitCometVersion = do
339 x <- getWord8
340 y <- getWord8
341 return $ Version [fromIntegral x, fromIntegral y] []
342
343 getOperaVersion = do
344 str <- BC.unpack <$> getByteString 4
345 return $ Version [fromMaybe 0 $ readMaybe str] []
346
347 getShadowImpl 'A' = IABC
348 getShadowImpl 'O' = IOspreyPermaseed
349 getShadowImpl 'Q' = IBTQueue
350 getShadowImpl 'R' = ITribler
351 getShadowImpl 'S' = IShadow
352 getShadowImpl 'T' = IBitTornado
353 getShadowImpl _ = IUnknown
354
355 decodeShadowVerNr :: Char -> Maybe Int
356 decodeShadowVerNr c
357 | '0' < c && c <= '9' = Just (fromEnum c - fromEnum '0')
358 | 'A' < c && c <= 'Z' = Just ((fromEnum c - fromEnum 'A') + 10)
359 | 'a' < c && c <= 'z' = Just ((fromEnum c - fromEnum 'a') + 36)
360 | otherwise = Nothing
361
362 getShadowVersion = do
363 str <- BC.unpack <$> getByteString 5
364 return $ Version (catMaybes $ L.map decodeShadowVerNr str) []
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-22 16:44:10 +0000