WIP: a command (recurring announcements) (Part 4)

1 files changed, 10 insertions, 5 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index fa4ce95b..931e1ba0 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -311,6 +311,8 @@ forkSearch method nid DHTQuery{qsearch,qshowTok,qshowR} dhtSearches dhtBuckets
             , searchResults = results
             }
     modifyTVar' dhtSearches $ Map.insert (method,nid) new
+    -- Finally, we write the search loop action into a tvar that will be executed in a new
+    -- thread.
     writeTVar kvar $ Just $ searchLoop qsearch nid storeResult st
 
 reportSearchResults :: (Show t, Ord t1, Ord t, Hashable t) =>
@@ -552,10 +554,10 @@ clientSession s@Session{..} sock cnum h = do
                             (dtastr,ys)    = break isSpace $ dropWhile isSpace xs
                             a = Map.lookup method dhtAnnouncables
                             q = Map.lookup method dhtQuery
-                            doit :: Char -> proxy ni -> Announcer -> AnnounceMethod ni r -> r -> IO ()
+                            doit :: Char -> proxy ni -> Announcer -> AnnounceKey -> AnnounceMethod r -> r -> IO ()
                             doit '+' _ = schedule
                             doit '-' _ = cancel
-                            doit _   _ = \_ _ _ -> hPutClient h "Starting(+) or canceling(-)?"
+                            doit _   _ = \_ _ _ _ -> hPutClient h "Starting(+) or canceling(-)?"
                             matchingResult ::
                                 ( Typeable sr
                                 , Typeable stok
@@ -573,9 +575,12 @@ clientSession s@Session{..} sock cnum h = do
                                 DHTQuery       { qsearch }           <- q
                                 (Refl,Refl,nr@Refl) <- matchingResult qsearch announceSendData
                                 dta <- either (const Nothing) Just $ announceParseData dtastr
-                                return $ doit op nr announcer
-                                                    (AnnounceMethod qsearch announceSendData)
-                                                    dta
+                                return $ do
+                                    akey <- atomically $ packAnnounceKey announcer (method ++ ":" ++ dtastr)
+                                    doit op nr announcer
+                                               akey
+                                               (AnnounceMethod qsearch announceSendData)
+                                               dta
                         fromMaybe (hPutClient h "error.") mameth
 
         ("s", s) | Just dht@DHT{..} <- Map.lookup netname dhts