Fleshed out KRPC instances for Mainline DHT.

4 files changed, 37 insertions, 18 deletions

diff --git a/src/Network/BitTorrent/DHT/Query.hs b/src/Network/BitTorrent/DHT/Query.hs
index ad29adb6..77fede94 100644
--- a/src/Network/BitTorrent/DHT/Query.hs
+++ b/src/Network/BitTorrent/DHT/Query.hs
@@ -133,7 +133,8 @@ nodeHandler :: forall raw dht addr u t q r.
      IsString t, Functor dht,
      KRPC dht (Query dht q) (Response dht r),
      SerializableTo raw (Response dht r),
-     SerializableTo raw (Query dht q)) =>
+     SerializableTo raw (Query dht q),
+     Show (QueryMethod dht)) =>
     (NodeInfo dht addr u -> Maybe ReflectedIP -> IO ())
     -> (NodeAddr addr -> IO (NodeId dht))
     -> (Char -> t -> Text -> IO ())
@@ -150,6 +151,7 @@ nodeHandler insertNode myNodeIdAccordingTo logm dta method action = handler meth
   case fromSockAddr sockAddr of
     Nothing    -> throwIO BadAddress
     Just naddr -> do
+      logm 'D' "nodeHandler" $ "Received query: " <> T.pack (show $ method)
       me <- myNodeIdAccordingTo naddr
       rextra <- liftIO $ makeResponseExtra dta me qry resptype
       let ni = NodeInfo remoteId naddr def
diff --git a/src/Network/DHT/Mainline.hs b/src/Network/DHT/Mainline.hs
index d68755a7..9af42a6d 100644
--- a/src/Network/DHT/Mainline.hs
+++ b/src/Network/DHT/Mainline.hs
@@ -218,11 +218,13 @@ instance Serialize (Response Ping) where
 
 -- | \"q\" = \"ping\"
 instance KRPC KMessageOf (Query KMessageOf (Ping KMessageOf)) (Response KMessageOf (Ping KMessageOf)) where
-#ifdef VERSION_bencoding
-  method = "ping"
-#else
-  method = Method Tox.Ping -- response: Tox.Pong
-#endif
+    method = "ping"
+    makeQueryExtra _ nid _ _ = return $ MainlineQuery nid False -- TODO: check for NAT issues. (BEP 43)
+    makeResponseExtra _ nid _ _ = return $ MainlineResponse nid
+
+    -- TODO KError Sender/Responder
+    messageSender (Q q) _ = queringNodeId $ queryExtra $ queryArgs q
+    messageResponder _ (R r) = queredNodeId $ responseExtra $ respVals r
 
 {-----------------------------------------------------------------------
 -- find_node method
@@ -302,13 +304,14 @@ instance Serialize (Response KMessageOf (NodeFound KMessageOf ip)) where
 -- | \"q\" == \"find_node\"
 instance (Address ip, Typeable ip)
       => KRPC KMessageOf (Query KMessageOf (FindNode KMessageOf ip)) (Response KMessageOf (NodeFound KMessageOf ip)) where
-#ifdef VERSION_bencoding
-  method = "find_node"
-#else
-  method = Method Tox.GetNodes -- response: Tox.SendNodes
-#endif
+    method = "find_node"
+    makeQueryExtra _ nid _ _ = return $ MainlineQuery nid False -- TODO: check for NAT issues. (BEP 43)
+    makeResponseExtra _ nid _ _ = return $ MainlineResponse nid
+
+    -- TODO KError Sender/Responder
+    messageSender (Q q) _ = queringNodeId $ queryExtra $ queryArgs q
+    messageResponder _ (R r) = queredNodeId $ responseExtra $ respVals r
 
-#ifdef VERSION_bencoding
 {-----------------------------------------------------------------------
 -- get_peers method
 -----------------------------------------------------------------------}
@@ -371,7 +374,14 @@ instance (Typeable ip, Serialize ip) => BEncode (GotPeers ip) where
 -- | \"q" = \"get_peers\"
 instance (Typeable ip, Serialize ip) =>
          KRPC KMessageOf (Query KMessageOf (GetPeers ip)) (Response KMessageOf (GotPeers ip)) where
-  method = "get_peers"
+    method = "get_peers"
+    makeQueryExtra _ nid _ _ = return $ MainlineQuery nid False -- TODO: check for NAT issues. (BEP 43)
+    makeResponseExtra _ nid _ _ = return $ MainlineResponse nid
+
+    -- TODO KError Sender/Responder
+    messageSender (Q q) _ = queringNodeId $ queryExtra $ queryArgs q
+    messageResponder _ (R r) = queredNodeId $ responseExtra $ respVals r
+
 
 {-----------------------------------------------------------------------
 -- announce method
@@ -443,10 +453,14 @@ instance BEncode Announced where
 
 -- | \"q" = \"announce\"
 instance KRPC KMessageOf (Query KMessageOf Announce) (Response KMessageOf Announced) where
-  method = "announce_peer"
+    method = "announce_peer"
+    makeQueryExtra _ nid _ _ = return $ MainlineQuery nid False -- TODO: check for NAT issues. (BEP 43)
+    makeResponseExtra _ nid _ _ = return $ MainlineResponse nid
+
+    -- TODO KError Sender/Responder
+    messageSender (Q q) _ = queringNodeId $ queryExtra $ queryArgs q
+    messageResponder _ (R r) = queredNodeId $ responseExtra $ respVals r
 
--- endif VERSION_bencoding
-#endif
 
 -- | Yields all 8 DHT neighborhoods available to you given a particular ip
 -- address.
diff --git a/src/Network/DatagramServer.hs b/src/Network/DatagramServer.hs
index b9c78885..1376748f 100644
--- a/src/Network/DatagramServer.hs
+++ b/src/Network/DatagramServer.hs
@@ -481,17 +481,19 @@ runHandler mgr@Manager{..} meth h addr m = Lifted.catches wrapper failbacks
 
     failbacks =
       [ E.Handler $ \ (e :: HandlerFailure) -> do
-          logMsg 'D' "handler.failed" signature
+          logMsg 'D' "handler.HandlerFailure" signature
           return $ Left $ KError ProtocolError (prettyHF e) (envelopeTransaction m)
 
 
         -- may happen if handler makes query and fail
       , E.Handler $ \ (e :: QueryFailure) -> do
+          logMsg 'D' "handler.QueryFailure" signature
           return $ Left $ KError ServerError (prettyQF e) (envelopeTransaction m)
 
         -- since handler thread exit after sendMessage we can safely
         -- suppress async exception here
       , E.Handler $ \ (e :: SomeException) -> do
+          logMsg 'D' "handler.SomeException" (signature <> T.pack (" "++show e))
           return $ Left $ KError GenericError (BC.pack (show e)) (envelopeTransaction m)
       ]
 
diff --git a/src/Network/DatagramServer/Tox.hs b/src/Network/DatagramServer/Tox.hs
index 3a6135cc..f666b951 100644
--- a/src/Network/DatagramServer/Tox.hs
+++ b/src/Network/DatagramServer/Tox.hs
@@ -274,7 +274,8 @@ instance Envelope Message where
 
     buildReply self addr qry payload = (fmap (const payload) qry) { msgClient = self }
 
-    -- buildQuery = todo
+    -- buildQuery :: NodeId envelope -> SockAddr -> QueryMethod envelope -> TransactionID envelope -> a -> IO (envelope a)
+    -- buildQuery nid addr meth tid q = todo
 
     uniqueTransactionId cnt = do
       return $ either (error "failed to create TransactionId") TID