WIP: "a" command (recurring announcements)

3 files changed, 42 insertions, 0 deletions

diff --git a/Announcer.hs b/Announcer.hs
new file mode 100644
index 00000000..2d2c2197
--- /dev/null
+++ b/Announcer.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE ExistentialQuantification #-}
+module Announcer where
+
+import Network.Kademlia.Search
+
+data Announcer = Announcer
+
+forkAnnouncer :: IO Announcer
+forkAnnouncer = return Announcer
+
+stopAnnouncer :: Announcer -> IO ()
+stopAnnouncer _ = return ()
+
+data AnnounceMethod ni r info = forall nid addr tok. AnnounceMethod
+    { aSearch  :: Search nid addr tok ni r
+    , aPublish :: info -> Maybe ni -> IO (Maybe r)
+    }
+
+schedule :: Announcer -> AnnounceMethod ni r info -> info -> IO ()
+schedule _ _ _ = return ()
+
+cancel :: Announcer -> AnnounceMethod ni r info -> info -> IO ()
+cancel _ _ _ = return ()
diff --git a/dht-client.cabal b/dht-client.cabal
index 6bd680cc..c5985a41 100644
--- a/dht-client.cabal
+++ b/dht-client.cabal
@@ -92,6 +92,7 @@ library
                     Crypto.Tox
                     Text.XXD
                     Roster
+                    Announcer
 
   build-depends:      base
                     , containers
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