Generate mainline node id, canonize ips in peer store.

1 files changed, 36 insertions, 19 deletions

diff --git a/Mainline.hs b/Mainline.hs
index 19646aeb..42b0be97 100644
--- a/Mainline.hs
+++ b/Mainline.hs
@@ -79,9 +79,12 @@ getNodeInfo4 = NodeInfo <$> (NodeId <$> S.getBytes 20)
                         <*> S.get
 
 putNodeInfo4 :: NodeInfo -> S.Put
-putNodeInfo4 (NodeInfo (NodeId nid) (IPv4 ip) port)
-               = S.putByteString nid >> S.put ip >> S.put port
-putNodeInfo4 _ = return ()
+putNodeInfo4 (NodeInfo (NodeId nid) ip port)
+    | IPv4 ip4 <- ip                          = put4 ip4
+    | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = put4 ip4
+    | otherwise                               = return ()
+ where
+    put4 ip4 = S.putByteString nid >> S.put ip4 >> S.put port
 
 getNodeInfo6 :: S.Get NodeInfo
 getNodeInfo6 = NodeInfo <$> (NodeId <$> S.getBytes 20)
@@ -255,7 +258,8 @@ newSwarmsDatabase = do
 type RoutingInfo = Info NodeInfo NodeId
 
 data Routing = Routing
-    { routing4 :: !( TVar (Maybe RoutingInfo) )
+    { tentativeId :: NodeId
+    , routing4 :: !( TVar (Maybe RoutingInfo) )
     , routing6 :: !( TVar (Maybe RoutingInfo) )
     }
 
@@ -263,11 +267,11 @@ newClient ::
       SockAddr -> IO (Client String Method TransactionId NodeInfo (Message BValue))
 newClient addr = do
     udp <- udpTransport addr
-    nid <- error "todo: tentative node id"
+    nid <- NodeId <$> getRandomBytes 20
     self <- atomically $ newTVar
              $ NodeInfo nid (fromMaybe (toEnum 0) $ fromSockAddr addr)
                             (fromMaybe 0 $ sockAddrPort addr)
-    routing <- atomically $ Routing <$> newTVar Nothing <*> newTVar Nothing
+    routing <- atomically $ Routing nid <$> newTVar Nothing <*> newTVar Nothing
     swarms <- newSwarmsDatabase
     let net = onInbound grok $ layerTransport parsePacket encodePacket udp
         grok _ _ = do
@@ -378,10 +382,18 @@ pingH _ Ping = return Pong
 -- as defined in RFC 4291.
 is4mapped :: IPv6 -> Bool
 is4mapped ip
-    | [0,0,0,0,0,0,0xffff,_] <- fromIPv6 ip
+    | [0,0,0,0,0,0xffff,_,_] <- fromIPv6 ip
                 = True
     | otherwise = False
 
+un4map :: IPv6 -> Maybe IPv4
+un4map ip
+    | [0,0,0,0,0,0xffff,x,y] <- fromIPv6 ip
+                = Just $ toIPv4
+                       $ map (.&. 0xFF)
+                             [x `shiftR` 8, x, y `shiftR` 8, y ]
+    | otherwise = Nothing
+
 prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP
 prefer4or6 addr iptyp = fromMaybe (ipFamily $ nodeIP addr) iptyp
 
@@ -399,9 +411,9 @@ findNodeH routing addr (FindNode node iptyp) = do
     return $ NodeFound ks ks6
  where
     go var = do
-        let myid   = error "TODO myid"   :: NodeId
-            k      = error "TODO k"      :: Int
-            nobkts = error "TODO nobkts" :: Int
+        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
@@ -567,12 +579,17 @@ announceH (SwarmsDatabase peers toks _) naddr announcement = do
     >>= bool (Left  <$> return (Error ProtocolError "invalid parameter: token"))
              (Right <$> go)
  where
-    go = do
-      let annPort  = if impliedPort announcement
-                        then nodePort naddr
-                        else port announcement
-          peerAddr = PeerAddr Nothing (nodeIP naddr) annPort
-      atomically
-            $ modifyTVar' peers
-            $ insertPeer (topic announcement) (announcedName announcement) peerAddr
-      return Announced
+    go = atomically $ do
+        modifyTVar' peers
+            $ insertPeer (topic announcement) (announcedName announcement)
+            $ PeerAddr
+                { peerId = Nothing
+                -- Avoid storing IPv4-mapped addresses.
+                , peerHost = case nodeIP naddr of
+                    IPv6 ip6 | Just ip4 <- un4map ip6 -> IPv4 ip4
+                    a                                 -> a
+                , peerPort = if impliedPort announcement
+                                then nodePort naddr
+                                else port announcement
+                }
+        return Announced