diff options
author | Sam Truzjan <pxqr.sta@gmail.com> | 2014-04-08 02:36:18 +0400 |
---|---|---|
committer | Sam Truzjan <pxqr.sta@gmail.com> | 2014-04-08 02:36:18 +0400 |
commit | 75711985512c8578e913a1b464816968b4aef5dd (patch) | |
tree | 5ab77d69af0e9bc315b58f1df6ba100e318adfce /src/Network/BitTorrent/Core | |
parent | 7e597cd924d2149b10f900c7dc14ce6e1e321cb5 (diff) |
Merge PeerAddr and NodeAddr modules
Diffstat (limited to 'src/Network/BitTorrent/Core')
-rw-r--r-- | src/Network/BitTorrent/Core/Fingerprint.hs | 290 | ||||
-rw-r--r-- | src/Network/BitTorrent/Core/NodeInfo.hs | 219 | ||||
-rw-r--r-- | src/Network/BitTorrent/Core/PeerAddr.hs | 312 | ||||
-rw-r--r-- | src/Network/BitTorrent/Core/PeerId.hs | 364 |
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 #-} | ||
24 | module Network.BitTorrent.Core.Fingerprint | ||
25 | ( ClientImpl (..) | ||
26 | , Fingerprint (..) | ||
27 | , libFingerprint | ||
28 | , libUserAgent | ||
29 | ) where | ||
30 | |||
31 | import Data.Default | ||
32 | import Data.List as L | ||
33 | import Data.List.Split as L | ||
34 | import Data.Monoid | ||
35 | import Data.String | ||
36 | import Data.Version | ||
37 | import Text.PrettyPrint hiding ((<>)) | ||
38 | import Text.PrettyPrint.Class | ||
39 | import Text.Read (readMaybe) | ||
40 | -- import Paths_bittorrent (version) | ||
41 | |||
42 | -- TODO FIXME | ||
43 | version :: Version | ||
44 | version = 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 | -- | ||
51 | data 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 | ||
130 | instance Default ClientImpl where | ||
131 | def = IUnknown | ||
132 | {-# INLINE def #-} | ||
133 | |||
134 | -- | Example: @\"BitLet\" == 'IBitLet'@ | ||
135 | instance 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\"@ | ||
144 | instance Pretty ClientImpl where | ||
145 | pretty = text . L.tail . show | ||
146 | |||
147 | -- | Just the '0' version. | ||
148 | instance 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 | -- | ||
155 | instance 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 | |||
162 | instance 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. | ||
167 | data Fingerprint = Fingerprint | ||
168 | { ciImpl :: ClientImpl | ||
169 | , ciVersion :: Version | ||
170 | } deriving (Show, Eq, Ord) | ||
171 | |||
172 | -- | Unrecognized client implementation. | ||
173 | instance Default Fingerprint where | ||
174 | def = Fingerprint def def | ||
175 | {-# INLINE def #-} | ||
176 | |||
177 | -- | Example: @\"BitComet-1.2\" == ClientInfo IBitComet (Version [1, 2] [])@ | ||
178 | instance 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 | |||
185 | instance 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 | -- | ||
192 | libFingerprint :: Fingerprint | ||
193 | libFingerprint = Fingerprint IlibHSbittorrent version | ||
194 | |||
195 | -- | HTTP user agent of this (the bittorrent library) package. Can be | ||
196 | -- used in HTTP tracker requests. | ||
197 | libUserAgent :: String | ||
198 | libUserAgent = render (pretty IlibHSbittorrent <> "/" <> pretty version) | ||
199 | |||
200 | {----------------------------------------------------------------------- | ||
201 | -- For torrent file | ||
202 | -----------------------------------------------------------------------} | ||
203 | -- TODO collect information about createdBy torrent field | ||
204 | {- | ||
205 | renderImpl :: ClientImpl -> Text | ||
206 | renderImpl = T.pack . L.tail . show | ||
207 | |||
208 | renderVersion :: Version -> Text | ||
209 | renderVersion = undefined | ||
210 | |||
211 | renderClientInfo :: ClientInfo -> Text | ||
212 | renderClientInfo ClientInfo {..} = renderImpl ciImpl <> "/" <> renderVersion ciVersion | ||
213 | |||
214 | parseClientInfo :: Text -> ClientImpl | ||
215 | parseClientInfo t = undefined | ||
216 | -} | ||
217 | {- | ||
218 | -- code used for generation; remove it later on | ||
219 | |||
220 | mkEnumTyDef :: NM -> String | ||
221 | mkEnumTyDef = unlines . map (" | I" ++) . nub . map snd | ||
222 | |||
223 | mkPars :: NM -> String | ||
224 | mkPars = unlines . map (\(code, impl) -> " f \"" ++ code ++ "\" = " ++ "I" ++ impl) | ||
225 | |||
226 | type NM = [(String, String)] | ||
227 | nameMap :: NM | ||
228 | nameMap = | ||
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 #-} | ||
23 | module 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 | |||
41 | import Control.Applicative | ||
42 | import Data.Bits | ||
43 | import Data.ByteString as BS | ||
44 | import Data.ByteString.Char8 as BC | ||
45 | import Data.ByteString.Base16 as Base16 | ||
46 | import Data.BEncode as BE | ||
47 | import Data.Default | ||
48 | import Data.Hashable | ||
49 | import Data.Foldable | ||
50 | import Data.IP | ||
51 | import Data.List as L | ||
52 | import Data.Monoid | ||
53 | import Data.Ord | ||
54 | import Data.Serialize as S | ||
55 | import Data.String | ||
56 | import Data.Typeable | ||
57 | import Data.Word | ||
58 | import Network | ||
59 | import System.Entropy | ||
60 | import Text.PrettyPrint as PP hiding ((<>)) | ||
61 | import Text.PrettyPrint.Class | ||
62 | |||
63 | import 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. | ||
75 | newtype NodeId = NodeId ByteString | ||
76 | deriving (Show, Eq, Ord, BEncode, Typeable) | ||
77 | |||
78 | nodeIdSize :: Int | ||
79 | nodeIdSize = 20 | ||
80 | |||
81 | -- | Meaningless node id, for testing purposes only. | ||
82 | instance Default NodeId where | ||
83 | def = NodeId (BS.replicate nodeIdSize 0) | ||
84 | |||
85 | instance Serialize NodeId where | ||
86 | get = NodeId <$> getByteString nodeIdSize | ||
87 | {-# INLINE get #-} | ||
88 | put (NodeId bs) = putByteString bs | ||
89 | {-# INLINE put #-} | ||
90 | |||
91 | -- | ASCII encoded. | ||
92 | instance 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. | ||
99 | instance Pretty NodeId where | ||
100 | pretty (NodeId nid) = PP.text $ BC.unpack $ Base16.encode nid | ||
101 | |||
102 | -- | Test if the nth bit is set. | ||
103 | testIdBit :: NodeId -> Word -> Bool | ||
104 | testIdBit (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 | -- | ||
115 | genNodeId :: IO NodeId | ||
116 | genNodeId = 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. | ||
124 | newtype NodeDistance = NodeDistance BS.ByteString | ||
125 | deriving (Eq, Ord) | ||
126 | |||
127 | instance 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. | ||
134 | distance :: NodeId -> NodeId -> NodeDistance | ||
135 | distance (NodeId a) (NodeId b) = NodeDistance (BS.pack (BS.zipWith xor a b)) | ||
136 | |||
137 | {----------------------------------------------------------------------- | ||
138 | -- Node address | ||
139 | -----------------------------------------------------------------------} | ||
140 | |||
141 | data NodeAddr a = NodeAddr | ||
142 | { nodeHost :: !a | ||
143 | , nodePort :: {-# UNPACK #-} !PortNumber | ||
144 | } deriving (Eq, Typeable, Functor) | ||
145 | |||
146 | instance Show a => Show (NodeAddr a) where | ||
147 | showsPrec i NodeAddr {..} | ||
148 | = showsPrec i nodeHost <> showString ":" <> showsPrec i nodePort | ||
149 | |||
150 | instance Read (NodeAddr IPv4) where | ||
151 | readsPrec i x = [ (fromPeerAddr a, s) | (a, s) <- readsPrec i x ] | ||
152 | |||
153 | -- | @127.0.0.1:6882@ | ||
154 | instance Default (NodeAddr IPv4) where | ||
155 | def = "127.0.0.1:6882" | ||
156 | |||
157 | -- | KRPC compatible encoding. | ||
158 | instance 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. | ||
165 | instance 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 | |||
171 | instance Hashable a => Hashable (NodeAddr a) where | ||
172 | hashWithSalt s NodeAddr {..} = hashWithSalt s (nodeHost, nodePort) | ||
173 | {-# INLINE hashWithSalt #-} | ||
174 | |||
175 | instance 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 | -- | ||
182 | instance IsString (NodeAddr IPv4) where | ||
183 | fromString = fromPeerAddr . fromString | ||
184 | |||
185 | fromPeerAddr :: PeerAddr a -> NodeAddr a | ||
186 | fromPeerAddr PeerAddr {..} = NodeAddr | ||
187 | { nodeHost = peerHost | ||
188 | , nodePort = peerPort | ||
189 | } | ||
190 | |||
191 | {----------------------------------------------------------------------- | ||
192 | -- Node info | ||
193 | -----------------------------------------------------------------------} | ||
194 | |||
195 | data NodeInfo a = NodeInfo | ||
196 | { nodeId :: !NodeId | ||
197 | , nodeAddr :: !(NodeAddr a) | ||
198 | } deriving (Show, Eq, Functor) | ||
199 | |||
200 | instance 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. | ||
207 | instance Serialize a => Serialize (NodeInfo a) where | ||
208 | get = NodeInfo <$> get <*> get | ||
209 | put NodeInfo {..} = put nodeId >> put nodeAddr | ||
210 | |||
211 | instance Pretty ip => Pretty (NodeInfo ip) where | ||
212 | pretty NodeInfo {..} = pretty nodeId <> "@(" <> pretty nodeAddr <> ")" | ||
213 | |||
214 | instance Pretty ip => Pretty [NodeInfo ip] where | ||
215 | pretty = PP.vcat . PP.punctuate "," . L.map pretty | ||
216 | |||
217 | -- | Order by closeness: nearest nodes first. | ||
218 | rank :: Eq ip => NodeId -> [NodeInfo ip] -> [NodeInfo ip] | ||
219 | rank 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 | ||
21 | module Network.BitTorrent.Core.PeerAddr | ||
22 | ( -- * Peer address | ||
23 | PeerAddr(..) | ||
24 | , defaultPorts | ||
25 | , peerSockAddr | ||
26 | , peerSocket | ||
27 | |||
28 | -- * Peer storage | ||
29 | ) where | ||
30 | |||
31 | import Control.Applicative | ||
32 | import Control.Monad | ||
33 | import Data.BEncode as BS | ||
34 | import Data.BEncode.BDict (BKey) | ||
35 | import Data.ByteString.Char8 as BS8 | ||
36 | import Data.Char | ||
37 | import Data.Default | ||
38 | import Data.Hashable | ||
39 | import Data.IP | ||
40 | import Data.List as L | ||
41 | import Data.List.Split | ||
42 | import Data.Monoid | ||
43 | import Data.Serialize as S | ||
44 | import Data.String | ||
45 | import Data.Typeable | ||
46 | import Data.Word | ||
47 | import Network.Socket | ||
48 | import Text.PrettyPrint as PP hiding ((<>)) | ||
49 | import Text.PrettyPrint.Class | ||
50 | import Text.Read (readMaybe) | ||
51 | import qualified Text.ParserCombinators.ReadP as RP | ||
52 | |||
53 | --import Data.Torrent | ||
54 | import Network.BitTorrent.Core.PeerId | ||
55 | |||
56 | |||
57 | {----------------------------------------------------------------------- | ||
58 | -- Port number | ||
59 | -----------------------------------------------------------------------} | ||
60 | |||
61 | instance 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 | |||
71 | instance Serialize PortNumber where | ||
72 | get = fromIntegral <$> getWord16be | ||
73 | {-# INLINE get #-} | ||
74 | put = putWord16be . fromIntegral | ||
75 | {-# INLINE put #-} | ||
76 | |||
77 | instance Hashable PortNumber where | ||
78 | hashWithSalt s = hashWithSalt s . fromEnum | ||
79 | {-# INLINE hashWithSalt #-} | ||
80 | |||
81 | instance Pretty PortNumber where | ||
82 | pretty = PP.int . fromEnum | ||
83 | {-# INLINE pretty #-} | ||
84 | |||
85 | {----------------------------------------------------------------------- | ||
86 | -- IP addr | ||
87 | -----------------------------------------------------------------------} | ||
88 | |||
89 | class IPAddress i where | ||
90 | toHostAddr :: i -> Either HostAddress HostAddress6 | ||
91 | |||
92 | instance IPAddress IPv4 where | ||
93 | toHostAddr = Left . toHostAddress | ||
94 | {-# INLINE toHostAddr #-} | ||
95 | |||
96 | instance IPAddress IPv6 where | ||
97 | toHostAddr = Right . toHostAddress6 | ||
98 | {-# INLINE toHostAddr #-} | ||
99 | |||
100 | instance IPAddress IP where | ||
101 | toHostAddr (IPv4 ip) = toHostAddr ip | ||
102 | toHostAddr (IPv6 ip) = toHostAddr ip | ||
103 | {-# INLINE toHostAddr #-} | ||
104 | |||
105 | deriving instance Typeable IP | ||
106 | deriving instance Typeable IPv4 | ||
107 | deriving instance Typeable IPv6 | ||
108 | |||
109 | ipToBEncode :: Show i => i -> BValue | ||
110 | ipToBEncode ip = BString $ BS8.pack $ show ip | ||
111 | {-# INLINE ipToBEncode #-} | ||
112 | |||
113 | ipFromBEncode :: Read a => BValue -> BS.Result a | ||
114 | ipFromBEncode (BString (BS8.unpack -> ipStr)) | ||
115 | | Just ip <- readMaybe (ipStr) = pure ip | ||
116 | | otherwise = decodingError $ "IP: " ++ ipStr | ||
117 | ipFromBEncode _ = decodingError $ "IP: addr should be a bstring" | ||
118 | |||
119 | instance BEncode IP where | ||
120 | toBEncode = ipToBEncode | ||
121 | {-# INLINE toBEncode #-} | ||
122 | fromBEncode = ipFromBEncode | ||
123 | {-# INLINE fromBEncode #-} | ||
124 | |||
125 | instance BEncode IPv4 where | ||
126 | toBEncode = ipToBEncode | ||
127 | {-# INLINE toBEncode #-} | ||
128 | fromBEncode = ipFromBEncode | ||
129 | {-# INLINE fromBEncode #-} | ||
130 | |||
131 | instance 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 | ||
140 | instance 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 | |||
151 | instance Serialize IPv4 where | ||
152 | put = putWord32host . toHostAddress | ||
153 | get = fromHostAddress <$> getWord32host | ||
154 | |||
155 | instance Serialize IPv6 where | ||
156 | put ip = put $ toHostAddress6 ip | ||
157 | get = fromHostAddress6 <$> get | ||
158 | |||
159 | instance Pretty IPv4 where | ||
160 | pretty = PP.text . show | ||
161 | {-# INLINE pretty #-} | ||
162 | |||
163 | instance Pretty IPv6 where | ||
164 | pretty = PP.text . show | ||
165 | {-# INLINE pretty #-} | ||
166 | |||
167 | instance Pretty IP where | ||
168 | pretty = PP.text . show | ||
169 | {-# INLINE pretty #-} | ||
170 | |||
171 | instance Hashable IPv4 where | ||
172 | hashWithSalt = hashUsing toHostAddress | ||
173 | {-# INLINE hashWithSalt #-} | ||
174 | |||
175 | instance Hashable IPv6 where | ||
176 | hashWithSalt s a = hashWithSalt s (toHostAddress6 a) | ||
177 | |||
178 | instance 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. | ||
189 | data 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 | |||
200 | peer_ip_key, peer_id_key, peer_port_key :: BKey | ||
201 | peer_ip_key = "ip" | ||
202 | peer_id_key = "peer id" | ||
203 | peer_port_key = "port" | ||
204 | |||
205 | -- | The tracker's 'announce response' compatible encoding. | ||
206 | instance (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 | ||
226 | instance (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@ | ||
231 | instance Default (PeerAddr IPv4) where | ||
232 | def = "127.0.0.1:6881" | ||
233 | |||
234 | -- | @127.0.0.1:6881@ | ||
235 | instance Default (PeerAddr IP) where | ||
236 | def = IPv4 <$> def | ||
237 | |||
238 | -- | Example: | ||
239 | -- | ||
240 | -- @peerPort \"127.0.0.1:6881\" == 6881@ | ||
241 | -- | ||
242 | instance 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 | |||
250 | instance 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 | |||
257 | readsIPv6_port :: String -> [((IPv6, PortNumber), String)] | ||
258 | readsIPv6_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 | |||
264 | instance 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 | |||
270 | instance 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 | ||
277 | instance 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 | |||
284 | instance 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. | ||
289 | defaultPorts :: [PortNumber] | ||
290 | defaultPorts = [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 | |||
303 | peerSockAddr :: PeerAddr IP -> SockAddr | ||
304 | peerSockAddr = snd . _peerSockAddr | ||
305 | |||
306 | -- | Create a socket connected to the address specified in a peerAddr | ||
307 | peerSocket :: SocketType -> PeerAddr IP -> IO Socket | ||
308 | peerSocket 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 #-} | ||
17 | module 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 | |||
36 | import Control.Applicative | ||
37 | import Data.BEncode as BE | ||
38 | import Data.ByteString as BS | ||
39 | import Data.ByteString.Internal as BS | ||
40 | import Data.ByteString.Char8 as BC | ||
41 | import qualified Data.ByteString.Lazy as BL | ||
42 | import qualified Data.ByteString.Lazy.Builder as BS | ||
43 | import Data.Convertible | ||
44 | import Data.Default | ||
45 | import Data.Foldable (foldMap) | ||
46 | import Data.List as L | ||
47 | import Data.List.Split as L | ||
48 | import Data.Maybe (fromMaybe, catMaybes) | ||
49 | import Data.Monoid | ||
50 | import Data.Hashable | ||
51 | import Data.Serialize as S | ||
52 | import Data.String | ||
53 | import Data.Time.Clock (getCurrentTime) | ||
54 | import Data.Time.Format (formatTime) | ||
55 | import Data.Typeable | ||
56 | import Data.Version (Version(Version), versionBranch) | ||
57 | import Network.HTTP.Types.QueryLike | ||
58 | import System.Entropy (getEntropy) | ||
59 | import System.Locale (defaultTimeLocale) | ||
60 | import Text.PrettyPrint hiding ((<>)) | ||
61 | import Text.PrettyPrint.Class | ||
62 | import Text.Read (readMaybe) | ||
63 | |||
64 | import 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. | ||
69 | newtype PeerId = PeerId { getPeerId :: ByteString } | ||
70 | deriving (Show, Eq, Ord, BEncode, Typeable) | ||
71 | |||
72 | peerIdLen :: Int | ||
73 | peerIdLen = 20 | ||
74 | |||
75 | -- | For testing purposes only. | ||
76 | instance Default PeerId where | ||
77 | def = azureusStyle defaultClientId defaultVersionNumber "" | ||
78 | |||
79 | instance Hashable PeerId where | ||
80 | hashWithSalt = hashUsing getPeerId | ||
81 | {-# INLINE hashWithSalt #-} | ||
82 | |||
83 | instance Serialize PeerId where | ||
84 | put = putByteString . getPeerId | ||
85 | get = PeerId <$> getBytes peerIdLen | ||
86 | |||
87 | instance QueryValueLike PeerId where | ||
88 | toQueryValue (PeerId pid) = Just pid | ||
89 | {-# INLINE toQueryValue #-} | ||
90 | |||
91 | instance 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 | |||
98 | instance Pretty PeerId where | ||
99 | pretty = text . BC.unpack . getPeerId | ||
100 | |||
101 | instance 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 | -- | ||
120 | byteStringPadded :: ByteString -- ^ bytestring to be padded. | ||
121 | -> Int -- ^ size of result builder. | ||
122 | -> Char -- ^ character used for padding. | ||
123 | -> BS.Builder | ||
124 | byteStringPadded 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 | -- | ||
142 | azureusStyle :: 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. | ||
146 | azureusStyle 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 | -- | ||
163 | shadowStyle :: Char -- ^ Client ID. | ||
164 | -> ByteString -- ^ Version number. | ||
165 | -> ByteString -- ^ Random number. | ||
166 | -> PeerId -- ^ Shadow style encoded peer ID. | ||
167 | shadowStyle 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. | ||
174 | defaultClientId :: ByteString | ||
175 | defaultClientId = "HS" | ||
176 | |||
177 | -- | Gives exactly 4 bytes long version number for any version of the | ||
178 | -- package. Version is taken from .cabal file. | ||
179 | defaultVersionNumber :: ByteString | ||
180 | defaultVersionNumber = 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 | -- | ||
199 | timestamp :: IO ByteString | ||
200 | timestamp = (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'. | ||
207 | entropy :: IO ByteString | ||
208 | entropy = 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 | -- | ||
221 | genPeerId :: IO PeerId | ||
222 | genPeerId = azureusStyle defaultClientId defaultVersionNumber <$> timestamp | ||
223 | |||
224 | {----------------------------------------------------------------------- | ||
225 | -- Decoding | ||
226 | -----------------------------------------------------------------------} | ||
227 | |||
228 | parseImpl :: ByteString -> ClientImpl | ||
229 | parseImpl = 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 | -- | ||
300 | fingerprint :: PeerId -> Fingerprint | ||
301 | fingerprint 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) [] | ||