Don't use BEP 43 read-only nodes for routing.

3 files changed, 23 insertions, 9 deletions

diff --git a/src/Network/BitTorrent/DHT/Message.hs b/src/Network/BitTorrent/DHT/Message.hs
index 008145de..b8f272c3 100644
--- a/src/Network/BitTorrent/DHT/Message.hs
+++ b/src/Network/BitTorrent/DHT/Message.hs
@@ -92,6 +92,7 @@ import Data.Serialize as S
 import Data.Typeable
 import Network
 import Network.KRPC
+import Data.Maybe
 
 import Data.Torrent
 import Network.BitTorrent.Address
@@ -105,11 +106,16 @@ import Network.KRPC ()
 node_id_key :: BKey
 node_id_key = "id"
 
+read_only_key :: BKey
+read_only_key = "ro"
+
+
 -- | All queries have an \"id\" key and value containing the node ID
 -- of the querying node.
 data Query a = Query
-  { queringNodeId :: NodeId -- ^ node id of /quering/ node;
-  , queryParams   :: a      -- ^ query parameters.
+  { queringNodeId   :: NodeId -- ^ node id of /quering/ node;
+  , queryIsReadOnly :: Bool   -- ^ node is read-only as per BEP 43
+  , queryParams     :: a      -- ^ query parameters.
   } deriving (Show, Eq, Typeable)
 
 instance BEncode a => BEncode (Query a) where
@@ -118,11 +124,13 @@ instance BEncode a => BEncode (Query a) where
       <>
       dict (toBEncode queryParams)
     where
-      dict (BDict d) = d
+      dict (BDict d) | queryIsReadOnly = Cons read_only_key (BInteger 1) d
+                     | otherwise       = d
       dict    _      = error "impossible: instance BEncode (Query a)"
 
   fromBEncode v = do
     Query <$> fromDict (field (req node_id_key)) v
+          <*> fromDict (fromMaybe False <$>? read_only_key) v
           <*> fromBEncode v
 
 -- | All responses have an \"id\" key and value containing the node ID
@@ -135,11 +143,11 @@ data Response a = Response
 instance BEncode a => BEncode (Response a) where
   toBEncode = toBEncode . toQuery
     where
-      toQuery (Response nid a) = Query nid a
+      toQuery (Response nid a) = Query nid False a
 
   fromBEncode b = fromQuery <$> fromBEncode b
     where
-      fromQuery (Query nid a) = Response nid a
+      fromQuery (Query nid _ a) = Response nid a
 
 
 {-----------------------------------------------------------------------
diff --git a/src/Network/BitTorrent/DHT/Query.hs b/src/Network/BitTorrent/DHT/Query.hs
index cb7d5c5f..d51ab505 100644
--- a/src/Network/BitTorrent/DHT/Query.hs
+++ b/src/Network/BitTorrent/DHT/Query.hs
@@ -68,11 +68,15 @@ import Network.BitTorrent.DHT.Session
 
 nodeHandler :: Address ip => KRPC (Query a) (Response b)
            => (NodeAddr ip -> a -> DHT ip b) -> NodeHandler ip
-nodeHandler action = handler $ \ sockAddr (Query remoteId q) -> do
+nodeHandler action = handler $ \ sockAddr (Query remoteId read_only q) -> do
   case fromSockAddr sockAddr of
     Nothing    -> throwIO BadAddress
     Just naddr -> do
-      insertNode (NodeInfo remoteId naddr) -- TODO need to block. why?
+      let ni = NodeInfo remoteId naddr
+      -- Do not route read-only nodes. (bep 43)
+      if read_only
+        then $(logWarnS) "nodeHandler" $ "READ-ONLY " <> T.pack (show $ pPrint ni)
+        else insertNode ni >> return () -- TODO need to block. why?
       Response <$> asks thisNodeId <*> action naddr q
 
 -- | Default 'Ping' handler.
@@ -125,6 +129,7 @@ pingQ addr = do
 findNodeQ :: Address ip => TableKey key => key -> Iteration ip NodeInfo
 findNodeQ key NodeInfo {..} = do
   NodeFound closest <- FindNode (toNodeId key) <@> nodeAddr
+  $(logInfoS) "findNodeQ" $ "NodeFound " <> T.pack (show $ L.map pPrint closest)
   return $ Right closest
 
 getPeersQ :: Address ip => InfoHash -> Iteration ip PeerAddr
@@ -155,7 +160,7 @@ type Search    ip o = Conduit [NodeInfo ip] (DHT ip) [o ip]
 
 -- TODO: use reorder and filter (Traversal option) leftovers
 search :: TableKey k => Address ip => k -> Iteration ip o -> Search ip o
-search k action = do
+search _ action = do
   awaitForever $ \ batch -> unless (L.null batch) $ do
     $(logWarnS) "search" "start query"
     responses <- lift $ queryParallel (action <$> batch)
diff --git a/src/Network/BitTorrent/DHT/Session.hs b/src/Network/BitTorrent/DHT/Session.hs
index 42270ae8..ffce47de 100644
--- a/src/Network/BitTorrent/DHT/Session.hs
+++ b/src/Network/BitTorrent/DHT/Session.hs
@@ -492,7 +492,8 @@ queryNode :: forall a b ip. Address ip => KRPC (Query a) (Response b)
           => NodeAddr ip -> a -> DHT ip (NodeId, b)
 queryNode addr q = do
   nid <- asks thisNodeId
-  Response remoteId r <- query (toSockAddr addr) (Query nid q)
+  let read_only = False -- TODO: check for NAT issues. (BEP 43)
+  Response remoteId r <- query (toSockAddr addr) (Query nid read_only q)
   insertNode (NodeInfo remoteId addr)
   return (remoteId, r)