1 files changed, 95 insertions, 23 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index bd9b9e09..f9dce3bc 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -112,10 +112,11 @@ data DHTQuery nid ni = forall addr r tok.
                         , Typeable tok
                         , Typeable ni
                         ) => DHTQuery
-    { qsearch  :: Search nid addr tok ni r
-    , qhandler :: ni -> nid -> IO ([ni], [r], tok) -- ^ Invoked on local node, when there is no query destination.
-    , qshowR   :: r -> String
-    , qshowTok :: tok -> Maybe String
+    { qsearch     :: Search nid addr tok ni r
+    , qhandler    :: ni -> nid -> IO ([ni], [r], tok) -- ^ Invoked on local node, when there is no query destination.
+    , qshowR      :: r -> String
+    , qshowTok    :: tok -> Maybe String
+    , qresultAddr :: r -> nid
     }
 
 data DHTAnnouncable = forall dta tok ni r.
@@ -129,6 +130,7 @@ data DHTAnnouncable = forall dta tok ni r.
     , announceParseToken :: dta -> String -> Either String tok
     , announceParseAddress :: String -> Either String ni
     , announceSendData :: dta -> tok -> Maybe ni -> IO (Maybe r)
+    , announceInterval :: POSIXTime
     }
 
 data DHTLink = forall status linkid params.
@@ -616,15 +618,19 @@ clientSession s@Session{..} sock cnum h = do
                             matchingResult _ _ = liftA3 (\a b c -> (a,b,c)) eqT eqT eqT
                             mameth = do
                                 DHTAnnouncable { announceSendData
-                                               , announceParseData } <- a
-                                DHTQuery       { qsearch }           <- q
+                                               , announceParseData
+                                               , announceInterval } <- a
+                                DHTQuery { qsearch
+                                         , qresultAddr } <- q
                                 (Refl,Refl,nr@Refl) <- matchingResult qsearch announceSendData
                                 dta <- either (const Nothing) Just $ announceParseData dtastr
                                 return $ do
                                     akey <- atomically $ packAnnounceKey announcer (method ++ ":" ++ dtastr)
                                     doit op nr announcer
                                                akey
-                                               (AnnounceMethod qsearch announceSendData)
+                                               (AnnounceMethod qsearch announceSendData dhtBuckets
+                                                               (qresultAddr dta)
+                                                               announceInterval)
                                                dta
                         fromMaybe (hPutClient h "error.") mameth
 
@@ -824,19 +830,25 @@ main = do
                                         , pingShowResult = show
                                         }
                     , dhtQuery   = Map.fromList
-                                    [ ("node", DHTQuery (Mainline.nodeSearch bt)
-                                                        (\ni -> fmap Mainline.unwrapNodes
+                                    [ ("node", DHTQuery
+                                        { qsearch = (Mainline.nodeSearch bt)
+                                        , qhandler = (\ni -> fmap Mainline.unwrapNodes
                                                                 . Mainline.findNodeH btR ni
                                                                 . flip Mainline.FindNode (Just Want_Both))
-                                                        show
-                                                        (const Nothing))
-                                    , ("peer", DHTQuery (Mainline.peerSearch bt)
-                                                        (\ni -> fmap Mainline.unwrapPeers
+                                        , qshowR = show
+                                        , qshowTok = (const Nothing)
+                                        , qresultAddr = Mainline.nodeId
+                                        })
+                                    , ("peer", DHTQuery
+                                        { qsearch = (Mainline.peerSearch bt)
+                                        , qhandler = (\ni -> fmap Mainline.unwrapPeers
                                                                 . Mainline.getPeersH btR swarms ni
                                                                 . flip Mainline.GetPeers (Just Want_Both)
                                                                 . (read . show)) -- TODO: InfoHash -> NodeId
-                                                        (show . pPrint)
-                                                        (Just . show))
+                                        , qshowR = (show . pPrint)
+                                        , qshowTok = (Just . show)
+                                        , qresultAddr = (read . show) -- TODO: InfoHash -> NodeId
+                                        })
                                     ]
                     , dhtParseId  = readEither :: String -> Either String Mainline.NodeId
                     , dhtSearches = mainlineSearches
@@ -851,6 +863,7 @@ main = do
                                                               , announceParseAddress = readEither
                                                               , announceParseData = readEither
                                                               , announceParseToken = const $ readEither
+                                                              , announceInterval = 60 -- TODO: Is one minute good?
                                                               })
                                     , ("port", DHTAnnouncable { announceParseData = readEither
                                                               , announceParseToken = \_ _ -> return ()
@@ -859,6 +872,8 @@ main = do
                                                                     Nothing -> do atomically $ writeTVar peerPort (dta :: PortNumber)
                                                                                   return $ Just dta
                                                                     Just _ -> return Nothing
+                                                              , announceInterval = 0 -- TODO: The "port" setting should probably
+                                                                                     -- be a command rather than an announcement.
                                                               })]
 
                     , dhtLinks = Map.fromList
@@ -908,16 +923,20 @@ main = do
                                             , pingShowResult = show
                                             })]
                     , dhtQuery   = Map.fromList
