diff options
-rw-r--r-- | Mainline.hs | 55 | ||||
-rw-r--r-- | src/Data/Torrent.hs | 2 |
2 files changed, 22 insertions, 35 deletions
diff --git a/Mainline.hs b/Mainline.hs index 12d1540b..e3a48976 100644 --- a/Mainline.hs +++ b/Mainline.hs | |||
@@ -23,6 +23,7 @@ import qualified Data.ByteArray as BA | |||
23 | import qualified Data.ByteString as B | 23 | import qualified Data.ByteString as B |
24 | ;import Data.ByteString (ByteString) | 24 | ;import Data.ByteString (ByteString) |
25 | import Data.ByteString.Lazy (toStrict) | 25 | import Data.ByteString.Lazy (toStrict) |
26 | import Data.Coerce | ||
26 | import Data.Data | 27 | import Data.Data |
27 | import Data.Default | 28 | import Data.Default |
28 | import Data.Hashable | 29 | import Data.Hashable |
@@ -413,13 +414,13 @@ instance BEncode GetPeers where | |||
413 | fromBEncode = fromDict $ GetPeers <$>! info_hash_key <*>? want_key | 414 | fromBEncode = fromDict $ GetPeers <$>! info_hash_key <*>? want_key |
414 | 415 | ||
415 | 416 | ||
416 | type PeerList = Either [NodeInfo] [PeerAddr] | ||
417 | |||
418 | data GotPeers = GotPeers | 417 | data GotPeers = GotPeers |
419 | { -- | If the queried node has no peers for the infohash, returned | 418 | { -- | If the queried node has no peers for the infohash, returned |
420 | -- the K nodes in the queried nodes routing table closest to the | 419 | -- the K nodes in the queried nodes routing table closest to the |
421 | -- infohash supplied in the query. | 420 | -- infohash supplied in the query. |
422 | peers :: PeerList | 421 | peers :: [PeerAddr] |
422 | |||
423 | , nodes :: NodeFound | ||
423 | 424 | ||
424 | -- | The token value is a required argument for a future | 425 | -- | The token value is a required argument for a future |
425 | -- announce_peer query. | 426 | -- announce_peer query. |
@@ -431,34 +432,22 @@ nodeIsIPv6 (NodeInfo _ (IPv6 _) _) = True | |||
431 | nodeIsIPv6 _ = False | 432 | nodeIsIPv6 _ = False |
432 | 433 | ||
433 | instance BEncode GotPeers where | 434 | instance BEncode GotPeers where |
434 | toBEncode GotPeers {..} = toDict $ | 435 | toBEncode GotPeers { nodes = NodeFound ns4 ns6, ..} = toDict $ |
435 | case peers of | 436 | nodes_key .=? (if null ns4 then Nothing |
436 | Left ns | 437 | else Just $ S.runPut (mapM_ putNodeInfo4 ns4)) |
437 | | let (ns6,ns4) = partition nodeIsIPv6 ns | 438 | .: nodes6_key .=? (if null ns6 then Nothing |
438 | -> | 439 | else Just $ S.runPut (mapM_ putNodeInfo4 ns6)) |
439 | nodes_key .=? (if null ns4 then Nothing | 440 | .: token_key .=! grantedToken |
440 | else Just $ S.runPut (mapM_ putNodeInfo4 ns4)) | 441 | .: peers_key .=! map S.encode peers -- TODO: Spec says we shouldn't mix ip4/ip6 here. |
441 | .: nodes6_key .=? (if null ns6 then Nothing | 442 | -- (We could filter in MethodHandler.) |
442 | else Just $ S.runPut (mapM_ putNodeInfo4 ns6)) | 443 | .: endDict |
443 | .: token_key .=! grantedToken | ||
444 | .: endDict | ||
445 | Right ps -> | ||
446 | token_key .=! grantedToken | ||
447 | .: peers_key .=! map S.encode ps -- TODO: Spec says we shouldn't mix ip4/ip6 here. | ||
448 | -- (We could filter in MethodHandler.) | ||
449 | .: endDict | ||
450 | 444 | ||
451 | fromBEncode = fromDict $ do | 445 | fromBEncode = fromDict $ do |
452 | mns4 <- optional (binary getNodeInfo4 nodes_key) -- "nodes" | 446 | ns4 <- fromMaybe [] <$> optional (binary getNodeInfo4 nodes_key) -- "nodes" |
453 | mns6 <- optional (binary getNodeInfo6 nodes6_key) -- "nodes6" | 447 | ns6 <- fromMaybe [] <$> optional (binary getNodeInfo6 nodes6_key) -- "nodes6" |
454 | let mns = ((++) <$> mns4 <*> mns6) | 448 | tok <- field (req token_key) -- "token" |
455 | <|> mns4 | 449 | ps <- fromMaybe [] <$> optional (field (req peers_key) >>= decodePeers) -- "values" |
456 | <|> mns6 | 450 | pure $ GotPeers ps (NodeFound ns4 ns6) tok |
457 | tok <- field (req token_key) -- "token" | ||
458 | mps <- optional (field (req peers_key) >>= decodePeers) -- "values" | ||
459 | case (Right <$> mps) <|> (Left <$> mns) of | ||
460 | Nothing -> fail "get_peers: neihter peers nor nodes key is valid" | ||
461 | Just xs -> pure $ GotPeers xs tok | ||
462 | where | 451 | where |
463 | decodePeers = either fail pure . mapM S.decode | 452 | decodePeers = either fail pure . mapM S.decode |
464 | 453 | ||
@@ -466,15 +455,13 @@ getPeersH :: Routing -> SwarmsDatabase -> NodeInfo -> GetPeers -> IO GotPeers | |||
466 | getPeersH routing (SwarmsDatabase peers toks _) naddr (GetPeers ih iptyp) = do | 455 | getPeersH routing (SwarmsDatabase peers toks _) naddr (GetPeers ih iptyp) = do |
467 | ps <- do | 456 | ps <- do |
468 | tm <- getTimestamp | 457 | tm <- getTimestamp |
469 | ps <- atomically $ do | 458 | atomically $ do |
470 | (ps,store') <- Peers.freshPeers ih tm <$> readTVar peers | 459 | (ps,store') <- Peers.freshPeers ih tm <$> readTVar peers |
471 | writeTVar peers store' | 460 | writeTVar peers store' |
472 | return ps | 461 | return ps |
473 | if null ps | ||
474 | then Left <$> error "TODO: getClosest ih" | ||
475 | else return (Right ps) | ||
476 | tok <- grantToken toks naddr | 462 | tok <- grantToken toks naddr |
477 | return $ GotPeers ps tok | 463 | ns <- findNodeH routing naddr (FindNode (coerce ih) iptyp) |
464 | return $ GotPeers ps ns tok | ||
478 | 465 | ||
479 | -- | Announce that the peer, controlling the querying node, is | 466 | -- | Announce that the peer, controlling the querying node, is |
480 | -- downloading a torrent on a port. | 467 | -- downloading a torrent on a port. |
diff --git a/src/Data/Torrent.hs b/src/Data/Torrent.hs index 73422a04..004369ce 100644 --- a/src/Data/Torrent.hs +++ b/src/Data/Torrent.hs | |||
@@ -32,7 +32,7 @@ | |||
32 | module Data.Torrent | 32 | module Data.Torrent |
33 | ( -- * InfoHash | 33 | ( -- * InfoHash |
34 | -- $infohash | 34 | -- $infohash |
35 | InfoHash | 35 | InfoHash(..) |
36 | , textToInfoHash | 36 | , textToInfoHash |
37 | , longHex | 37 | , longHex |
38 | , shortHex | 38 | , shortHex |