1 files changed, 87 insertions, 34 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index c8929e89..f54c5249 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -113,24 +113,24 @@ data DHTQuery nid ni = forall addr r 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.
+    , qhandler    :: ni -> nid -> IO ([ni], [r], Maybe 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.
+data DHTAnnouncable nid = forall dta tok ni r.
                         ( Show r
                         , Typeable dta
                         , Typeable tok
-                        , Typeable ni
                         , Typeable r
+                        , Typeable ni
                         ) => DHTAnnouncable
     { announceParseData :: String -> Either String dta
     , announceParseToken :: dta -> String -> Either String tok
     , announceParseAddress :: String -> Either String ni
     , announceSendData :: dta -> tok -> Maybe ni -> IO (Maybe r)
     , announceInterval :: POSIXTime
+    , qresultAddr :: dta -> nid
     }
 
 data DHTLink = forall status linkid params.
@@ -177,7 +177,7 @@ data DHT = forall nid ni. ( Show     ni
     , dhtSecretKey     :: STM (Maybe SecretKey)
     , dhtPing          :: Map.Map String (DHTPing ni)
     , dhtQuery         :: Map.Map String (DHTQuery nid ni)
-    , dhtAnnouncables  :: Map.Map String DHTAnnouncable
+    , dhtAnnouncables  :: Map.Map String (DHTAnnouncable nid)
     , dhtLinks         :: Map.Map String DHTLink
     , dhtParseId       :: String -> Either String nid
     , dhtSearches      :: TVar (Map.Map (String,nid) (DHTSearch nid ni))
@@ -254,7 +254,7 @@ reportResult ::
     -> (tok -> Maybe String)
     -> (ni -> String)
     -> Handle
-    -> Either String ([ni],[r],tok)
+    -> Either String ([ni],[r],Maybe tok)
     -> IO ()
 reportResult meth showR showTok showN h (Left e)            = hPutClient h e
 reportResult meth showR showTok showN h (Right (ns,rs,tok)) = do
@@ -262,7 +262,7 @@ reportResult meth showR showTok showN h (Right (ns,rs,tok)) = do
  where
     report = intercalate [("","")] [ tok_r , node_r , result_r ]
 
-    tok_r = maybe [] (pure . ("token:",)) $ showTok tok
+    tok_r = maybe [] (pure . ("token:",)) $ showTok =<< tok
 
     node_r = map ( ("n",) . showN ) ns
 
@@ -344,9 +344,9 @@ reportSearchResults meth h DHTSearch{searchShowTok,searchState,searchResults} =
             rs = Set.toList rset
         return (ns,rs)
     let n'width       = succ $ maximum $ map (length . show . fst) ns
-        showN (n,tok) = take n'width (show n ++ repeat ' ') ++ (fromMaybe "" $ searchShowTok tok)
+        showN (n,tok) = take n'width (show n ++ repeat ' ') ++ (fromMaybe "" $ searchShowTok =<< tok)
         ns'           = map showN ns
-    reportResult meth id (const Nothing) id h (Right (ns',rs,()))
+    reportResult meth id (const Nothing) id h (Right (ns',rs, Just ()))
 
 data Session = Session
     { netname           :: String
@@ -602,38 +602,81 @@ 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 -> AnnounceKey -> AnnounceMethod r -> r -> IO ()
-                            doit '+' _ = schedule
-                            doit '-' _ = cancel
-                            doit _   _ = \_ _ _ _ -> hPutClient h "Starting(+) or canceling(-)?"
+                            doit :: Char -> Announcer -> AnnounceKey -> AnnounceMethod r -> r -> IO ()
+                            doit '+' = schedule
+                            doit '-' = cancel
+                            doit _   = \_ _ _ _ -> hPutClient h "Starting(+) or canceling(-)?"
                             matchingResult ::
-                                ( Typeable sr
-                                , Typeable stok
+                                ( Typeable stok
+                                , Typeable ptok
+                                , Typeable sni
+                                , Typeable pni )
+                                            => Search nid addr stok sni sr
+                                            -> (pr -> ptok -> Maybe pni -> IO (Maybe pubr))
+                                            -> Maybe (stok :~: ptok, sni :~: pni)
+                            matchingResult _ _ = liftA2 (,) eqT eqT
+                            matchingTok ::
+                                ( Typeable stok
+                                , Typeable ptok
                                 , Typeable sni
-                                , Typeable pr
+                                , Typeable pni )
+                                            => Search nid addr stok sni sr
+                                            -> (pr -> ptok -> Maybe pni -> IO (Maybe pubr))
+                                            -> Maybe (stok :~: ptok)
+                            matchingTok _ _ = eqT
+                            matchingNI ::
+                                ( Typeable stok
                                 , Typeable ptok
+                                , Typeable sni
                                 , 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
+                                            -> Maybe (sni :~: pni)
+                            matchingNI _ _ = eqT
+                            chktok :: Maybe ()
+                            chktok = do
+                                DHTAnnouncable { announceSendData
+                                               , announceParseData
+                                               , announceInterval
+                                               , qresultAddr } <- a
+                                DHTQuery { qsearch } <- q
+                                Refl <- matchingTok qsearch announceSendData
+                                return ()
+                            chkni :: Maybe ()
+                            chkni = do
+                                DHTAnnouncable { announceSendData
+                                               , announceParseData
+                                               , announceInterval
+                                               , qresultAddr } <- a
+                                DHTQuery { qsearch } <- q
+                                Refl <- matchingNI qsearch announceSendData
+                                return ()
                             mameth = do
                                 DHTAnnouncable { announceSendData
                                                , announceParseData
-                                               , announceInterval } <- a
-                                DHTQuery { qsearch
-                                         , qresultAddr } <- q
-                                (Refl,Refl,nr@Refl) <- matchingResult qsearch announceSendData
+                                               , announceInterval
+                                               , qresultAddr } <- a
+                                DHTQuery { qsearch } <- q
+                                (Refl, Refl) <- matchingResult qsearch announceSendData
+                                -- return $ hPutClient h "Type matches."
                                 dta <- either (const Nothing) Just $ announceParseData dtastr
                                 return $ do
                                     akey <- atomically $ packAnnounceKey announcer (method ++ ":" ++ dtastr)
-                                    doit op nr announcer
-                                               akey
-                                               (AnnounceMethod qsearch announceSendData dhtBuckets
-                                                               (qresultAddr dta)
-                                                               announceInterval)
-                                               dta
-                        fromMaybe (hPutClient h "error.") mameth
+                                    doit op announcer
+                                            akey
+                                            (AnnounceMethod qsearch announceSendData dhtBuckets
+                                                            (qresultAddr dta)
+                                                            announceInterval)
+                                            dta
+                        let aerror = unlines
+                                [ "announce error."
+                                , "method = " ++ method
+                                , "query = " ++ maybe "nil" (const "ok") q
+                                , "publish = " ++ maybe "nil" (const "ok") a
+                                , "chktok = " ++ maybe "nil" (const "ok") chktok -- chktok = nil
+                                , "chkni = " ++ maybe "nil" (const "ok") chkni
+                                ]
+                        fromMaybe (hPutClient h aerror) mameth
 
         ("s", s) | Just dht@DHT{..} <- Map.lookup netname dhts
                     -> cmd0 $ do
@@ -838,8 +881,11 @@ main = do
                                                                 . flip Mainline.FindNode (Just Want_Both))
                                         , qshowR = show
                                         , qshowTok = (const Nothing)
-                                        , qresultAddr = Mainline.nodeId
                                         })
+                                    -- Maybe (sr :~: pr, stok :~: ptok, sni :~: pni )
+                                    -- sr = InfoHash
+                                    -- stok = Token
+                                    -- sni = NodeInfo
                                     , ("peer", DHTQuery
                                         { qsearch = (Mainline.peerSearch bt)
                                         , qhandler = (\ni -> fmap Mainline.unwrapPeers
@@ -848,13 +894,17 @@ main = do
                                                                 . (read . show)) -- TODO: InfoHash -> NodeId
                                         , qshowR = (show . pPrint)
                                         , qshowTok = (Just . show)
-                                        , qresultAddr = (read . show) -- TODO: InfoHash -> NodeId
                                         })
                                     ]
                     , dhtParseId  = readEither :: String -> Either String Mainline.NodeId
                     , dhtSearches = mainlineSearches
                     , dhtFallbackNodes = Mainline.bootstrapNodes wantip
                     , dhtAnnouncables = Map.fromList
+                                    -- Maybe (sr :~: pr, stok :~: ptok, sni :~: pni )
+                                    -- dta = Announce
+                                    -- pr = Announced
+                                    -- ptok = Token
+                                    -- pni = NodeInfo
                                     [ ("peer", DHTAnnouncable { announceSendData = \ih tok -> \case
                                                                     Just ni -> do
                                                                         port <- atomically $ readTVar peerPort
@@ -865,6 +915,7 @@ main = do
                                                               , announceParseData = readEither
                                                               , announceParseToken = const $ readEither
                                                               , announceInterval = 60 -- TODO: Is one minute good?
+                                                              , qresultAddr = (read . show) -- TODO: InfoHash -> NodeId -- peer
                                                               })
                                     , ("port", DHTAnnouncable { announceParseData = readEither
                                                               , announceParseToken = \_ _ -> return ()
@@ -875,6 +926,7 @@ main = do
                                                                     Just _ -> return Nothing
                                                               , announceInterval = 0 -- TODO: The "port" setting should probably
                                                                                      -- be a command rather than an announcement.
+                                                              , qresultAddr = const $ Mainline.zeroID
                                                               })]
 
                     , dhtLinks = Map.fromList
@@ -932,7 +984,6 @@ main = do
                                                                 . Tox.GetNodes)
                                         , qshowR = show -- NodeInfo
                                         , qshowTok = (const Nothing)
-                                        , qresultAddr = Tox.nodeId
                                         })
                                     , ("toxid", DHTQuery
                                         { qsearch = (Tox.toxidSearch (Tox.onionTimeout tox)
@@ -948,8 +999,7 @@ main = do
                                                                                   (Tox.OnionDestination Tox.SearchingAlias ni Nothing)
                                                                                   (Tox.AnnounceRequest zeros32 nid Tox.zeroID))
                                         , qshowR  = show -- Rendezvous
-                                        , qshowTok = (fmap show) -- Nonce32
-                                        , qresultAddr = Tox.key2id . Tox.rendezvousKey
+                                        , qshowTok = Just . show -- Nonce32
                                         })
                                     ]
                     , dhtParseId  = readEither :: String -> Either String Tox.NodeId
@@ -969,6 +1019,7 @@ main = do
                                                                , announceParseAddress = readEither
                                                                , announceParseToken = const $ readEither
                                                                , announceParseData = fmap Tox.id2key . readEither
+                                                               , qresultAddr = Tox.key2id -- toxid
 
                     -- For peers we are announcing ourselves to, if we are not
                     -- announced to them toxcore tries every 3 seconds to
@@ -997,6 +1048,7 @@ main = do
                                                                , announceParseAddress = readEither
                                                                , announceParseToken = \_ _ -> return ()
                                                                , announceParseData = fmap Tox.id2key . readEither
+                                                               , qresultAddr = Tox.key2id
 
                     -- We send this packet every 30 seconds if there is more
                     -- than one peer (in the 8) that says they our friend is
@@ -1034,6 +1086,7 @@ main = do
                                                                               (Tox.verifyChecksum pubkey)
                                                                               chksum
                                                                         return nospam
+                                                                , qresultAddr = Tox.key2id
 
                     -- Friend requests are sent with exponentially increasing
                     -- interval of 2 seconds, 4 seconds, 8 seconds, etc... in