6 files changed, 104 insertions, 50 deletions

diff --git a/Announcer.hs b/Announcer.hs
index f19f8d46..2f0eca10 100644
--- a/Announcer.hs
+++ b/Announcer.hs
@@ -64,7 +64,7 @@ stopAnnouncer announcer = do
     interruptDelay (interrutible announcer)
     atomically $ readTVar (announcerActive announcer) >>= check . not
 
-data AnnounceMethod r = forall nid ni addr tok a.
+data AnnounceMethod r = forall nid ni sr addr tok a.
                         ( Show nid
                         , Hashable nid
                         , Hashable ni
@@ -72,7 +72,7 @@ data AnnounceMethod r = forall nid ni addr tok a.
                         , Ord nid
                         , Ord ni
                         ) => AnnounceMethod
-    { aSearch  :: Search nid addr tok ni r
+    { aSearch  :: Search nid addr tok ni sr
     , aPublish :: r -> tok -> Maybe ni -> IO (Maybe a)
     , aBuckets :: TVar (R.BucketList ni)
     , aTarget  :: nid
@@ -86,7 +86,8 @@ schedule announcer k AnnounceMethod{aSearch,aPublish,aBuckets,aTarget,aInterval}
             is <- atomically $ do
                 bs <- readTVar (searchInformant st {- :: TVar (MinMaxPSQ' ni nid tok -})
                 return $ MM.toList bs
-            forM_ is $ \(Binding ni tok _) -> do
+            forM_ is $ \(Binding ni mtok _) -> do
+            forM_ mtok $ \tok -> do
             aPublish r tok (Just ni)
             return ()
         onResult _ = return True -- action for each search-hit (True = keep searching)
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index f9dce3bc..c0330657 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
@@ -601,38 +601,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
@@ -837,8 +880,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
@@ -847,13 +893,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
@@ -864,6 +914,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 ()
@@ -874,6 +925,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
@@ -930,7 +982,6 @@ main = do
                                                                 . Tox.GetNodes)
                                         , qshowR = show -- NodeInfo
                                         , qshowTok = (const Nothing)
-                                        , qresultAddr = Tox.nodeId
                                         })
                                     , ("toxid", DHTQuery
                                         { qsearch = (Tox.toxidSearch (Tox.onionTimeout tox)
@@ -946,8 +997,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
@@ -967,6 +1017,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
@@ -995,6 +1046,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
@@ -1032,6 +1084,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
diff --git a/src/Network/BitTorrent/MainlineDHT.hs b/src/Network/BitTorrent/MainlineDHT.hs
index f4a5ade1..eb06564a 100644
--- a/src/Network/BitTorrent/MainlineDHT.hs
+++ b/src/Network/BitTorrent/MainlineDHT.hs
@@ -1013,19 +1013,19 @@ ping client addr =
     <$> mainlineSend (Method "ping") (\Pong -> True) (const Ping) client () addr
 
 -- searchQuery        :: ni -> IO (Maybe [ni], [r], tok))
-getNodes :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],()))
+getNodes :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ()))
 getNodes = mainlineSend (Method "find_node") unwrapNodes $ flip FindNode (Just Want_Both)
 
-unwrapNodes :: NodeFound -> ([NodeInfo], [NodeInfo], ())
-unwrapNodes (NodeFound ns4 ns6) = (ns4++ns6, ns4++ns6,())
+unwrapNodes :: NodeFound -> ([NodeInfo], [NodeInfo], Maybe ())
+unwrapNodes (NodeFound ns4 ns6) = (ns4++ns6, ns4++ns6, Just ())
 
-getPeers :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[PeerAddr],Token))
+getPeers :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[PeerAddr],Maybe Token))
 getPeers = mainlineSend (Method "get_peers") unwrapPeers $ flip GetPeers (Just Want_Both) . coerce
 
-unwrapPeers :: GotPeers -> ([NodeInfo], [PeerAddr], Token)
-unwrapPeers (GotPeers ps (NodeFound ns4 ns6) tok) = (ns4++ns6, ps, tok)
+unwrapPeers :: GotPeers -> ([NodeInfo], [PeerAddr], Maybe Token)
+unwrapPeers (GotPeers ps (NodeFound ns4 ns6) tok) = (ns4++ns6, ps, Just tok)
 
