From 35aed24bdd67cecbd77e0c64c6c054e736aac787 Mon Sep 17 00:00:00 2001 From: joe Date: Mon, 16 Oct 2017 19:22:53 -0400 Subject: Untested announce-peer command for bittorrent dht. --- examples/dhtd.hs | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) (limited to 'examples/dhtd.hs') diff --git a/examples/dhtd.hs b/examples/dhtd.hs index d23aca78..6529e746 100644 --- a/examples/dhtd.hs +++ b/examples/dhtd.hs @@ -107,6 +107,11 @@ data DHTQuery nid ni = forall addr r tok. , qshowTok :: tok -> Maybe String } +data DHTAnnouncable nid ni = forall dta r. Show r => DHTAnnouncable + { announceParseData :: String -> String -> IO (Either String dta) + , announceSendData :: dta -> Maybe ni -> IO (Maybe r) + } + data DHTSearch nid ni = forall addr tok r. DHTSearch { searchThread :: ThreadId , searchState :: SearchState nid addr tok ni r @@ -130,6 +135,7 @@ data DHT = forall nid ni. ( Show ni { dhtBuckets :: TVar (BucketList ni) , dhtPing :: ni -> IO Bool , dhtQuery :: Map.Map String (DHTQuery nid ni) + , dhtAnnouncables :: Map.Map String (DHTAnnouncable nid ni) , dhtParseId :: String -> Either String nid , dhtSearches :: TVar (Map.Map (String,nid) (DHTSearch nid ni)) , dhtFallbackNodes :: IO [ni] @@ -440,6 +446,32 @@ clientSession s@Session{..} sock cnum h = do goQuery $ Map.lookup method dhtQuery + ("p", s) | Just DHT{..} <- Map.lookup netname dhts + -> cmd0 $ do + -- arguments: method + -- data + -- token + -- (optional dest-ni) + self <- atomically $ thisNode <$> readTVar dhtBuckets + let (method,xs) = break isSpace $ dropWhile isSpace s + (dtastr,ys) = break isSpace $ dropWhile isSpace xs + (tokenstr,zs) = break isSpace $ dropWhile isSpace ys + destination = dropWhile isSpace zs + goTarget DHTAnnouncable{..} = do + parseResult <- announceParseData dtastr tokenstr + case parseResult of + Left e -> hPutClient h e + Right nid -> go nid >>= either (hPutClient h) (hPutClient h . show) + where + go | null destination = fmap (maybe (Left "Timeout.") Right) + . flip announceSendData Nothing + | otherwise = case readEither destination of + Right ni -> fmap (maybe (Left "Timeout.") Right) + . flip announceSendData (Just ni) + Left e -> const $ return $ Left ("Bad destination: "++e) + maybe (hPutClient h ("Unsupported method: "++method)) + goTarget + $ Map.lookup method dhtAnnouncables ("s", s) | Just dht@DHT{..} <- Map.lookup netname dhts -> cmd0 $ do let (method,xs) = break isSpace s @@ -583,6 +615,7 @@ main = do (bt,btR) <- Mainline.newClient swarms addr quitBt <- forkListener "bt" (clientNet bt) mainlineSearches <- atomically $ newTVar Map.empty + peerPort <- atomically $ newTVar 6881 -- BitTorrent client TCP port. let mainlineDHT bkts wantip = DHT { dhtBuckets = bkts btR , dhtPing = Mainline.ping bt @@ -604,6 +637,23 @@ main = do , dhtParseId = readEither :: String -> Either String Mainline.NodeId , dhtSearches = mainlineSearches , dhtFallbackNodes = Mainline.bootstrapNodes wantip + , dhtAnnouncables = Map.fromList + [ ("peer", DHTAnnouncable { announceSendData = \dta -> \case + Just ni -> Mainline.announce bt dta ni + Nothing -> return Nothing + , announceParseData = \str tokstr -> do + port <- atomically $ readTVar peerPort + let ih = read str + tok = read tokstr + return $ Right $ Mainline.mkAnnounce port ih tok + }) + , ("port", DHTAnnouncable { announceParseData = \portstr _ -> return $ readEither portstr + , announceSendData = \dta -> \case + Nothing -> do atomically $ writeTVar peerPort (dta :: PortNumber) + return $ Just dta + Just _ -> return Nothing + })] + } dhts = Map.fromList $ ("bt4", mainlineDHT Mainline.routing4 Want_IP4) @@ -656,6 +706,7 @@ main = do , dhtParseId = readEither :: String -> Either String Tox.NodeId , dhtSearches = toxSearches , dhtFallbackNodes = return [] + , dhtAnnouncables = Map.empty -- TODO } dhts = Map.fromList $ ("tox4", toxDHT Tox.routing4) -- cgit v1.2.3