3 files changed, 131 insertions, 40 deletions

diff --git a/Announcer.hs b/Announcer.hs
index 1f539d5d..f19f8d46 100644
--- a/Announcer.hs
+++ b/Announcer.hs
@@ -15,9 +15,11 @@ module Announcer
     , cancel
     ) where
 
-import Data.Wrapper.PSQ as PSQ
-import Network.Kademlia.Search
+import qualified Data.MinMaxPSQ as MM
+import Data.Wrapper.PSQ         as PSQ
 import InterruptibleDelay
+import Network.Kademlia.Routing as R
+import Network.Kademlia.Search
 
 import Control.Concurrent.Lifted.Instrument
 import Control.Concurrent.STM
@@ -42,9 +44,9 @@ data ScheduledItem
     = forall r. ScheduledItem (AnnounceMethod r)
     | StopAnnouncer
     | NewAnnouncement (IO ()) (IO ()) POSIXTime
+    | SearchFinished (IO ()) (IO ()) POSIXTime
     | Announce (IO ()) POSIXTime
     | DeleteAnnouncement
-    | SearchFinished
 
 data Announcer = Announcer
     { scheduled       :: TVar (PSQ' AnnounceKey POSIXTime ScheduledItem)
@@ -62,22 +64,39 @@ stopAnnouncer announcer = do
     interruptDelay (interrutible announcer)
     atomically $ readTVar (announcerActive announcer) >>= check . not
 
-data AnnounceMethod r = forall nid ni addr r tok a. AnnounceMethod
+data AnnounceMethod r = forall nid ni addr tok a.
+                        ( Show nid
+                        , Hashable nid
+                        , Hashable ni
+                        , Ord addr
+                        , Ord nid
+                        , Ord ni
+                        ) => AnnounceMethod
     { aSearch  :: Search nid addr tok ni r
     , aPublish :: r -> tok -> Maybe ni -> IO (Maybe a)
+    , aBuckets :: TVar (R.BucketList ni)
+    , aTarget  :: nid
+    , aInterval :: POSIXTime
     }
 
 schedule :: Announcer -> AnnounceKey -> AnnounceMethod r -> r -> IO ()
-schedule announcer k AnnounceMethod{aSearch,aPublish} r = do
-    let announce = _todo :: IO ()     -- publish to current search results
-        onResult _ = return True
-        search   = _todo :: IO ()     -- thread to fork
-            -- ns <- R.kclosest (searchSpace qsearch) searchK nid <$> readTVar dhtBuckets
-            -- st <- newSearch qsearch nid ns
-            -- searchLoop :: Search nid addr tok ni r -> nid -> (r -> STM Bool) -> SearchState nid addr tok ni r -> IO ()
-            -- searchLoop aSearch nid onResult st
-        interval = _todo :: POSIXTime -- publish interval
-    atomically $ scheduleImmediately announcer k $ NewAnnouncement search announce interval
+schedule announcer k AnnounceMethod{aSearch,aPublish,aBuckets,aTarget,aInterval} r = do
+    st <- atomically $ newSearch aSearch aTarget []
+    let announce = do -- publish to current search results
+            is <- atomically $ do
+                bs <- readTVar (searchInformant st {- :: TVar (MinMaxPSQ' ni nid tok -})
+                return $ MM.toList bs
+            forM_ is $ \(Binding ni tok _) -> do
+            aPublish r tok (Just ni)
+            return ()
+        onResult _ = return True -- action for each search-hit (True = keep searching)
+        search  = do -- thread to fork
+            atomically $ reset aBuckets aSearch aTarget st
+            searchLoop aSearch aTarget onResult st
+            atomically $ scheduleImmediately announcer k
+                         $ SearchFinished {- st -} search announce aInterval
+            interruptDelay (interrutible announcer)
+    atomically $ scheduleImmediately announcer k $ NewAnnouncement search announce aInterval
     interruptDelay (interrutible announcer)
 
 cancel :: Announcer -> AnnounceKey -> AnnounceMethod r -> r -> IO ()
@@ -129,7 +148,6 @@ performScheduledItem announcer now = \case
         modifyTVar (scheduled announcer)
                    (PSQ.insert' k (Announce announce interval) (now + interval))
         return $ Just $ do
-            interruptDelay (interrutible announcer)
             fork search
             return ()
 
@@ -147,7 +165,7 @@ performScheduledItem announcer now = \case
     -- search finished:
     --   if any of the current storing-nodes set have not been
     --   announced to, announce to them.
-    (Binding _ SearchFinished _) -> return $ Just $ return ()
+    (Binding _ (SearchFinished {- st -} search announce interval) _) -> return $ Just $ return ()
 
 
 
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 -}
diff --git a/src/Network/Kademlia/Search.hs b/src/Network/Kademlia/Search.hs
index 5f024cd0..9d51e815 100644
--- a/src/Network/Kademlia/Search.hs
+++ b/src/Network/Kademlia/Search.hs
@@ -105,7 +105,7 @@ reset :: (Ord ni, Ord nid, Hashable ni, Hashable nid) =>
        -> Search nid addr1 tok1 ni r1
        -> nid
        -> SearchState nid addr tok ni r
-       -> STM ()
+       -> STM (SearchState nid addr tok ni r)
 reset bkts qsearch target st = do
     searchIsFinished st >>= check -- Wait for a search to finish before resetting.
     bktNodes <- map (\ni -> ni :-> kademliaLocation (searchSpace qsearch) ni)
@@ -116,6 +116,7 @@ reset bkts qsearch target st = do
     writeTVar (searchInformant    st) MM.empty
     writeTVar (searchVisited      st) Set.empty
     writeTVar (searchPendingCount st) 0
+    return st
 
 searchAlpha :: Int
 searchAlpha = 8