WIP: "a" command (recurring announcements)

1 files changed, 18 insertions, 0 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index ebc8b69e..fc2996a6 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -50,6 +50,7 @@ import qualified Data.Vector as V
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 
+import Announcer
 import Crypto.Tox -- (zeros32,SecretKey,PublicKey, generateSecretKey, toPublic, encodeSecret, decodeSecret, userKeys)
 import Network.UPNP as UPNP
 import Network.Address hiding (NodeId, NodeInfo(..))
@@ -324,6 +325,7 @@ data Session = Session
     , toxkeys           :: TVar Tox.AnnouncedKeys
     , userkeys          :: TVar [(SecretKey,PublicKey)]
     , roster            :: Roster
+    , announcer         :: Announcer
     , signalQuit        :: MVar ()
     }
 
@@ -528,6 +530,18 @@ clientSession s@Session{..} sock cnum h = do
                         maybe (hPutClient h ("Unsupported method: "++method))
                               goTarget
                               $ Map.lookup method dhtAnnouncables
+
+        ("a", s) | Just DHT{..} <- Map.lookup netname dhts
+                 , not (null s)
+                    -> cmd0 $ do
+                        let (op:method,xs) = break isSpace $ dropWhile isSpace s
+                            (dtastr,ys)    = break isSpace $ dropWhile isSpace xs
+                            a = Map.lookup method dhtAnnouncables
+                            q = Map.lookup method dhtQuery
+                            doit '+' = schedule
+                            doit '-' = cancel
+                            doit _   = \_ _ _ -> hPutClient h "Starting(+) or canceling(-)?"
+                        doit op announcer _announcemethod _what
         ("s", s) | Just dht@DHT{..} <- Map.lookup netname dhts
                     -> cmd0 $ do
                         let (method,xs) = break isSpace s
@@ -667,6 +681,8 @@ main = do
            (atomically . writeTVar (Mainline.contactInfo swarms))
            (peerdb >>= S.decodeLazy)
 
+    announcer <- forkAnnouncer
+
     (quitBt,btdhts,btips,baddrs) <- case portbt opts of
         "" -> return (return (), Map.empty,return [],[])
         p  -> do
@@ -871,6 +887,7 @@ main = do
                 , userkeys          = toxids
                 , roster            = rstr
                 , externalAddresses = liftM2 (++) btips toxips
+                , announcer         = announcer
                 }
         srv <- streamServer (withSession session) (SockAddrUnix "dht.sock")
         return $ do
@@ -957,6 +974,7 @@ main = do
 
     waitForSignal
 
+    stopAnnouncer announcer
     quitBt
     quitTox