From d65e0f858db8d8df25da24c54bc125cc4eede183 Mon Sep 17 00:00:00 2001 From: joe Date: Sun, 29 Oct 2017 20:52:22 -0400 Subject: WIP: "a" command (recurring announcements) (Part 2) --- examples/dhtd.hs | 59 ++++++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 45 insertions(+), 14 deletions(-) (limited to 'examples/dhtd.hs') 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 -- cgit v1.2.3