3 files changed, 160 insertions, 94 deletions

diff --git a/Mainline.hs b/Mainline.hs
index 77c0d5f1..4ce4f4da 100644
--- a/Mainline.hs
+++ b/Mainline.hs
@@ -61,7 +61,7 @@ import Network.BitTorrent.DHT.ContactInfo     as Peers
 import Network.BitTorrent.DHT.Search          (Search (..))
 import Network.BitTorrent.DHT.Token           as Token
 import qualified Network.DHT.Routing          as R
-         ;import Network.DHT.Routing          (Info, Timestamp, getTimestamp)
+         ;import Network.DHT.Routing          (Timestamp, getTimestamp)
 import Network.QueryResponse
 import Network.Socket
 import System.IO
@@ -79,6 +79,7 @@ import qualified Data.Aeson as JSON
          ;import Data.Aeson (FromJSON, ToJSON, (.=))
 import Text.Read
 import Global6
+import TriadCommittee
 
 newtype NodeId = NodeId ByteString
  deriving (Eq,Ord,ByteArrayAccess, Bits, Hashable)
@@ -495,8 +496,6 @@ newSwarmsDatabase = do
                     <*> newTVar toks
                     <*> newTVar def
 
-type RoutingInfo = Info NodeInfo NodeId
-
 data Routing = Routing
     { tentativeId :: NodeInfo
     , sched4      :: !( TVar (Int.PSQ POSIXTime) )
@@ -596,7 +595,7 @@ newClient addr = do
                 let var = case flip prefer4or6 Nothing <$> maddr of
                             Just Want_IP6 -> routing6 routing
                             _             -> routing4 routing
-                R.selfNode <$> readTVar var
+                R.thisNode <$> readTVar var
             , clientResponseId    = return
             }
 
