5 files changed, 75 insertions, 69 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 99ff7218..de1f11ab 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -151,8 +151,8 @@ godht ::
     , SerializableTo raw (Response dht (NodeFound dht IPv4))
     , SerializableTo raw (Query dht (Ping dht))
     , SerializableTo raw (Response dht (Ping dht))
-    , KRPC (Query dht (FindNode dht IPv4)) (Response dht (NodeFound dht IPv4))
-    , KRPC (Query dht (Ping dht)) (Response dht (Ping dht))
+    , KRPC dht (Query dht (FindNode dht IPv4)) (Response dht (NodeFound dht IPv4))
+    , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht))
     , Ord (NodeId dht)
     , FiniteBits (NodeId dht)
     , Serialize (NodeId dht)
@@ -195,8 +195,8 @@ data GenericDHT ip a
             , SerializableTo raw (Response dht (NodeFound dht ip))
             , SerializableTo raw (Query dht (Ping dht))
             , SerializableTo raw (Response dht (Ping dht))
-            , KRPC (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip))
-            , KRPC (Query dht (Ping dht)) (Response dht (Ping dht))
+            , KRPC dht (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip))
+            , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht))
             , Ord (NodeId dht)
             , FiniteBits (NodeId dht)
             , Serialize (NodeId dht)
@@ -249,10 +249,12 @@ instance Serialize (Response Tox.Message (NodeFound Tox.Message IPv4)) where
 instance Serialize (Response Tox.Message (Ping Tox.Message)) where -- TODO
     get = error "TODO get"
     put = error "TODO put"
-instance KRPC (Query    Tox.Message (FindNode Tox.Message IPv4))
+instance KRPC Tox.Message (Query    Tox.Message (FindNode Tox.Message IPv4))
               (Response Tox.Message (NodeFound Tox.Message IPv4)) where
-instance KRPC (Query    Tox.Message (Ping Tox.Message ))
+    method = error "TODO method"
+instance KRPC Tox.Message (Query    Tox.Message (Ping Tox.Message ))
               (Response Tox.Message (Ping Tox.Message )) where
+    method = error "TODO method"
 instance DataHandlers ByteString Tox.Message where
 
 
diff --git a/src/Network/BitTorrent/DHT.hs b/src/Network/BitTorrent/DHT.hs
index 6d31eab2..fa8071d5 100644
--- a/src/Network/BitTorrent/DHT.hs
+++ b/src/Network/BitTorrent/DHT.hs
@@ -119,8 +119,8 @@ dht ::
     , Show (QueryMethod dht)
     , Pretty (NodeInfo dht ip u)
     , Kademlia dht
-    , KRPC (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip))
-    , KRPC (Query dht (Ping dht)) (Response dht (Ping dht))
+    , KRPC dht (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip))
+    , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht))
     , DataHandlers raw dht
     , WireFormat raw dht
     , Show u
@@ -227,8 +227,8 @@ bootstrap :: forall raw dht u ip.
     , Show (QueryMethod dht)
     , Pretty (NodeInfo dht ip u)
     , Kademlia dht
-    , KRPC (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip))
-    , KRPC (Query dht (Ping dht)) (Response dht (Ping dht))
+    , KRPC dht (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip))
+    , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht))
     , DataHandlers raw dht
     , WireFormat raw dht
     , Show u
diff --git a/src/Network/BitTorrent/DHT/Query.hs b/src/Network/BitTorrent/DHT/Query.hs
index 67dc4541..4c980e22 100644
--- a/src/Network/BitTorrent/DHT/Query.hs
+++ b/src/Network/BitTorrent/DHT/Query.hs
@@ -123,7 +123,7 @@ import Data.String
 
 {-
 nodeHandler :: ( Address ip
-               , KRPC (Query KMessageOf a) (Response KMessageOf b)
+               , KRPC dht (Query KMessageOf a) (Response KMessageOf b)
                )
            => (NodeInfo KMessageOf ip () -> Maybe ReflectedIP -> IO ()) -> (NodeAddr ip -> IO (NodeId KMessageOf)) -> (Char -> String -> Text -> IO ()) -> QueryMethod KMessageOf -> (NodeAddr ip -> a -> IO b) -> NodeHandler
 -}
