diff options
author | joe <joe@jerkface.net> | 2017-07-14 23:50:39 -0400 |
---|---|---|
committer | joe <joe@jerkface.net> | 2017-07-14 23:50:39 -0400 |
commit | f5186fa528bf9c79533d4c4ee1a3846eab4fc6be (patch) | |
tree | 247d8eb8411c671c17546777740e010e2b0155b7 /src/Network/BitTorrent | |
parent | 31d72c02c1bd3574042ac3b67eb4d28d87d187df (diff) |
Removed ip polymorphism from PeerAddr type.
Diffstat (limited to 'src/Network/BitTorrent')
-rw-r--r-- | src/Network/BitTorrent/DHT/ContactInfo.hs | 43 |
1 files changed, 25 insertions, 18 deletions
diff --git a/src/Network/BitTorrent/DHT/ContactInfo.hs b/src/Network/BitTorrent/DHT/ContactInfo.hs index 3db3d5a8..172306a1 100644 --- a/src/Network/BitTorrent/DHT/ContactInfo.hs +++ b/src/Network/BitTorrent/DHT/ContactInfo.hs | |||
@@ -1,6 +1,7 @@ | |||
1 | {-# LANGUAGE BangPatterns #-} | 1 | {-# LANGUAGE BangPatterns #-} |
2 | module Network.BitTorrent.DHT.ContactInfo | 2 | module Network.BitTorrent.DHT.ContactInfo |
3 | ( PeerStore | 3 | ( PeerStore |
4 | , PeerAddr(..) | ||
4 | , Network.BitTorrent.DHT.ContactInfo.lookup | 5 | , Network.BitTorrent.DHT.ContactInfo.lookup |
5 | , Network.BitTorrent.DHT.ContactInfo.freshPeers | 6 | , Network.BitTorrent.DHT.ContactInfo.freshPeers |
6 | , Network.BitTorrent.DHT.ContactInfo.insertPeer | 7 | , Network.BitTorrent.DHT.ContactInfo.insertPeer |
@@ -36,17 +37,17 @@ import Network.Address | |||
36 | -- -- PeerSet | 37 | -- -- PeerSet |
37 | -- -----------------------------------------------------------------------} | 38 | -- -----------------------------------------------------------------------} |
38 | -- | 39 | -- |
39 | -- type PeerSet a = [(PeerAddr a, NodeInfo a, Timestamp)] | 40 | -- type PeerSet a = [(PeerAddr, NodeInfo a, Timestamp)] |
40 | -- | 41 | -- |
41 | -- -- compare PSQueue vs Ordered list | 42 | -- -- compare PSQueue vs Ordered list |
42 | -- | 43 | -- |
43 | -- takeNewest :: PeerSet a -> [PeerAddr a] | 44 | -- takeNewest :: PeerSet a -> [PeerAddr] |
44 | -- takeNewest = undefined | 45 | -- takeNewest = undefined |
45 | -- | 46 | -- |
46 | -- dropOld :: Timestamp -> PeerSet a -> PeerSet a | 47 | -- dropOld :: Timestamp -> PeerSet a -> PeerSet a |
47 | -- dropOld = undefined | 48 | -- dropOld = undefined |
48 | -- | 49 | -- |
49 | -- insert :: PeerAddr a -> Timestamp -> PeerSet a -> PeerSet a | 50 | -- insert :: PeerAddr -> Timestamp -> PeerSet a -> PeerSet a |
50 | -- insert = undefined | 51 | -- insert = undefined |
51 | -- | 52 | -- |
52 | -- type Mask = Int | 53 | -- type Mask = Int |
@@ -116,16 +117,19 @@ import Network.Address | |||
116 | 117 | ||
117 | -- | Storage used to keep track a set of known peers in client, | 118 | -- | Storage used to keep track a set of known peers in client, |
118 | -- tracker or DHT sessions. | 119 | -- tracker or DHT sessions. |
119 | newtype PeerStore ip = PeerStore (HashMap InfoHash (SwarmData ip)) | 120 | newtype PeerStore = PeerStore (HashMap InfoHash SwarmData) |
120 | 121 | ||
121 | type Timestamp = POSIXTime | 122 | type Timestamp = POSIXTime |
122 | 123 | ||
123 | data SwarmData ip = SwarmData | 124 | data SwarmData = SwarmData |
124 | { peers :: !(PSQ (PeerAddr ip) Timestamp) | 125 | { peers :: !(PSQ PeerAddr Timestamp) |
125 | , name :: !(Maybe ByteString) | 126 | , name :: !(Maybe ByteString) |
126 | } | 127 | } |
127 | 128 | ||
128 | 129 | -- | This wrapper will serialize an ip address with a '4' or '6' prefix byte | |
130 | -- to indicate whether it is IPv4 or IPv6. | ||
131 | -- | ||
132 | -- Note: it does not serialize port numbers. | ||
129 | newtype SerializeAddress a = SerializeAddress { unserializeAddress :: a } | 133 | newtype SerializeAddress a = SerializeAddress { unserializeAddress :: a } |
130 | 134 | ||
131 | instance Address a => Serialize (SerializeAddress a) where | 135 | instance Address a => Serialize (SerializeAddress a) where |
@@ -145,7 +149,8 @@ instance Address a => Serialize (SerializeAddress a) where | |||
145 | | otherwise = return $ error "cannot serialize non-IP SerializeAddress" | 149 | | otherwise = return $ error "cannot serialize non-IP SerializeAddress" |
146 | 150 | ||
147 | 151 | ||
148 | instance (Ord ip, Address ip) => Serialize (SwarmData ip) where | 152 | {- XXX: What happened to the ports? |
153 | instance Serialize SwarmData where | ||
149 | get = flip SwarmData <$> get | 154 | get = flip SwarmData <$> get |
150 | <*> ( PSQ.fromList . L.map parseAddr <$> get ) | 155 | <*> ( PSQ.fromList . L.map parseAddr <$> get ) |
151 | where | 156 | where |
@@ -157,17 +162,17 @@ instance (Ord ip, Address ip) => Serialize (SwarmData ip) where | |||
157 | put $ L.map (\(addr :-> _) -> (SerializeAddress <$> addr)) | 162 | put $ L.map (\(addr :-> _) -> (SerializeAddress <$> addr)) |
158 | -- XXX: should we serialize the timestamp? | 163 | -- XXX: should we serialize the timestamp? |
159 | $ PSQ.toList peers | 164 | $ PSQ.toList peers |
165 | -} | ||
160 | 166 | ||
161 | 167 | knownSwarms :: PeerStore -> [ (InfoHash, Int, Maybe ByteString) ] | |
162 | knownSwarms :: PeerStore ip -> [ (InfoHash, Int, Maybe ByteString) ] | ||
163 | knownSwarms (PeerStore m) = L.map (\(ih,SwarmData q n) -> (ih,PSQ.size q,n)) $ HM.toList m | 168 | knownSwarms (PeerStore m) = L.map (\(ih,SwarmData q n) -> (ih,PSQ.size q,n)) $ HM.toList m |
164 | 169 | ||
165 | swarmSingleton :: Ord ip => PeerAddr ip -> SwarmData ip | 170 | swarmSingleton :: PeerAddr -> SwarmData |
166 | swarmSingleton a = SwarmData | 171 | swarmSingleton a = SwarmData |
167 | { peers = PSQ.singleton a 0 | 172 | { peers = PSQ.singleton a 0 |
168 | , name = Nothing } | 173 | , name = Nothing } |
169 | 174 | ||
170 | swarmInsert :: Ord ip => SwarmData ip -> SwarmData ip -> SwarmData ip | 175 | swarmInsert :: SwarmData -> SwarmData -> SwarmData |
171 | swarmInsert old new = SwarmData | 176 | swarmInsert old new = SwarmData |
172 | { peers = L.foldl' (\q (a :-> t) -> PSQ.insertWith (\p _ -> p) a t q) (peers old) (PSQ.toList $ peers new) | 177 | { peers = L.foldl' (\q (a :-> t) -> PSQ.insertWith (\p _ -> p) a t q) (peers old) (PSQ.toList $ peers new) |
173 | , name = name new <|> name old -- TODO: decodeUtf8' check | 178 | , name = name new <|> name old -- TODO: decodeUtf8' check |
@@ -176,12 +181,12 @@ swarmInsert old new = SwarmData | |||
176 | isSwarmOccupied SwarmData{..} = not $ PSQ.null peers | 181 | isSwarmOccupied SwarmData{..} = not $ PSQ.null peers |
177 | 182 | ||
178 | -- | Empty store. | 183 | -- | Empty store. |
179 | instance Default (PeerStore a) where | 184 | instance Default (PeerStore) where |
180 | def = PeerStore HM.empty | 185 | def = PeerStore HM.empty |
181 | {-# INLINE def #-} | 186 | {-# INLINE def #-} |
182 | 187 | ||
183 | -- | Monoid under union operation. | 188 | -- | Monoid under union operation. |
184 | instance Ord a => Monoid (PeerStore a) where | 189 | instance Monoid PeerStore where |
185 | mempty = def | 190 | mempty = def |
186 | {-# INLINE mempty #-} | 191 | {-# INLINE mempty #-} |
187 | 192 | ||
@@ -189,20 +194,22 @@ instance Ord a => Monoid (PeerStore a) where | |||
189 | PeerStore (HM.unionWith swarmInsert a b) | 194 | PeerStore (HM.unionWith swarmInsert a b) |
190 | {-# INLINE mappend #-} | 195 | {-# INLINE mappend #-} |
191 | 196 | ||
197 | {- | ||
192 | -- | Can be used to store peers between invocations of the client | 198 | -- | Can be used to store peers between invocations of the client |
193 | -- software. | 199 | -- software. |
194 | instance (Ord a, Address a) => Serialize (PeerStore a) where | 200 | instance Serialize PeerStore where |
195 | get = PeerStore . HM.fromList <$> get | 201 | get = PeerStore . HM.fromList <$> get |
196 | put (PeerStore m) = put (L.filter (isSwarmOccupied . snd) $ HM.toList m) | 202 | put (PeerStore m) = put (L.filter (isSwarmOccupied . snd) $ HM.toList m) |
203 | -} | ||
197 | 204 | ||
198 | -- | Returns all peers associated with a given info hash. | 205 | -- | Returns all peers associated with a given info hash. |
199 | lookup :: Ord a => InfoHash -> PeerStore a -> [PeerAddr a] | 206 | lookup :: InfoHash -> PeerStore -> [PeerAddr] |
200 | lookup ih (PeerStore m) = maybe [] (PSQ.keys . peers) $ HM.lookup ih m | 207 | lookup ih (PeerStore m) = maybe [] (PSQ.keys . peers) $ HM.lookup ih m |
201 | 208 | ||
202 | batchSize = 64 | 209 | batchSize = 64 |
203 | 210 | ||
204 | -- | Used in 'get_peers' DHT queries. | 211 | -- | Used in 'get_peers' DHT queries. |
205 | freshPeers :: Ord a => InfoHash -> Timestamp -> PeerStore a -> ([PeerAddr a], PeerStore a) | 212 | freshPeers :: InfoHash -> Timestamp -> PeerStore -> ([PeerAddr], PeerStore) |
206 | freshPeers ih tm (PeerStore m) = fromMaybe ([],PeerStore m) $ do | 213 | freshPeers ih tm (PeerStore m) = fromMaybe ([],PeerStore m) $ do |
207 | swarm <- HM.lookup ih m | 214 | swarm <- HM.lookup ih m |
208 | let ps0 = take batchSize $ unfoldr (incomp minView) (peers swarm) | 215 | let ps0 = take batchSize $ unfoldr (incomp minView) (peers swarm) |
@@ -219,7 +226,7 @@ incomp !f !x = do | |||
219 | pure $! ( (result,x'), x' ) | 226 | pure $! ( (result,x'), x' ) |
220 | 227 | ||
221 | -- | Used in 'announce_peer' DHT queries. | 228 | -- | Used in 'announce_peer' DHT queries. |
222 | insertPeer :: Ord a => InfoHash -> Maybe ByteString -> PeerAddr a -> PeerStore a -> PeerStore a | 229 | insertPeer :: InfoHash -> Maybe ByteString -> PeerAddr -> PeerStore -> PeerStore |
223 | insertPeer !ih !name !a !(PeerStore m) = seq a' $ PeerStore (HM.insertWith swarmInsert ih a' m) | 230 | insertPeer !ih !name !a !(PeerStore m) = seq a' $ PeerStore (HM.insertWith swarmInsert ih a' m) |
224 | where | 231 | where |
225 | a' = SwarmData { peers = PSQ.singleton a 0 | 232 | a' = SwarmData { peers = PSQ.singleton a 0 |