4 files changed, 68 insertions, 20 deletions

diff --git a/Global6.hs b/Global6.hs
new file mode 100644
index 00000000..346be708
--- /dev/null
+++ b/Global6.hs
@@ -0,0 +1,28 @@
+module Global6 where
+
+import Control.Monad
+import Data.IP
+import Data.List
+import Data.Maybe
+import Network.Socket
+import System.Process
+import Text.Read
+
+parseIpAddr :: String -> Maybe IPv6
+parseIpAddr s = do
+    let ws        = words s
+        (addr,bs) = splitAt 1 $ drop 1 $ dropWhile (/= "inet6") ws
+    guard ("global" `elem` bs)
+    addr <- listToMaybe addr
+    guard (not $ isPrefixOf "fd" addr)
+    guard (not $ isPrefixOf "fc" addr)
+    let (addr',slash) = break (=='/') addr
+    ip6 <- readMaybe addr'
+    return $ (ip6 :: IPv6)
+
+
+global6 :: IO (Maybe IPv6)
+global6 = do
+    addrs <- lines <$> readProcess "ip" ["-o","-6","addr"] ""
+    return $ foldr1 mplus $ map parseIpAddr addrs
+
diff --git a/Kademlia.hs b/Kademlia.hs
index ef5c6a48..017209a7 100644
--- a/Kademlia.hs
+++ b/Kademlia.hs
@@ -267,10 +267,11 @@ forkPollForRefresh interval psq refresh = do
 
 refreshBucket :: forall nid tok ni addr.
                  ( Show nid, FiniteBits nid, Serialize nid, Ord nid, Ord ni, Hashable nid, Hashable ni, Ord addr ) =>
-                 Search nid addr tok ni ni -> TVar (BucketList ni) -> nid -> Int -> IO Int
-refreshBucket sch var nid n = do
+                 Search nid addr tok ni ni -> TVar (BucketList ni) -> Int -> IO Int
+refreshBucket sch var n = do
     tbl <- atomically (readTVar var)
     let count = bktCount tbl
+        nid = kademliaLocation (searchSpace sch) (thisNode tbl)
     sample <- if n+1 >= count            -- Is this the last bucket?
                 then return nid          -- Yes? Search our own id.
                 else genBucketSample nid -- No? Generate a random id.
@@ -362,7 +363,6 @@ bootstrap sch var ping ns ns0 = do
                     hPutStrLn stderr
                         $ "Not enough buckets, refresh " ++ show (R.defaultBucketCount - 1)
                     cnt <- refreshBucket sch var
-                        (kademliaLocation (searchSpace sch) (thisNode tbl))
                         (R.defaultBucketCount - 1)
                     again cnt
             (size,num):_ -> do
@@ -371,5 +371,5 @@ bootstrap sch var ping ns ns0 = do
                 let num' | bktCount tbl < R.defaultBucketCount = R.defaultBucketCount - 1
                          | otherwise                           = num
                 hPutStrLn stderr $ "Bucket too small, refresh "++ show (num',(size,num),shp)
-                cnt <- refreshBucket sch var (kademliaLocation (searchSpace sch) (thisNode tbl)) num'
+                cnt <- refreshBucket sch var num'
                 again cnt
diff --git a/Mainline.hs b/Mainline.hs
index deb75079..6aa1c517 100644
--- a/Mainline.hs
+++ b/Mainline.hs
@@ -77,6 +77,7 @@ import Control.Exception    (SomeException (..), handle)
 import qualified Data.Aeson as JSON
          ;import Data.Aeson (FromJSON, ToJSON, (.=))
 import Text.Read
+import Global6
 
 newtype NodeId = NodeId ByteString
  deriving (Eq,Ord,ByteArrayAccess, Bits, Hashable)
@@ -524,17 +525,24 @@ newClient :: SockAddr -> IO (MainlineClient, Routing, SwarmsDatabase)
 newClient addr = do
     udp <- udpTransport addr
     nid <- NodeId <$> getRandomBytes 20
-    let tenative_info = NodeInfo
+    let tentative_info = NodeInfo
                 { nodeId   = nid
                 , nodeIP   = fromMaybe (toEnum 0) $ fromSockAddr addr
                 , nodePort = fromMaybe 0 $ sockAddrPort addr
                 }
+    tentative_info6 <-
+        maybe tentative_info
+              (\ip6 -> tentative_info { nodeId = fromMaybe (nodeId tentative_info)
+                                                    $ bep42 (toSockAddr ip6) (nodeId tentative_info)
+                                      , nodeIP = IPv6 ip6
+                                      })
+            <$> global6
     addr4 <- atomically $ newTChan
     addr6 <- atomically $ newTChan
     routing <- atomically $ do
         let nobkts = R.defaultBucketCount :: Int
-        tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tenative_info nobkts
-        tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tenative_info nobkts
+        tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info nobkts
+        tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info6 nobkts
         let updateIPVote tblvar addrvar a = do
                 bkts <- readTVar tblvar
                 case bep42 a (nodeId $ R.thisNode bkts) of
@@ -552,7 +560,7 @@ newClient addr = do
         committee6 <- newTriadCommittee $ updateIPVote tbl6 addr6
         sched4 <- newTVar Int.empty
         sched6 <- newTVar Int.empty
-        return $ Routing tenative_info sched4 tbl4 committee4 sched6 tbl6 committee6
+        return $ Routing tentative_info sched4 tbl4 committee4 sched6 tbl6 committee6
     swarms <- newSwarmsDatabase
     map_var <- atomically $ newTVar (0, mempty)
     let net = onInbound (updateRouting outgoingClient routing)
@@ -619,11 +627,11 @@ newClient addr = do
     refresh_thread4 <- forkPollForRefresh
                             (15*60)
                             (sched4 routing)
-                            (refreshBucket (nodeSearch client) (routing4 routing) (nodeId tenative_info))
+                            (refreshBucket (nodeSearch client) (routing4 routing))
     refresh_thread6 <- forkPollForRefresh
                             (15*60)
                             (sched6 routing)
-                            (refreshBucket (nodeSearch client) (routing6 routing) (nodeId tenative_info))
+                            (refreshBucket (nodeSearch client) (routing6 routing))
 
     return (client, routing, swarms)
 
@@ -705,13 +713,15 @@ updateRouting client routing naddr msg = do
         Want_IP6 -> go (routing6 routing) (committee6 routing) (sched6 routing)
  where
     go tbl committee sched = do
-        case msg of
-            R { rspReflectedIP = Just sockaddr }
-                -> do
-                    -- hPutStrLn stderr $ "External: "++show (nodeId naddr,sockaddr)
-                    atomically $ addVote committee (nodeId naddr) sockaddr
-            _   -> return ()
-        insertNode (mainlineKademlia client committee tbl sched) naddr
+        self <- atomically $ R.thisNode <$> readTVar tbl
+        when (nodeIP self /= nodeIP naddr) $ do
+            case msg of
+                R { rspReflectedIP = Just sockaddr }
+                    -> do
+                        -- hPutStrLn stderr $ "External: "++show (nodeId naddr,sockaddr)
+                        atomically $ addVote committee (nodeId naddr) sockaddr
+                _   -> return ()
+            insertNode (mainlineKademlia client committee tbl sched) naddr
 
 data Ping = Ping deriving Show
 
@@ -809,11 +819,19 @@ ipFamily ip = case ip of
 findNodeH :: Routing -> NodeInfo -> FindNode -> IO NodeFound
 findNodeH routing addr (FindNode node iptyp) = do
     let preferred = prefer4or6 addr iptyp
-    ks  <- bool (return []) (go $ routing4 routing) (preferred /= Want_IP6)
-    ks6 <- bool (return []) (go $ routing6 routing) (preferred /= Want_IP4)
+
+    (append4,append6) <- atomically $ do
+        ni4 <- R.thisNode <$> readTVar (routing4 routing)
+        ni6 <- R.thisNode <$> readTVar (routing6 routing)
+        return $ case ipFamily (nodeIP addr) of
+            Want_IP4 -> (id, (++ [ni6]))
+            Want_IP6 -> ((++ [ni4]), id)
+    ks  <- bool (return []) (go append4 $ routing4 routing) (preferred /= Want_IP6)
+    ks6 <- bool (return []) (go append6 $ routing6 routing) (preferred /= Want_IP4)
     return $ NodeFound ks ks6
  where
-    go var = R.kclosest mainlineSpace k node <$> atomically (readTVar var)
+    go f var = f . R.kclosest mainlineSpace k node <$> atomically (readTVar var)
+
     k = R.defaultK
 
 
diff --git a/bittorrent.cabal b/bittorrent.cabal
index 4af89b97..f985f76b 100644
--- a/bittorrent.cabal
+++ b/bittorrent.cabal
@@ -92,6 +92,7 @@ library
                     Tasks
                     Kademlia
                     Mainline
+                    Global6
 
   build-depends:      base
                     , containers
@@ -119,6 +120,7 @@ library
                     , cereal
                     , http-types
 
+                    , process
                     , split
                     , pretty
                     , convertible