@@ -197,10 +197,10 @@ kademliaHandlers :: forall raw dht u ip. (Eq ip, Ord ip, Address ip
                     , Serialize (TransactionID dht)
                     , WireFormat raw dht
                     , Kademlia dht
-                    , KRPC (Query dht (Ping dht)) (Response dht (Ping dht))
+                    , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht))
                     , Functor dht
                     , Pretty (NodeInfo dht ip u)
-                    , KRPC (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip))
+                    , KRPC dht (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip))
                     , SerializableTo raw (Response dht (NodeFound dht ip))
                     , SerializableTo raw (Query dht (FindNode dht ip))
                     ) => LogFun -> DHT raw dht u ip [Handler IO dht raw]
@@ -208,7 +208,7 @@ kademliaHandlers :: forall raw dht u ip. (Eq ip, Ord ip, Address ip
 kademliaHandlers logger = do
     groknode <- insertNode1
     mynid <- myNodeIdAccordingTo1
-    let handler :: ( KRPC (Query dht a) (Response dht b)
+    let handler :: ( KRPC dht (Query dht a) (Response dht b)
                    , SerializableTo raw (Response dht b)
                    , SerializableTo raw (Query dht a)
                    ) => QueryMethod dht -> (NodeAddr ip -> a -> IO b) -> Handler IO dht raw
@@ -264,10 +264,10 @@ defaultHandlers :: forall raw dht u ip.
                     , Serialize (TransactionID dht)
                     , WireFormat raw dht
                     , Kademlia dht
-                    , KRPC (Query dht (Ping dht)) (Response dht (Ping dht))
+                    , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht))
                     , Functor dht
                     , Pretty (NodeInfo dht ip u)
-                    , KRPC (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip))
+                    , KRPC dht (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip))
                     , SerializableTo raw (Response dht (NodeFound dht ip))
                     , SerializableTo raw (Query dht (FindNode dht ip))
                     , Eq ip, Ord ip, Address ip, DataHandlers raw dht
@@ -293,7 +293,7 @@ type Iteration raw dht u ip o = NodeInfo dht ip u -> DHT raw dht u ip (Either [N
 pingQ :: forall raw dht u ip.
             ( DHT.Kademlia dht
             , Address ip
-            , KRPC (Query dht (Ping dht)) (Response dht (Ping dht))
+            , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht))
             , Default u
             , Show u
             , Ord (TransactionID dht)
@@ -361,7 +361,7 @@ ioGetPeers ih = do
 
 ioFindNode :: ( DHT.Kademlia dht
               , WireFormat raw dht
-              , KRPC (Query dht (Ping dht)) (Response dht (Ping dht))
+              , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht))
               , Address ip
               , Default u
               , Show u
@@ -371,7 +371,7 @@ ioFindNode :: ( DHT.Kademlia dht
               , Ord (NodeId dht)
               , FiniteBits (NodeId dht)
               , Show (NodeId dht)
-              , KRPC (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip))
+              , KRPC dht (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip))
               , Ord (TransactionID dht)
               , Serialize (TransactionID dht)
               , SerializableTo raw (Response dht (NodeFound dht ip))
@@ -390,7 +390,7 @@ ioFindNode ih = do
 -- | Like ioFindNode, but considers all found nodes to be 'Right' results.
 ioFindNodes :: ( DHT.Kademlia dht
               , WireFormat raw dht
-              , KRPC (Query dht (Ping dht)) (Response dht (Ping dht))
+              , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht))
               , Address ip
               , Default u
               , Show u
@@ -400,7 +400,7 @@ ioFindNodes :: ( DHT.Kademlia dht
               , Ord (NodeId dht)
               , FiniteBits (NodeId dht)
               , Show (NodeId dht)
-              , KRPC (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip))
+              , KRPC dht (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip))
               , Ord (TransactionID dht)
               , Serialize (TransactionID dht)
               , SerializableTo raw (Response dht (NodeFound dht ip))
