diff options
Diffstat (limited to 'Presence')
-rw-r--r-- | Presence/Presence.hs | 65 | ||||
-rw-r--r-- | Presence/XMPPServer.hs | 94 |
2 files changed, 125 insertions, 34 deletions
diff --git a/Presence/Presence.hs b/Presence/Presence.hs index 4f0deb32..fad87aeb 100644 --- a/Presence/Presence.hs +++ b/Presence/Presence.hs | |||
@@ -475,19 +475,49 @@ delclient k mlp = do | |||
475 | 475 | ||
476 | eofConn :: PresenceState -> SockAddr -> ConnectionData -> IO () | 476 | eofConn :: PresenceState -> SockAddr -> ConnectionData -> IO () |
477 | eofConn state saddr cdta = do | 477 | eofConn state saddr cdta = do |
478 | atomically $ case classifyConnection saddr cdta of | ||
479 | Left (pkey,_) -> modifyTVar' (pkeyToChan state) $ Map.delete pkey | ||
480 | Right (ckey,_) -> modifyTVar' (ckeyToChan state) $ Map.delete ckey | ||
481 | case classifyConnection saddr cdta of | 478 | case classifyConnection saddr cdta of |
482 | Left (k,_) -> do | 479 | Left (k,_) -> do |
483 | let h = peerKeyToText k | 480 | h <- case cdType cdta of |
481 | -- TODO: This should be cached (perhaps by rewriteJIDForClient?) so that we | ||
482 | -- guarantee that the OFFLINE message matches the ONLINE message. | ||
483 | -- For now, we reverse-resolve the peer key. | ||
484 | XMPP -> -- For XMPP peers, informPeerPresence expects a textual | ||
485 | -- representation of the IP address to reverse-resolve. | ||
486 | return $ peerKeyToText k | ||
487 | Tox -> do | ||
488 | -- For Tox peers, informPeerPresence expects the actual hostname | ||
489 | -- so we will use the one that the peer told us at greeting time. | ||
490 | m <- atomically $ swapTVar (cdRemoteName cdta) Nothing | ||
491 | case m of | ||
492 | Nothing -> do | ||
493 | dput XJabber $ "BUG: Tox peer didn't inform us of its name." | ||
494 | -- The following fallback behavior is probably wrong. | ||
495 | return $ peerKeyToText k | ||
496 | Just toxname -> return toxname | ||
497 | -- ioToSource terminated. | ||
498 | -- | ||
499 | -- dhtd: Network.Socket.getAddrInfo | ||
500 | -- (called with preferred socket type/protocol: AddrInfo | ||
501 | -- { addrFlags = [AI_NUMERICHOST], addrFamily = AF_UNSPEC | ||
502 | -- , addrSocketType = NoSocketType, addrProtocol = 0 | ||
503 | -- , addrAddress = <assumed to be undefined> | ||
504 | -- , addrCanonName = <assumed to be undefined>} | ||
505 | -- , host name: Just "DdhbLjiwaV0GAiGKgesNPbvj2TbhrBHEWEEc5icfvQN.tox" | ||
506 | -- , service name: Just "0") | ||
507 | -- : does not exist (Name or service not known) | ||
508 | |||
484 | jids <- atomically $ do | 509 | jids <- atomically $ do |
485 | rbp <- readTVar (remotesByPeer state) | 510 | rbp <- readTVar (remotesByPeer state) |
486 | return $ do | 511 | return $ do |
487 | umap <- maybeToList $ Map.lookup k rbp | 512 | umap <- maybeToList $ Map.lookup k rbp |
488 | (u,rp) <- Map.toList umap | 513 | (u,rp) <- Map.toList umap |
489 | r <- Map.keys (resources rp) | 514 | r <- Map.keys (resources rp) |
490 | return $ unsplitJID (Just u, h, Just r) | 515 | let excludeEmpty "" = Nothing |
516 | excludeEmpty x = Just x | ||
517 | return $ unsplitJID (excludeEmpty u, h, excludeEmpty r) | ||
518 | -- EOF PEER PeerAddress [d768:82dd:3e86:a6ba:8fb3:6f9c:6327:75d8%4236342772]:0: | ||
519 | -- ["@[d768:82dd:3e86:a6ba:8fb3:6f9c:6327:75d8%4236342772]/"] | ||
520 | -- dput XJabber $ "EOF PEER "++show k++": "++show jids | ||
491 | forM_ jids $ \jid -> do | 521 | forM_ jids $ \jid -> do |
492 | stanza <- makePresenceStanza "jabber:client" (Just jid) Offline | 522 | stanza <- makePresenceStanza "jabber:client" (Just jid) Offline |
493 | informPeerPresence state k stanza | 523 | informPeerPresence state k stanza |
@@ -502,6 +532,9 @@ eofConn state saddr cdta = do | |||
502 | atomically $ do | 532 | atomically $ do |
503 | modifyTVar' (clientsByUser state) $ Map.alter (delclient k) (clientUser client) | 533 | modifyTVar' (clientsByUser state) $ Map.alter (delclient k) (clientUser client) |
504 | modifyTVar' (clientsByProfile state) $ Map.alter (delclient k) (clientProfile client) | 534 | modifyTVar' (clientsByProfile state) $ Map.alter (delclient k) (clientProfile client) |
535 | atomically $ case classifyConnection saddr cdta of | ||
536 | Left (pkey,_) -> modifyTVar' (pkeyToChan state) $ Map.delete pkey | ||
537 | Right (ckey,_) -> modifyTVar' (ckeyToChan state) $ Map.delete ckey | ||
505 | 538 | ||
506 | {- | 539 | {- |
507 | parseRemoteAddress :: Text -> IO (Maybe (Remote SockAddr)) | 540 | parseRemoteAddress :: Text -> IO (Maybe (Remote SockAddr)) |
@@ -594,8 +627,9 @@ deliverMessage state fail msg = | |||
594 | -- Case 1. Client -> Peer | 627 | -- Case 1. Client -> Peer |
595 | mto <- join $ atomically $ do | 628 | mto <- join $ atomically $ do |
596 | mclient <- Map.lookup senderk <$> readTVar (clients state) | 629 | mclient <- Map.lookup senderk <$> readTVar (clients state) |
597 | return | 630 | return $ do |
598 | $ fromMaybe -- Resolve XMPP peer. | 631 | dput XJabber $ "deliverMessage: to="++show (stanzaTo msg,fmap clientProfile mclient) |
632 | fromMaybe -- Resolve XMPP peer. | ||
599 | (fmap join $ mapM rewriteJIDForPeer (stanzaTo msg)) | 633 | (fmap join $ mapM rewriteJIDForPeer (stanzaTo msg)) |
600 | $ do | 634 | $ do |
601 | client <- mclient | 635 | client <- mclient |
@@ -603,6 +637,7 @@ deliverMessage state fail msg = | |||
603 | let (mu,th,rsc) = splitJID to | 637 | let (mu,th,rsc) = splitJID to |
604 | (toxman,me,_) <- weAreTox state client th | 638 | (toxman,me,_) <- weAreTox state client th |
605 | return $ do | 639 | return $ do |
640 | dput XJabber $ "deliverMessage: weAreTox="++show me | ||
606 | -- In case the client sends us a lower-cased version of the base64 | 641 | -- In case the client sends us a lower-cased version of the base64 |
607 | -- tox key hostname, we resolve it by comparing it with roster entries. | 642 | -- tox key hostname, we resolve it by comparing it with roster entries. |
608 | xs <- getBuddiesAndSolicited state (clientProfile client) $ \case | 643 | xs <- getBuddiesAndSolicited state (clientProfile client) $ \case |
@@ -637,7 +672,7 @@ deliverMessage state fail msg = | |||
637 | fail) | 672 | fail) |
638 | $ Map.lookup senderk pchans | 673 | $ Map.lookup senderk pchans |
639 | <&> \(Conn { connChan = sender_chan | 674 | <&> \(Conn { connChan = sender_chan |
640 | , auxData = ConnectionData (Left laddr) ctyp cprof }) -> do | 675 | , auxData = ConnectionData (Left laddr) ctyp cprof _ }) -> do |
641 | fromMaybe (do dput XJabber $ "Message missing \"to\" attribute." | 676 | fromMaybe (do dput XJabber $ "Message missing \"to\" attribute." |
642 | fail) | 677 | fail) |
643 | $ (stanzaTo msg) <&> \to -> do | 678 | $ (stanzaTo msg) <&> \to -> do |
@@ -777,7 +812,7 @@ informPeerPresence state k stanza = do | |||
777 | let (muser0,h,mresource0) = splitJID from | 812 | let (muser0,h,mresource0) = splitJID from |
778 | -- We'll allow the case that user and resource are simultaneously | 813 | -- We'll allow the case that user and resource are simultaneously |
779 | -- absent. They will be stored in the remotesByPeer map using the | 814 | -- absent. They will be stored in the remotesByPeer map using the |
780 | -- empty string. This is to accomodate the tox protocol which didn't | 815 | -- empty string. This is to accommodate the tox protocol which didn't |
781 | -- anticipate a single peer would have multiple users or front-ends. | 816 | -- anticipate a single peer would have multiple users or front-ends. |
782 | (muser,mresource) = case (muser0,mresource0) of | 817 | (muser,mresource) = case (muser0,mresource0) of |
783 | (Nothing,Nothing) -> (Just "", Just "") | 818 | (Nothing,Nothing) -> (Just "", Just "") |
@@ -826,14 +861,16 @@ informPeerPresence state k stanza = do | |||
826 | (ctyp,cprof) <- atomically $ do | 861 | (ctyp,cprof) <- atomically $ do |
827 | mconn <- Map.lookup k <$> readTVar (pkeyToChan state) | 862 | mconn <- Map.lookup k <$> readTVar (pkeyToChan state) |
828 | return $ fromMaybe (XMPP,".") $ do | 863 | return $ fromMaybe (XMPP,".") $ do |
829 | ConnectionData _ ctyp cprof <- auxData <$> mconn | 864 | ConnectionData _ ctyp cprof _ <- auxData <$> mconn |
830 | return (ctyp,cprof) | 865 | return (ctyp,cprof) |
831 | forM_ clients $ \(ck,con,client) -> do | 866 | forM_ clients $ \(ck,con,client) -> do |
832 | -- (TODO: appropriately authorized clients only.) | 867 | -- (TODO: appropriately authorized clients only.) |
833 | -- For now, all "available" clients (available = sent initial presence) | 868 | -- For now, all "available" clients (available = sent initial presence) |
834 | is_avail <- atomically $ clientIsAvailable client | 869 | is_avail <- atomically $ clientIsAvailable client |
835 | when is_avail $ do | 870 | when is_avail $ do |
836 | dput XJabber $ "reversing for client: " ++ show from | 871 | -- reversing for client: ("DdhbLjiwaV0GAiGKgesNPbvj2TbhrBHEWEEc5icfvQN.tox" |
872 | -- ,XMPP,"OrjBG.GyWuQhGc1pb0KssgmYAocohFh35Vx8mREC9Nu.tox",".") | ||
873 | dput XJabber $ "reversing for client: " ++ show (from,ctyp,clientProfile client,cprof) | ||
837 | froms <- case ctyp of | 874 | froms <- case ctyp of |
838 | Tox | clientProfile client == cprof -> return [from] | 875 | Tox | clientProfile client == cprof -> return [from] |
839 | _ -> do -- flip (maybe $ return [from]) k . const $ do | 876 | _ -> do -- flip (maybe $ return [from]) k . const $ do |
@@ -1030,7 +1067,7 @@ clientSubscriptionRequest :: PresenceState -> IO () -> ClientAddress -> Stanza - | |||
1030 | clientSubscriptionRequest state fail k stanza chan = do | 1067 | clientSubscriptionRequest state fail k stanza chan = do |
1031 | forClient state k fail $ \client -> do | 1068 | forClient state k fail $ \client -> do |
1032 | fromMaybe fail $ (splitJID <$> stanzaTo stanza) <&> \(mu,h,_) -> do | 1069 | fromMaybe fail $ (splitJID <$> stanzaTo stanza) <&> \(mu,h,_) -> do |
1033 | dput XJabber $ "Forwarding solictation to peer" | 1070 | dput XJabber $ "Forwarding solicitation to peer" |
1034 | let to0 = unsplitJID (mu,h,Nothing) -- deleted resource | 1071 | let to0 = unsplitJID (mu,h,Nothing) -- deleted resource |
1035 | cuser = clientUser client | 1072 | cuser = clientUser client |
1036 | cprof = clientProfile client | 1073 | cprof = clientProfile client |
@@ -1166,7 +1203,7 @@ peerSubscriptionRequest state fail k stanza chan = do | |||
1166 | cmap <- readTVar (clients state) | 1203 | cmap <- readTVar (clients state) |
1167 | return (pktc,cktc,cmap) | 1204 | return (pktc,cktc,cmap) |
1168 | fromMaybe fail $ (Map.lookup k pktc) | 1205 | fromMaybe fail $ (Map.lookup k pktc) |
1169 | <&> \Conn { auxData=ConnectionData (Left laddr) ctyp profile } -> do | 1206 | <&> \Conn { auxData=ConnectionData (Left laddr) ctyp profile _ } -> do |
1170 | (mine,totup) <- case (ctyp,profile) of | 1207 | (mine,totup) <- case (ctyp,profile) of |
1171 | (Tox,p) -> let (u,h,r) = splitJID to | 1208 | (Tox,p) -> let (u,h,r) = splitJID to |
1172 | in return ( h == p, (u,h,r) ) | 1209 | in return ( h == p, (u,h,r) ) |
@@ -1314,7 +1351,7 @@ peerInformSubscription state fail k stanza = do | |||
1314 | return (pktc,cktc,cmap) | 1351 | return (pktc,cktc,cmap) |
1315 | fromMaybe fail $ Map.lookup k ktc | 1352 | fromMaybe fail $ Map.lookup k ktc |
1316 | <&> \(Conn { connChan=sender_chan | 1353 | <&> \(Conn { connChan=sender_chan |
1317 | , auxData =ConnectionData (Left laddr) ctyp profile}) -> do | 1354 | , auxData =ConnectionData (Left laddr) ctyp profile _ }) -> do |
1318 | (from_u,from_h,_) <- case ctyp of | 1355 | (from_u,from_h,_) <- case ctyp of |
1319 | Tox -> return $ splitJID from | 1356 | Tox -> return $ splitJID from |
1320 | XMPP -> snd <$> rewriteJIDForClient laddr from [] | 1357 | XMPP -> snd <$> rewriteJIDForClient laddr from [] |
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs index ae861a61..0d2d479b 100644 --- a/Presence/XMPPServer.hs +++ b/Presence/XMPPServer.hs | |||
@@ -42,6 +42,8 @@ module XMPPServer | |||
42 | , greet' | 42 | , greet' |
43 | , (<&>) | 43 | , (<&>) |
44 | , grokStanza | 44 | , grokStanza |
45 | , Uniq24(..) | ||
46 | , uniqueAsKey | ||
45 | ) where | 47 | ) where |
46 | 48 | ||
47 | import ConnectionKey | 49 | import ConnectionKey |
@@ -56,6 +58,8 @@ import qualified Connection | |||
56 | import Util | 58 | import Util |
57 | import Network.Address (getBindAddress, sockAddrPort) | 59 | import Network.Address (getBindAddress, sockAddrPort) |
58 | 60 | ||
61 | import Data.Bits | ||
62 | import Data.Word | ||
59 | import Debug.Trace | 63 | import Debug.Trace |
60 | import Control.Monad.Trans (lift) | 64 | import Control.Monad.Trans (lift) |
61 | import Control.Monad.IO.Class (MonadIO, liftIO) | 65 | import Control.Monad.IO.Class (MonadIO, liftIO) |
@@ -908,7 +912,7 @@ makePong namespace mid to from = | |||
908 | 912 | ||
909 | data ClientOrPeer = IsClient | IsPeer | 913 | data ClientOrPeer = IsClient | IsPeer |
910 | 914 | ||
911 | xmppInbound :: Server SockAddr ConnectionData releaseKey XML.Event -- ^ XXX: unused | 915 | xmppInbound :: ConnectionData |
912 | -> XMPPServerParameters -- ^ XXX: unused | 916 | -> XMPPServerParameters -- ^ XXX: unused |
913 | -> (Text, IO Text, IO Text, TChan Stanza -> StanzaOrigin) | 917 | -> (Text, IO Text, IO Text, TChan Stanza -> StanzaOrigin) |
914 | -> FlagCommand -- ^ action to check whether the connection needs a ping (XXX: unused) | 918 | -> FlagCommand -- ^ action to check whether the connection needs a ping (XXX: unused) |
@@ -916,14 +920,16 @@ xmppInbound :: Server SockAddr ConnectionData releaseKey XML.Event -- ^ XXX: unu | |||
916 | -> TChan Stanza -- ^ channel used to send stanzas | 920 | -> TChan Stanza -- ^ channel used to send stanzas |
917 | -> TMVar () -- ^ mvar that is filled when the connection quits | 921 | -> TMVar () -- ^ mvar that is filled when the connection quits |
918 | -> ConduitM Event o IO () | 922 | -> ConduitM Event o IO () |
919 | xmppInbound sv xmpp (namespace,tellmyname,tellyourname,mkorigin) pingflag stanzas output donevar = doNestingXML $ do | 923 | xmppInbound cdta xmpp (namespace,tellmyname,tellyourname,mkorigin) pingflag stanzas output donevar = doNestingXML $ do |
920 | withXML $ \begindoc -> do | 924 | withXML $ \begindoc -> do |
921 | when (begindoc==EventBeginDocument) $ do | 925 | when (begindoc==EventBeginDocument) $ do |
922 | whenJust nextElement $ \xml -> do | 926 | whenJust nextElement $ \xml -> do |
923 | withJust (elementAttrs "stream" xml) $ \stream_attrs -> do | 927 | withJust (elementAttrs "stream" xml) $ \stream_attrs -> do |
924 | -- liftIO $ dput XMisc $ "STREAM ATTRS "++show stream_attrs | 928 | -- liftIO $ dput XMisc $ "STREAM ATTRS "++show stream_attrs |
925 | let stream_name = lookupAttrib "to" stream_attrs | 929 | let stream_name = lookupAttrib "to" stream_attrs |
930 | stream_remote = lookupAttrib "from" stream_attrs | ||
926 | -- xmpp_version = lookupAttrib "version" stream_attrs | 931 | -- xmpp_version = lookupAttrib "version" stream_attrs |
932 | liftIO $ atomically $ writeTVar (cdRemoteName cdta) stream_remote | ||
927 | fix $ \loop -> do | 933 | fix $ \loop -> do |
928 | -- liftIO . wlog $ "waiting for stanza." | 934 | -- liftIO . wlog $ "waiting for stanza." |
929 | (chan,clsrs) <- liftIO . atomically $ | 935 | (chan,clsrs) <- liftIO . atomically $ |
@@ -1282,13 +1288,25 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas = do | |||
1282 | let lbl n = concat [ n | 1288 | let lbl n = concat [ n |
1283 | , Text.unpack (Text.drop 7 namespace) | 1289 | , Text.unpack (Text.drop 7 namespace) |
1284 | , "." | 1290 | , "." |
1285 | , show saddr ] | 1291 | , case cdProfile cdta of |
1286 | forkIO $ do myThreadId >>= flip labelThread (lbl "post-queue.") | 1292 | _ | Right _ <- cdAddr cdta -> show saddr |
1293 | "." -> show saddr | ||
1294 | mytoxname -> show saddr {- TODO: remote tox peer name? -} ] | ||
1295 | |||
1296 | forkIO $ do myThreadId >>= flip labelThread (lbl "xmpp-post.") | ||
1297 | -- This thread handles messages after they are pulled out of | ||
1298 | -- the slots-queue. Hence, xmpp-post, for post- slots-queue. | ||
1299 | |||
1300 | -- Read all slots-queued XML events or stanzas and yield them | ||
1301 | -- upstream. This should continue until the connection is | ||
1302 | -- closed. | ||
1287 | (greet_src >> slot_src) $$ snk | 1303 | (greet_src >> slot_src) $$ snk |
1304 | |||
1305 | -- Connection is now closed. Here we handle any unsent stanzas. | ||
1288 | last <- atomically $ readTVar lastStanza | 1306 | last <- atomically $ readTVar lastStanza |
1289 | es <- while (atomically . fmap not $ Slotted.isEmpty slots) | 1307 | es <- while (atomically . fmap not $ Slotted.isEmpty slots) |
1290 | (atomically . Slotted.pull $ slots) | 1308 | (atomically . Slotted.pull $ slots) |
1291 | let es' = mapMaybe metadata es | 1309 | let es' = mapMaybe metadata es -- We only care about full stanzas. |
1292 | metadata (Left s) = Just s | 1310 | metadata (Left s) = Just s |
1293 | metadata _ = Nothing | 1311 | metadata _ = Nothing |
1294 | -- TODO: Issuing RecipientUnavailable for all errors is a presence leak | 1312 | -- TODO: Issuing RecipientUnavailable for all errors is a presence leak |
@@ -1304,17 +1322,21 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas = do | |||
1304 | xmppDeliverMessage xmpp (wlog $ "discarded error delivery fail") replystanza | 1322 | xmppDeliverMessage xmpp (wlog $ "discarded error delivery fail") replystanza |
1305 | notError s = case stanzaType s of | 1323 | notError s = case stanzaType s of |
1306 | Error {} -> False | 1324 | Error {} -> False |
1307 | _ -> True | 1325 | _ -> True |
1308 | -- TODO: Probably some stanzas should be queued or saved for re-connect. | 1326 | -- TODO: Probably some stanzas should be queued or saved for re-connect. |
1309 | mapM_ fail $ filter notError (maybeToList last ++ es') | 1327 | mapM_ fail $ filter notError (maybeToList last ++ es') |
1310 | wlog $ "end post-queue fork: " ++ (lbl "") | 1328 | wlog $ "end xmpp-post fork: " ++ (lbl "") |
1311 | 1329 | ||
1312 | output <- atomically newTChan | 1330 | output <- atomically newTChan |
1313 | hacks <- atomically $ newTVar Map.empty | 1331 | hacks <- atomically $ newTVar Map.empty |
1314 | msgids <- atomically $ newTVar [] | 1332 | msgids <- atomically $ newTVar [] |
1315 | forkIO $ do | 1333 | forkIO $ do |
1334 | -- Here is the pre- slots-queue thread which handles messages as they | ||
1335 | -- arrive and assigns slots to them if that is appropriate. | ||
1336 | |||
1316 | -- mapM_ (atomically . Slotted.push slots Nothing) greetPeer | 1337 | -- mapM_ (atomically . Slotted.push slots Nothing) greetPeer |
1317 | myThreadId >>= flip labelThread (lbl "pre-queue.") | 1338 | myThreadId >>= flip labelThread (lbl "xmpp-pre.") |
1339 | |||
1318 | verbosity <- xmppVerbosity xmpp | 1340 | verbosity <- xmppVerbosity xmpp |
1319 | fix $ \loop -> do | 1341 | fix $ \loop -> do |
1320 | what <- atomically $ foldr1 orElse | 1342 | what <- atomically $ foldr1 orElse |
@@ -1385,11 +1407,11 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas = do | |||
1385 | ,readTMVar rdone >> return (return ()) | 1407 | ,readTMVar rdone >> return (return ()) |
1386 | ] | 1408 | ] |
1387 | what | 1409 | what |
1388 | wlog $ "end pre-queue fork: " ++ show (lbl "") | 1410 | wlog $ "end xmpp-pre fork: " ++ show (lbl "") |
1389 | forkIO $ do | 1411 | forkIO $ do |
1390 | myThreadId >>= flip labelThread (lbl "reader.") | 1412 | myThreadId >>= flip labelThread (lbl "reader.") |
1391 | -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show) | 1413 | -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show) |
1392 | src $$ xmppInbound sv xmpp clientOrServer pingflag stanzas output rdone | 1414 | src $$ xmppInbound cdta xmpp clientOrServer pingflag stanzas output rdone |
1393 | atomically $ putTMVar rdone () | 1415 | atomically $ putTMVar rdone () |
1394 | wlog $ "end reader fork: " ++ lbl "" | 1416 | wlog $ "end reader fork: " ++ lbl "" |
1395 | return output | 1417 | return output |
@@ -1413,20 +1435,48 @@ peerKey bind_addr sock = do | |||
1413 | if c then getPeerName sock -- addr is normally socketName | 1435 | if c then getPeerName sock -- addr is normally socketName |
1414 | else return laddr -- Weird hack: addr is would-be peer name | 1436 | else return laddr -- Weird hack: addr is would-be peer name |
1415 | -- Assume remote peers are listening on the same port that we do. | 1437 | -- Assume remote peers are listening on the same port that we do. |
1416 | let peerport = fromIntegral $ fromMaybe 5269 $ bind_addr >>= sockAddrPort | 1438 | let peerport = fromIntegral $ fromMaybe 5269 $ do |
1439 | p <- bind_addr >>= sockAddrPort | ||
1440 | guard (p /= 0) -- Make sure we never use port 0 because it is used | ||
1441 | -- to distinguish fake address connection keys. | ||
1442 | return p | ||
1443 | rname <- atomically $ newTVar Nothing | ||
1417 | return $ ( raddr `withPort` peerport | 1444 | return $ ( raddr `withPort` peerport |
1418 | , ConnectionData { cdAddr = Left (Local laddr) | 1445 | , ConnectionData { cdAddr = Left (Local laddr) |
1419 | , cdType = XMPP | 1446 | , cdType = XMPP |
1420 | , cdProfile = "." } ) | 1447 | , cdProfile = "." |
1448 | , cdRemoteName = rname } ) | ||
1421 | 1449 | ||
1422 | clientKey :: SocketLike sock => sock -> IO (SockAddr,ConnectionData) | 1450 | clientKey :: SocketLike sock => sock -> IO (SockAddr,ConnectionData) |
1423 | clientKey sock = do | 1451 | clientKey sock = do |
1424 | laddr <- getSocketName sock | 1452 | laddr <- getSocketName sock |
1425 | raddr <- getPeerName sock | 1453 | raddr <- getPeerName sock |
1454 | when (Just 0 == sockAddrPort laddr) $ do | ||
1455 | dput XMan $ unwords [ "BUG: XMPP Client" | ||
1456 | , show (laddr,raddr) | ||
1457 | , "is using port zero. This could interfere" | ||
1458 | , "with Tox peer sessions." ] | ||
1459 | rname <- atomically $ newTVar Nothing | ||
1426 | return $ ( laddr | 1460 | return $ ( laddr |
1427 | , ConnectionData { cdAddr = Right (Remote raddr) | 1461 | , ConnectionData { cdAddr = Right (Remote raddr) |
1428 | , cdType = XMPP | 1462 | , cdType = XMPP |
1429 | , cdProfile = "." } ) | 1463 | , cdProfile = "." |
1464 | , cdRemoteName = rname } ) | ||
1465 | |||
1466 | |||
1467 | data Uniq24 = Uniq24 !Word64 !Word64 !Word64 | ||
1468 | deriving (Eq,Ord,Show) | ||
1469 | |||
1470 | uniqueAsKey :: Uniq24 -> SockAddr | ||
1471 | uniqueAsKey (Uniq24 x y z) = SockAddrInet6 (fromIntegral 0) a bcde f | ||
1472 | where | ||
1473 | a = fromIntegral (x `shiftR` 32) | ||
1474 | b = fromIntegral x | ||
1475 | c = fromIntegral (y `shiftR` 32) | ||
1476 | d = fromIntegral y | ||
1477 | e = fromIntegral (z `shiftR` 32) | ||
1478 | f = fromIntegral z | ||
1479 | bcde = (b,c,d,e) | ||
1430 | 1480 | ||
1431 | xmlifyRosterItems :: Monad m => Set Text -> Text -> Set Text -> ConduitM i Event m () | 1481 | xmlifyRosterItems :: Monad m => Set Text -> Text -> Set Text -> ConduitM i Event m () |
1432 | xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set) | 1482 | xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set) |
@@ -1840,9 +1890,13 @@ data ConnectionData = ConnectionData | |||
1840 | , cdProfile :: Text -- Currently ignored for clients. Instead, see | 1890 | , cdProfile :: Text -- Currently ignored for clients. Instead, see |
1841 | -- 'clientProfile' field of 'ClientState'. | 1891 | -- 'clientProfile' field of 'ClientState'. |
1842 | -- | 1892 | -- |
1843 | -- For peers: "." for XMPP, otherwise the ".tox" hostname. | 1893 | -- For peers: "." for XMPP, otherwise the ".tox" hostname |
1894 | -- of this local node. | ||
1895 | |||
1896 | -- Initially Nothing, when the remote end identifies itself by a given name, | ||
1897 | -- the result will be stored here. | ||
1898 | , cdRemoteName :: TVar (Maybe Text) | ||
1844 | } | 1899 | } |
1845 | deriving (Eq,Ord,Show) | ||
1846 | 1900 | ||
1847 | addrToPeerKey :: Remote SockAddr -> PeerAddress | 1901 | addrToPeerKey :: Remote SockAddr -> PeerAddress |
1848 | addrToPeerKey (Remote raddr) = PeerAddress raddr | 1902 | addrToPeerKey (Remote raddr) = PeerAddress raddr |