diff options
Diffstat (limited to 'src/Network/BitTorrent/Core/PeerAddr.hs')
-rw-r--r-- | src/Network/BitTorrent/Core/PeerAddr.hs | 354 |
1 files changed, 0 insertions, 354 deletions
diff --git a/src/Network/BitTorrent/Core/PeerAddr.hs b/src/Network/BitTorrent/Core/PeerAddr.hs deleted file mode 100644 index 92fb83a7..00000000 --- a/src/Network/BitTorrent/Core/PeerAddr.hs +++ /dev/null | |||
@@ -1,354 +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 | , PeerStore | ||
30 | , Network.BitTorrent.Core.PeerAddr.lookup | ||
31 | , Network.BitTorrent.Core.PeerAddr.insert | ||
32 | ) where | ||
33 | |||
34 | import Control.Applicative | ||
35 | import Control.Monad | ||
36 | import Data.BEncode as BS | ||
37 | import Data.BEncode.BDict (BKey) | ||
38 | import Data.ByteString.Char8 as BS8 | ||
39 | import Data.Char | ||
40 | import Data.Default | ||
41 | import Data.Hashable | ||
42 | import Data.HashMap.Strict as HM | ||
43 | import Data.IP | ||
44 | import Data.List as L | ||
45 | import Data.List.Split | ||
46 | import Data.Maybe | ||
47 | import Data.Monoid | ||
48 | import Data.Serialize as S | ||
49 | import Data.String | ||
50 | import Data.Typeable | ||
51 | import Data.Word | ||
52 | import Network.Socket | ||
53 | import Text.PrettyPrint as PP hiding ((<>)) | ||
54 | import Text.PrettyPrint.Class | ||
55 | import Text.Read (readMaybe) | ||
56 | import qualified Text.ParserCombinators.ReadP as RP | ||
57 | |||
58 | import Data.Torrent.InfoHash | ||
59 | import Network.BitTorrent.Core.PeerId | ||
60 | |||
61 | |||
62 | {----------------------------------------------------------------------- | ||
63 | -- Port number | ||
64 | -----------------------------------------------------------------------} | ||
65 | |||
66 | instance BEncode PortNumber where | ||
67 | toBEncode = toBEncode . fromEnum | ||
68 | fromBEncode = fromBEncode >=> portNumber | ||
69 | where | ||
70 | portNumber :: Integer -> BS.Result PortNumber | ||
71 | portNumber n | ||
72 | | 0 <= n && n <= fromIntegral (maxBound :: Word16) | ||
73 | = pure $ fromIntegral n | ||
74 | | otherwise = decodingError $ "PortNumber: " ++ show n | ||
75 | |||
76 | instance Serialize PortNumber where | ||
77 | get = fromIntegral <$> getWord16be | ||
78 | {-# INLINE get #-} | ||
79 | put = putWord16be . fromIntegral | ||
80 | {-# INLINE put #-} | ||
81 | |||
82 | instance Hashable PortNumber where | ||
83 | hashWithSalt s = hashWithSalt s . fromEnum | ||
84 | {-# INLINE hashWithSalt #-} | ||
85 | |||
86 | instance Pretty PortNumber where | ||
87 | pretty = PP.int . fromEnum | ||
88 | {-# INLINE pretty #-} | ||
89 | |||
90 | {----------------------------------------------------------------------- | ||
91 | -- IP addr | ||
92 | -----------------------------------------------------------------------} | ||
93 | |||
94 | class IPAddress i where | ||
95 | toHostAddr :: i -> Either HostAddress HostAddress6 | ||
96 | |||
97 | instance IPAddress IPv4 where | ||
98 | toHostAddr = Left . toHostAddress | ||
99 | {-# INLINE toHostAddr #-} | ||
100 | |||
101 | instance IPAddress IPv6 where | ||
102 | toHostAddr = Right . toHostAddress6 | ||
103 | {-# INLINE toHostAddr #-} | ||
104 | |||
105 | instance IPAddress IP where | ||
106 | toHostAddr (IPv4 ip) = toHostAddr ip | ||
107 | toHostAddr (IPv6 ip) = toHostAddr ip | ||
108 | {-# INLINE toHostAddr #-} | ||
109 | |||
110 | deriving instance Typeable IP | ||
111 | deriving instance Typeable IPv4 | ||
112 | deriving instance Typeable IPv6 | ||
113 | |||
114 | ipToBEncode :: Show i => i -> BValue | ||
115 | ipToBEncode ip = BString $ BS8.pack $ show ip | ||
116 | {-# INLINE ipToBEncode #-} | ||
117 | |||
118 | ipFromBEncode :: Read a => BValue -> BS.Result a | ||
119 | ipFromBEncode (BString (BS8.unpack -> ipStr)) | ||
120 | | Just ip <- readMaybe (ipStr) = pure ip | ||
121 | | otherwise = decodingError $ "IP: " ++ ipStr | ||
122 | ipFromBEncode _ = decodingError $ "IP: addr should be a bstring" | ||
123 | |||
124 | instance BEncode IP where | ||
125 | toBEncode = ipToBEncode | ||
126 | {-# INLINE toBEncode #-} | ||
127 | fromBEncode = ipFromBEncode | ||
128 | {-# INLINE fromBEncode #-} | ||
129 | |||
130 | instance BEncode IPv4 where | ||
131 | toBEncode = ipToBEncode | ||
132 | {-# INLINE toBEncode #-} | ||
133 | fromBEncode = ipFromBEncode | ||
134 | {-# INLINE fromBEncode #-} | ||
135 | |||
136 | instance BEncode IPv6 where | ||
137 | toBEncode = ipToBEncode | ||
138 | {-# INLINE toBEncode #-} | ||
139 | fromBEncode = ipFromBEncode | ||
140 | {-# INLINE fromBEncode #-} | ||
141 | |||
142 | -- | When 'get'ing an IP it must be 'isolate'd to the appropriate | ||
143 | -- number of bytes since we have no other way of telling which | ||
144 | -- address type we are trying to parse | ||
145 | instance Serialize IP where | ||
146 | put (IPv4 ip) = put ip | ||
147 | put (IPv6 ip) = put ip | ||
148 | |||
149 | get = do | ||
150 | n <- remaining | ||
151 | case n of | ||
152 | 4 -> IPv4 <$> get | ||
153 | 16 -> IPv6 <$> get | ||
154 | _ -> fail "Wrong number of bytes remaining to parse IP" | ||
155 | |||
156 | instance Serialize IPv4 where | ||
157 | put = putWord32host . toHostAddress | ||
158 | get = fromHostAddress <$> getWord32host | ||
159 | |||
160 | instance Serialize IPv6 where | ||
161 | put ip = put $ toHostAddress6 ip | ||
162 | get = fromHostAddress6 <$> get | ||
163 | |||
164 | instance Pretty IPv4 where | ||
165 | pretty = PP.text . show | ||
166 | {-# INLINE pretty #-} | ||
167 | |||
168 | instance Pretty IPv6 where | ||
169 | pretty = PP.text . show | ||
170 | {-# INLINE pretty #-} | ||
171 | |||
172 | instance Pretty IP where | ||
173 | pretty = PP.text . show | ||
174 | {-# INLINE pretty #-} | ||
175 | |||
176 | instance Hashable IPv4 where | ||
177 | hashWithSalt = hashUsing toHostAddress | ||
178 | {-# INLINE hashWithSalt #-} | ||
179 | |||
180 | instance Hashable IPv6 where | ||
181 | hashWithSalt s a = hashWithSalt s (toHostAddress6 a) | ||
182 | |||
183 | instance Hashable IP where | ||
184 | hashWithSalt s (IPv4 h) = hashWithSalt s h | ||
185 | hashWithSalt s (IPv6 h) = hashWithSalt s h | ||
186 | |||
187 | {----------------------------------------------------------------------- | ||
188 | -- Peer addr | ||
189 | -----------------------------------------------------------------------} | ||
190 | -- TODO check semantic of ord and eq instances | ||
191 | |||
192 | -- | Peer address info normally extracted from peer list or peer | ||
193 | -- compact list encoding. | ||
194 | data PeerAddr a = PeerAddr | ||
195 | { peerId :: !(Maybe PeerId) | ||
196 | |||
197 | -- | This is usually 'IPv4', 'IPv6', 'IP' or unresolved | ||
198 | -- 'HostName'. | ||
199 | , peerHost :: !a | ||
200 | |||
201 | -- | The port the peer listenning for incoming P2P sessions. | ||
202 | , peerPort :: {-# UNPACK #-} !PortNumber | ||
203 | } deriving (Show, Eq, Ord, Typeable, Functor) | ||
204 | |||
205 | peer_ip_key, peer_id_key, peer_port_key :: BKey | ||
206 | peer_ip_key = "ip" | ||
207 | peer_id_key = "peer id" | ||
208 | peer_port_key = "port" | ||
209 | |||
210 | -- | The tracker's 'announce response' compatible encoding. | ||
211 | instance (Typeable a, BEncode a) => BEncode (PeerAddr a) where | ||
212 | toBEncode PeerAddr {..} = toDict $ | ||
213 | peer_ip_key .=! peerHost | ||
214 | .: peer_id_key .=? peerId | ||
215 | .: peer_port_key .=! peerPort | ||
216 | .: endDict | ||
217 | |||
218 | fromBEncode = fromDict $ do | ||
219 | peerAddr <$>! peer_ip_key | ||
220 | <*>? peer_id_key | ||
221 | <*>! peer_port_key | ||
222 | where | ||
223 | peerAddr = flip PeerAddr | ||
224 | |||
225 | -- | The tracker's 'compact peer list' compatible encoding. The | ||
226 | -- 'peerId' is always 'Nothing'. | ||
227 | -- | ||
228 | -- For more info see: <http://www.bittorrent.org/beps/bep_0023.html> | ||
229 | -- | ||
230 | -- TODO: test byte order | ||
231 | instance (Serialize a) => Serialize (PeerAddr a) where | ||
232 | put PeerAddr {..} = put peerHost >> put peerPort | ||
233 | get = PeerAddr Nothing <$> get <*> get | ||
234 | |||
235 | -- | @127.0.0.1:6881@ | ||
236 | instance Default (PeerAddr IPv4) where | ||
237 | def = "127.0.0.1:6881" | ||
238 | |||
239 | -- | @127.0.0.1:6881@ | ||
240 | instance Default (PeerAddr IP) where | ||
241 | def = IPv4 <$> def | ||
242 | |||
243 | -- | Example: | ||
244 | -- | ||
245 | -- @peerPort \"127.0.0.1:6881\" == 6881@ | ||
246 | -- | ||
247 | instance IsString (PeerAddr IPv4) where | ||
248 | fromString str | ||
249 | | [hostAddrStr, portStr] <- splitWhen (== ':') str | ||
250 | , Just hostAddr <- readMaybe hostAddrStr | ||
251 | , Just portNum <- toEnum <$> readMaybe portStr | ||
252 | = PeerAddr Nothing hostAddr portNum | ||
253 | | otherwise = error $ "fromString: unable to parse (PeerAddr IPv4): " ++ str | ||
254 | |||
255 | instance Read (PeerAddr IPv4) where | ||
256 | readsPrec i = RP.readP_to_S $ do | ||
257 | ipv4 <- RP.readS_to_P (readsPrec i) | ||
258 | _ <- RP.char ':' | ||
259 | port <- toEnum <$> RP.readS_to_P (readsPrec i) | ||
260 | return $ PeerAddr Nothing ipv4 port | ||
261 | |||
262 | readsIPv6_port :: String -> [((IPv6, PortNumber), String)] | ||
263 | readsIPv6_port = RP.readP_to_S $ do | ||
264 | ip <- RP.char '[' *> (RP.readS_to_P reads) <* RP.char ']' | ||
265 | _ <- RP.char ':' | ||
266 | port <- toEnum <$> read <$> (RP.many1 $ RP.satisfy isDigit) <* RP.eof | ||
267 | return (ip,port) | ||
268 | |||
269 | instance IsString (PeerAddr IPv6) where | ||
270 | fromString str | ||
271 | | [((ip,port),"")] <- readsIPv6_port str = | ||
272 | PeerAddr Nothing ip port | ||
273 | | otherwise = error $ "fromString: unable to parse (PeerAddr IPv6): " ++ str | ||
274 | |||
275 | instance IsString (PeerAddr IP) where | ||
276 | fromString str | ||
277 | | '[' `L.elem` str = IPv6 <$> fromString str | ||
278 | | otherwise = IPv4 <$> fromString str | ||
279 | |||
280 | -- | fingerprint + "at" + dotted.host.inet.addr:port | ||
281 | -- TODO: instances for IPv6, HostName | ||
282 | instance Pretty a => Pretty (PeerAddr a) where | ||
283 | pretty PeerAddr {..} | ||
284 | | Just pid <- peerId = pretty (fingerprint pid) <+> "at" <+> paddr | ||
285 | | otherwise = paddr | ||
286 | where | ||
287 | paddr = pretty peerHost <> ":" <> text (show peerPort) | ||
288 | |||
289 | instance Hashable a => Hashable (PeerAddr a) where | ||
290 | hashWithSalt s PeerAddr {..} = | ||
291 | s `hashWithSalt` peerId `hashWithSalt` peerHost `hashWithSalt` peerPort | ||
292 | |||
293 | -- | Ports typically reserved for bittorrent P2P listener. | ||
294 | defaultPorts :: [PortNumber] | ||
295 | defaultPorts = [6881..6889] | ||
296 | |||
297 | _resolvePeerAddr :: (IPAddress i) => PeerAddr HostName -> PeerAddr i | ||
298 | _resolvePeerAddr = undefined | ||
299 | |||
300 | _peerSockAddr :: PeerAddr IP -> (Family, SockAddr) | ||
301 | _peerSockAddr PeerAddr {..} = | ||
302 | case peerHost of | ||
303 | IPv4 ipv4 -> | ||
304 | (AF_INET, SockAddrInet peerPort (toHostAddress ipv4)) | ||
305 | IPv6 ipv6 -> | ||
306 | (AF_INET6, SockAddrInet6 peerPort 0 (toHostAddress6 ipv6) 0) | ||
307 | |||
308 | peerSockAddr :: PeerAddr IP -> SockAddr | ||
309 | peerSockAddr = snd . _peerSockAddr | ||
310 | |||
311 | -- | Create a socket connected to the address specified in a peerAddr | ||
312 | peerSocket :: SocketType -> PeerAddr IP -> IO Socket | ||
313 | peerSocket socketType pa = do | ||
314 | let (family, addr) = _peerSockAddr pa | ||
315 | sock <- socket family socketType defaultProtocol | ||
316 | connect sock addr | ||
317 | return sock | ||
318 | |||
319 | {----------------------------------------------------------------------- | ||
320 | -- Peer storage | ||
321 | -----------------------------------------------------------------------} | ||
322 | -- TODO use more memory efficient representation | ||
323 | |||
324 | -- | Storage used to keep track a set of known peers in client, | ||
325 | -- tracker or DHT sessions. | ||
326 | newtype PeerStore ip = PeerStore (HashMap InfoHash [PeerAddr ip]) | ||
327 | |||
328 | -- | Empty store. | ||
329 | instance Default (PeerStore a) where | ||
330 | def = PeerStore HM.empty | ||
331 | {-# INLINE def #-} | ||
332 | |||
333 | -- | Monoid under union operation. | ||
334 | instance Eq a => Monoid (PeerStore a) where | ||
335 | mempty = def | ||
336 | {-# INLINE mempty #-} | ||
337 | |||
338 | mappend (PeerStore a) (PeerStore b) = | ||
339 | PeerStore (HM.unionWith L.union a b) | ||
340 | {-# INLINE mappend #-} | ||
341 | |||
342 | -- | Can be used to store peers between invocations of the client | ||
343 | -- software. | ||
344 | instance Serialize (PeerStore a) where | ||
345 | get = undefined | ||
346 | put = undefined | ||
347 | |||
348 | -- | Used in 'get_peers' DHT queries. | ||
349 | lookup :: InfoHash -> PeerStore a -> [PeerAddr a] | ||
350 | lookup ih (PeerStore m) = fromMaybe [] $ HM.lookup ih m | ||
351 | |||
352 | -- | Used in 'announce_peer' DHT queries. | ||
353 | insert :: Eq a => InfoHash -> PeerAddr a -> PeerStore a -> PeerStore a | ||
354 | insert ih a (PeerStore m) = PeerStore (HM.insertWith L.union ih [a] m) | ||