@@ -481,7 +481,7 @@ publish = error "todo"
 
 probeNode :: ( Default u
             , Show u
-            , KRPC (Query dht (Ping dht)) (Response dht (Ping dht))
+            , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht))
             , DHT.Kademlia dht
             , Address ip
             , Ord (TransactionID dht)
@@ -507,9 +507,22 @@ refreshNodes :: forall raw dht u ip.
                 , Default u
                 , FiniteBits (NodeId dht)
                 , Pretty (NodeId dht)
-                , DHT.Kademlia dht )  => NodeId dht -> DHT raw dht u ip () -- [NodeInfo KMessageOf ip ()]
-refreshNodes _  = return () -- TODO
-#if 0
+                , DHT.Kademlia dht
+                , Ord ip
+                , Ord (TransactionID dht)
+                , SerializableTo raw (Response dht (NodeFound dht ip))
+                , SerializableTo raw (Query dht (FindNode dht ip))
+                , SerializableTo raw (Response dht (Ping dht))
+                , SerializableTo raw (Query dht (Ping dht))
+                , Pretty (NodeInfo dht ip u)
+                , Show (NodeId dht)
+                , Show u
+                , Show (QueryMethod dht)
+                , Serialize (TransactionID dht)
+                , WireFormat raw dht
+                , KRPC dht (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip))
+                , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht))
+                )  => NodeId dht -> DHT raw dht u ip () -- [NodeInfo KMessageOf ip ()]
 -- FIXME do not use getClosest sinse we should /refresh/ them
 refreshNodes nid = do
   $(logDebugS) "routing.refresh_bucket" (T.pack (render (pPrint nid)))
@@ -520,15 +533,15 @@ refreshNodes nid = do
     -- Expected type: ConduitM [NodeAddr ip] [NodeInfo KMessageOf ip ()] (DHT ip) ()
     --   Actual type: ConduitM [NodeInfo KMessageOf ip ()] [NodeInfo KMessageOf ip ()] (DHT ip) ()
     -- nss <- sourceList [[addr]] \$= search nid (findNodeQ nid) $$ C.consume
-    nss <- sourceList [nodes] $= search nid (findNodeQ (Proxy :: Proxy dht) nid) $$ C.consume
-    $(logWarnS) "refreshNodes" $ "received " <> T.pack (show (L.length (L.concat nss))) <> " nodes."
-    _ <- queryParallel $ flip L.map (L.concat nss) $ \n -> do
+    -- nss <- sourceList [nodes] \$= search nid (findNodeQ (Proxy :: Proxy dht) nid) $$ C.consume
+    ns <- bgsearch ioFindNodes nid
+    $(logWarnS) "refreshNodes" $ "received " <> T.pack (show (L.length ns)) <> " nodes."
+    _ <- queryParallel $ flip L.map ns $ \n -> do
         $(logWarnS) "refreshNodes" $ "received node: " <> T.pack (show (pPrint n))
         pingQ (nodeAddr n)
         -- pingQ takes care of inserting the node.
     return ()
   return () -- \$ L.concat nss
-#endif
 
 logc :: Char -> String -> DHT raw dht u ip ()
 logc 'D' = $(logDebugS) "insertNode" . T.pack
@@ -546,7 +559,7 @@ insertNode :: forall raw dht u ip.
               , Default u
               , Show u
               , DHT.Kademlia dht
-              , KRPC (Query dht (Ping dht)) (Response dht (Ping dht))
+              , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht))
               , Ord (TransactionID dht)
               , WireFormat raw dht
               , Serialize (TransactionID dht)
@@ -567,7 +580,7 @@ insertNode1 :: forall raw dht u ip.
                , Ord (NodeId dht)
                , FiniteBits (NodeId dht)
                , Show (NodeId dht)
-               , KRPC (Query dht (Ping dht)) (Response dht (Ping dht))
+               , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht))
                , DHT.Kademlia dht
                , Ord (TransactionID dht)
                , WireFormat raw dht