-mainlineSearch :: (NodeId -> NodeInfo -> IO (Maybe ([NodeInfo], [r], tok)))
+mainlineSearch :: (NodeId -> NodeInfo -> IO (Maybe ([NodeInfo], [r], Maybe tok)))
                   -> Search NodeId (IP, PortNumber) tok NodeInfo r
 mainlineSearch qry = Search
     { searchSpace       = mainlineSpace
diff --git a/src/Network/Kademlia/Search.hs b/src/Network/Kademlia/Search.hs
index 9d51e815..58c8fad8 100644
--- a/src/Network/Kademlia/Search.hs
+++ b/src/Network/Kademlia/Search.hs
@@ -38,7 +38,7 @@ import GHC.Conc                  (labelThread)
 data Search nid addr tok ni r = Search
     { searchSpace        :: KademliaSpace nid ni
     , searchNodeAddress  :: ni -> addr
-    , searchQuery        :: nid -> ni -> IO (Maybe ([ni], [r], tok))
+    , searchQuery        :: nid -> ni -> IO (Maybe ([ni], [r], Maybe tok))
     }
 
 data SearchState nid addr tok ni r = SearchState
@@ -61,7 +61,7 @@ data SearchState nid addr tok ni r = SearchState
       -- | Nodes scheduled to be queried.
     , searchQueued       :: TVar (MinMaxPSQ ni nid)
       -- | The nearest K nodes that issued a reply.
-    , searchInformant    :: TVar (MinMaxPSQ' ni nid tok)
+    , searchInformant    :: TVar (MinMaxPSQ' ni nid (Maybe tok))
       -- | This tracks already-queried addresses so we avoid bothering them
       -- again. XXX: We could probably keep only the pending queries in this
       -- set.  It also can be a bounded 'MinMaxPSQ', although searchAlpha
diff --git a/src/Network/Tox/DHT/Handlers.hs b/src/Network/Tox/DHT/Handlers.hs
index 4576fc85..89f3d442 100644
--- a/src/Network/Tox/DHT/Handlers.hs
+++ b/src/Network/Tox/DHT/Handlers.hs
@@ -306,10 +306,10 @@ unsendNodes :: Message -> Maybe (Asymm (Nonce8,SendNodes))
 unsendNodes (DHTSendNodes asymm) = Just asymm
 unsendNodes _                    = Nothing
 
-unwrapNodes :: SendNodes -> ( [NodeInfo], [NodeInfo], () )
-unwrapNodes (SendNodes ns) = (ns,ns,())
+unwrapNodes :: SendNodes -> ( [NodeInfo], [NodeInfo], Maybe () )
+unwrapNodes (SendNodes ns) = (ns,ns,Just ())
 
-getNodes :: Client -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],()))
+getNodes :: Client -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ()))
 getNodes client nid addr = do
     -- hPutStrLn stderr $ show addr ++ " <-- getnodes " ++ show nid
     reply <- QR.sendQuery client (serializer GetNodesType DHTGetNodes unsendNodes) (GetNodes nid) addr
diff --git a/src/Network/Tox/Onion/Handlers.hs b/src/Network/Tox/Onion/Handlers.hs
index b06fc2af..e792aa50 100644
--- a/src/Network/Tox/Onion/Handlers.hs
+++ b/src/Network/Tox/Onion/Handlers.hs
@@ -171,7 +171,7 @@ handlers net _ _ keydb _ = Just $ NoReply Right $ dataToRouteH keydb net
 toxidSearch :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
                -> TransportCrypto
                -> Client r
-               -> Search NodeId (IP, PortNumber) (Maybe Nonce32) NodeInfo Rendezvous
+               -> Search NodeId (IP, PortNumber) Nonce32 NodeInfo Rendezvous
 toxidSearch getTimeout crypto client = Search
     { searchSpace       = toxSpace
     , searchNodeAddress = nodeIP &&& nodePort