summaryrefslogtreecommitdiff
path: root/examples/dhtd.hs
diff options
context:
space:
mode:
Diffstat (limited to 'examples/dhtd.hs')
-rw-r--r--examples/dhtd.hs38
1 files changed, 24 insertions, 14 deletions
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 1aa36b77..8ceafd00 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -158,7 +158,8 @@ data DHTAnnouncable nid = forall dta tok ni r.
158 { announceParseData :: String -> Either String dta 158 { announceParseData :: String -> Either String dta
159 , announceParseToken :: dta -> String -> Either String tok 159 , announceParseToken :: dta -> String -> Either String tok
160 , announceParseAddress :: String -> Either String ni 160 , announceParseAddress :: String -> Either String ni
161 , announceSendData :: dta -> tok -> Maybe ni -> IO (Maybe r) 161 , announceSendData :: Either (dta -> r -> IO (Maybe r))
162 (dta -> tok -> Maybe ni -> IO (Maybe r))
162 , announceInterval :: POSIXTime 163 , announceInterval :: POSIXTime
163 , qresultAddr :: dta -> nid 164 , qresultAddr :: dta -> nid
164 } 165 }
@@ -703,12 +704,16 @@ clientSession s@Session{..} sock cnum h = do
703 Left e -> hPutClient h e 704 Left e -> hPutClient h e
704 Right nid -> go nid >>= either (hPutClient h) (hPutClient h . show) 705 Right nid -> go nid >>= either (hPutClient h) (hPutClient h . show)
705 where 706 where
706 go | null destination = fmap (maybe (Left "Timeout.") Right) 707 go | Right asend <- announceSendData
707 . flip (uncurry announceSendData) Nothing 708 , null destination = fmap (maybe (Left "Timeout.") Right)
708 | otherwise = case announceParseAddress destination of 709 . flip (uncurry asend) Nothing
710 | Right asend <- announceSendData
711 = case announceParseAddress destination of
709 Right ni -> fmap (maybe (Left "Timeout.") Right) 712 Right ni -> fmap (maybe (Left "Timeout.") Right)
710 . flip (uncurry announceSendData) (Just ni) 713 . flip (uncurry asend) (Just ni)
711 Left e -> const $ return $ Left ("Bad destination: "++e) 714 Left e -> const $ return $ Left ("Bad destination: "++e)
715 | Left asend <- announceSendData
716 = const $ return $ Left "TODO"
712 maybe (hPutClient h ("Unsupported method: "++method)) 717 maybe (hPutClient h ("Unsupported method: "++method))
713 goTarget 718 goTarget
714 $ Map.lookup method dhtAnnouncables 719 $ Map.lookup method dhtAnnouncables
@@ -780,7 +785,8 @@ clientSession s@Session{..} sock cnum h = do
780 , announceInterval 785 , announceInterval
781 , qresultAddr } <- a 786 , qresultAddr } <- a
782 DHTQuery { qsearch } <- q 787 DHTQuery { qsearch } <- q
783 Refl <- matchingTok qsearch announceSendData 788 asend <- either (const Nothing) Just announceSendData
789 Refl <- matchingTok qsearch asend
784 return () 790 return ()
785 chkni :: Maybe () 791 chkni :: Maybe ()
786 chkni = do 792 chkni = do
@@ -789,7 +795,8 @@ clientSession s@Session{..} sock cnum h = do
789 , announceInterval 795 , announceInterval
790 , qresultAddr } <- a 796 , qresultAddr } <- a
791 DHTQuery { qsearch } <- q 797 DHTQuery { qsearch } <- q
792 Refl <- matchingNI qsearch announceSendData 798 asend <- either (const Nothing) Just announceSendData
799 Refl <- matchingNI qsearch asend
793 return () 800 return ()
794 mameth = do 801 mameth = do
795 DHTAnnouncable { announceSendData 802 DHTAnnouncable { announceSendData
@@ -797,14 +804,15 @@ clientSession s@Session{..} sock cnum h = do
797 , announceInterval 804 , announceInterval
798 , qresultAddr } <- a 805 , qresultAddr } <- a
799 DHTQuery { qsearch } <- q 806 DHTQuery { qsearch } <- q
800 (Refl, Refl) <- matchingResult qsearch announceSendData 807 asend <- either (const Nothing) Just announceSendData
808 (Refl, Refl) <- matchingResult qsearch asend
801 -- return $ hPutClient h "Type matches." 809 -- return $ hPutClient h "Type matches."
802 dta <- either (const Nothing) Just $ announceParseData dtastr 810 dta <- either (const Nothing) Just $ announceParseData dtastr
803 return $ do 811 return $ do
804 akey <- atomically $ packAnnounceKey announcer (method ++ ":" ++ dtastr) 812 akey <- atomically $ packAnnounceKey announcer (method ++ ":" ++ dtastr)
805 doit op announcer 813 doit op announcer
806 akey 814 akey
807 (AnnounceMethod qsearch announceSendData dhtBuckets 815 (AnnounceMethod qsearch (Right asend) dhtBuckets
808 (qresultAddr dta) 816 (qresultAddr dta)
809 announceInterval) 817 announceInterval)
810 dta 818 dta
@@ -1118,7 +1126,7 @@ main = runResourceT $ liftBaseWith $ \resT -> do
1118 -- pr = Announced 1126 -- pr = Announced
1119 -- ptok = Token 1127 -- ptok = Token
1120 -- pni = NodeInfo 1128 -- pni = NodeInfo
1121 [ ("peer", DHTAnnouncable { announceSendData = \ih tok -> \case 1129 [ ("peer", DHTAnnouncable { announceSendData = Right $ \ih tok -> \case
1122 Just ni -> do 1130 Just ni -> do
1123 port <- atomically $ readTVar peerPort 1131 port <- atomically $ readTVar peerPort
1124 let dta = Mainline.mkAnnounce port ih tok 1132 let dta = Mainline.mkAnnounce port ih tok
@@ -1133,7 +1141,7 @@ main = runResourceT $ liftBaseWith $ \resT -> do
1133 , ("port", DHTAnnouncable { announceParseData = readEither 1141 , ("port", DHTAnnouncable { announceParseData = readEither
1134 , announceParseToken = \_ _ -> return () 1142 , announceParseToken = \_ _ -> return ()
1135 , announceParseAddress = const $ Right () 1143 , announceParseAddress = const $ Right ()
1136 , announceSendData = \dta () -> \case 1144 , announceSendData = Right $ \dta () -> \case
1137 Nothing -> do atomically $ writeTVar peerPort (dta :: PortNumber) 1145 Nothing -> do atomically $ writeTVar peerPort (dta :: PortNumber)
1138 return $ Just dta 1146 return $ Just dta
1139 Just _ -> return Nothing 1147 Just _ -> return Nothing
@@ -1222,7 +1230,7 @@ main = runResourceT $ liftBaseWith $ \resT -> do
1222 , dhtSearches = toxSearches 1230 , dhtSearches = toxSearches
1223 , dhtFallbackNodes = return [] 1231 , dhtFallbackNodes = return []
1224 , dhtAnnouncables = Map.fromList 1232 , dhtAnnouncables = Map.fromList
1225 [ ("toxid", DHTAnnouncable { announceSendData = \pubkey token -> \case 1233 [ ("toxid", DHTAnnouncable { announceSendData = Right $ \pubkey token -> \case
1226 Just ni -> 1234 Just ni ->
1227 Tox.putRendezvous 1235 Tox.putRendezvous
1228 (Tox.onionTimeout tox) 1236 (Tox.onionTimeout tox)
@@ -1252,7 +1260,8 @@ main = runResourceT $ liftBaseWith $ \resT -> do
1252 , announceInterval = 15 1260 , announceInterval = 15
1253 1261
1254 }) 1262 })
1255 , ("dhtkey", DHTAnnouncable { announceSendData = \pubkey () -> \case 1263 -- FIXME: Should use announceSendData = Left ...
1264 , ("dhtkey", DHTAnnouncable { announceSendData = Right $ \pubkey () -> \case
1256 Just addr -> do 1265 Just addr -> do
1257 dkey <- Tox.getContactInfo tox 1266 dkey <- Tox.getContactInfo tox
1258 sendMessage 1267 sendMessage
@@ -1283,7 +1292,8 @@ main = runResourceT $ liftBaseWith $ \resT -> do
1283 , announceInterval = 30 1292 , announceInterval = 30
1284 1293
1285 }) 1294 })
1286 , ("friend", DHTAnnouncable { announceSendData = \pubkey nospam -> \case 1295 -- FIXME: Should use announceSendData = Left ...
1296 , ("friend", DHTAnnouncable { announceSendData = Right $ \pubkey nospam -> \case
1287 Just addr -> do 1297 Just addr -> do
1288 let fr = Tox.FriendRequest nospam txt 1298 let fr = Tox.FriendRequest nospam txt
1289 -- nospam = 0xD64A8B00 1299 -- nospam = 0xD64A8B00
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 20:50:50 +0000