@@ -611,8 +624,8 @@ insertNode1 = do
 -- | Throws exception if node is not responding.
 queryNode :: forall raw dht u a b ip.
     ( Address ip
-    , KRPC (Query dht a) (Response dht b)
-    , KRPC (Query dht (Ping dht)) (Response dht (Ping dht))
+    , KRPC dht (Query dht a) (Response dht b)
+    , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht))
     , Default u
     , Show u
     , DHT.Kademlia dht
@@ -635,8 +648,8 @@ queryNode' :: forall raw dht u a b ip.
     , Default u
     , Show u
     , DHT.Kademlia dht
-    , KRPC (Query dht a) (Response dht b)
-    , KRPC (Query dht (Ping dht)) (Response dht (Ping dht))
+    , KRPC dht (Query dht a) (Response dht b)
+    , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht))
     , Ord (TransactionID dht)
     , Serialize (TransactionID dht)
     , WireFormat raw dht
@@ -652,9 +665,9 @@ queryNode' :: forall raw dht u a b ip.
 queryNode' addr q = do
   nid <- myNodeIdAccordingTo addr
   let read_only = False -- TODO: check for NAT issues. (BEP 43)
-  let KRPC.Method name = KRPC.method :: KRPC.Method (Query dht a) (Response dht b)
+  let KRPC.Method name = KRPC.method :: KRPC.Method dht (Query dht a) (Response dht b)
   mgr <- asks manager
-  (Response remoteId r, witnessed_ip) <- liftIO $ query' mgr (error "TODO: name") (toSockAddr addr) (Query nid read_only q)
+  (Response remoteId r, witnessed_ip) <- liftIO $ query' mgr name (toSockAddr addr) (Query nid read_only q)
   -- \$(logDebugS) "queryNode" $ "Witnessed address: " <> T.pack (show witnessed_ip)
   --                             <> " by " <> T.pack (show (toSockAddr addr))
   _ <- insertNode (NodeInfo remoteId addr def) witnessed_ip
@@ -662,8 +675,8 @@ queryNode' addr q = do
 
 -- | Infix version of 'queryNode' function.
 (<@>) :: ( Address ip
-         , KRPC (Query dht a) (Response dht b)
-         , KRPC (Query dht (Ping dht)) (Response dht (Ping dht))
+         , KRPC dht (Query dht a) (Response dht b)
+         , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht))
          , Default u
          , Show u
          , Show (QueryMethod dht)
diff --git a/src/Network/DHT/Mainline.hs b/src/Network/DHT/Mainline.hs
index aefd7742..b756ff6a 100644
--- a/src/Network/DHT/Mainline.hs
+++ b/src/Network/DHT/Mainline.hs
@@ -217,7 +217,7 @@ instance Serialize (Response Ping) where
 #endif
 
 -- | \"q\" = \"ping\"
-instance KRPC (Query KMessageOf (Ping KMessageOf)) (Response KMessageOf (Ping KMessageOf)) where
+instance KRPC KMessageOf (Query KMessageOf (Ping KMessageOf)) (Response KMessageOf (Ping KMessageOf)) where
 #ifdef VERSION_bencoding
   method = "ping"
 #else
@@ -301,7 +301,7 @@ instance Serialize (Response KMessageOf (NodeFound KMessageOf ip)) where
 
 -- | \"q\" == \"find_node\"
 instance (Address ip, Typeable ip)
-      => KRPC (Query KMessageOf (FindNode KMessageOf ip)) (Response KMessageOf (NodeFound KMessageOf ip)) where
+      => KRPC KMessageOf (Query KMessageOf (FindNode KMessageOf ip)) (Response KMessageOf (NodeFound KMessageOf ip)) where
 #ifdef VERSION_bencoding
   method = "find_node"
 #else
@@ -370,7 +370,7 @@ instance (Typeable ip, Serialize ip) => BEncode (GotPeers ip) where
 
 -- | \"q" = \"get_peers\"
 instance (Typeable ip, Serialize ip) =>
