1 files changed, 107 insertions, 82 deletions

diff --git a/dht/src/Network/Tox/DHT/Handlers.hs b/dht/src/Network/Tox/DHT/Handlers.hs
index 323d5f5e..5156ec44 100644
--- a/dht/src/Network/Tox/DHT/Handlers.hs
+++ b/dht/src/Network/Tox/DHT/Handlers.hs
@@ -5,22 +5,24 @@
 {-# LANGUAGE TupleSections              #-}
 module Network.Tox.DHT.Handlers where
 
-import Debug.Trace
-import Network.Tox.DHT.Transport as DHTTransport
-import Network.Tox.TCP.NodeId as TCP (fromUDPNode, udpNodeInfo)
-import Network.QueryResponse as QR hiding (Client)
-import qualified Network.QueryResponse as QR (Client)
+import Control.TriadCommittee
 import Crypto.Tox
-import Network.Kademlia.Search
-import qualified Data.Wrapper.PSQInt as Int
+import qualified Data.Tox.DHT.Multi       as Multi
+import qualified Data.Wrapper.PSQInt      as Int
+import Debug.Trace
+import DebugTag
+import DPut
+import Network.Address                    (WantIP (..), fromSockAddr, ipFamily,
+                                           sockAddrPort)
 import Network.Kademlia
 import Network.Kademlia.Bootstrap
-import Network.Address               (WantIP (..), ipFamily, fromSockAddr, sockAddrPort)
 import qualified Network.Kademlia.Routing as R
-import Control.TriadCommittee
+import Network.Kademlia.Search
+import qualified Network.QueryResponse    as QR (Client)
+         ;import Network.QueryResponse    as QR hiding (Client)
+import Network.Tox.DHT.Transport          as DHTTransport
+import Network.Tox.TCP.NodeId             as TCP (fromUDPNode, udpNodeInfo)
 import System.Global6
-import DPut
-import DebugTag
 
 import qualified Data.ByteArray as BA
 import qualified Data.ByteString.Char8 as C8
@@ -29,6 +31,7 @@ import Control.Arrow
 import Control.Monad
 import Control.Concurrent.Lifted.Instrument
 import Control.Concurrent.STM
+import Data.Dependent.Sum ((==>))
 import Data.Hashable
 import Data.Ord
 import Data.Time.Clock.POSIX  (POSIXTime, getPOSIXTime)
@@ -80,21 +83,21 @@ pattern SendNodesType = PacketKind 4 -- 0x04     Nodes Response
 
 
 instance Show PacketKind where
-    showsPrec d PingType = mappend "PingType"
-    showsPrec d PongType = mappend "PongType"
-    showsPrec d GetNodesType = mappend "GetNodesType"
-    showsPrec d SendNodesType = mappend "SendNodesType"
-    showsPrec d DHTRequestType = mappend "DHTRequestType"
-    showsPrec d OnionRequest0Type = mappend "OnionRequest0Type"
-    showsPrec d OnionResponse1Type = mappend "OnionResponse1Type"
-    showsPrec d OnionResponse3Type = mappend "OnionResponse3Type"
-    showsPrec d AnnounceType = mappend "AnnounceType"
+    showsPrec d PingType             = mappend "PingType"
+    showsPrec d PongType             = mappend "PongType"
+    showsPrec d GetNodesType         = mappend "GetNodesType"
+    showsPrec d SendNodesType        = mappend "SendNodesType"
+    showsPrec d DHTRequestType       = mappend "DHTRequestType"
+    showsPrec d OnionRequest0Type    = mappend "OnionRequest0Type"
+    showsPrec d OnionResponse1Type   = mappend "OnionResponse1Type"
+    showsPrec d OnionResponse3Type   = mappend "OnionResponse3Type"
+    showsPrec d AnnounceType         = mappend "AnnounceType"
     showsPrec d AnnounceResponseType = mappend "AnnounceResponseType"
-    showsPrec d DataRequestType = mappend "DataRequestType"
-    showsPrec d DataResponseType = mappend "DataResponseType"
-    showsPrec d CookieRequestType = mappend "CookieRequestType"
-    showsPrec d CookieResponseType = mappend "CookieResponseType"
-    showsPrec d (PacketKind x) = mappend "PacketKind " . showsPrec (d+1) x
+    showsPrec d DataRequestType      = mappend "DataRequestType"
+    showsPrec d DataResponseType     = mappend "DataResponseType"
+    showsPrec d CookieRequestType    = mappend "CookieRequestType"
+    showsPrec d CookieResponseType   = mappend "CookieResponseType"
+    showsPrec d (PacketKind x)       = mappend "PacketKind " . showsPrec (d+1) x
 
 msgType :: ( Serialize (f DHTRequest)
            , Serialize (f (Cookie Encrypted)), Serialize (f CookieRequest)
@@ -103,7 +106,7 @@ msgType :: ( Serialize (f DHTRequest)
            ) => DHTMessage f -> PacketKind
 msgType msg = PacketKind $ fst $ dhtMessageType msg
 
-classify :: Client -> Message -> MessageClass String PacketKind TransactionId NodeInfo Message
+classify :: Client -> Message -> MessageClass String PacketKind TransactionId Multi.NodeInfo Message
 classify client (DHTLanDiscovery {}) = IsUnsolicited (lanDiscoveryH client)
 classify client msg = fromMaybe (IsUnknown "unknown")
                       $ mapMessage (\nonce24 (nonce8,_) -> go msg (TransactionId nonce8 nonce24)) msg
@@ -121,7 +124,7 @@ data NodeInfoCallback = NodeInfoCallback
     , listenerId        :: Int
     , observedAddress   :: POSIXTime -> NodeInfo -- Address and port for interestingNodeId
                                      -> STM ()
-    , rumoredAddress    :: POSIXTime -> SockAddr -- source of information
+    , rumoredAddress    :: POSIXTime -> Multi.NodeInfo -- source of information
                                      -> NodeInfo -- Address and port for interestingNodeId
                                      -> STM ()
     }
@@ -208,7 +211,7 @@ newRouting addr crypto update4 update6 = do
         cbvar <- newTVar HashMap.empty
         return $ \client ->
             -- Now we have a client, so tell the BucketRefresher how to search and ping.
-            let updIO r = updateRefresherIO (nodeSearch client cbvar) (ping client) r
+            let updIO r = updateRefresherIO (nodeSearch client cbvar) (pingUDP client) r
             in Routing { tentativeId     = tentative_info
                        , committee4      = committee4
                        , committee6      = committee6
@@ -226,32 +229,28 @@ isLocal (IPv4 ip4) = (ip4 == toEnum 0)
 isGlobal :: IP -> Bool
 isGlobal = not . isLocal
 
-prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP
-prefer4or6 addr iptyp = fromMaybe (ipFamily $ nodeIP addr) iptyp
-
-toxSpace :: R.KademliaSpace NodeId NodeInfo
-toxSpace = R.KademliaSpace
-    { R.kademliaLocation = nodeId
-    , R.kademliaTestBit  = testNodeIdBit
-    , R.kademliaXor      = xorNodeId
-    , R.kademliaSample   = sampleNodeId
-    }
+prefer4or6 :: Multi.NodeInfo -> Maybe WantIP -> WantIP
+prefer4or6 addr iptyp = fromMaybe fallback iptyp
+ where
+    fallback = case Multi.udpNode addr of
+        Just ni -> ipFamily $ nodeIP ni
+        Nothing -> Want_Both
 
 
-pingH :: NodeInfo -> Ping -> IO Pong
+pingH :: ni -> Ping -> IO Pong
 pingH _ Ping = return Pong
 
-getNodesH :: Routing -> NodeInfo -> GetNodes -> IO SendNodes
+getNodesH :: Routing -> Multi.NodeInfo -> GetNodes -> IO SendNodes
 getNodesH routing addr (GetNodes nid) = do
     let preferred = prefer4or6 addr Nothing
 
     (append4,append6) <- atomically $ do
         ni4 <- R.thisNode <$> readTVar (routing4 routing)
         ni6 <- R.thisNode <$> readTVar (routing6 routing)
-        return $ case ipFamily (nodeIP addr) of
-            Want_IP4 | isGlobal (nodeIP ni6) -> (id, (++ [ni6]))
-            Want_IP6 | isGlobal (nodeIP ni4) -> ((++ [ni4]), id)
-            _                                -> (id, id)
+        return $ case ipFamily . nodeIP <$> Multi.udpNode addr of
+            Just Want_IP4 | isGlobal (nodeIP ni6) -> (id, (++ [ni6]))
+            Just Want_IP6 | isGlobal (nodeIP ni4) -> ((++ [ni4]), id)
+            _                                     -> (id, id)
     ks  <- go append4 $ routing4 routing
     ks6 <- go append6 $ routing6 routing
     let (ns1,ns2) = case preferred of Want_IP6 -> (ks6,ks)
@@ -266,7 +265,7 @@ getNodesH routing addr (GetNodes nid) = do
 
     k = 4
 
-createCookie :: TransportCrypto -> NodeInfo -> PublicKey -> IO (Cookie Encrypted)
+createCookie :: TransportCrypto -> Multi.NodeInfo -> PublicKey -> IO (Cookie Encrypted)
 createCookie crypto ni remoteUserKey = do
     (n24,sym) <- atomically $ do
         n24 <- transportNewNonce crypto
@@ -276,12 +275,12 @@ createCookie crypto ni remoteUserKey = do
     let dta = encodePlain $ CookieData
             { cookieTime  = timestamp
             , longTermKey = remoteUserKey
-            , dhtKey      = id2key $ nodeId ni -- transportPublic crypto
+            , dhtKey      = id2key $ Multi.nodeId ni -- transportPublic crypto
             }
         edta = encryptSymmetric sym n24 dta
     return $ Cookie n24 edta
 
-createCookieSTM :: POSIXTime -> TransportCrypto -> NodeInfo -> PublicKey -> STM (Cookie Encrypted)
+createCookieSTM :: POSIXTime -> TransportCrypto -> Multi.NodeInfo -> PublicKey -> STM (Cookie Encrypted)
 createCookieSTM now crypto ni remoteUserKey = do
     let dmsg msg = trace msg (return ())
     (n24,sym) <- do
@@ -292,37 +291,38 @@ createCookieSTM now crypto ni remoteUserKey = do
     let dta = encodePlain $ CookieData
             { cookieTime  = timestamp
             , longTermKey = remoteUserKey
-            , dhtKey      = id2key $ nodeId ni -- transportPublic crypto
+            , dhtKey      = id2key $ Multi.nodeId ni -- transportPublic crypto
             }
         edta = encryptSymmetric sym n24 dta
     return $ Cookie n24 edta
 
-cookieRequestH :: TransportCrypto -> NodeInfo -> CookieRequest -> IO (Cookie Encrypted)
+cookieRequestH :: TransportCrypto -> Multi.NodeInfo -> CookieRequest -> IO (Cookie Encrypted)
 cookieRequestH crypto ni (CookieRequest remoteUserKey) = do
     dput XNetCrypto $ unlines
-        [ show (nodeAddr ni) ++ " --> request cookie: remoteUserKey=" ++ show (key2id remoteUserKey)
-        , show (nodeAddr ni) ++ " -->                        sender=" ++ show (nodeId ni) ]
+        [ show ni ++ " --> request cookie: remoteUserKey=" ++ show (key2id remoteUserKey)
+        , show ni ++ " -->                        sender=" ++ show (Multi.nodeId ni) ]
     x <- createCookie crypto ni remoteUserKey
-    dput XNetCrypto $ show (nodeAddr ni) ++ " <-- cookie " ++ show (key2id remoteUserKey)
+    dput XNetCrypto $ show ni ++ " <-- cookie " ++ show (key2id remoteUserKey)
     return x
 
-lanDiscoveryH :: Client -> NodeInfo -> NodeInfo -> IO (Maybe (Message -> Message))
+lanDiscoveryH :: Client -> Multi.NodeInfo -> Multi.NodeInfo -> IO (Maybe (Message -> Message))
 lanDiscoveryH client _ ni = do
-    dput XLan $ show (nodeAddr ni) ++ " --> LanAnnounce " ++ show (nodeId ni)
-    forkIO $ do
-        myThreadId >>= flip labelThread "lan-discover-ping"
-        ping client ni
-        return ()
+    forM_ (Multi.udpNode ni) $ \uni -> do
+        dput XLan $ show (nodeAddr uni) ++ " --> LanAnnounce " ++ show (nodeId uni)
+        forkIO $ do
+            myThreadId >>= flip labelThread "lan-discover-ping"
+            pingUDP client uni
+            return ()
     return Nothing
 
 type Message = DHTMessage ((,) Nonce8)
 
-type Client = QR.Client String PacketKind TransactionId NodeInfo Message
+type Client = QR.Client String PacketKind TransactionId Multi.NodeInfo Message
 
 
-wrapAsymm :: TransactionId -> NodeInfo -> NodeInfo -> (Nonce8 -> dta) -> Asymm dta
+wrapAsymm :: TransactionId -> Multi.NodeInfo -> Multi.NodeInfo -> (Nonce8 -> dta) -> Asymm dta
 wrapAsymm (TransactionId n8 n24) src dst dta = Asymm
-    { senderKey = id2key $ nodeId src
+    { senderKey = id2key $ Multi.nodeId src
     , asymmNonce = n24
     , asymmData = dta n8
     }
@@ -330,7 +330,7 @@ wrapAsymm (TransactionId n8 n24) src dst dta = Asymm
 serializer :: PacketKind
                 -> (Asymm (Nonce8,ping) -> Message)
                 -> (Message -> Maybe (Asymm (Nonce8,pong)))
-                -> MethodSerializer TransactionId NodeInfo Message PacketKind ping (Maybe pong)
+                -> MethodSerializer TransactionId Multi.NodeInfo Message PacketKind ping (Maybe pong)
 serializer pktkind mkping mkpong = MethodSerializer
         { methodTimeout  = \addr -> return (addr, 5000000)
         , method         = pktkind
@@ -345,7 +345,10 @@ unpong :: Message -> Maybe (Asymm (Nonce8,Pong))
 unpong (DHTPong asymm) = Just asymm
 unpong _               = Nothing
 
-ping :: Client -> NodeInfo -> IO Bool
+pingUDP :: Client -> NodeInfo -> IO Bool
+pingUDP client ni = ping client (Multi.UDP ==> ni)
+
+ping :: Client -> Multi.NodeInfo -> IO Bool
 ping client addr = do
     dput XPing $ show addr ++ " <-- ping"
     reply <- QR.sendQuery client (serializer PingType DHTPing unpong) Ping addr
@@ -372,10 +375,14 @@ loseCookieKey var saddr pk = do
         _                                     -> return () -- unreachable?
 
 
-cookieRequest :: TransportCrypto -> Client -> PublicKey -> NodeInfo -> IO (Maybe (Cookie Encrypted))
+cookieRequest :: TransportCrypto -> Client -> PublicKey -> Multi.NodeInfo -> IO (Maybe (Cookie Encrypted))
 cookieRequest crypto client localUserKey addr = do
-    let sockAddr = nodeAddr addr
-        nid = id2key $ nodeId addr
+    let (runfirst,runlast) = case Multi.udpNode addr of
+            Just ni -> let sockAddr = nodeAddr ni
+                           nid = id2key $ nodeId ni
+                        in ( atomically $ saveCookieKey (pendingCookies crypto) sockAddr nid
+                           , atomically $ loseCookieKey (pendingCookies crypto) sockAddr nid )
+            Nothing -> (return (), return ())
         cookieSerializer
             = MethodSerializer
                    { methodTimeout  = \addr -> return (addr, 5000000)
@@ -384,10 +391,10 @@ cookieRequest crypto client localUserKey addr = do
                    , unwrapResponse = fmap snd . unCookie
                    }
         cookieRequest = CookieRequest localUserKey
-    atomically $ saveCookieKey (pendingCookies crypto) sockAddr nid
+    runfirst
     dput XNetCrypto $ show addr ++ " <-- cookieRequest"
     reply <- QR.sendQuery client cookieSerializer cookieRequest addr
-    atomically $ loseCookieKey (pendingCookies crypto) sockAddr nid
+    runlast
     dput XNetCrypto $ show addr ++ " -cookieResponse-> " ++ show reply
     return $ join reply
 
@@ -403,39 +410,42 @@ unsendNodes _                    = Nothing
 unwrapNodes :: SendNodes -> ( [NodeInfo], [NodeInfo], Maybe () )
 unwrapNodes (SendNodes ns) = (map udpNodeInfo ns,map udpNodeInfo ns,Just ())
 
-getNodes :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ()))
+getNodes :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> Multi.NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ()))
 getNodes client cbvar nid addr = do
     -- dput XMisc $ show addr ++ " <-- getnodes " ++ show nid
     reply <- QR.sendQuery client (serializer GetNodesType DHTGetNodes unsendNodes) (GetNodes nid) addr
     -- dput XMisc $ show addr ++ " -sendnodes-> " ++ show reply
