Implement clientAddress for Mainline DHT.

1 files changed, 38 insertions, 16 deletions

diff --git a/Mainline.hs b/Mainline.hs
index 818150b4..ef452f7d 100644
--- a/Mainline.hs
+++ b/Mainline.hs
@@ -32,19 +32,21 @@ import Data.IP
 import Data.List
 import Data.Maybe
 import Data.Monoid
+import Data.Ord
 import qualified Data.Serialize           as S
 import Data.Set                           (Set)
 import Data.Torrent
 import Data.Typeable
 import Data.Word
 import Network.Address                    (Address, fromSockAddr, setPort,
-                                           sockAddrPort, toSockAddr)
+                                           sockAddrPort, toSockAddr, testIdBit)
 import Network.BitTorrent.DHT.ContactInfo as Peers
 import Network.BitTorrent.DHT.Token       as Token
 import qualified Network.DHT.Routing      as R
          ;import Network.DHT.Routing      (Info, Timestamp, getTimestamp)
 import Network.QueryResponse
 import Network.Socket
+import Kademlia
 
 newtype NodeId = NodeId ByteString
  deriving (Eq,Ord,Show,ByteArrayAccess, BEncode, Bits)
@@ -258,9 +260,9 @@ newSwarmsDatabase = do
 type RoutingInfo = Info NodeInfo NodeId
 
 data Routing = Routing
-    { tentativeId :: NodeId
-    , routing4 :: !( TVar (Maybe RoutingInfo) )
-    , routing6 :: !( TVar (Maybe RoutingInfo) )
+    { tentativeId :: NodeInfo
+    , routing4 :: !( TVar (R.BucketList NodeInfo) )
+    , routing6 :: !( TVar (R.BucketList NodeInfo) )
     }
 
 newClient ::
@@ -268,10 +270,16 @@ newClient ::
 newClient addr = do
     udp <- udpTransport addr
     nid <- NodeId <$> getRandomBytes 20
-    self <- atomically $ newTVar
-             $ NodeInfo nid (fromMaybe (toEnum 0) $ fromSockAddr addr)
-                            (fromMaybe 0 $ sockAddrPort addr)
-    routing <- atomically $ Routing nid <$> newTVar Nothing <*> newTVar Nothing
+    let tenative_info = NodeInfo
+                { nodeId   = nid
+                , nodeIP   = fromMaybe (toEnum 0) $ fromSockAddr addr
+                , nodePort = fromMaybe 0 $ sockAddrPort addr
+                }
+    routing <- atomically $ do
+        let nobkts = R.defaultBucketCount :: Int
+        tbl4 <- newTVar $ R.nullTable (comparing nodeId) tenative_info nobkts
+        tbl6 <- newTVar $ R.nullTable (comparing nodeId) tenative_info nobkts
+        return $ Routing tenative_info tbl4 tbl6
     swarms <- newSwarmsDatabase
     let net = onInbound (updateRouting routing)
               $ layerTransport parsePacket encodePacket
@@ -298,7 +306,11 @@ newClient addr = do
             , clientDispatcher    = dispatch mapT
             , clientErrorReporter = ignoreErrors -- TODO
             , clientPending       = map_var
-            , clientAddress       = atomically (readTVar self)
+            , clientAddress       = \maddr -> atomically $ do
+                let var = case flip prefer4or6 Nothing <$> maddr of
+                            Just Want_IP6 -> routing6 routing
+                            _             -> routing4 routing
+                R.selfNode <$> readTVar var
             , clientResponseId    = return
             }
 
@@ -308,8 +320,22 @@ defaultHandler meth = MethodHandler decodePayload errorPayload returnError
     returnError :: NodeInfo -> BValue -> IO Error
     returnError _ _ = return $ Error MethodUnknown ("Unknown method " <> meth)
 
+mainlineKademlia :: Kademlia NodeId NodeInfo
+mainlineKademlia = Kademlia quietInsertions
+                            mainlineSpace
+                            (vanillaIO (error "var") $ error "pingProbe")
+
+mainlineSpace :: R.KademliaSpace NodeId NodeInfo
+mainlineSpace = R.KademliaSpace
+    { R.kademliaLocation = nodeId
+    , R.kademliaTestBit  = testIdBit
+    , R.kademliaXor      = xor
+    }
+
+
 updateRouting :: Routing -> NodeInfo -> Message BValue -> IO ()
 updateRouting routing naddr _ = do
+    error "todo" insertNode
     -- TODO Update kademlia table.
     -- TODO Update external ip address and update BEP-42 node id.
     return ()
@@ -413,13 +439,9 @@ findNodeH routing addr (FindNode node iptyp) = do
     ks6 <- bool (return []) (go $ routing6 routing) (preferred /= Want_IP4)
     return $ NodeFound ks ks6
  where
-    go var = do
-        let myid   = tentativeId routing  :: NodeId
-            k      = R.defaultK           :: Int
-            nobkts = R.defaultBucketCount :: Int
-        nfo <- atomically $ readTVar var
-        let tbl = maybe (R.nullTable myid nobkts) R.myBuckets nfo
-        return $ R.kclosest nodeId k node tbl
+    go var = R.kclosest nodeId k node <$> atomically (readTVar var)
+    k = R.defaultK
+
 
 data GetPeers = GetPeers InfoHash (Maybe WantIP)