summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2014-03-10 22:44:21 -0400
committerjoe <joe@jerkface.net>2014-03-10 22:44:21 -0400
commite0869b7109ac5cb8902e0718c315869e3f135866 (patch)
tree322f9df827f9aaafe9c51b54f3a0f095dbb250ba
parent6725df5d9a557e7086fa0e6dfaf282768876e1e1 (diff)
prefer roster-name to canonical name if possible.
-rw-r--r--Presence/XMPPServer.hs16
-rw-r--r--xmppServer.hs38
2 files changed, 29 insertions, 25 deletions
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 9059a4c0..efd865d8 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -16,8 +16,6 @@ module XMPPServer
16 , cloneStanza 16 , cloneStanza
17 , LangSpecificMessage(..) 17 , LangSpecificMessage(..)
18 , peerKeyToText 18 , peerKeyToText
19 , peerKeyToResolvedName
20 , peerKeyToResolvedNames
21 , addrToText 19 , addrToText
22 , sendModifiedStanzaToPeer 20 , sendModifiedStanzaToPeer
23 , sendModifiedStanzaToClient 21 , sendModifiedStanzaToClient
@@ -185,7 +183,7 @@ data XMPPServerParameters =
185 , xmppRosterOthers :: ConnectionKey -> IO [Text] 183 , xmppRosterOthers :: ConnectionKey -> IO [Text]
186 , xmppSubscribeToRoster :: ConnectionKey -> IO () 184 , xmppSubscribeToRoster :: ConnectionKey -> IO ()
187 -- , xmppLookupClientJID :: ConnectionKey -> IO Text 185 -- , xmppLookupClientJID :: ConnectionKey -> IO Text
188 , xmppTellClientNameOfPeer :: ConnectionKey -> IO Text 186 , xmppTellClientNameOfPeer :: ConnectionKey -> [Text] -> IO Text
189 , xmppDeliverMessage :: (IO ()) -> Stanza -> IO () 187 , xmppDeliverMessage :: (IO ()) -> Stanza -> IO ()
190 , xmppInformClientPresence :: ConnectionKey -> Stanza -> IO () 188 , xmppInformClientPresence :: ConnectionKey -> Stanza -> IO ()
191 , xmppInformPeerPresence :: ConnectionKey -> Stanza -> IO () 189 , xmppInformPeerPresence :: ConnectionKey -> Stanza -> IO ()
@@ -240,12 +238,6 @@ peerKeyToText :: ConnectionKey -> Text
240peerKeyToText (PeerKey { callBackAddress=addr }) = addrToText addr 238peerKeyToText (PeerKey { callBackAddress=addr }) = addrToText addr
241peerKeyToText (ClientKey { localAddress=addr }) = "ErrorClIeNt0" 239peerKeyToText (ClientKey { localAddress=addr }) = "ErrorClIeNt0"
242 240
243peerKeyToResolvedName :: ConnectionKey -> IO Text
244peerKeyToResolvedName k@(ClientKey { localAddress=addr }) = return "ErrorClIeNt1"
245peerKeyToResolvedName pk = do
246 ns <- peerKeyToResolvedNames pk
247 return $ maybe (peerKeyToText pk) id (listToMaybe ns)
248
249 241
250wlog :: String -> IO () 242wlog :: String -> IO ()
251wlog s = putStrLn s >> hFlush stdout 243wlog s = putStrLn s >> hFlush stdout
@@ -1343,9 +1335,6 @@ sendRoster query xmpp replyto = do
1343 NetworkOrigin k _ -> Just k 1335 NetworkOrigin k _ -> Just k
1344 LocalPeer -> Nothing -- local peer requested roster? 1336 LocalPeer -> Nothing -- local peer requested roster?
1345 flip (maybe $ return ()) k $ \k -> do 1337 flip (maybe $ return ()) k $ \k -> do
1346 jid <- case k of
1347 ClientKey {} -> xmppTellClientHisName xmpp k -- LookupClientJID xmpp k
1348 PeerKey {} -> xmppTellClientNameOfPeer xmpp k
1349 hostname <- xmppTellMyNameToClient xmpp 1338 hostname <- xmppTellMyNameToClient xmpp
1350 let getlist f = do 1339 let getlist f = do
1351 bs <- f xmpp k 1340 bs <- f xmpp k
@@ -1354,6 +1343,9 @@ sendRoster query xmpp replyto = do
1354 subscribers <- getlist xmppRosterSubscribers 1343 subscribers <- getlist xmppRosterSubscribers
1355 solicited <- getlist xmppRosterSolicited 1344 solicited <- getlist xmppRosterSolicited
1356 subnone0 <- getlist xmppRosterOthers 1345 subnone0 <- getlist xmppRosterOthers
1346 jid <- case k of
1347 ClientKey {} -> xmppTellClientHisName xmpp k -- LookupClientJID xmpp k
1348 PeerKey {} -> xmppTellClientNameOfPeer xmpp k (Set.toList buddies)
1357 let subnone = Set.union solicited subnone0 \\ Set.union buddies subscribers 1349 let subnone = Set.union solicited subnone0 \\ Set.union buddies subscribers
1358 let subto = buddies \\ subscribers 1350 let subto = buddies \\ subscribers
1359 let subfrom = subscribers \\ buddies 1351 let subfrom = subscribers \\ buddies
diff --git a/xmppServer.hs b/xmppServer.hs
index f7f7fb36..babde683 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -9,7 +9,8 @@ import Control.Monad.Trans
9import Control.Monad.IO.Class (MonadIO, liftIO) 9import Control.Monad.IO.Class (MonadIO, liftIO)
10import Network.Socket ( SockAddr(..) ) 10import Network.Socket ( SockAddr(..) )
11import System.Endian (fromBE32) 11import System.Endian (fromBE32)
12import Data.List (nub, (\\), intersect, groupBy, sort ) 12import Data.List (nub, (\\), intersect, groupBy, sort, sortBy )
13import Data.Ord (comparing )
13import Data.Monoid ( (<>) ) 14import Data.Monoid ( (<>) )
14import qualified Data.Text as Text 15import qualified Data.Text as Text
15import qualified Data.Text.IO as Text 16import qualified Data.Text.IO as Text
@@ -351,18 +352,28 @@ withPort (SockAddrInet6 _ a b c) port = SockAddrInet6 (toEnum port) a b c
351-- came in on. The returned JID parts are suitable for unsplitJID to create a 352-- came in on. The returned JID parts are suitable for unsplitJID to create a
352-- valid JID for communicating to a client. The returned Bool is True when the 353-- valid JID for communicating to a client. The returned Bool is True when the
353-- host part refers to this local host (i.e. it equals the given SockAddr). 354-- host part refers to this local host (i.e. it equals the given SockAddr).
354rewriteJIDForClient :: SockAddr -> Text -> IO (Bool,(Maybe Text,Text,Maybe Text)) 355-- If there are multiple results, it will prefer one which is a member of the
355rewriteJIDForClient laddr jid = do 356-- given list in the last argument.
357rewriteJIDForClient :: SockAddr -> Text -> [Text] -> IO (Bool,(Maybe Text,Text,Maybe Text))
358rewriteJIDForClient laddr jid buds = do
356 let (n,h,r) = splitJID jid 359 let (n,h,r) = splitJID jid
357 maddr <- parseAddress (strip_brackets h) 360 maddr <- parseAddress (strip_brackets h)
358 flip (maybe $ return (False,(n,ip6literal h,r))) maddr $ \addr -> do 361 flip (maybe $ return (False,(n,ip6literal h,r))) maddr $ \addr -> do
359 let mine = laddr `withPort` 0 == addr `withPort` 0 362 let mine = laddr `withPort` 0 == addr `withPort` 0
360 h' <- if mine then textHostName 363 h' <- if mine then textHostName
361 else peerKeyToResolvedName (PeerKey addr) 364 else peerKeyToResolvedName buds (PeerKey addr)
362 return (mine,(n,h',r)) 365 return (mine,(n,h',r))
363 366
364sameAddress laddr addr = laddr `withPort` 0 == addr `withPort` 0 367sameAddress laddr addr = laddr `withPort` 0 == addr `withPort` 0
365 368
369peerKeyToResolvedName :: [Text] -> ConnectionKey -> IO Text
370peerKeyToResolvedName buds k@(ClientKey { localAddress=addr }) = return "ErrorClIeNt1"
371peerKeyToResolvedName buds pk = do
372 ns <- peerKeyToResolvedNames pk
373 let ns' = sortBy (comparing $ not . flip elem buds) ns
374 return $ maybe (peerKeyToText pk) id (listToMaybe ns')
375
376
366multiplyJIDForClient :: SockAddr -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)]) 377multiplyJIDForClient :: SockAddr -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)])
367multiplyJIDForClient laddr jid = do 378multiplyJIDForClient laddr jid = do
368 let (n,h,r) = splitJID jid 379 let (n,h,r) = splitJID jid
@@ -427,16 +438,17 @@ deliverMessage state fail msg =
427 $ \(Conn { connChan=sender_chan 438 $ \(Conn { connChan=sender_chan
428 , auxAddr=laddr }) -> do 439 , auxAddr=laddr }) -> do
429 flip (maybe fail) (stanzaTo msg) $ \to -> do 440 flip (maybe fail) (stanzaTo msg) $ \to -> do
430 (mine,(n,h,r)) <- rewriteJIDForClient laddr to 441 (mine,(n,h,r)) <- rewriteJIDForClient laddr to []
431 if not mine then fail else do 442 if not mine then fail else do
432 let to' = unsplitJID (n,h,r) 443 let to' = unsplitJID (n,h,r)
433 from' <- do
434 flip (maybe $ return Nothing) (stanzaFrom msg) $ \from -> do
435 (_,trip) <- rewriteJIDForClient laddr from
436 return . Just $ unsplitJID trip
437 cmap <- atomically . readTVar $ clientsByUser state 444 cmap <- atomically . readTVar $ clientsByUser state
438 flip (maybe fail) n $ \n -> do 445 flip (maybe fail) n $ \n -> do
439 flip (maybe fail) (Map.lookup n cmap) $ \presence_container -> do 446 flip (maybe fail) (Map.lookup n cmap) $ \presence_container -> do
447 buds <- configText ConfigFiles.getBuddies n
448 from' <- do
449 flip (maybe $ return Nothing) (stanzaFrom msg) $ \from -> do
450 (_,trip) <- rewriteJIDForClient laddr from [] -- XXX
451 return . Just $ unsplitJID trip
440 let ks = Map.keys (networkClients presence_container) 452 let ks = Map.keys (networkClients presence_container)
441 chans = mapMaybe (flip Map.lookup key_to_chan) ks 453 chans = mapMaybe (flip Map.lookup key_to_chan) ks
442 if null chans then fail else do 454 if null chans then fail else do
@@ -767,9 +779,9 @@ peerSubscriptionRequest state fail k stanza chan = do
767 ktc <- atomically . readTVar $ keyToChan state 779 ktc <- atomically . readTVar $ keyToChan state
768 flip (maybe fail) (Map.lookup k ktc) 780 flip (maybe fail) (Map.lookup k ktc)
769 $ \Conn { auxAddr=laddr } -> do 781 $ \Conn { auxAddr=laddr } -> do
770 (mine,totup) <- rewriteJIDForClient laddr to 782 (mine,totup) <- rewriteJIDForClient laddr to []
771 if not mine then fail else do 783 if not mine then fail else do
772 (_,fromtup) <- rewriteJIDForClient laddr from 784 (_,fromtup) <- rewriteJIDForClient laddr from []
773 flip (maybe fail) mto_u $ \u -> do 785 flip (maybe fail) mto_u $ \u -> do
774 flip (maybe fail) mfrom_u $ \from_u -> do 786 flip (maybe fail) mfrom_u $ \from_u -> do
775 resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u 787 resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u
@@ -890,7 +902,7 @@ peerInformSubscription state fail k stanza = do
890 flip (maybe fail) (Map.lookup k ktc) 902 flip (maybe fail) (Map.lookup k ktc)
891 $ \(Conn { connChan=sender_chan 903 $ \(Conn { connChan=sender_chan
892 , auxAddr=laddr }) -> do 904 , auxAddr=laddr }) -> do
893 (_,(from_u,from_h,_)) <- rewriteJIDForClient laddr from 905 (_,(from_u,from_h,_)) <- rewriteJIDForClient laddr from []
894 let from'' = unsplitJID (from_u,from_h,Nothing) 906 let from'' = unsplitJID (from_u,from_h,Nothing)
895 muser = do 907 muser = do
896 to <- stanzaTo stanza 908 to <- stanzaTo stanza
@@ -955,7 +967,7 @@ main = runResourceT $ do
955 , xmppTellMyNameToClient = textHostName 967 , xmppTellMyNameToClient = textHostName
956 , xmppTellMyNameToPeer = \addr -> return $ addrToText addr 968 , xmppTellMyNameToPeer = \addr -> return $ addrToText addr
957 , xmppTellPeerHisName = return . peerKeyToText 969 , xmppTellPeerHisName = return . peerKeyToText
958 , xmppTellClientNameOfPeer = peerKeyToResolvedName 970 , xmppTellClientNameOfPeer = flip peerKeyToResolvedName
959 , xmppNewConnection = newConn state 971 , xmppNewConnection = newConn state
960 , xmppEOF = eofConn state 972 , xmppEOF = eofConn state
961 , xmppRosterBuddies = rosterGetBuddies state 973 , xmppRosterBuddies = rosterGetBuddies state