-    forM_ (join reply) $ \(SendNodes ns) -> 
+    forM_ (join reply) $ \(SendNodes ns) ->
         forM_ ns $ \n -> do
             now <- getPOSIXTime
             atomically $ do
                 mcbs <- HashMap.lookup (nodeId . udpNodeInfo $ n) <$> readTVar cbvar
                 forM_ mcbs $ \cbs -> do
                     forM_ cbs $ \cb -> do
-                        rumoredAddress cb now (nodeAddr addr) (udpNodeInfo n)
+                        rumoredAddress cb now addr (udpNodeInfo n)
     return $ fmap unwrapNodes $ join reply
 
+getNodesUDP :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ()))
+getNodesUDP client cbvar nid addr = getNodes client cbvar nid (Multi.UDP ==> addr)
+
 updateRouting :: Client -> Routing
                         -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ())
-                        -> NodeInfo
+                        -> Multi.NodeInfo
                         -> Message
                         -> IO ()
-updateRouting client routing orouter naddr msg
+updateRouting client routing orouter naddr0 msg
     | PacketKind 0x21 <- msgType msg = -- dput XLan "(tox)updateRouting: ignoring lan discovery" -- ignore lan discovery
                                        -- Ignore lan announcements until they reply to our ping.
                                        -- We do this because the lan announce is not authenticated.
                                        return ()