-         KRPC (Query KMessageOf (GetPeers ip)) (Response KMessageOf (GotPeers ip)) where
+         KRPC KMessageOf (Query KMessageOf (GetPeers ip)) (Response KMessageOf (GotPeers ip)) where
   method = "get_peers"
 
 {-----------------------------------------------------------------------
@@ -442,7 +442,7 @@ instance BEncode Announced where
   fromBEncode _ = pure  Announced
 
 -- | \"q" = \"announce\"
-instance KRPC (Query KMessageOf Announce) (Response KMessageOf Announced) where
+instance KRPC KMessageOf (Query KMessageOf Announce) (Response KMessageOf Announced) where
   method = "announce_peer"
 
 -- endif VERSION_bencoding
diff --git a/src/Network/KRPC/Method.hs b/src/Network/KRPC/Method.hs
index d0eb136a..84c7fe4c 100644
--- a/src/Network/KRPC/Method.hs
+++ b/src/Network/KRPC/Method.hs
@@ -9,12 +9,14 @@
 --
 {-# LANGUAGE CPP                        #-}
 {-# LANGUAGE DefaultSignatures          #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FunctionalDependencies     #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE StandaloneDeriving         #-}
 {-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE FunctionalDependencies #-}
 module Network.KRPC.Method
        ( Method (..)
        , KRPC (..)
@@ -32,6 +34,7 @@ import Data.List as L
 import Data.String
 import Data.Typeable
 import Network.DatagramServer.Mainline
+import Network.DatagramServer.Types
 
 
 -- | Method datatype used to describe method name, parameters and
@@ -44,28 +47,24 @@ import Network.DatagramServer.Mainline
 --
 --     * result: Type of return value of the method.
 --
-newtype Method param result = Method { methodName :: MethodName }
-  deriving ( Eq, Ord
-#ifdef VERSION_bencoding
-           , IsString
-           , BEncode
-#endif
-           )
+newtype Method dht param result = Method { methodName :: QueryMethod dht }
+
+deriving instance Eq (QueryMethod dht) => Eq (Method dht param result)
+deriving instance Ord (QueryMethod dht) => Ord (Method dht param result)
+deriving instance IsString (QueryMethod dht) => IsString (Method dht param result)
+deriving instance BEncode (QueryMethod dht) => BEncode (Method dht param result)
 
 -- | Example:
 --
 --   @show (Method \"concat\" :: [Int] Int) == \"concat :: [Int] -> Int\"@
 --
-instance (Typeable a, Typeable b) => Show (Method a b) where
+instance (Show (QueryMethod dht), Typeable a, Typeable b) => Show (Method dht a b) where
   showsPrec _ = showsMethod
 
-showsMethod :: forall a b. ( Typeable a , Typeable b ) => Method a b -> ShowS
+showsMethod :: forall dht a b. ( Show (QueryMethod dht), Typeable a , Typeable b ) => Method dht a b -> ShowS
 showsMethod (Method name) =
-#ifdef VERSION_bencoding
-    showString (BC.unpack name) <>
-#else
+    -- showString (BC.unpack name) <>
     shows (show name) <>
-#endif
     showString " :: " <>
     shows paramsTy <>
     showString " -> " <>
@@ -88,24 +87,16 @@ showsMethod (Method name) =
 --     method = \"ping\"
 --   @
 --
-class ( Typeable req, Typeable resp
--- #ifdef VERSION_bencoding
-      -- , BEncode req, BEncode resp
--- #else
-      -- , Serialize req, Serialize resp
--- #endif
-      )
-    => KRPC req resp | req -> resp, resp -> req where
+class ( Typeable req, Typeable resp)
+    => KRPC dht req resp | req -> resp, resp -> req where
 
   -- | Method name. Default implementation uses lowercased @req@
   -- datatype name.
   --
-  method :: Method req resp
+  method :: Method dht req resp
 
-#ifdef VERSION_bencoding
   -- TODO add underscores
-  default method :: Typeable req => Method req resp
+  default method :: (IsString (QueryMethod dht), Typeable req) => Method dht req resp
   method = Method $ fromString $ L.map toLower $ show $ typeOf hole
     where
       hole = error "krpc.method: impossible" :: req
-#endif