@@ -1027,84 +1026,6 @@ getPeers = mainlineSend (Method "get_peers") unwrapPeers $ flip GetPeers (Just W
 
 unwrapPeers (GotPeers ps (NodeFound ns4 ns6) tok) = (ns4++ns6, ps, tok)
 
-data TriadSlot = SlotA | SlotB | SlotC
- deriving (Eq,Ord,Enum,Show,Read)
-
-data TriadCommittee voter a = TriadCommittee
-    { triadDecider :: TVar TriadSlot
-    , triadA :: TVar (Maybe (voter,a))
-    , triadB :: TVar (Maybe (voter,a))
-    , triadC :: TVar (Maybe (voter,a))
-    , triadNewDecision :: a -> STM ()
-    }
-
-triadSlot :: TriadSlot -> TriadCommittee voter a -> TVar (Maybe (voter,a))
-triadSlot SlotA = triadA
-triadSlot SlotB = triadB
-triadSlot SlotC = triadC
-
-triadDecision :: a -> TriadCommittee voter a -> STM a
-triadDecision fallback triad = do
-    slot <- readTVar (triadDecider triad)
-    maybe fallback snd <$> readTVar (triadSlot slot triad)
-
-
-newTriadCommittee :: (a -> STM ()) -> STM (TriadCommittee voter a)
-newTriadCommittee onChange =
-    TriadCommittee <$> newTVar SlotA
-                   <*> newTVar Nothing
-                   <*> newTVar Nothing
-                   <*> newTVar Nothing
-                   <*> pure onChange
-
-triadCountVotes :: Eq a => Maybe a -> TriadCommittee voter a -> STM ()
-triadCountVotes prior triad = do
-    a <- fmap ((SlotA,) . snd) <$> readTVar (triadA triad)
-    b <- fmap ((SlotB,) . snd) <$> readTVar (triadB triad)
-    c <- fmap ((SlotC,) . snd) <$> readTVar (triadC triad)
-    let (slot,vote) = case catMaybes [a,b,c] of
-            [  (x,xvote)
-             , (y,yvote)
-             , (z,zvote) ]  -> if xvote == yvote then (x,Just xvote)
-                                                 else (z,Just zvote)
-            []              -> (SlotA,Nothing)
-            ((slot,vote):_) -> (slot, Just vote)
-    writeTVar (triadDecider triad) slot
-    case vote of
-        Just v | vote /= prior -> triadNewDecision triad v
-        _                      -> return ()
-
-
-addVote :: (Eq voter, Eq a) => TriadCommittee voter a -> voter -> a -> STM ()
-addVote triad voter vote = do
-    a <- (SlotA,) . fmap fst <$> readTVar (triadA triad)
-    b <- (SlotB,) . fmap fst <$> readTVar (triadB triad)
-    c <- (SlotC,) . fmap fst <$> readTVar (triadC triad)
-    let avail (_,Nothing) = True
-        avail (_,Just x ) = (x == voter)
-        slots = filter avail [a,b,c]
-    forM_ (take 1 slots) $ \(slot,_) -> do
-        prior <- do
-            slotp <- readTVar (triadDecider triad)
-            fmap snd <$> readTVar (triadSlot slotp triad)
-        writeTVar (triadSlot slot triad)
-                  (Just (voter,vote))
-        triadCountVotes prior triad
-
-delVote :: (Eq voter, Eq a) => TriadCommittee voter a -> voter -> STM ()
-delVote triad voter = do
-    a <- (SlotA,) . fmap fst <$> readTVar (triadA triad)
-    b <- (SlotB,) . fmap fst <$> readTVar (triadB triad)
-    c <- (SlotC,) . fmap fst <$> readTVar (triadC triad)
-    let match (_,Just x ) = (x == voter)
-        slots = filter match [a,b,c]
-    forM_ (take 1 slots) $ \(slot,_) -> do
-        prior <- do
-            slotp <- readTVar (triadDecider triad)
-            fmap snd <$> readTVar (triadSlot slotp triad)
-        writeTVar (triadSlot slot triad) Nothing
-        triadCountVotes prior triad
-
 mainlineSearch qry = Search
     { searchSpace       = mainlineSpace
     , searchNodeAddress = nodeIP &&& nodePort
@@ -1154,3 +1075,5 @@ resolve want hostAndPort = do
         --  pattern matching never fails.
         info : _ <- getAddrInfo (Just hints) (Just host) port
         return $ addrAddress info
+
+
diff --git a/Tox.hs b/Tox.hs
index 25c650b3..34e5d6f3 100644
--- a/Tox.hs
+++ b/Tox.hs
@@ -41,7 +41,7 @@ import Foreign.Ptr
 import Foreign.Storable
 import GHC.Generics                     (Generic)
 import Network.Address                  (Address, fromSockAddr, sockAddrPort,
-                                         toSockAddr, setPort,un4map)
+                                         toSockAddr, setPort, un4map, WantIP(..), ipFamily)
 import Network.QueryResponse
 import Network.Socket
 import System.Endian
@@ -50,9 +50,16 @@ import Data.Bits
 import Data.Bits.ByteString ()
 import qualified Text.ParserCombinators.ReadP as RP
 import Data.Char
+import TriadCommittee
+import qualified Network.DHT.Routing          as R
+import qualified Data.Wrapper.PSQInt          as Int
+import Data.Time.Clock.POSIX                  (POSIXTime)
+import Global6
+import Data.Ord
+import System.IO
 
 newtype NodeId = NodeId ByteString
- deriving (Eq,Ord,ByteArrayAccess, Bits)
+ deriving (Eq,Ord,ByteArrayAccess, Bits, Hashable)
 
 instance Show NodeId where
     show (NodeId bs) = C8.unpack $ Base16.encode bs
@@ -350,6 +357,18 @@ encodePacket :: SecretKey -> SecretsCache -> Message ByteString -> NodeInfo -> (
 encodePacket sk cache msg ni = ( S.runPut . putMessage $ encryptMessage sk cache (nodeId ni) msg
                                , nodeAddr ni )
 
+
+data Routing = Routing
+    { tentativeId :: NodeInfo
+    , sched4      :: !( TVar (Int.PSQ POSIXTime) )
+    , routing4    :: !( TVar (R.BucketList NodeInfo) )
+    , committee4  :: TriadCommittee NodeId SockAddr
+    , sched6      :: !( TVar (Int.PSQ POSIXTime) )
+    , routing6    :: !( TVar (R.BucketList NodeInfo) )
+    , committee6  :: TriadCommittee NodeId SockAddr
+    }
+
+
 newClient :: SockAddr -> IO (Client String Method TransactionId NodeInfo (Message ByteString))
 newClient addr = do
     udp <- udpTransport addr
@@ -357,9 +376,32 @@ newClient addr = do
     let pubkey = key2id $ toPublic secret
     cache <- newEmptyCache
     drg <- getSystemDRG
-    self <- atomically $ newTVar
-             $ NodeInfo pubkey (fromMaybe (toEnum 0) $ fromSockAddr addr)
-                               (fromMaybe 0 $ sockAddrPort addr)
+    let tentative_info = NodeInfo
+                { nodeId   = pubkey
+                , nodeIP   = fromMaybe (toEnum 0) $ fromSockAddr addr
+                , nodePort = fromMaybe 0 $ sockAddrPort addr
+                }
+    tentative_info6 <-
+        maybe tentative_info
+              (\ip6 -> 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) 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 nodeInfo (nodeId (R.thisNode bkts)) a of
+                    Right ni -> writeTVar tblvar (bkts { R.thisNode = ni })
+                    Left _   -> return ()
+                writeTChan addrvar (a,map fst $ concat $ R.toList bkts)
+        committee4 <- newTriadCommittee $ updateIPVote tbl4 addr4
+        committee6 <- newTriadCommittee $ updateIPVote tbl6 addr6
+        sched4 <- newTVar Int.empty
+        sched6 <- newTVar Int.empty
+        return $ Routing tentative_info sched4 tbl4 committee4 sched6 tbl6 committee6
     let net = layerTransport (parsePacket secret cache)
                              (encodePacket secret cache)
                              udp
@@ -368,6 +410,12 @@ newClient addr = do
             , lookupHandler = handlers
             , tableMethods = tbl
             }
+
+        handlers :: Method -> Maybe Handler
+        handlers PingType     = handler PongType pingH
+        handlers GetNodesType = handler SendNodesType $ getNodesH routing
+        handlers _            = Nothing
+
         genNonce24 var (TransactionId nonce8 _) = atomically $ do
             (g,pending) <- readTVar var
             let (bs, g') = randomBytesGenerate 24 g
@@ -376,9 +424,13 @@ newClient addr = do
         client tbl var = Client
             { clientNet           = net
             , clientDispatcher    = dispatch tbl
-            , clientErrorReporter = ignoreErrors -- TODO
+            , clientErrorReporter = printErrors stderr
             , clientPending       = var
-            , clientAddress       = \maddr -> atomically (readTVar self)
+            , clientAddress       = \maddr -> atomically $ do
+                let var = case flip prefer4or6 Nothing <$> maddr of
+                            Just Want_IP6 -> routing6 routing
+                            _             -> routing4 routing
+                R.thisNode <$> readTVar var
             , clientResponseId    = genNonce24 var
             }
     if fitsInInt (Proxy :: Proxy Word64)
@@ -426,12 +478,9 @@ encodePayload typ (TransactionId (Nonce8 tid) nonce) self dest b
 decodePayload :: S.Serialize a => Message ByteString -> Either String a
 decodePayload msg = S.decode $ dropEnd8 $ msgPayload msg
 
-handler typ f = Just $ MethodHandler decodePayload (encodePayload typ) f
+type Handler = MethodHandler String TransactionId NodeInfo (Message ByteString)
 
-handlers :: Method -> Maybe (MethodHandler String TransactionId NodeInfo (Message ByteString))
-handlers PingType     = handler PingType pingH
-handlers GetNodesType = error "find_node"
-handlers _            = Nothing
+handler typ f = Just $ MethodHandler decodePayload (encodePayload typ) f
 
 data Ping = Ping deriving Show
 data Pong = Pong deriving Show
@@ -471,6 +520,12 @@ instance S.Serialize SendNodes where
 pingH :: NodeInfo -> Ping -> IO Pong
 pingH _ Ping = return Pong
 
+prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP
+prefer4or6 addr iptyp = fromMaybe (ipFamily $ nodeIP addr) iptyp
+
+getNodesH :: Routing -> NodeInfo -> GetNodes -> IO SendNodes
+getNodesH = error "todo: getNodesH"
+
 intKey :: TransactionId -> Int
 intKey (TransactionId (Nonce8 w) _) = fromIntegral w
 
diff --git a/TriadCommittee.hs b/TriadCommittee.hs
new file mode 100644
index 00000000..3fe3ebe6
--- /dev/null
+++ b/TriadCommittee.hs
@@ -0,0 +1,88 @@
+{-# LANGUAGE TupleSections #-}
+module TriadCommittee where
+
+import Control.Concurrent.STM
+import Control.Monad
+import Data.Maybe
+
+
+data TriadSlot = SlotA | SlotB | SlotC
+ deriving (Eq,Ord,Enum,Show,Read)
+
+data TriadCommittee voter a = TriadCommittee
+    { triadDecider :: TVar TriadSlot
+    , triadA :: TVar (Maybe (voter,a))
+    , triadB :: TVar (Maybe (voter,a))
+    , triadC :: TVar (Maybe (voter,a))
+    , triadNewDecision :: a -> STM ()
+    }
+
+triadSlot :: TriadSlot -> TriadCommittee voter a -> TVar (Maybe (voter,a))
+triadSlot SlotA = triadA
+triadSlot SlotB = triadB
+triadSlot SlotC = triadC
+
+triadDecision :: a -> TriadCommittee voter a -> STM a
+triadDecision fallback triad = do
+    slot <- readTVar (triadDecider triad)
+    maybe fallback snd <$> readTVar (triadSlot slot triad)
+
+
+newTriadCommittee :: (a -> STM ()) -> STM (TriadCommittee voter a)
+newTriadCommittee onChange =
+    TriadCommittee <$> newTVar SlotA
+                   <*> newTVar Nothing
+                   <*> newTVar Nothing
+                   <*> newTVar Nothing
+                   <*> pure onChange
+
+
+triadCountVotes :: Eq a => Maybe a -> TriadCommittee voter a -> STM ()
+triadCountVotes prior triad = do
+    a <- fmap ((SlotA,) . snd) <$> readTVar (triadA triad)
+    b <- fmap ((SlotB,) . snd) <$> readTVar (triadB triad)
+    c <- fmap ((SlotC,) . snd) <$> readTVar (triadC triad)
+    let (slot,vote) = case catMaybes [a,b,c] of
+            [  (x,xvote)
+             , (y,yvote)
+             , (z,zvote) ]  -> if xvote == yvote then (x,Just xvote)
+                                                 else (z,Just zvote)
+            []              -> (SlotA,Nothing)
+            ((slot,vote):_) -> (slot, Just vote)
+    writeTVar (triadDecider triad) slot
+    case vote of
+        Just v | vote /= prior -> triadNewDecision triad v
+        _                      -> return ()
+
+
+addVote :: (Eq voter, Eq a) => TriadCommittee voter a -> voter -> a -> STM ()
+addVote triad voter vote = do
+    a <- (SlotA,) . fmap fst <$> readTVar (triadA triad)
+    b <- (SlotB,) . fmap fst <$> readTVar (triadB triad)
+    c <- (SlotC,) . fmap fst <$> readTVar (triadC triad)
+    let avail (_,Nothing) = True
+        avail (_,Just x ) = (x == voter)
+        slots = filter avail [a,b,c]
+    forM_ (take 1 slots) $ \(slot,_) -> do
+        prior <- do
+            slotp <- readTVar (triadDecider triad)
+            fmap snd <$> readTVar (triadSlot slotp triad)
+        writeTVar (triadSlot slot triad)
+                  (Just (voter,vote))
+        triadCountVotes prior triad
+
+
+delVote :: (Eq voter, Eq a) => TriadCommittee voter a -> voter -> STM ()
+delVote triad voter = do
+    a <- (SlotA,) . fmap fst <$> readTVar (triadA triad)
+    b <- (SlotB,) . fmap fst <$> readTVar (triadB triad)
+    c <- (SlotC,) . fmap fst <$> readTVar (triadC triad)
+    let match (_,Just x ) = (x == voter)
+        slots = filter match [a,b,c]
+    forM_ (take 1 slots) $ \(slot,_) -> do
+        prior <- do
+            slotp <- readTVar (triadDecider triad)
+            fmap snd <$> readTVar (triadSlot slotp triad)
+        writeTVar (triadSlot slot triad) Nothing
+        triadCountVotes prior triad
+