WIP: "a" command (recurring announcements) (Part 2)

1 files changed, 45 insertions, 14 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index fc2996a6..14076463 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -17,6 +17,7 @@
 {-# LANGUAGE TypeOperators             #-}
 
 import Control.Arrow
+import Control.Applicative
 import Control.Concurrent.STM
 import Control.DeepSeq
 import Control.Exception
@@ -107,17 +108,25 @@ hPutClientChunk h s = hPutStr h (' ' : marshalForClient s)
 data DHTQuery nid ni = forall addr r tok.
                         ( Ord addr
                         , Typeable r
-                        )=> DHTQuery
+                        , 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
     }
 
-data DHTAnnouncable = forall dta ni r. Show r => DHTAnnouncable
-    { announceParseData :: String -> String -> IO (Either String dta)
+data DHTAnnouncable = forall dta tok ni r.
+                        ( Show r
+                        , Typeable dta
+                        , Typeable tok
+                        , Typeable ni
+                        , Typeable r
+                        ) => DHTAnnouncable
+    { announceParseData :: String -> String -> IO (Either String (dta,tok))
     , announceParseAddress :: String -> Either String ni
-    , announceSendData :: dta -> Maybe ni -> IO (Maybe r)
+    , announceSendData :: (dta,tok) -> Maybe ni -> IO (Maybe r)
     }
 
 data DHTSearch nid ni = forall addr tok r. DHTSearch
@@ -538,10 +547,30 @@ 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 '+' = schedule
-                            doit '-' = cancel
-                            doit _   = \_ _ _ -> hPutClient h "Starting(+) or canceling(-)?"
-                        doit op announcer _announcemethod _what
+                            doit :: Char -> proxy ni -> Announcer -> AnnounceMethod ni -> info -> IO ()
+                            doit '+' _ = schedule
+                            doit '-' _ = cancel
+                            doit _   _ = \_ _ _ -> hPutClient h "Starting(+) or canceling(-)?"
+                            matchingResult ::
+                                ( Typeable sr
+                                , Typeable stok
+                                , Typeable sni
+                                , Typeable pr
+                                , Typeable ptok
+                                , Typeable pni )
+                                            => Search nid addr stok sni sr
+                                            -> ((pr,ptok) -> Maybe pni -> IO (Maybe pubr))
+                                            -> Maybe (sr :~: pr, stok :~: ptok, sni :~: pni )
+                            matchingResult _ _ = liftA3 (\a b c -> (a,b,c)) eqT eqT eqT
+                            mameth = do
+                                DHTQuery       {qsearch}          <- q
+                                DHTAnnouncable {announceSendData} <- a
+                                (Refl,Refl,nr@Refl) <- matchingResult qsearch announceSendData
+                                return $ doit op nr announcer
+                                                    (AnnounceMethod qsearch announceSendData)
+                                                    _what
+                        fromMaybe (hPutClient h "error.") mameth
+
         ("s", s) | Just dht@DHT{..} <- Map.lookup netname dhts
                     -> cmd0 $ do
                         let (method,xs) = break isSpace s
@@ -716,19 +745,21 @@ main = do
                     , dhtSearches = mainlineSearches
                     , dhtFallbackNodes = Mainline.bootstrapNodes wantip
                     , dhtAnnouncables = Map.fromList
-                                    [ ("peer", DHTAnnouncable { announceSendData = \dta -> \case
-                                                                    Just ni -> Mainline.announce bt dta ni
+                                    [ ("peer", DHTAnnouncable { announceSendData = \(ih,tok) -> \case
+                                                                    Just ni -> do
+                                                                        port <- atomically $ readTVar peerPort
+                                                                        let dta = Mainline.mkAnnounce port ih tok
+                                                                        Mainline.announce bt dta ni
                                                                     Nothing -> return Nothing
                                                               , announceParseAddress = readEither
                                                               , announceParseData = \str tokstr -> do
-                                                                    port <- atomically $ readTVar peerPort
                                                                     let ih = read str
                                                                         tok = read tokstr
-                                                                    return $ Right $ Mainline.mkAnnounce port ih tok
+                                                                    return $ Right (ih,tok)
                                                               })
-                                    , ("port", DHTAnnouncable { announceParseData = \portstr _ -> return $ readEither portstr
+                                    , ("port", DHTAnnouncable { announceParseData = \portstr _ -> return $ (, ()) <$> readEither portstr
                                                               , announceParseAddress = const $ Right ()
-                                                              , announceSendData = \dta -> \case
+                                                              , announceSendData = \(dta,()) -> \case
                                                                     Nothing -> do atomically $ writeTVar peerPort (dta :: PortNumber)
                                                                                   return $ Just dta
                                                                     Just _ -> return Nothing