-                                    [ ("node", DHTQuery (Tox.nodeSearch $ Tox.toxDHT tox)
-                                                        (\ni -> fmap Tox.unwrapNodes
+                                    [ ("node", DHTQuery
+                                        { qsearch = (Tox.nodeSearch $ Tox.toxDHT tox)
+                                        , qhandler = (\ni -> fmap Tox.unwrapNodes
                                                                 . Tox.getNodesH (Tox.toxRouting tox) ni
                                                                 . Tox.GetNodes)
-                                                        show -- NodeInfo
-                                                        (const Nothing))
-                                    , ("toxid", DHTQuery (Tox.toxidSearch (Tox.onionTimeout tox)
+                                        , qshowR = show -- NodeInfo
+                                        , qshowTok = (const Nothing)
+                                        , qresultAddr = Tox.nodeId
+                                        })
+                                    , ("toxid", DHTQuery
+                                        { qsearch = (Tox.toxidSearch (Tox.onionTimeout tox)
                                                                           (Tox.toxCryptoKeys tox)
                                                                           (Tox.toxOnion tox))
-                                                         -- qhandler :: ni -> nid -> IO ([ni], [r], tok)
+                                        , qhandler = -- qhandler :: ni -> nid -> IO ([ni], [r], tok)
                                                          (\ni nid ->
                                                             Tox.unwrapAnnounceResponse Nothing
                                                                 <$> clientAddress (Tox.toxDHT tox) Nothing
@@ -926,8 +945,10 @@ main = do
                                                                                   (Tox.toxAnnouncedKeys tox)
                                                                                   (Tox.OnionDestination Tox.SearchingAlias ni Nothing)
                                                                                   (Tox.AnnounceRequest zeros32 nid Tox.zeroID))
-                                                         show -- PublicKey
-                                                         (fmap show))
+                                        , qshowR  = show -- Rendezvous
+                                        , qshowTok = (fmap show) -- Nonce32
+                                        , qresultAddr = Tox.key2id . Tox.rendezvousKey
+                                        })
                                     ]
                     , dhtParseId  = readEither :: String -> Either String Tox.NodeId
                     , dhtSearches = toxSearches
@@ -946,6 +967,21 @@ main = do
                                                                , announceParseAddress = readEither
                                                                , announceParseToken = const $ readEither
                                                                , announceParseData = fmap Tox.id2key . readEither
+
+                    -- For peers we are announcing ourselves to, if we are not
+                    -- announced to them toxcore tries every 3 seconds to
+                    -- announce ourselves to them until they return that we
+                    -- have announced ourselves to, then toxcore sends an
+                    -- announce request packet every 15 seconds to see if we
+                    -- are still announced and re announce ourselves at the
+                    -- same time. The timeout of 15 seconds means a `ping_id`
+                    -- received in the last packet will not have had time to
+                    -- expire (20 second minimum timeout) before it is resent
+                    -- 15 seconds later. Toxcore sends every announce packet
+                    -- with the `ping_id` previously received from that peer
+                    -- with the same path (if possible).
+                                                               , announceInterval = 15
+
                                                                })
                                     , ("dhtkey", DHTAnnouncable { announceSendData = \pubkey () -> \case
                                                                     Just addr -> do
@@ -959,6 +995,23 @@ main = do
                                                                , announceParseAddress = readEither
                                                                , announceParseToken = \_ _ -> return ()
                                                                , announceParseData = fmap Tox.id2key . readEither
+
+                    -- We send this packet every 30 seconds if there is more
+                    -- than one peer (in the 8) that says they our friend is
+                    -- announced on them. This packet can also be sent through
+                    -- the DHT module as a DHT request packet (see DHT) if we
+                    -- know the DHT public key of the friend and are looking
+                    -- for them in the DHT but have not connected to them yet.
+                    -- 30 second is a reasonable timeout to not flood the
+                    -- network with too many packets while making sure the
+                    -- other will eventually receive the packet. Since packets
+                    -- are sent through every peer that knows the friend,
+                    -- resending it right away without waiting has a high
+                    -- likelihood of failure as the chances of packet loss
+                    -- happening to all (up to to 8) packets sent is low.
+                    --
+                                                               , announceInterval = 30
+
                                                                })
                                     , ("friend", DHTAnnouncable { announceSendData = \pubkey nospam -> \case
                                                                     Just addr -> do
@@ -979,6 +1032,25 @@ main = do
                                                                               (Tox.verifyChecksum pubkey)
                                                                               chksum
                                                                         return nospam
+
+                    -- Friend requests are sent with exponentially increasing
+                    -- interval of 2 seconds, 4 seconds, 8 seconds, etc... in
+                    -- toxcore. This is so friend requests get resent but
+                    -- eventually get resent in intervals that are so big that
+                    -- they essentially expire. The sender has no way of
+                    -- knowing if a peer refuses a friend requests which is why
+                    -- friend requests need to expire in some way.  Note that
+                    -- the interval is the minimum timeout, if toxcore cannot
+                    -- send that friend request it will try again until it
+                    -- manages to send it. One reason for not being able to
+                    -- send the friend request would be that the onion has not
+                    -- found the friend in the onion and so cannot send an
+                    -- onion data packet to them.
+                    --
+                    -- TODO: Support exponential backoff behavior.  For now, setting
+                    -- interval to 8 seconds.
+
+                                                               , announceInterval = 8
                                                                })]
                     , dhtLinks = Map.fromList
                                     [ {- TODO -}