summaryrefslogtreecommitdiff
path: root/examples/dhtd.hs
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2017-10-30 18:06:49 -0400
committerjoe <joe@jerkface.net>2017-10-30 18:06:49 -0400
commit23767c2ebc53a2853c0065e727c3bbbf40cd5a83 (patch)
treecbf80574e76244acafad256f031c944fdbfc33ed /examples/dhtd.hs
parentdd0e843d33a3e483e1699697fb3a25e9d76351dc (diff)
WIP: a command (recurring announcements) (Part 3)
Diffstat (limited to 'examples/dhtd.hs')
-rw-r--r--examples/dhtd.hs126
1 files changed, 34 insertions, 92 deletions
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 14076463..a2ebdf86 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -124,9 +124,10 @@ data DHTAnnouncable = forall dta tok ni r.
124 , Typeable ni 124 , Typeable ni
125 , Typeable r 125 , Typeable r
126 ) => DHTAnnouncable 126 ) => DHTAnnouncable
127 { announceParseData :: String -> String -> IO (Either String (dta,tok)) 127 { announceParseData :: String -> Either String dta
128 , announceParseToken :: dta -> String -> Either String tok
128 , announceParseAddress :: String -> Either String ni 129 , announceParseAddress :: String -> Either String ni
129 , announceSendData :: (dta,tok) -> Maybe ni -> IO (Maybe r) 130 , announceSendData :: dta -> tok -> Maybe ni -> IO (Maybe r)
130 } 131 }
131 132
132data DHTSearch nid ni = forall addr tok r. DHTSearch 133data DHTSearch nid ni = forall addr tok r. DHTSearch
@@ -421,6 +422,8 @@ clientSession s@Session{..} sock cnum h = do
421 , ("node-id", show $ thisNode bkts) 422 , ("node-id", show $ thisNode bkts)
422 , ("network", netname) ] 423 , ("network", netname) ]
423 424
425 -- "ping"
426 -- "cookie"
424 (pinglike, s) | Just DHT{dhtPing} <- Map.lookup netname dhts 427 (pinglike, s) | Just DHT{dhtPing} <- Map.lookup netname dhts
425 , Just DHTPing{ pingQuery=ping 428 , Just DHTPing{ pingQuery=ping
426 , pingShowResult=showr } <- Map.lookup pinglike dhtPing 429 , pingShowResult=showr } <- Map.lookup pinglike dhtPing
@@ -525,16 +528,17 @@ clientSession s@Session{..} sock cnum h = do
525 (tokenstr,zs) = break isSpace $ dropWhile isSpace ys 528 (tokenstr,zs) = break isSpace $ dropWhile isSpace ys
526 destination = dropWhile isSpace zs 529 destination = dropWhile isSpace zs
527 goTarget DHTAnnouncable{..} = do 530 goTarget DHTAnnouncable{..} = do
528 parseResult <- announceParseData dtastr tokenstr 531 let dta = announceParseData dtastr
529 case parseResult of 532 tok = dta >>= flip announceParseToken tokenstr
530 Left e -> hPutClient h e 533 case liftA2 (,) dta tok of
534 Left e -> hPutClient h e
531 Right nid -> go nid >>= either (hPutClient h) (hPutClient h . show) 535 Right nid -> go nid >>= either (hPutClient h) (hPutClient h . show)
532 where 536 where
533 go | null destination = fmap (maybe (Left "Timeout.") Right) 537 go | null destination = fmap (maybe (Left "Timeout.") Right)
534 . flip announceSendData Nothing 538 . flip (uncurry announceSendData) Nothing
535 | otherwise = case announceParseAddress destination of 539 | otherwise = case announceParseAddress destination of
536 Right ni -> fmap (maybe (Left "Timeout.") Right) 540 Right ni -> fmap (maybe (Left "Timeout.") Right)
537 . flip announceSendData (Just ni) 541 . flip (uncurry announceSendData) (Just ni)
538 Left e -> const $ return $ Left ("Bad destination: "++e) 542 Left e -> const $ return $ Left ("Bad destination: "++e)
539 maybe (hPutClient h ("Unsupported method: "++method)) 543 maybe (hPutClient h ("Unsupported method: "++method))
540 goTarget 544 goTarget
@@ -547,7 +551,7 @@ clientSession s@Session{..} sock cnum h = do
547 (dtastr,ys) = break isSpace $ dropWhile isSpace xs 551 (dtastr,ys) = break isSpace $ dropWhile isSpace xs
548 a = Map.lookup method dhtAnnouncables 552 a = Map.lookup method dhtAnnouncables
549 q = Map.lookup method dhtQuery 553 q = Map.lookup method dhtQuery
550 doit :: Char -> proxy ni -> Announcer -> AnnounceMethod ni -> info -> IO () 554 doit :: Char -> proxy ni -> Announcer -> AnnounceMethod ni r -> r -> IO ()
551 doit '+' _ = schedule 555 doit '+' _ = schedule
552 doit '-' _ = cancel 556 doit '-' _ = cancel
553 doit _ _ = \_ _ _ -> hPutClient h "Starting(+) or canceling(-)?" 557 doit _ _ = \_ _ _ -> hPutClient h "Starting(+) or canceling(-)?"
@@ -559,16 +563,18 @@ clientSession s@Session{..} sock cnum h = do
559 , Typeable ptok 563 , Typeable ptok
560 , Typeable pni ) 564 , Typeable pni )
561 => Search nid addr stok sni sr 565 => Search nid addr stok sni sr
562 -> ((pr,ptok) -> Maybe pni -> IO (Maybe pubr)) 566 -> (pr -> ptok -> Maybe pni -> IO (Maybe pubr))
563 -> Maybe (sr :~: pr, stok :~: ptok, sni :~: pni ) 567 -> Maybe (sr :~: pr, stok :~: ptok, sni :~: pni )
564 matchingResult _ _ = liftA3 (\a b c -> (a,b,c)) eqT eqT eqT 568 matchingResult _ _ = liftA3 (\a b c -> (a,b,c)) eqT eqT eqT
565 mameth = do 569 mameth = do
566 DHTQuery {qsearch} <- q 570 DHTAnnouncable { announceSendData
567 DHTAnnouncable {announceSendData} <- a 571 , announceParseData } <- a
572 DHTQuery { qsearch } <- q
568 (Refl,Refl,nr@Refl) <- matchingResult qsearch announceSendData 573 (Refl,Refl,nr@Refl) <- matchingResult qsearch announceSendData
574 dta <- either (const Nothing) Just $ announceParseData dtastr
569 return $ doit op nr announcer 575 return $ doit op nr announcer
570 (AnnounceMethod qsearch announceSendData) 576 (AnnounceMethod qsearch announceSendData)
571 _what 577 dta
572 fromMaybe (hPutClient h "error.") mameth 578 fromMaybe (hPutClient h "error.") mameth
573 579
574 ("s", s) | Just dht@DHT{..} <- Map.lookup netname dhts 580 ("s", s) | Just dht@DHT{..} <- Map.lookup netname dhts
@@ -745,21 +751,20 @@ main = do
745 , dhtSearches = mainlineSearches 751 , dhtSearches = mainlineSearches
746 , dhtFallbackNodes = Mainline.bootstrapNodes wantip 752 , dhtFallbackNodes = Mainline.bootstrapNodes wantip
747 , dhtAnnouncables = Map.fromList 753 , dhtAnnouncables = Map.fromList
748 [ ("peer", DHTAnnouncable { announceSendData = \(ih,tok) -> \case 754 [ ("peer", DHTAnnouncable { announceSendData = \ih tok -> \case
749 Just ni -> do 755 Just ni -> do
750 port <- atomically $ readTVar peerPort 756 port <- atomically $ readTVar peerPort
751 let dta = Mainline.mkAnnounce port ih tok 757 let dta = Mainline.mkAnnounce port ih tok
752 Mainline.announce bt dta ni 758 Mainline.announce bt dta ni
753 Nothing -> return Nothing 759 Nothing -> return Nothing
754 , announceParseAddress = readEither 760 , announceParseAddress = readEither
755 , announceParseData = \str tokstr -> do 761 , announceParseData = readEither
756 let ih = read str 762 , announceParseToken = const $ readEither
757 tok = read tokstr
758 return $ Right (ih,tok)
759 }) 763 })
760 , ("port", DHTAnnouncable { announceParseData = \portstr _ -> return $ (, ()) <$> readEither portstr 764 , ("port", DHTAnnouncable { announceParseData = readEither
765 , announceParseToken = \_ _ -> return ()
761 , announceParseAddress = const $ Right () 766 , announceParseAddress = const $ Right ()
762 , announceSendData = \(dta,()) -> \case 767 , announceSendData = \dta () -> \case
763 Nothing -> do atomically $ writeTVar peerPort (dta :: PortNumber) 768 Nothing -> do atomically $ writeTVar peerPort (dta :: PortNumber)
764 return $ Just dta 769 return $ Just dta
765 Just _ -> return Nothing 770 Just _ -> return Nothing
@@ -832,7 +837,7 @@ main = do
832 , dhtSearches = toxSearches 837 , dhtSearches = toxSearches
833 , dhtFallbackNodes = return [] 838 , dhtFallbackNodes = return []
834 , dhtAnnouncables = Map.fromList 839 , dhtAnnouncables = Map.fromList
835 [ ("toxid", DHTAnnouncable { announceSendData = \(pubkey,token) -> \case 840 [ ("toxid", DHTAnnouncable { announceSendData = \pubkey token -> \case
836 Just ni -> 841 Just ni ->
837 Tox.putRendezvous 842 Tox.putRendezvous
838 (Tox.onionTimeout tox) 843 (Tox.onionTimeout tox)
@@ -843,15 +848,10 @@ main = do
843 ni 848 ni
844 Nothing -> return Nothing 849 Nothing -> return Nothing
845 , announceParseAddress = readEither 850 , announceParseAddress = readEither
846 , announceParseData = \str tokstr -> do 851 , announceParseToken = const $ readEither
847 r <- return $ do 852 , announceParseData = fmap Tox.id2key . readEither
848 pubkey <- Tox.id2key <$> readEither str
849 tok <- readEither tokstr
850 Right (pubkey :: PublicKey, tok :: Nonce32)
851 hPutStrLn stderr ("PARSED(toxid): "++show (fmap (Control.Arrow.first Tox.key2id) r))
852 return r
853 }) 853 })
854 , ("dhtkey", DHTAnnouncable { announceSendData = \(pubkey,()) -> \case 854 , ("dhtkey", DHTAnnouncable { announceSendData = \pubkey () -> \case
855 Just addr -> do 855 Just addr -> do
856 dkey <- Tox.getContactInfo tox 856 dkey <- Tox.getContactInfo tox
857 sendMessage 857 sendMessage
@@ -861,13 +861,10 @@ main = do
861 return $ Just () 861 return $ Just ()
862 Nothing -> return Nothing 862 Nothing -> return Nothing
863 , announceParseAddress = readEither 863 , announceParseAddress = readEither
864 , announceParseData = \str _ -> do 864 , announceParseToken = \_ _ -> return ()
865 r <- return $ do 865 , announceParseData = fmap Tox.id2key . readEither
866 pubkey <- Tox.id2key <$> readEither str
867 Right (pubkey :: PublicKey, ())
868 return r
869 }) 866 })
870 , ("friend", DHTAnnouncable { announceSendData = \(pubkey,nospam) -> \case 867 , ("friend", DHTAnnouncable { announceSendData = \pubkey nospam -> \case
871 Just addr -> do 868 Just addr -> do
872 let fr = Tox.FriendRequest nospam txt 869 let fr = Tox.FriendRequest nospam txt
873 -- nospam = 0xD64A8B00 870 -- nospam = 0xD64A8B00
@@ -879,15 +876,13 @@ main = do
879 return $ Just () 876 return $ Just ()
880 Nothing -> return Nothing 877 Nothing -> return Nothing
881 , announceParseAddress = readEither 878 , announceParseAddress = readEither
882 , announceParseData = \str nospamstr -> do 879 , announceParseData = fmap Tox.id2key . readEither
883 r <- return $ do 880 , announceParseToken = \pubkey nospamstr -> do
884 pubkey <- Tox.id2key <$> readEither str
885 Tox.NoSpam nospam chksum <- readEither nospamstr 881 Tox.NoSpam nospam chksum <- readEither nospamstr
886 maybe (Right ()) 882 maybe (Right ())
887 (Tox.verifyChecksum pubkey) 883 (Tox.verifyChecksum pubkey)
888 chksum 884 chksum
889 Right (pubkey :: PublicKey, nospam) 885 return nospam
890 return r
891 })] 886 })]
892 , dhtSecretKey = return $ Just $ transportSecret (Tox.toxCryptoKeys tox) 887 , dhtSecretKey = return $ Just $ transportSecret (Tox.toxCryptoKeys tox)
893 } 888 }
@@ -950,59 +945,6 @@ main = do
950 Nothing -> return () 945 Nothing -> return ()
951 return () 946 return ()
952 947
953 {-
954 let bkts4 = Mainline.routing4 btR
955 (fallbackNodes4,fallbackNodes6) <- case portbt opts of
956 [] -> return ([],[])
957 _ -> do
958 btSaved4 <- loadNodes "bt4" :: IO [Mainline.NodeInfo]
959 putStrLn $ "Loaded "++show (length btSaved4)++" nodes for bt4."
960 fallbackNodes4 <- Mainline.bootstrapNodes Want_IP4
961 fork $ do
962 myThreadId >>= flip labelThread "bootstrap.Mainline4"
963 bootstrap (Mainline.nodeSearch bt) bkts4 (Mainline.ping bt) btSaved4 fallbackNodes4
964 saveNodes "bt4" (dhts Map.! "bt4")
965
966 fallbackNodes6 <- case ip6bt opts of
967 True -> do
968 btSaved6 <- loadNodes "bt6"
969 putStrLn $ "Loaded "++show (length btSaved6)++" nodes for bt6."
970 let bkts6 = Mainline.routing6 btR
971 fallbackNodes6 <- Mainline.bootstrapNodes Want_IP6
972 fork $ do
973 myThreadId >>= flip labelThread "bootstrap.Mainline6"
974 bootstrap (Mainline.nodeSearch bt) bkts6 (Mainline.ping bt) btSaved6 fallbackNodes6
975 saveNodes "bt6" (dhts Map.! "bt6")
976 return fallbackNodes6
977 False -> return []
978 return (fallbackNodes4,fallbackNodes6)
979
980 (toxSaved4, toxSaved6) <- case porttox opts of
981 [] -> return ([],[])
982 _ -> do
983 toxSaved4 <- loadNodes "tox4"
984 putStrLn $ "Loaded "++show (length toxSaved4)++" nodes for tox4"
985 fork $ do
986 myThreadId >>= flip labelThread "bootstrap.Tox4"
987 bootstrap (Tox.nodeSearch $ Tox.toxDHT tox) (Tox.routing4 (Tox.toxRouting tox)) (Tox.ping $ Tox.toxDHT tox) toxSaved4 []
988 saveNodes "tox4" (dhts Map.! "tox4")
989
990 toxSaved6 <- case ip6tox opts of
991 True -> do
992 toxSaved6 <- loadNodes "tox6"
993 putStrLn $ "Loaded "++show (length toxSaved6)++" nodes for tox6"
994 fork $ do
995 myThreadId >>= flip labelThread "bootstrap.Tox6"
996 bootstrap (Tox.nodeSearch $ Tox.toxDHT tox) (Tox.routing6 (Tox.toxRouting tox)) (Tox.ping $ Tox.toxDHT tox) toxSaved6 []
997 saveNodes "tox6" (dhts Map.! "tox6")
998 return toxSaved6
999 False -> return []
1000 return (toxSaved4,toxSaved6)
1001
1002 hPutStr stderr $ showReport $ map (("bootstrap (IPv4)",) . show) fallbackNodes4
1003 ++ map (("bootstrap (IPv6)",) . show) fallbackNodes6
1004 -}
1005
1006 waitForSignal 948 waitForSignal
1007 949
1008 stopAnnouncer announcer 950 stopAnnouncer announcer
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 17:38:43 +0000