-    | otherwise                      = do
+    | otherwise                      = forM_ (Multi.udpNode naddr0) $ \naddr -> do
     now <- getPOSIXTime
     atomically $ do
         m <- HashMap.lookup (nodeId naddr) <$> readTVar (nodesOfInterest routing)
         forM_ m $ mapM_ $ \NodeInfoCallback{interestingNodeId,observedAddress} -> do
             when (interestingNodeId == nodeId naddr)
                 $ observedAddress now naddr
-    case prefer4or6 naddr Nothing of
+    case prefer4or6 (Multi.UDP ==> naddr) Nothing of
         Want_IP4 -> updateTable client naddr orouter (committee4 routing) (refresher4 routing)
         Want_IP6 -> updateTable client naddr orouter (committee6 routing) (refresher6 routing)
         Want_Both -> do dput XMisc "BUG:unreachable"
@@ -461,7 +471,7 @@ toxKademlia :: Client
 toxKademlia client committee orouter refresher
     = Kademlia quietInsertions
                toxSpace
-               (vanillaIO (refreshBuckets refresher) $ ping client)
+               (vanillaIO (refreshBuckets refresher) $ pingUDP client)
                    { tblTransition = \tr -> do
                         io1 <- transitionCommittee committee tr
                         io2 <- touchBucket refresher tr -- toxSpace (15*60) var sched tr
@@ -486,34 +496,34 @@ transitionCommittee committee (RoutingTransition ni Stranger) = do
         return ()
 transitionCommittee committee _ = return $ return ()
 
-type Handler = MethodHandler String TransactionId NodeInfo Message
+type Handler = MethodHandler String TransactionId Multi.NodeInfo Message
 
 isPing :: (f Ping -> Ping) ->  DHTMessage f -> Either String Ping
 isPing unpack (DHTPing a) = Right $ unpack $ asymmData a
 isPing _      _           = Left "Bad ping"
 
-mkPong :: TransactionId -> NodeInfo -> NodeInfo -> Pong -> DHTMessage ((,) Nonce8)
+mkPong :: TransactionId -> Multi.NodeInfo -> Multi.NodeInfo -> Pong -> DHTMessage ((,) Nonce8)
 mkPong tid src dst pong = DHTPong $ wrapAsymm tid src dst (, pong)
 
 isGetNodes :: (f GetNodes -> GetNodes) ->  DHTMessage f -> Either String GetNodes
 isGetNodes unpack (DHTGetNodes a) = Right $ unpack $ asymmData a
 isGetNodes _      _               = Left "Bad GetNodes"
 
-mkSendNodes :: TransactionId -> NodeInfo -> NodeInfo -> SendNodes -> DHTMessage ((,) Nonce8)
+mkSendNodes :: TransactionId -> Multi.NodeInfo -> Multi.NodeInfo -> SendNodes -> DHTMessage ((,) Nonce8)
 mkSendNodes tid src dst sendnodes = DHTSendNodes $ wrapAsymm tid src dst (, sendnodes)
 
 isCookieRequest :: (f CookieRequest -> CookieRequest) -> DHTMessage f -> Either String CookieRequest
 isCookieRequest unpack (DHTCookieRequest a) = Right $ unpack $ asymmData a
 isCookieRequest _      _                    = Left "Bad cookie request"
 
-mkCookie :: TransactionId -> NodeInfo -> NodeInfo -> Cookie Encrypted -> DHTMessage ((,) Nonce8)
+mkCookie :: TransactionId -> ni -> ni -> Cookie Encrypted -> DHTMessage ((,) Nonce8)
 mkCookie (TransactionId n8 n24) src dst cookie = DHTCookie n24 (n8,cookie)
 
 isDHTRequest :: (f DHTRequest -> DHTRequest) -> DHTMessage f -> Either String DHTRequest
 isDHTRequest unpack (DHTDHTRequest pubkey a) = Right $ unpack $ asymmData a
 isDHTRequest _      _                        = Left "Bad dht relay request"
 
-dhtRequestH :: NodeInfo -> DHTRequest -> IO ()
+dhtRequestH :: Multi.NodeInfo -> DHTRequest -> IO ()
 dhtRequestH ni req = do
     dput XMisc $ "Unhandled DHT Request: " ++ show req
 
@@ -528,8 +538,23 @@ nodeSearch :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> Search NodeI
 nodeSearch client cbvar = Search
     { searchSpace       = toxSpace
     , searchNodeAddress = nodeIP &&& nodePort
-    , searchQuery       = Left $ getNodes client cbvar
+    -- searchQuery :: Either (nid -> ni -> IO (Maybe ([ni], [r], Maybe tok)))
+    --                       (nid -> ni -> (Maybe ([ni],[r],Maybe tok) -> IO ()) -> IO ())
+    , searchQuery       = Left $ getNodesUDP client cbvar
     , searchAlpha       = 8
     , searchK           = 16
+    }
 
+{-
+nodeSearchMulti :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> Search NodeId (IP,PortNumber) () Multi.NodeInfo Multi.NodeInfo
+nodeSearchMulti client cbvar = Search
+    { searchSpace       = toxSpace
+    , searchNodeAddress = nodeIP &&& nodePort
+    -- searchQuery :: Either (nid -> ni -> IO (Maybe ([ni], [r], Maybe tok)))
+    --                       (nid -> ni -> (Maybe ([ni],[r],Maybe tok) -> IO ()) -> IO ())
+    , searchQuery       = Left $ \nid ni -> fmap fixupUDP <$> getNodes client cbvar nid ni
+    , searchAlpha       = 8
+    , searchK           = 16
     }
+    where fixupUDP (xs,ys,m) = (map (Multi.UDP ==>) xs, map (Multi.UDP ==>) ys, m)
+-}