Share toxid over avahi

This isn't really completely correct; there should be some possibility for
denial of service. The call to setContactAddr is destructive of whatever
information was there previously, but we haven't verified that we're talking to
the real contact at the time it is called.

This problem exists even in the ordinary path where the nodeinfocallback isn't
really requiring proof of anything before throwing out data.

2 files changed, 36 insertions, 23 deletions

diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index 93d42eca..00dfcf9f 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -486,12 +486,20 @@ routing4nodeInfo :: DHT.Routing -> IO NodeInfo
 routing4nodeInfo (DHT.routing4 -> tv) = R.thisNode <$> readTVarIO tv
 
 dnssdAnnounce :: Tox extra -> IO ()
-dnssdAnnounce (toxRouting -> r) = do
-    ni <- routing4nodeInfo r
-    announceToxService (nodePort ni) (nodeId ni)
-
-dnssdDiscover :: Tox extra -> NodeInfo -> IO ()
-dnssdDiscover (toxDHT -> client) ni = void $ DHT.ping client ni
+dnssdAnnounce tox = do
+  ni   <- routing4nodeInfo (toxRouting tox)
+  keys <- fmap (key2id . snd) <$> atomically (userKeys $ toxCryptoKeys tox)
+  announceToxService (nodePort ni) (nodeId ni) (listToMaybe keys)
+
+dnssdDiscover :: Tox extra -> NodeInfo -> (Maybe NodeId) -> IO ()
+dnssdDiscover tox ni toxid = do
+  acts <- atomically $ readTVar $ accounts $ toxContactInfo tox
+  now  <- getPOSIXTime
+  forM toxid $ \tid ->
+    forM acts $ \act ->
+      atomically $ setContactAddr now (id2key tid) ni act
+
+  void $ DHT.ping (toxDHT tox) ni
 
 forkTox :: Tox extra -> IO (IO (), [NodeInfo] -> [NodeInfo] -> IO (), [NodeInfo] -> [NodeInfo] -> IO ())
 forkTox tox = do
diff --git a/src/Network/Tox/Avahi.hs b/src/Network/Tox/Avahi.hs
index 7fe87db2..559e5fd7 100644
--- a/src/Network/Tox/Avahi.hs
+++ b/src/Network/Tox/Avahi.hs
@@ -1,16 +1,18 @@
+{-# OPTIONS_GHC -Wall #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ViewPatterns    #-}
 module Network.Tox.Avahi
   ( module Network.Tox.Avahi
   , NodeInfo(..)
-  , NodeId(..)
+  , NodeId
   ) where
 
-import           Data.Foldable
-import           Network.Address
-import           Network.Avahi
-import           Network.Tox.NodeId
-import           Text.Read
+import Control.Applicative
+import Data.Foldable
+import Network.Address
+import Network.Avahi
+import Network.Tox.NodeId
+import Text.Read
 
 toxServiceName :: String
 toxServiceName = "_tox_dht._udp"
@@ -21,8 +23,8 @@ toxServiceDomain = "local"
 (<.>) :: String -> String -> String
 a <.> b = a ++ "." ++ b
 
-toxService :: String -> PortNumber -> NodeId -> Service
-toxService hostname (fromIntegral -> port) (show -> extra) =
+toxService :: String -> PortNumber -> NodeId -> (Maybe NodeId) -> Service
+toxService hostname (fromIntegral -> port) dhtkey toxid =
   Service {
     serviceProtocol = PROTO_UNSPEC,
     serviceName     = "Tox DHT @ " ++ hostname,
@@ -31,16 +33,17 @@ toxService hostname (fromIntegral -> port) (show -> extra) =
     serviceHost     = if null hostname then "" else hostname <.> toxServiceDomain,
     serviceAddress  = Nothing,
     servicePort     = port,
-    serviceText     = extra
+    serviceText     = maybe (show dhtkey) (show . ((,) dhtkey)) toxid
   }
 
-announceToxServiceWithHostname :: String -> PortNumber -> NodeId -> IO ()
-announceToxServiceWithHostname  = ((.).(.).(.)) announce toxService
+announceToxServiceWithHostname :: String -> PortNumber -> NodeId -> (Maybe NodeId) -> IO ()
+announceToxServiceWithHostname  = (boobs.boobs) announce toxService
+  where boobs = ((.).(.))
 
-announceToxService :: PortNumber -> NodeId -> IO ()
+announceToxService :: PortNumber -> NodeId -> (Maybe NodeId) -> IO ()
 announceToxService = announceToxServiceWithHostname ""
 
-queryToxService :: (NodeInfo -> IO ()) -> IO ()
+queryToxService :: (NodeInfo -> Maybe NodeId -> IO ()) -> IO ()
 queryToxService cb =
   browse $
   BrowseQuery
@@ -50,8 +53,10 @@ queryToxService cb =
   , lookupCallback    = runCallback
   }
   where
-    runCallback x@Service {..} = do
-      let nid = readMaybe serviceText
+    runCallback Service {..} = do
+      let both :: Maybe (NodeId, NodeId)
+          both = readMaybe serviceText
+          nid  = (fst <$> both) <|> readMaybe serviceText
           addr = readMaybe =<< serviceAddress
-          p = fromIntegral servicePort
-      forM_ nid $ \n -> forM_ addr $ \a -> cb (NodeInfo n a p)
+          p    = fromIntegral servicePort
+      forM_ nid $ \n -> forM_ addr $ \a -> cb (NodeInfo n a p) (snd <$> both)