summaryrefslogtreecommitdiff
path: root/Presence/Presence.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Presence/Presence.hs')
-rw-r--r--Presence/Presence.hs258
1 files changed, 135 insertions, 123 deletions
diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index fad87aeb..98d701e9 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -39,17 +39,18 @@ import Control.Applicative
39import Crypto.PubKey.Curve25519 (SecretKey,toPublic) 39import Crypto.PubKey.Curve25519 (SecretKey,toPublic)
40 40
41import ControlMaybe 41import ControlMaybe
42import DNSCache (parseAddress, strip_brackets, withPort)
42import LockedChan (LockedChan) 43import LockedChan (LockedChan)
43import Text.Read (readMaybe) 44import Text.Read (readMaybe)
44import TraversableT 45import TraversableT
45import UTmp (ProcessID,users) 46import UTmp (ProcessID,users)
46import LocalPeerCred 47import LocalPeerCred
47import XMPPServer 48import XMPPServer
48import PeerResolve
49import ConsoleWriter 49import ConsoleWriter
50import ClientState 50import ClientState
51import Util 51import Util
52import qualified Connection 52import qualified Connection
53 ;import Connection (PeerAddress (..), resolvePeer, reverseAddress)
53import Network.Tox.NodeId (key2id,parseNoSpamId,nospam64,NoSpamId(..),ToxProgress,ToxContact(..)) 54import Network.Tox.NodeId (key2id,parseNoSpamId,nospam64,NoSpamId(..),ToxProgress,ToxContact(..))
54import Crypto.Tox (decodeSecret) 55import Crypto.Tox (decodeSecret)
55import DPut 56import DPut
@@ -88,13 +89,16 @@ data ToxManager k = ToxManager
88 , resolveToxPeer :: Text -> Text -> IO (Maybe PeerAddress) 89 , resolveToxPeer :: Text -> Text -> IO (Maybe PeerAddress)
89 } 90 }
90 91
91data PresenceState = forall status. PresenceState 92type ClientProfile = Text
93
94data PresenceState status = PresenceState
92 { clients :: TVar (Map ClientAddress ClientState) 95 { clients :: TVar (Map ClientAddress ClientState)
93 , clientsByUser :: TVar (Map Text LocalPresence) 96 , clientsByUser :: TVar (Map Text LocalPresence)
94 , clientsByProfile :: TVar (Map Text LocalPresence) 97 , clientsByProfile :: TVar (Map Text LocalPresence)
95 , remotesByPeer :: TVar (Map PeerAddress 98 , remotesByPeer :: TVar (Map PeerAddress
96 (Map UserName RemotePresence)) 99 (Map UserName RemotePresence))
97 , server :: TMVar (XMPPServer, Connection.Manager status Text) 100 , server :: XMPPServer
101 , manager :: ClientProfile -> Connection.Manager status Text
98 , ckeyToChan :: TVar (Map ClientAddress Conn) 102 , ckeyToChan :: TVar (Map ClientAddress Conn)
99 , pkeyToChan :: TVar (Map PeerAddress Conn) 103 , pkeyToChan :: TVar (Map PeerAddress Conn)
100 , consoleWriter :: Maybe ConsoleWriter 104 , consoleWriter :: Maybe ConsoleWriter
@@ -103,10 +107,11 @@ data PresenceState = forall status. PresenceState
103 107
104 108
105newPresenceState :: Maybe ConsoleWriter 109newPresenceState :: Maybe ConsoleWriter
106 -> Maybe (PresenceState -> ToxManager ClientAddress) 110 -> Maybe (PresenceState status -> ToxManager ClientAddress)
107 -> TMVar (XMPPServer, Connection.Manager status Text) 111 -> XMPPServer
108 -> IO PresenceState 112 -> (ClientProfile -> Connection.Manager status Text)
109newPresenceState cw toxman xmpp = atomically $ do 113 -> IO (PresenceState status)
114newPresenceState cw toxman sv man = atomically $ do
110 clients <- newTVar Map.empty 115 clients <- newTVar Map.empty
111 clientsByUser <- newTVar Map.empty 116 clientsByUser <- newTVar Map.empty
112 clientsByProfile <- newTVar Map.empty 117 clientsByProfile <- newTVar Map.empty
@@ -120,14 +125,15 @@ newPresenceState cw toxman xmpp = atomically $ do
120 , remotesByPeer = remotesByPeer 125 , remotesByPeer = remotesByPeer
121 , ckeyToChan = ckeyToChan 126 , ckeyToChan = ckeyToChan
122 , pkeyToChan = pkeyToChan 127 , pkeyToChan = pkeyToChan
123 , server = xmpp 128 , server = sv
129 , manager = man
124 , consoleWriter = cw 130 , consoleWriter = cw
125 , toxManager = Nothing 131 , toxManager = Nothing
126 } 132 }
127 return $ st { toxManager = fmap ($ st) toxman } 133 return $ st { toxManager = fmap ($ st) toxman }
128 134
129 135
130nameForClient :: PresenceState -> ClientAddress -> IO Text 136nameForClient :: PresenceState stat -> ClientAddress -> IO Text
131nameForClient state k = do 137nameForClient state k = do
132 mc <- atomically $ do 138 mc <- atomically $ do
133 cmap <- readTVar (clients state) 139 cmap <- readTVar (clients state)
@@ -138,7 +144,7 @@ nameForClient state k = do
138 "." -> textHostName 144 "." -> textHostName
139 profile -> return profile 145 profile -> return profile
140 146
141presenceHooks :: PresenceState -> Int -> Maybe SockAddr -- ^ client-to-server bind address 147presenceHooks :: PresenceState stat -> Int -> Maybe SockAddr -- ^ client-to-server bind address
142 -> Maybe SockAddr -- ^ server-to-server bind address 148 -> Maybe SockAddr -- ^ server-to-server bind address
143 -> XMPPServerParameters 149 -> XMPPServerParameters
144presenceHooks state verbosity mclient mpeer = XMPPServerParameters 150presenceHooks state verbosity mclient mpeer = XMPPServerParameters
@@ -204,7 +210,7 @@ pcIsEmpty pc = Map.null (networkClients pc)
204 210
205 211
206 212
207getConsolePids :: PresenceState -> IO [(Text,ProcessID)] 213getConsolePids :: PresenceState stat -> IO [(Text,ProcessID)]
208getConsolePids state = do 214getConsolePids state = do
209 us <- UTmp.users 215 us <- UTmp.users
210 return $ map (\(_,tty,pid)->(lazyByteStringToText tty,pid)) us 216 return $ map (\(_,tty,pid)->(lazyByteStringToText tty,pid)) us
@@ -218,7 +224,7 @@ identifyTTY' ttypids uid inode = ttypid
218 ttypid = fmap textify $ identifyTTY ttypids' uid inode 224 ttypid = fmap textify $ identifyTTY ttypids' uid inode
219 textify (tty,pid) = (fmap lazyByteStringToText tty, pid) 225 textify (tty,pid) = (fmap lazyByteStringToText tty, pid)
220 226
221chooseResourceName :: PresenceState 227chooseResourceName :: PresenceState stat
222 -> ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO Text 228 -> ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO Text
223chooseResourceName state k (Remote addr) clientsNameForMe desired = do 229chooseResourceName state k (Remote addr) clientsNameForMe desired = do
224 muid <- getLocalPeerCred' addr 230 muid <- getLocalPeerCred' addr
@@ -267,7 +273,7 @@ chooseResourceName state k (Remote addr) clientsNameForMe desired = do
267 buds <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client) 273 buds <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client)
268 forM_ buds $ \bud -> do 274 forM_ buds $ \bud -> do
269 let (_,h,_) = splitJID bud 275 let (_,h,_) = splitJID bud
270 forkIO $ void $ resolvePeer h 276 forkIO $ void $ resolvePeer (manager state $ clientProfile client) h
271 277
272 atomically $ do 278 atomically $ do
273 modifyTVar' (clients state) $ Map.insert k client 279 modifyTVar' (clients state) $ Map.insert k client
@@ -304,14 +310,14 @@ chooseResourceName state k (Remote addr) clientsNameForMe desired = do
304-- Perform action with 'ClientState' associated with the given 'ClientAddress'. 310-- Perform action with 'ClientState' associated with the given 'ClientAddress'.
305-- If there is no associated 'ClientState', then perform the supplied fallback 311-- If there is no associated 'ClientState', then perform the supplied fallback
306-- action. 312-- action.
307forClient :: PresenceState -> ClientAddress -> IO b -> (ClientState -> IO b) -> IO b 313forClient :: PresenceState stat -> ClientAddress -> IO b -> (ClientState -> IO b) -> IO b
308forClient state k fallback f = do 314forClient state k fallback f = do
309 mclient <- atomically $ do 315 mclient <- atomically $ do
310 cs <- readTVar (clients state) 316 cs <- readTVar (clients state)
311 return $ Map.lookup k cs 317 return $ Map.lookup k cs
312 maybe fallback f mclient 318 maybe fallback f mclient
313 319
314tellClientHisName :: PresenceState -> ClientAddress -> IO Text 320tellClientHisName :: PresenceState stat -> ClientAddress -> IO Text
315tellClientHisName state k = forClient state k fallback go 321tellClientHisName state k = forClient state k fallback go
316 where 322 where
317 fallback = localJID "nobody" "." "fallback" 323 fallback = localJID "nobody" "." "fallback"
@@ -320,22 +326,22 @@ tellClientHisName state k = forClient state k fallback go
320toMapUnit :: Ord k => [k] -> Map k () 326toMapUnit :: Ord k => [k] -> Map k ()
321toMapUnit xs = Map.fromList $ map (,()) xs 327toMapUnit xs = Map.fromList $ map (,()) xs
322 328
323resolveAllPeers :: [Text] -> IO (Map PeerAddress ()) 329resolveAllPeers :: Connection.Manager stat Text -> [Text] -> IO (Map PeerAddress ())
324resolveAllPeers hosts = fmap (toMapUnit . concat) $ Prelude.mapM (fmap (take 1) . resolvePeer) hosts 330resolveAllPeers man hosts = fmap (toMapUnit . concat) $ Prelude.mapM (fmap (take 1) . resolvePeer man) hosts
325 331
326 332
327-- Read a roster file and start trying to connect to all relevent peers. 333-- Read a roster file and start trying to connect to all relevent peers.
328rosterGetStuff 334rosterGetStuff
329 :: (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString]) 335 :: (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString])
330 -> PresenceState -> ClientAddress -> IO [Text] 336 -> PresenceState stat -> ClientAddress -> IO [Text]
331rosterGetStuff what state k = forClient state k (return []) 337rosterGetStuff what state k = forClient state k (return [])
332 $ \client -> do 338 $ \client -> do
333 jids0 <- configText what (clientUser client) (clientProfile client) 339 jids0 <- configText what (clientUser client) (clientProfile client)
334 let jids = map splitJID jids0 340 let jids = map splitJID jids0
335 -- Using case to bring 'status' type variable to Connection.Manager into scope. 341 -- Using case to bring 'status' type variable to Connection.Manager into scope.
336 case state of 342 case state of
337 PresenceState { server = svVar } -> do 343 PresenceState { server = sv } -> do
338 (sv,conns) <- atomically $ takeTMVar svVar 344 let conns = manager state $ clientProfile client
339 -- Grok peers to associate with from the roster: 345 -- Grok peers to associate with from the roster:
340 let isTox = do (me , ".tox") <- Just $ Text.splitAt 43 (clientProfile client) 346 let isTox = do (me , ".tox") <- Just $ Text.splitAt 43 (clientProfile client)
341 return me 347 return me
@@ -353,23 +359,22 @@ rosterGetStuff what state k = forClient state k (return [])
353 meid <- readMaybe $ Text.unpack $ Text.take 43 (clientProfile client) 359 meid <- readMaybe $ Text.unpack $ Text.take 43 (clientProfile client)
354 themid <- readMaybe $ Text.unpack them 360 themid <- readMaybe $ Text.unpack them
355 return $ Connection.setPolicy (toxConnections toxman) 361 return $ Connection.setPolicy (toxConnections toxman)
356 (ToxContact meid themid) 362 (ToxContact meid themid)
357 policySetter Connection.TryingToConnect 363 policySetter Connection.TryingToConnect
358 atomically $ putTMVar svVar (sv,conns)
359 return $ fromMaybe jids0 $ do isTox 364 return $ fromMaybe jids0 $ do isTox
360 Just $ map noToxUsers jids 365 Just $ map noToxUsers jids
361 366
362rosterGetBuddies :: PresenceState -> ClientAddress -> IO [Text] 367rosterGetBuddies :: PresenceState stat -> ClientAddress -> IO [Text]
363rosterGetBuddies state k = rosterGetStuff ConfigFiles.getBuddies state k 368rosterGetBuddies state k = rosterGetStuff ConfigFiles.getBuddies state k
364 369
365rosterGetSolicited :: PresenceState -> ClientAddress -> IO [Text] 370rosterGetSolicited :: PresenceState stat -> ClientAddress -> IO [Text]
366rosterGetSolicited = rosterGetStuff ConfigFiles.getSolicited 371rosterGetSolicited = rosterGetStuff ConfigFiles.getSolicited
367 372
368-- XXX: Should we be connecting to these peers? 373-- XXX: Should we be connecting to these peers?
369rosterGetOthers :: PresenceState -> ClientAddress -> IO [Text] 374rosterGetOthers :: PresenceState stat -> ClientAddress -> IO [Text]
370rosterGetOthers = rosterGetStuff ConfigFiles.getOthers 375rosterGetOthers = rosterGetStuff ConfigFiles.getOthers
371 376
372rosterGetSubscribers :: PresenceState -> ClientAddress -> IO [Text] 377rosterGetSubscribers :: PresenceState stat -> ClientAddress -> IO [Text]
373rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers 378rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers
374 379
375data Conn = Conn { connChan :: TChan Stanza 380data Conn = Conn { connChan :: TChan Stanza
@@ -404,7 +409,7 @@ getSolicited' = configText ConfigFiles.getSolicited
404-- 409--
405-- * Text - Hostname as it appears in roster. 410-- * Text - Hostname as it appears in roster.
406-- 411--
407getBuddiesAndSolicited :: PresenceState 412getBuddiesAndSolicited :: PresenceState stat
408 -> Text -- ^ Config profile: "." or tox host. 413 -> Text -- ^ Config profile: "." or tox host.
409 -> (Text -> IO Bool) -- ^ Return True if you want this hostname. 414 -> (Text -> IO Bool) -- ^ Return True if you want this hostname.
410 -> IO [(Bool, Maybe UserName, Text, Text)] 415 -> IO [(Bool, Maybe UserName, Text, Text)]
@@ -425,7 +430,7 @@ getBuddiesAndSolicited state profile pred
425 then return [(isbud,u,user,h)] 430 then return [(isbud,u,user,h)]
426 else return [] 431 else return []
427 432
428sendProbesAndSolicitations :: PresenceState -> PeerAddress -> Local SockAddr -> TChan Stanza -> IO () 433sendProbesAndSolicitations :: PresenceState stat -> PeerAddress -> Local SockAddr -> TChan Stanza -> IO ()
429sendProbesAndSolicitations state k (Local laddr) chan = do 434sendProbesAndSolicitations state k (Local laddr) chan = do
430 prof <- atomically $ do 435 prof <- atomically $ do
431 pktc <- readTVar (pkeyToChan state) 436 pktc <- readTVar (pkeyToChan state)
@@ -434,7 +439,7 @@ sendProbesAndSolicitations state k (Local laddr) chan = do
434 xs <- getBuddiesAndSolicited state prof $ \case 439 xs <- getBuddiesAndSolicited state prof $ \case
435 h | ".tox" `Text.isSuffixOf` h -> return False -- Tox probes/solicitations are handled in ToxToXMPP module. 440 h | ".tox" `Text.isSuffixOf` h -> return False -- Tox probes/solicitations are handled in ToxToXMPP module.
436 h -> do 441 h -> do
437 addrs <- nub <$> resolvePeer h 442 addrs <- nub <$> resolvePeer (manager state $ prof) h
438 return $ k `elem` addrs -- Roster item resolves to /k/ peer. 443 return $ k `elem` addrs -- Roster item resolves to /k/ peer.
439 forM_ xs $ \(isbud,u,user,h) -> do 444 forM_ xs $ \(isbud,u,user,h) -> do
440 let make = if isbud then presenceProbe 445 let make = if isbud then presenceProbe
@@ -452,7 +457,7 @@ sendProbesAndSolicitations state k (Local laddr) chan = do
452 -- reverse xs `seq` return () 457 -- reverse xs `seq` return ()
453 458
454 459
455newConn :: PresenceState -> SockAddr -> ConnectionData -> TChan Stanza -> IO () 460newConn :: PresenceState stat -> SockAddr -> ConnectionData -> TChan Stanza -> IO ()
456newConn state saddr cdta outchan = 461newConn state saddr cdta outchan =
457 case classifyConnection saddr cdta of 462 case classifyConnection saddr cdta of
458 Left (pkey,laddr) -> do 463 Left (pkey,laddr) -> do
@@ -473,7 +478,7 @@ delclient k mlp = do
473 guard $ not (Map.null nc) 478 guard $ not (Map.null nc)
474 return $ lp { networkClients = nc } 479 return $ lp { networkClients = nc }
475 480
476eofConn :: PresenceState -> SockAddr -> ConnectionData -> IO () 481eofConn :: PresenceState stat -> SockAddr -> ConnectionData -> IO ()
477eofConn state saddr cdta = do 482eofConn state saddr cdta = do
478 case classifyConnection saddr cdta of 483 case classifyConnection saddr cdta of
479 Left (k,_) -> do 484 Left (k,_) -> do
@@ -545,9 +550,9 @@ parseRemoteAddress s = fmap Remote <$> parseAddress s
545-- domain name as it appears in the roster. It prefers host names that occur 550-- domain name as it appears in the roster. It prefers host names that occur
546-- in the given list of JIDs, but will fall back to any reverse-resolved name 551-- in the given list of JIDs, but will fall back to any reverse-resolved name
547-- and if it was unable to reverse the address, it will yield an ip address. 552-- and if it was unable to reverse the address, it will yield an ip address.
548peerKeyToResolvedName :: [Text] -> PeerAddress -> IO Text 553peerKeyToResolvedName :: Connection.Manager s Text -> [Text] -> PeerAddress -> IO Text
549peerKeyToResolvedName buds pk = do 554peerKeyToResolvedName man buds pk = do
550 ns <- peerKeyToResolvedNames pk 555 ns <- reverseAddress man pk
551 let hs = map (\jid -> let (_,h,_)=splitJID jid in h) buds 556 let hs = map (\jid -> let (_,h,_)=splitJID jid in h) buds
552 ns' = sortBy (comparing $ not . flip elem hs) ns 557 ns' = sortBy (comparing $ not . flip elem hs) ns
553 return $ fromMaybe (peerKeyToText pk) (listToMaybe ns') 558 return $ fromMaybe (peerKeyToText pk) (listToMaybe ns')
@@ -559,22 +564,22 @@ peerKeyToResolvedName buds pk = do
559-- host part refers to this local host (i.e. it equals the given SockAddr). 564-- host part refers to this local host (i.e. it equals the given SockAddr).
560-- If there are multiple results, it will prefer one which is a member of the 565-- If there are multiple results, it will prefer one which is a member of the
561-- given list in the last argument. 566-- given list in the last argument.
562rewriteJIDForClient :: Local SockAddr -> Text -> [Text] -> IO (Bool,(Maybe Text,Text,Maybe Text)) 567rewriteJIDForClient :: Connection.Manager s Text -> Local SockAddr -> Text -> [Text] -> IO (Bool,(Maybe Text,Text,Maybe Text))
563rewriteJIDForClient (Local laddr) jid buds = do 568rewriteJIDForClient man (Local laddr) jid buds = do
564 let (n,h,r) = splitJID jid 569 let (n,h,r) = splitJID jid
565 -- dput XJabber $ "rewriteJIDForClient parsing " ++ show h 570 -- dput XJabber $ "rewriteJIDForClient parsing " ++ show h
566 maddr <- parseAddress (strip_brackets h) 571 maddr <- parseAddress (strip_brackets h)
567 fromMaybe (return (False,(n,ip6literal h,r))) $ maddr <&> \saddr -> do 572 fromMaybe (return (False,(n,ip6literal h,r))) $ maddr <&> \saddr -> do
568 let mine = sameAddress laddr saddr 573 let mine = sameAddress laddr saddr
569 h' <- if mine then textHostName 574 h' <- if mine then textHostName
570 else peerKeyToResolvedName buds (addrToPeerKey $ Remote saddr) 575 else peerKeyToResolvedName man buds (addrToPeerKey $ Remote saddr)
571 return (mine,(n,h',r)) 576 return (mine,(n,h',r))
572 577
573-- Given a local address and an IP-address JID, we return True if the JID is 578-- Given a local address and an IP-address JID, we return True if the JID is
574-- local, False otherwise. Additionally, a list of equivalent hostname JIDS 579-- local, False otherwise. Additionally, a list of equivalent hostname JIDS
575-- are returned. 580-- are returned.
576multiplyJIDForClient :: ClientAddress -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)]) 581multiplyJIDForClient :: Connection.Manager s Text -> ClientAddress -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)])
577multiplyJIDForClient k jid = do 582multiplyJIDForClient man k jid = do
578 let (n,h,r) = splitJID jid 583 let (n,h,r) = splitJID jid
579 -- dput XJabber $ "multiplyJIDForClient parsing " ++ show h 584 -- dput XJabber $ "multiplyJIDForClient parsing " ++ show h
580 maddr <- parseAddress (strip_brackets h) 585 maddr <- parseAddress (strip_brackets h)
@@ -582,7 +587,7 @@ multiplyJIDForClient k jid = do
582 let Local laddr = addrFromClientKey k 587 let Local laddr = addrFromClientKey k
583 mine = sameAddress laddr saddr 588 mine = sameAddress laddr saddr
584 names <- if mine then fmap (:[]) textHostName 589 names <- if mine then fmap (:[]) textHostName
585 else peerKeyToResolvedNames (addrToPeerKey $ Remote saddr) 590 else reverseAddress man (addrToPeerKey $ Remote saddr)
586 return (mine,map (\h' -> (n,h',r)) names) 591 return (mine,map (\h' -> (n,h',r)) names)
587 592
588 593
@@ -600,16 +605,16 @@ guardPortStrippedAddress h (Local laddr) = do
600-- with a PeerAddress with the address part of that JID in 605-- with a PeerAddress with the address part of that JID in
601-- binary form. If no suitable address could be resolved 606-- binary form. If no suitable address could be resolved
602-- for the given name, Nothing is returned. 607-- for the given name, Nothing is returned.
603rewriteJIDForPeer :: Text -> IO (Maybe (Text,PeerAddress)) 608rewriteJIDForPeer :: Connection.Manager s Text -> Text -> IO (Maybe (Text,PeerAddress))
604rewriteJIDForPeer jid = do 609rewriteJIDForPeer man jid = do
605 let (n,h,r) = splitJID jid 610 let (n,h,r) = splitJID jid
606 maddr <- fmap listToMaybe $ resolvePeer h 611 maddr <- fmap listToMaybe $ resolvePeer man h
607 return $ flip fmap maddr $ \addr -> 612 return $ flip fmap maddr $ \addr ->
608 let h' = peerKeyToText addr 613 let h' = peerKeyToText addr
609 to' = unsplitJID (n,h',r) 614 to' = unsplitJID (n,h',r)
610 in (to',addr) 615 in (to',addr)
611 616
612deliverToConsole :: PresenceState -> IO () -> Stanza -> IO () 617deliverToConsole :: PresenceState stat -> IO () -> Stanza -> IO ()
613deliverToConsole PresenceState{ consoleWriter = Just cw } fail msg = do 618deliverToConsole PresenceState{ consoleWriter = Just cw } fail msg = do
614 did1 <- writeActiveTTY cw msg 619 did1 <- writeActiveTTY cw msg
615 did2 <- writeAllPty cw msg 620 did2 <- writeAllPty cw msg
@@ -617,7 +622,7 @@ deliverToConsole PresenceState{ consoleWriter = Just cw } fail msg = do
617deliverToConsole _ fail _ = fail 622deliverToConsole _ fail _ = fail
618 623
619-- | deliver <message/> or error stanza 624-- | deliver <message/> or error stanza
620deliverMessage :: PresenceState 625deliverMessage :: PresenceState stat
621 -> IO () 626 -> IO ()
622 -> StanzaWrap (LockedChan Event) 627 -> StanzaWrap (LockedChan Event)
623 -> IO () 628 -> IO ()
@@ -630,7 +635,8 @@ deliverMessage state fail msg =
630 return $ do 635 return $ do
631 dput XJabber $ "deliverMessage: to="++show (stanzaTo msg,fmap clientProfile mclient) 636 dput XJabber $ "deliverMessage: to="++show (stanzaTo msg,fmap clientProfile mclient)
632 fromMaybe -- Resolve XMPP peer. 637 fromMaybe -- Resolve XMPP peer.
633 (fmap join $ mapM rewriteJIDForPeer (stanzaTo msg)) 638 (fmap join $ mapM (uncurry $ rewriteJIDForPeer . manager state)
639 $ (,) <$> (clientProfile <$> mclient) <*> stanzaTo msg)
634 $ do 640 $ do
635 client <- mclient 641 client <- mclient
636 to <- stanzaTo msg 642 to <- stanzaTo msg
@@ -679,7 +685,7 @@ deliverMessage state fail msg =
679 (mine,(n,h,r)) <- case (ctyp,cprof) of 685 (mine,(n,h,r)) <- case (ctyp,cprof) of
680 (Tox,prof) -> let (n,h,r) = splitJID to 686 (Tox,prof) -> let (n,h,r) = splitJID to
681 in return ( h==prof, (n,h,r) ) 687 in return ( h==prof, (n,h,r) )
682 _ -> rewriteJIDForClient laddr to [] 688 _ -> rewriteJIDForClient (manager state cprof) laddr to []
683 if not mine then do dput XJabber $ "Address mis-match " ++ show (laddr,to) 689 if not mine then do dput XJabber $ "Address mis-match " ++ show (laddr,to)
684 fail 690 fail
685 else do 691 else do
@@ -701,7 +707,7 @@ deliverMessage state fail msg =
701 Tox -> return $ stanzaFrom msg 707 Tox -> return $ stanzaFrom msg
702 XMPP -> do 708 XMPP -> do
703 forM (stanzaFrom msg) $ \from -> do 709 forM (stanzaFrom msg) $ \from -> do
704 (_,trip) <- rewriteJIDForClient laddr from buds 710 (_,trip) <- rewriteJIDForClient (manager state cprof) laddr from buds
705 return $ unsplitJID trip 711 return $ unsplitJID trip
706 to' <- case ctyp of 712 to' <- case ctyp of
707 XMPP -> return $ stanzaTo msg 713 XMPP -> return $ stanzaTo msg
@@ -715,7 +721,7 @@ deliverMessage state fail msg =
715 buds <- maybe (return []) 721 buds <- maybe (return [])
716 (\n -> configText ConfigFiles.getBuddies n ".") 722 (\n -> configText ConfigFiles.getBuddies n ".")
717 n 723 n
718 (_,trip) <- rewriteJIDForClient laddr from buds 724 (_,trip) <- rewriteJIDForClient (manager state cprof) laddr from buds
719 return . Just $ unsplitJID trip 725 return . Just $ unsplitJID trip
720 let msg' = msg { stanzaTo=Just to' 726 let msg' = msg { stanzaTo=Just to'
721 , stanzaFrom=from' } 727 , stanzaFrom=from' }
@@ -735,7 +741,7 @@ deliverMessage state fail msg =
735 chan 741 chan
736 742
737 743
738setClientFlag :: PresenceState -> ClientAddress -> Int8 -> IO () 744setClientFlag :: PresenceState stat -> ClientAddress -> Int8 -> IO ()
739setClientFlag state k flag = 745setClientFlag state k flag =
740 atomically $ do 746 atomically $ do
741 cmap <- readTVar (clients state) 747 cmap <- readTVar (clients state)
@@ -746,16 +752,16 @@ setClientFlag0 :: ClientState -> Int8 -> STM ()
746setClientFlag0 client flag = 752setClientFlag0 client flag =
747 modifyTVar' (clientFlags client) (\flgs -> flgs .|. flag) 753 modifyTVar' (clientFlags client) (\flgs -> flgs .|. flag)
748 754
749informSentRoster :: PresenceState -> ClientAddress -> IO () 755informSentRoster :: PresenceState stat -> ClientAddress -> IO ()
750informSentRoster state k = do 756informSentRoster state k = do
751 setClientFlag state k cf_interested 757 setClientFlag state k cf_interested
752 758
753 759
754subscribedPeers :: Text -> Text -> IO [PeerAddress] 760subscribedPeers :: Connection.Manager s Text -> Text -> Text -> IO [PeerAddress]
755subscribedPeers user profile = do 761subscribedPeers man user profile = do
756 jids <- configText ConfigFiles.getSubscribers user profile 762 jids <- configText ConfigFiles.getSubscribers user profile
757 let hosts = map ((\(_,h,_)->h) . splitJID) jids 763 let hosts = map ((\(_,h,_)->h) . splitJID) jids
758 fmap Map.keys $ resolveAllPeers hosts 764 fmap Map.keys $ resolveAllPeers man hosts
759 765
760-- | this JID is suitable for peers, not clients. 766-- | this JID is suitable for peers, not clients.
761clientJID :: Conn -> ClientState -> Text 767clientJID :: Conn -> ClientState -> Text
@@ -769,13 +775,13 @@ clientJID con client = unsplitJID ( Just $ clientUser client
769-- | Send presence notification to subscribed peers. 775-- | Send presence notification to subscribed peers.
770-- Note that a full JID from address will be added to the 776-- Note that a full JID from address will be added to the
771-- stanza if it is not present. 777-- stanza if it is not present.
772informClientPresence :: PresenceState 778informClientPresence :: PresenceState stat
773 -> ClientAddress -> StanzaWrap (LockedChan Event) -> IO () 779 -> ClientAddress -> StanzaWrap (LockedChan Event) -> IO ()
774informClientPresence state k stanza = do 780informClientPresence state k stanza = do
775 forClient state k (return ()) $ \client -> do 781 forClient state k (return ()) $ \client -> do
776 informClientPresence0 state (Just k) client stanza 782 informClientPresence0 state (Just k) client stanza
777 783
778informClientPresence0 :: PresenceState 784informClientPresence0 :: PresenceState stat
779 -> Maybe ClientAddress 785 -> Maybe ClientAddress
780 -> ClientState 786 -> ClientState
781 -> StanzaWrap (LockedChan Event) 787 -> StanzaWrap (LockedChan Event)
@@ -787,21 +793,21 @@ informClientPresence0 state mbk client stanza = do
787 when (not is_avail) $ do 793 when (not is_avail) $ do
788 atomically $ setClientFlag0 client cf_available 794 atomically $ setClientFlag0 client cf_available
789 maybe (return ()) (sendCachedPresence state) mbk 795 maybe (return ()) (sendCachedPresence state) mbk
790 addrs <- subscribedPeers (clientUser client) (clientProfile client) 796 addrs <- subscribedPeers (manager state $ clientProfile client) (clientUser client) (clientProfile client)
791 ktc <- atomically $ readTVar (pkeyToChan state) 797 ktc <- atomically $ readTVar (pkeyToChan state)
792 let connected = mapMaybe (flip Map.lookup ktc) addrs 798 let connected = mapMaybe (flip Map.lookup ktc) addrs
793 forM_ connected $ \con -> do 799 forM_ connected $ \con -> do
794 let from' = clientJID con client 800 let from' = clientJID con client
795 mto <- runTraversableT $ do 801 mto <- runTraversableT $ do
796 to <- liftT $ stanzaTo stanza 802 to <- liftT $ stanzaTo stanza
797 (to',_) <- liftMT $ rewriteJIDForPeer to 803 (to',_) <- liftMT $ rewriteJIDForPeer (manager state $ clientProfile client) to
798 return to' 804 return to'
799 dup <- cloneStanza stanza 805 dup <- cloneStanza stanza
800 sendModifiedStanzaToPeer dup { stanzaFrom = Just from' 806 sendModifiedStanzaToPeer dup { stanzaFrom = Just from'
801 , stanzaTo = mto } 807 , stanzaTo = mto }
802 (connChan con) 808 (connChan con)
803 809
804informPeerPresence :: PresenceState 810informPeerPresence :: PresenceState stat
805 -> PeerAddress 811 -> PeerAddress
806 -> StanzaWrap (LockedChan Event) 812 -> StanzaWrap (LockedChan Event)
807 -> IO () 813 -> IO ()
@@ -874,7 +880,7 @@ informPeerPresence state k stanza = do
874 froms <- case ctyp of 880 froms <- case ctyp of
875 Tox | clientProfile client == cprof -> return [from] 881 Tox | clientProfile client == cprof -> return [from]
876 _ -> do -- flip (maybe $ return [from]) k . const $ do 882 _ -> do -- flip (maybe $ return [from]) k . const $ do
877 (_,trip) <- multiplyJIDForClient ck from 883 (_,trip) <- multiplyJIDForClient (manager state $ clientProfile client) ck from
878 return (map unsplitJID trip) 884 return (map unsplitJID trip)
879 885
880 dput XJabber $ "sending to client: " ++ show (stanzaType stanza,froms) 886 dput XJabber $ "sending to client: " ++ show (stanzaType stanza,froms)
@@ -883,12 +889,12 @@ informPeerPresence state k stanza = do
883 sendModifiedStanzaToClient (dup { stanzaFrom=Just from' }) 889 sendModifiedStanzaToClient (dup { stanzaFrom=Just from' })
884 (connChan con) 890 (connChan con)
885 891
886consoleClients :: PresenceState -> STM (Map Text ClientState) 892consoleClients :: PresenceState stat -> STM (Map Text ClientState)
887consoleClients PresenceState{ consoleWriter = Just cw } = readTVar (cwClients cw) 893consoleClients PresenceState{ consoleWriter = Just cw } = readTVar (cwClients cw)
888consoleClients _ = return Map.empty 894consoleClients _ = return Map.empty
889 895
890 896
891answerProbe :: PresenceState -> Maybe Text -> PeerAddress -> TChan Stanza -> IO () 897answerProbe :: PresenceState stat -> Maybe Text -> PeerAddress -> TChan Stanza -> IO ()
892answerProbe state mto k chan = do 898answerProbe state mto k chan = do
893 -- dput XJabber $ "answerProbe! " ++ show (stanzaType stanza) 899 -- dput XJabber $ "answerProbe! " ++ show (stanzaType stanza)
894 ktc <- atomically $ readTVar (pkeyToChan state) 900 ktc <- atomically $ readTVar (pkeyToChan state)
@@ -911,7 +917,8 @@ answerProbe state mto k chan = do
911 forM_ profiles $ \profile -> do 917 forM_ profiles $ \profile -> do
912 918
913 -- only subscribed peers should get probe replies 919 -- only subscribed peers should get probe replies
914 resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u profile 920 let man = manager state $ cdProfile $ auxData conn
921 resolved_subs <- resolvedFromRoster man ConfigFiles.getSubscribers u profile
915 let gaddrs = groupBy sameHost (sort resolved_subs) 922 let gaddrs = groupBy sameHost (sort resolved_subs)
916 sameHost a b = (snd a == snd b) -- (==) `on` snd 923 sameHost a b = (snd a == snd b) -- (==) `on` snd
917 whitelist = do 924 whitelist = do
@@ -951,13 +958,13 @@ answerProbe state mto k chan = do
951 958
952-- Send friend requests and remote presences stored in remotesByPeer to XMPP 959-- Send friend requests and remote presences stored in remotesByPeer to XMPP
953-- clients. 960-- clients.
954sendCachedPresence :: PresenceState -> ClientAddress -> IO () 961sendCachedPresence :: PresenceState stat -> ClientAddress -> IO ()
955sendCachedPresence state k = do 962sendCachedPresence state k = do
956 forClient state k (return ()) $ \client -> do 963 forClient state k (return ()) $ \client -> do
957 rbp <- atomically $ readTVar (remotesByPeer state) 964 rbp <- atomically $ readTVar (remotesByPeer state)
958 jids <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client) 965 jids <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client)
959 let hosts = map ((\(_,h,_)->h) . splitJID) jids 966 let hosts = map ((\(_,h,_)->h) . splitJID) jids
960 addrs <- resolveAllPeers hosts 967 addrs <- resolveAllPeers (manager state $ clientProfile client) hosts
961 let onlines = rbp `Map.intersection` addrs 968 let onlines = rbp `Map.intersection` addrs
962 mcon <- atomically $ do ktc <- readTVar (ckeyToChan state) 969 mcon <- atomically $ do ktc <- readTVar (ckeyToChan state)
963 return $ Map.lookup k ktc 970 return $ Map.lookup k ktc
@@ -967,7 +974,7 @@ sendCachedPresence state k = do
967 let h = peerKeyToText pk 974 let h = peerKeyToText pk
968 forM_ (Map.toList $ resources rp) $ \(resource,stanza) -> do 975 forM_ (Map.toList $ resources rp) $ \(resource,stanza) -> do
969 let jid = unsplitJID (Just user,h,Just resource) 976 let jid = unsplitJID (Just user,h,Just resource)
970 (mine,js) <- multiplyJIDForClient k jid 977 (mine,js) <- multiplyJIDForClient (manager state $ clientProfile client) k jid
971 forM_ js $ \jid -> do 978 forM_ js $ \jid -> do
972 let from' = unsplitJID jid 979 let from' = unsplitJID jid
973 dup <- cloneStanza stanza 980 dup <- cloneStanza stanza
@@ -988,37 +995,40 @@ sendCachedPresence state k = do
988 return () 995 return ()
989 996
990addToRosterFile :: 997addToRosterFile ::
991 (ConfigFiles.User 998 Connection.Manager s Text
992 -> ConfigFiles.Profile 999 -> (ConfigFiles.User
993 -> (L.ByteString -> IO (Maybe L.ByteString)) 1000 -> ConfigFiles.Profile
994 -> Maybe L.ByteString 1001 -> (L.ByteString -> IO (Maybe L.ByteString))
995 -> t1) 1002 -> Maybe L.ByteString
1003 -> t1)
996 -> Text -- user 1004 -> Text -- user
997 -> Text -- profile 1005 -> Text -- profile
998 -> Text -> [PeerAddress] -> t1 1006 -> Text -> [PeerAddress] -> t1
999addToRosterFile doit whose profile to addrs = 1007addToRosterFile man doit whose profile to addrs =
1000 modifyRosterFile doit whose profile to addrs True 1008 modifyRosterFile man doit whose profile to addrs True
1001 1009
1002removeFromRosterFile :: 1010removeFromRosterFile ::
1003 (ConfigFiles.User 1011 Connection.Manager s Text
1004 -> ConfigFiles.Profile 1012 -> (ConfigFiles.User
1005 -> (L.ByteString -> IO (Maybe L.ByteString)) 1013 -> ConfigFiles.Profile
1006 -> Maybe L.ByteString 1014 -> (L.ByteString -> IO (Maybe L.ByteString))
1007 -> t1) 1015 -> Maybe L.ByteString
1016 -> t1)
1008 -> Text -- user 1017 -> Text -- user
1009 -> Text -- profile 1018 -> Text -- profile
1010 -> Text -> [PeerAddress] -> t1 1019 -> Text -> [PeerAddress] -> t1
1011removeFromRosterFile doit whose profile to addrs = 1020removeFromRosterFile man doit whose profile to addrs =
1012 modifyRosterFile doit whose profile to addrs False 1021 modifyRosterFile man doit whose profile to addrs False
1013 1022
1014-- | Sanity-checked roster file manipulation. Primarily, this function handles 1023-- | Sanity-checked roster file manipulation. Primarily, this function handles
1015-- hostname aliases. 1024-- hostname aliases.
1016modifyRosterFile :: 1025modifyRosterFile ::
1017 (ConfigFiles.User 1026 Connection.Manager s Text
1018 -> ConfigFiles.Profile 1027 -> (ConfigFiles.User
1019 -> (L.ByteString -> IO (Maybe L.ByteString)) 1028 -> ConfigFiles.Profile
1020 -> Maybe L.ByteString 1029 -> (L.ByteString -> IO (Maybe L.ByteString))
1021 -> t1) -- ^ Lower-level modification function 1030 -> Maybe L.ByteString
1031 -> t1) -- ^ Lower-level modification function
1022 -- indicating which file is being modified. 1032 -- indicating which file is being modified.
1023 -- Valid choices from ConfigFiles module: 1033 -- Valid choices from ConfigFiles module:
1024 -- 1034 --
@@ -1035,7 +1045,7 @@ modifyRosterFile ::
1035 -> [PeerAddress] -- ^ Alias addresses for hostname in the JID. 1045 -> [PeerAddress] -- ^ Alias addresses for hostname in the JID.
1036 -> Bool -- ^ True if adding, otherwise False 1046 -> Bool -- ^ True if adding, otherwise False
1037 -> t1 1047 -> t1
1038modifyRosterFile doit whose profile to addrs bAdd = do 1048modifyRosterFile man doit whose profile to addrs bAdd = do
1039 let (mu,_,_) = splitJID to 1049 let (mu,_,_) = splitJID to
1040 -- For each jid in the file, this function will decide whether to keep 1050 -- For each jid in the file, this function will decide whether to keep
1041 -- it (possibly modified) which is indicated by Just _ or to remove the 1051 -- it (possibly modified) which is indicated by Just _ or to remove the
@@ -1046,7 +1056,7 @@ modifyRosterFile doit whose profile to addrs bAdd = do
1046 keep = return (Just jid) :: IO (Maybe L.ByteString) 1056 keep = return (Just jid) :: IO (Maybe L.ByteString)
1047 delete = return Nothing :: IO (Maybe L.ByteString) 1057 delete = return Nothing :: IO (Maybe L.ByteString)
1048 iocheck = do 1058 iocheck = do
1049 stored_addrs <- resolvePeer stored_h -- TODO: don't resolve .tox peers. 1059 stored_addrs <- resolvePeer man stored_h -- TODO: don't resolve .tox peers.
1050 case stored_addrs of 1060 case stored_addrs of
1051 [] -> keep -- do not delete if failed to resolve 1061 [] -> keep -- do not delete if failed to resolve
1052 xs | null (xs \\ addrs) -> delete -- hostname alias, delete 1062 xs | null (xs \\ addrs) -> delete -- hostname alias, delete
@@ -1063,7 +1073,7 @@ modifyRosterFile doit whose profile to addrs bAdd = do
1063 (guard bAdd >> Just (textToLazyByteString to)) 1073 (guard bAdd >> Just (textToLazyByteString to))
1064 1074
1065 1075
1066clientSubscriptionRequest :: PresenceState -> IO () -> ClientAddress -> Stanza -> TChan Stanza -> IO () 1076clientSubscriptionRequest :: PresenceState stat -> IO () -> ClientAddress -> Stanza -> TChan Stanza -> IO ()
1067clientSubscriptionRequest state fail k stanza chan = do 1077clientSubscriptionRequest state fail k stanza chan = do
1068 forClient state k fail $ \client -> do 1078 forClient state k fail $ \client -> do
1069 fromMaybe fail $ (splitJID <$> stanzaTo stanza) <&> \(mu,h,_) -> do 1079 fromMaybe fail $ (splitJID <$> stanzaTo stanza) <&> \(mu,h,_) -> do
@@ -1071,6 +1081,7 @@ clientSubscriptionRequest state fail k stanza chan = do
1071 let to0 = unsplitJID (mu,h,Nothing) -- deleted resource 1081 let to0 = unsplitJID (mu,h,Nothing) -- deleted resource
1072 cuser = clientUser client 1082 cuser = clientUser client
1073 cprof = clientProfile client 1083 cprof = clientProfile client
1084 man = manager state cprof
1074 mto = if ".tox" `Text.isSuffixOf` cprof 1085 mto = if ".tox" `Text.isSuffixOf` cprof
1075 then case parseNoSpamId to0 of 1086 then case parseNoSpamId to0 of
1076 Right toxjid@(NoSpamId nspam _) -> Just ( Text.pack $ '$' : nospam64 nspam 1087 Right toxjid@(NoSpamId nspam _) -> Just ( Text.pack $ '$' : nospam64 nspam
@@ -1079,16 +1090,16 @@ clientSubscriptionRequest state fail k stanza chan = do
1079 Left _ | Text.isSuffixOf ".tox" h -> Nothing 1090 Left _ | Text.isSuffixOf ".tox" h -> Nothing
1080 Left _ | Text.all isHexDigit h 1091 Left _ | Text.all isHexDigit h
1081 && Text.length h == 76 -> Nothing 1092 && Text.length h == 76 -> Nothing
1082 Left _ -> fmap (\u -> (u, to0 ,resolvePeer h)) mu 1093 Left _ -> fmap (\u -> (u, to0 ,resolvePeer man h)) mu
1083 else fmap (\u -> (u, to0 ,resolvePeer h)) mu 1094 else fmap (\u -> (u, to0 ,resolvePeer man h)) mu
1084 fromMaybe fail $ mto <&> \(u,to,resolv) -> do 1095 fromMaybe fail $ mto <&> \(u,to,resolv) -> do
1085 -- add to-address to from's solicited 1096 -- add to-address to from's solicited
1086 dput XJabber $ unlines [ "to0=" ++ Text.unpack to0 1097 dput XJabber $ unlines [ "to0=" ++ Text.unpack to0
1087 , "to=" ++ show (Text.unpack to) ] 1098 , "to=" ++ show (Text.unpack to) ]
1088 addrs <- resolv 1099 addrs <- resolv
1089 addToRosterFile ConfigFiles.modifySolicited cuser cprof to addrs 1100 addToRosterFile man ConfigFiles.modifySolicited cuser cprof to addrs
1090 removeFromRosterFile ConfigFiles.modifyBuddies cuser cprof to addrs 1101 removeFromRosterFile man ConfigFiles.modifyBuddies cuser cprof to addrs
1091 resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers cuser cprof 1102 resolved_subs <- resolvedFromRoster man ConfigFiles.getSubscribers cuser cprof
1092 let is_subscribed = not . null $ [ (mu, a) | a <- addrs ] 1103 let is_subscribed = not . null $ [ (mu, a) | a <- addrs ]
1093 `intersect` resolved_subs 1104 `intersect` resolved_subs
1094 -- subscribers: "from" 1105 -- subscribers: "from"
@@ -1100,8 +1111,7 @@ clientSubscriptionRequest state fail k stanza chan = do
1100 (cktc,pktc,(sv,conns)) <- atomically $ do 1111 (cktc,pktc,(sv,conns)) <- atomically $ do
1101 cktc <- readTVar $ ckeyToChan state 1112 cktc <- readTVar $ ckeyToChan state
1102 pktc <- readTVar $ pkeyToChan state 1113 pktc <- readTVar $ pkeyToChan state
1103 sc <- takeTMVar svVar 1114 return (cktc,pktc,(server state,man))
1104 return (cktc,pktc,sc)
1105 1115
1106 -- Update roster for each client. 1116 -- Update roster for each client.
1107 case stanzaType stanza of 1117 case stanzaType stanza of
@@ -1132,7 +1142,7 @@ clientSubscriptionRequest state fail k stanza chan = do
1132 from = unsplitJID ( Just $ clientUser client 1142 from = unsplitJID ( Just $ clientUser client
1133 , (\(Local a) -> addrToText a) $ laddr 1143 , (\(Local a) -> addrToText a) $ laddr
1134 , Nothing ) 1144 , Nothing )
1135 mb <- rewriteJIDForPeer to 1145 mb <- rewriteJIDForPeer (manager state $ cdProfile $ auxData con) to
1136 forM_ mb $ \(to',addr) -> do 1146 forM_ mb $ \(to',addr) -> do
1137 dup <- cloneStanza stanza 1147 dup <- cloneStanza stanza
1138 sendModifiedStanzaToPeer (dup { stanzaTo = Just to' 1148 sendModifiedStanzaToPeer (dup { stanzaTo = Just to'
@@ -1145,9 +1155,8 @@ clientSubscriptionRequest state fail k stanza chan = do
1145 Just $ Connection.setPolicy (toxConnections toxman) (ToxContact meid themid) 1155 Just $ Connection.setPolicy (toxConnections toxman) (ToxContact meid themid)
1146 -- Add peer if we are not already associated ... 1156 -- Add peer if we are not already associated ...
1147 policySetter Connection.TryingToConnect 1157 policySetter Connection.TryingToConnect
1148 atomically $ putTMVar svVar (sv,conns)
1149 1158
1150weAreTox :: PresenceState -> ClientState -> Text -> Maybe (ToxManager ClientAddress,Text{- me -},Text{- them -}) 1159weAreTox :: PresenceState stat -> ClientState -> Text -> Maybe (ToxManager ClientAddress,Text{- me -},Text{- them -})
1151weAreTox state client h = do 1160weAreTox state client h = do
1152 toxman <- toxManager state 1161 toxman <- toxManager state
1153 (me , ".tox") <- Just $ Text.splitAt 43 (clientProfile client) 1162 (me , ".tox") <- Just $ Text.splitAt 43 (clientProfile client)
@@ -1155,20 +1164,21 @@ weAreTox state client h = do
1155 return (toxman,me,them) 1164 return (toxman,me,them)
1156 1165
1157resolvedFromRoster 1166resolvedFromRoster
1158 :: (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString]) 1167 :: Connection.Manager s Text
1168 -> (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString])
1159 -> UserName -> Text -> IO [(Maybe UserName, PeerAddress)] 1169 -> UserName -> Text -> IO [(Maybe UserName, PeerAddress)]
1160resolvedFromRoster doit u profile = do 1170resolvedFromRoster man doit u profile = do
1161 subs <- configText doit u profile 1171 subs <- configText doit u profile
1162 runTraversableT $ do 1172 runTraversableT $ do
1163 (mu,h,_) <- liftT $ splitJID `fmap` subs 1173 (mu,h,_) <- liftT $ splitJID `fmap` subs
1164 addr <- liftMT $ fmap nub $ resolvePeer h 1174 addr <- liftMT $ fmap nub $ resolvePeer man h
1165 return (mu,addr) 1175 return (mu,addr)
1166 1176
1167clientCons :: PresenceState 1177clientCons :: PresenceState stat
1168 -> Map ClientAddress t -> Text -> IO [(t, ClientState)] 1178 -> Map ClientAddress t -> Text -> IO [(t, ClientState)]
1169clientCons state ktc u = map snd <$> clientCons' state ktc u 1179clientCons state ktc u = map snd <$> clientCons' state ktc u
1170 1180
1171clientCons' :: PresenceState 1181clientCons' :: PresenceState stat
1172 -> Map ClientAddress t -> Text -> IO [(ClientAddress,(t, ClientState))] 1182 -> Map ClientAddress t -> Text -> IO [(ClientAddress,(t, ClientState))]
1173clientCons' state ktc u = do 1183clientCons' state ktc u = do
1174 mlp <- atomically $ do 1184 mlp <- atomically $ do
@@ -1188,7 +1198,7 @@ releventProfiles ctyp user = do
1188 -- .presence/ directory. 1198 -- .presence/ directory.
1189 return [] 1199 return []
1190 1200
1191peerSubscriptionRequest :: PresenceState -> IO () -> PeerAddress -> Stanza -> TChan Stanza -> IO () 1201peerSubscriptionRequest :: PresenceState stat -> IO () -> PeerAddress -> Stanza -> TChan Stanza -> IO ()
1192peerSubscriptionRequest state fail k stanza chan = do 1202peerSubscriptionRequest state fail k stanza chan = do
1193 dput XJabber $ "Handling pending subscription from remote" 1203 dput XJabber $ "Handling pending subscription from remote"
1194 fromMaybe fail $ (stanzaFrom stanza) <&> \from -> do 1204 fromMaybe fail $ (stanzaFrom stanza) <&> \from -> do
@@ -1207,12 +1217,12 @@ peerSubscriptionRequest state fail k stanza chan = do
1207 (mine,totup) <- case (ctyp,profile) of 1217 (mine,totup) <- case (ctyp,profile) of
1208 (Tox,p) -> let (u,h,r) = splitJID to 1218 (Tox,p) -> let (u,h,r) = splitJID to
1209 in return ( h == p, (u,h,r) ) 1219 in return ( h == p, (u,h,r) )
1210 _ -> rewriteJIDForClient laddr to [] 1220 _ -> rewriteJIDForClient (manager state profile) laddr to []
1211 if not mine then fail else do 1221 if not mine then fail else do
1212 (_,fromtup) <- rewriteJIDForClient laddr from [] 1222 (_,fromtup) <- rewriteJIDForClient (manager state profile) laddr from []
1213 fromMaybe fail $ mto_u <&> \u -> do 1223 fromMaybe fail $ mto_u <&> \u -> do
1214 fromMaybe fail $ mfrom_u <&> \from_u -> do 1224 fromMaybe fail $ mfrom_u <&> \from_u -> do
1215 resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u profile 1225 resolved_subs <- resolvedFromRoster (manager state profile) ConfigFiles.getSubscribers u profile
1216 let already_subscribed = elem (mfrom_u,k) resolved_subs 1226 let already_subscribed = elem (mfrom_u,k) resolved_subs
1217 is_wanted = case stanzaType stanza of 1227 is_wanted = case stanzaType stanza of
1218 PresenceRequestSubscription b -> b 1228 PresenceRequestSubscription b -> b
@@ -1233,7 +1243,7 @@ peerSubscriptionRequest state fail k stanza chan = do
1233 -- TODO: if peer-connection is to self, then auto-approve local user. 1243 -- TODO: if peer-connection is to self, then auto-approve local user.
1234 1244
1235 -- add from-address to to's pending 1245 -- add from-address to to's pending
1236 addrs <- resolvePeer from_h 1246 addrs <- resolvePeer (manager state profile) from_h
1237 1247
1238 -- Catch exception in case the user does not exist 1248 -- Catch exception in case the user does not exist
1239 if null addrs then fail else do 1249 if null addrs then fail else do
@@ -1243,9 +1253,9 @@ peerSubscriptionRequest state fail k stanza chan = do
1243 -- Update roster files (subscribe: add to pending, unsubscribe: remove from subscribers). 1253 -- Update roster files (subscribe: add to pending, unsubscribe: remove from subscribers).
1244 already_pending <- 1254 already_pending <-
1245 if is_wanted then 1255 if is_wanted then
1246 addToRosterFile ConfigFiles.modifyPending u profile from' addrs 1256 addToRosterFile (manager state profile) ConfigFiles.modifyPending u profile from' addrs
1247 else do 1257 else do
1248 removeFromRosterFile ConfigFiles.modifySubscribers u profile from' addrs 1258 removeFromRosterFile (manager state profile) ConfigFiles.modifySubscribers u profile from' addrs
1249 reply <- makeInformSubscription "jabber:server" to from is_wanted 1259 reply <- makeInformSubscription "jabber:server" to from is_wanted
1250 sendModifiedStanzaToPeer reply chan 1260 sendModifiedStanzaToPeer reply chan
1251 return False 1261 return False
@@ -1270,7 +1280,7 @@ myMakeRosterUpdate prf tojid contact as
1270myMakeRosterUpdate _ tojid contact as = XMPPServer.makeRosterUpdate tojid contact as 1280myMakeRosterUpdate _ tojid contact as = XMPPServer.makeRosterUpdate tojid contact as
1271 1281
1272 1282
1273clientInformSubscription :: PresenceState 1283clientInformSubscription :: PresenceState stat
1274 -> IO () 1284 -> IO ()
1275 -> ClientAddress 1285 -> ClientAddress
1276 -> StanzaWrap (LockedChan Event) 1286 -> StanzaWrap (LockedChan Event)
@@ -1280,11 +1290,12 @@ clientInformSubscription state fail k stanza = do
1280 fromMaybe fail $ (stanzaTo stanza) <&> \to -> do 1290 fromMaybe fail $ (stanzaTo stanza) <&> \to -> do
1281 dput XJabber $ "clientInformSubscription" 1291 dput XJabber $ "clientInformSubscription"
1282 let (mu,h,mr) = splitJID to 1292 let (mu,h,mr) = splitJID to
1283 addrs <- resolvePeer h 1293 man = manager state $ clientProfile client
1294 addrs <- resolvePeer man h
1284 -- remove from pending 1295 -- remove from pending
1285 buds <- resolvedFromRoster ConfigFiles.getBuddies (clientUser client) (clientProfile client) 1296 buds <- resolvedFromRoster man ConfigFiles.getBuddies (clientUser client) (clientProfile client)
1286 let is_buddy = not . null $ map (mu,) addrs `intersect` buds 1297 let is_buddy = not . null $ map (mu,) addrs `intersect` buds
1287 removeFromRosterFile ConfigFiles.modifyPending (clientUser client) (clientProfile client) to addrs 1298 removeFromRosterFile man ConfigFiles.modifyPending (clientUser client) (clientProfile client) to addrs
1288 let (relationship,addf,remf) = 1299 let (relationship,addf,remf) =
1289 case stanzaType stanza of 1300 case stanzaType stanza of
1290 PresenceInformSubscription True -> 1301 PresenceInformSubscription True ->
@@ -1296,8 +1307,8 @@ clientInformSubscription state fail k stanza = do
1296 else "none" ) 1307 else "none" )
1297 , ConfigFiles.modifyOthers 1308 , ConfigFiles.modifyOthers
1298 , ConfigFiles.modifySubscribers ) 1309 , ConfigFiles.modifySubscribers )
1299 addToRosterFile addf (clientUser client) (clientProfile client) to addrs 1310 addToRosterFile man addf (clientUser client) (clientProfile client) to addrs
1300 removeFromRosterFile remf (clientUser client) (clientProfile client) to addrs 1311 removeFromRosterFile man remf (clientUser client) (clientProfile client) to addrs
1301 1312
1302 do 1313 do
1303 cbu <- atomically $ readTVar (clientsByUser state) 1314 cbu <- atomically $ readTVar (clientsByUser state)
@@ -1335,7 +1346,7 @@ clientInformSubscription state fail k stanza = do
1335 (connChan con) 1346 (connChan con)
1336 answerProbe state (Just from) pk (connChan con) 1347 answerProbe state (Just from) pk (connChan con)
1337 1348
1338peerInformSubscription :: PresenceState 1349peerInformSubscription :: PresenceState stat
1339 -> IO () 1350 -> IO ()
1340 -> PeerAddress 1351 -> PeerAddress
1341 -> StanzaWrap (LockedChan Event) 1352 -> StanzaWrap (LockedChan Event)
@@ -1352,9 +1363,10 @@ peerInformSubscription state fail k stanza = do
1352 fromMaybe fail $ Map.lookup k ktc 1363 fromMaybe fail $ Map.lookup k ktc
1353 <&> \(Conn { connChan=sender_chan 1364 <&> \(Conn { connChan=sender_chan
1354 , auxData =ConnectionData (Left laddr) ctyp profile _ }) -> do 1365 , auxData =ConnectionData (Left laddr) ctyp profile _ }) -> do
1366 let man = manager state profile
1355 (from_u,from_h,_) <- case ctyp of 1367 (from_u,from_h,_) <- case ctyp of
1356 Tox -> return $ splitJID from 1368 Tox -> return $ splitJID from
1357 XMPP -> snd <$> rewriteJIDForClient laddr from [] 1369 XMPP -> snd <$> rewriteJIDForClient man laddr from []
1358 let from'' = unsplitJID (from_u,from_h,Nothing) 1370 let from'' = unsplitJID (from_u,from_h,Nothing)
1359 muser = do 1371 muser = do
1360 to <- stanzaTo stanza 1372 to <- stanzaTo stanza
@@ -1365,10 +1377,10 @@ peerInformSubscription state fail k stanza = do
1365 -- This would allow us to answer anonymous probes with 'unsubscribed'. 1377 -- This would allow us to answer anonymous probes with 'unsubscribed'.
1366 fromMaybe fail $ muser <&> \user -> do 1378 fromMaybe fail $ muser <&> \user -> do
1367 1379
1368 addrs <- resolvePeer from_h 1380 addrs <- resolvePeer man from_h
1369 was_solicited <- removeFromRosterFile ConfigFiles.modifySolicited user profile from'' addrs 1381 was_solicited <- removeFromRosterFile man ConfigFiles.modifySolicited user profile from'' addrs
1370 1382
1371 subs <- resolvedFromRoster ConfigFiles.getSubscribers user profile 1383 subs <- resolvedFromRoster man ConfigFiles.getSubscribers user profile
1372 let is_sub = not . null $ map (from_u,) addrs `intersect` subs 1384 let is_sub = not . null $ map (from_u,) addrs `intersect` subs
1373 dput XJabber $ "DEBUG peerInformSubscription (is_sub,typ)=" ++ show (is_sub,stanzaType stanza) 1385 dput XJabber $ "DEBUG peerInformSubscription (is_sub,typ)=" ++ show (is_sub,stanzaType stanza)
1374 let (relationship,addf,remf) = 1386 let (relationship,addf,remf) =
@@ -1382,8 +1394,8 @@ peerInformSubscription state fail k stanza = do
1382 else "none") 1394 else "none")
1383 , ConfigFiles.modifyOthers 1395 , ConfigFiles.modifyOthers
1384 , ConfigFiles.modifyBuddies ) 1396 , ConfigFiles.modifyBuddies )
1385 addToRosterFile addf user profile from'' addrs 1397 addToRosterFile man addf user profile from'' addrs
1386 removeFromRosterFile remf user profile from'' addrs 1398 removeFromRosterFile man remf user profile from'' addrs
1387 1399
1388 chans <- clientCons' state cktc user 1400 chans <- clientCons' state cktc user
1389 forM_ chans $ \(ckey,(Conn { connChan=chan }, client)) -> do 1401 forM_ chans $ \(ckey,(Conn { connChan=chan }, client)) -> do