summaryrefslogtreecommitdiff
path: root/dht/Presence/Presence.hs
diff options
context:
space:
mode:
Diffstat (limited to 'dht/Presence/Presence.hs')
-rw-r--r--dht/Presence/Presence.hs1428
1 files changed, 1428 insertions, 0 deletions
diff --git a/dht/Presence/Presence.hs b/dht/Presence/Presence.hs
new file mode 100644
index 00000000..8cdd1cdc
--- /dev/null
+++ b/dht/Presence/Presence.hs
@@ -0,0 +1,1428 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE ExistentialQuantification #-}
3{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE TupleSections #-}
6module Presence where
7
8import System.Directory
9import System.IO.Error
10#ifndef THREAD_DEBUG
11import Control.Concurrent
12#else
13import Control.Concurrent.Lifted.Instrument
14#endif
15
16import Control.Concurrent.STM
17import Control.Monad.Trans
18import Network.Socket ( SockAddr(..) )
19import Data.Char
20import Data.List (nub, (\\), intersect, groupBy, sort, sortBy )
21import Data.Ord (comparing )
22import Data.Monoid ((<>))
23import qualified Data.Text as Text
24import qualified Data.Text.Encoding as Text
25import Control.Monad
26import Data.Text (Text)
27import qualified Data.Map as Map
28import Data.Map (Map)
29import Control.Exception ({-evaluate,-}handle,SomeException(..))
30import System.Posix.User (getUserEntryForID,userName)
31import qualified Data.ByteString.Lazy.Char8 as L
32import qualified ConfigFiles
33import Data.Maybe
34import Data.Bits
35import Data.Int (Int8)
36import Data.XML.Types (Event)
37import System.Posix.Types (UserID,CPid)
38import Control.Applicative
39import Crypto.PubKey.Curve25519 (SecretKey,toPublic)
40
41import ControlMaybe
42import DNSCache (parseAddress, strip_brackets, withPort)
43import LockedChan (LockedChan)
44import Text.Read (readMaybe)
45import UTmp (ProcessID,users)
46import LocalPeerCred
47import XMPPServer
48import ConsoleWriter
49import ClientState
50import Util
51import qualified Connection
52 ;import Connection (PeerAddress (..), resolvePeer, reverseAddress)
53import Network.Tox.NodeId (key2id,parseNoSpamId,nospam64,NoSpamId(..),ToxProgress,ToxContact(..))
54import Crypto.Tox (decodeSecret)
55import DPut
56import DebugTag
57
58{-
59isPeerKey :: ClientAddress -> Bool
60isPeerKey k = case k of { PeerKey {} -> True ; _ -> False }
61
62isClientKey :: ClientAddress -> Bool
63isClientKey k = case k of { ClientKey {} -> True ; _ -> False }
64-}
65
66localJID :: Text -> Text -> Text -> IO Text
67localJID user "." resource = do
68 hostname <- textHostName
69 return $ user <> "@" <> hostname <> "/" <> resource
70localJID user profile resource =
71 return $ user <> "@" <> profile <> "/" <> resource
72
73-- | These hooks will be invoked in order to connect to *.tox hosts in the
74-- user's roster.
75--
76-- The parameter k is a lookup key corresponding to an XMPP client. Each
77-- unique value should be able to hold a reference to the ToxID identity which
78-- should stay online until all interested keys have run 'deactivateAccount'.
79data ToxManager k = ToxManager
80 -- | Put the given ToxID online.
81 { activateAccount :: k -> Text -> SecretKey -> IO ()
82 -- | Take the given ToxID offline (assuming no other /k/ has a claim).
83 , deactivateAccount :: k -> Text -> IO ()
84 , toxConnections :: Connection.Manager ToxProgress ToxContact
85 -- | Given a remote Tox key, return the address of a connected peer.
86 --
87 -- The arguments are our public key (in base64 format) followed by
88 -- their public key (in base64 format).
89 , resolveToxPeer :: Text -> Text -> IO (Maybe PeerAddress)
90 }
91
92type ClientProfile = Text
93
94data PresenceState status = PresenceState
95 { clients :: TVar (Map ClientAddress ClientState)
96 , clientsByUser :: TVar (Map Text LocalPresence)
97 , clientsByProfile :: TVar (Map Text LocalPresence)
98 , remotesByPeer :: TVar (Map PeerAddress
99 (Map UserName RemotePresence))
100 , server :: XMPPServer
101 , manager :: ClientProfile -> Connection.Manager status Text
102 , ckeyToChan :: TVar (Map ClientAddress Conn)
103 , pkeyToChan :: TVar (Map PeerAddress Conn)
104 , consoleWriter :: Maybe ConsoleWriter
105 , toxManager :: Maybe (ToxManager ClientAddress)
106 }
107
108
109newPresenceState :: Maybe ConsoleWriter
110 -> Maybe (PresenceState status -> ToxManager ClientAddress)
111 -> XMPPServer
112 -> (ClientProfile -> Connection.Manager status Text)
113 -> IO (PresenceState status)
114newPresenceState cw toxman sv man = atomically $ do
115 clients <- newTVar Map.empty
116 clientsByUser <- newTVar Map.empty
117 clientsByProfile <- newTVar Map.empty
118 remotesByPeer <- newTVar Map.empty
119 ckeyToChan <- newTVar Map.empty
120 pkeyToChan <- newTVar Map.empty
121 let st = PresenceState
122 { clients = clients
123 , clientsByUser = clientsByUser
124 , clientsByProfile = clientsByProfile
125 , remotesByPeer = remotesByPeer
126 , ckeyToChan = ckeyToChan
127 , pkeyToChan = pkeyToChan
128 , server = sv
129 , manager = man
130 , consoleWriter = cw
131 , toxManager = Nothing
132 }
133 return $ st { toxManager = fmap ($ st) toxman }
134
135
136nameForClient :: PresenceState stat -> ClientAddress -> IO Text
137nameForClient state k = do
138 mc <- atomically $ do
139 cmap <- readTVar (clients state)
140 return $ Map.lookup k cmap
141 case mc of
142 Nothing -> textHostName
143 Just client -> case clientProfile client of
144 "." -> textHostName
145 profile -> return profile
146
147presenceHooks :: PresenceState stat -> Map Text MUC
148 -> Int
149 -> Maybe SockAddr -- ^ client-to-server bind address
150 -> Maybe SockAddr -- ^ server-to-server bind address
151 -> XMPPServerParameters
152presenceHooks state chats verbosity mclient mpeer = XMPPServerParameters
153 { xmppChooseResourceName = chooseResourceName state
154 , xmppTellClientHisName = tellClientHisName state
155 , xmppTellMyNameToClient = nameForClient state
156 , xmppTellMyNameToPeer = \(Local addr) -> return $ addrToText addr
157 , xmppTellPeerHisName = return . peerKeyToText
158 , xmppNewConnection = newConn state
159 , xmppEOF = eofConn state
160 , xmppRosterBuddies = rosterGetBuddies state
161 , xmppRosterSubscribers = rosterGetSubscribers state
162 , xmppRosterSolicited = rosterGetSolicited state
163 , xmppRosterOthers = rosterGetOthers state
164 , xmppSubscribeToRoster = informSentRoster state
165 , xmppDeliverMessage = deliverMessage state
166 , xmppInformClientPresence = informClientPresence state
167 , xmppInformPeerPresence = informPeerPresence state
168 , xmppAnswerProbe = \k stanza chan -> answerProbe state (stanzaTo stanza) k chan
169 , xmppClientSubscriptionRequest = clientSubscriptionRequest state
170 , xmppPeerSubscriptionRequest = peerSubscriptionRequest state
171 , xmppClientInformSubscription = clientInformSubscription state
172 , xmppPeerInformSubscription = peerInformSubscription state
173 , xmppVerbosity = return verbosity
174 , xmppGroupChat = chats {- Map.singleton "chat" chat
175 { mucRoomList = return [("testroom",Just "testroom")]
176 , mucRoomOccupants = \case
177 "testroom" -> return [("fakeperson",Nothing)]
178 _ -> return []
179 , mucReservedNick = \case
180 "testroom" -> return $ Just (return . Just)
181 _ -> return Nothing
182 , mucJoinRoom = \room nick caddr stanza -> do
183 who <- tellClientHisName state caddr
184 dput XJabber $ Text.unpack who ++ " joined " ++ Text.unpack room
185 ++ " with nick: " ++ Text.unpack nick
186 -- TODO: broadcast presence to all participants.
187 -- See 7.2.3 of XEP-0045
188 -}
189 , xmppClientBind = mclient
190 , xmppPeerBind = mpeer
191 }
192
193
194data LocalPresence = LocalPresence
195 { networkClients :: Map ClientAddress ClientState
196 -- TODO: loginClients
197 }
198
199data RemotePresence = RemotePresence
200 { resources :: Map ResourceName Stanza
201 -- , localSubscribers :: Map Text ()
202 -- ^ subset of clientsByUser who should be
203 -- notified about this presence.
204 }
205
206
207
208pcSingletonNetworkClient :: ClientAddress -> ClientState -> LocalPresence
209pcSingletonNetworkClient key client =
210 LocalPresence
211 { networkClients = Map.singleton key client
212 }
213
214pcInsertNetworkClient :: ClientAddress -> ClientState -> LocalPresence -> LocalPresence
215pcInsertNetworkClient key client pc =
216 pc { networkClients = Map.insert key client (networkClients pc) }
217
218pcRemoveNewtworkClient :: ClientAddress
219 -> LocalPresence -> Maybe LocalPresence
220pcRemoveNewtworkClient key pc = if pcIsEmpty pc' then Nothing
221 else Just pc'
222 where
223 pc' = pc { networkClients = Map.delete key (networkClients pc) }
224
225pcIsEmpty :: LocalPresence -> Bool
226pcIsEmpty pc = Map.null (networkClients pc)
227
228
229
230getConsolePids :: PresenceState stat -> IO [(Text,ProcessID)]
231getConsolePids state = do
232 us <- UTmp.users
233 return $ map (\(_,tty,pid)->(lazyByteStringToText tty,pid)) us
234
235identifyTTY' :: [(Text, ProcessID)]
236 -> System.Posix.Types.UserID
237 -> L.ByteString
238 -> IO (Maybe Text, Maybe System.Posix.Types.CPid)
239identifyTTY' ttypids uid inode = ttypid
240 where ttypids' = map (\(tty,pid)->(L.fromChunks [Text.encodeUtf8 tty], pid)) ttypids
241 ttypid = fmap textify $ identifyTTY ttypids' uid inode
242 textify (tty,pid) = (fmap lazyByteStringToText tty, pid)
243
244chooseResourceName :: PresenceState stat
245 -> ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO Text
246chooseResourceName state k (Remote addr) clientsNameForMe desired = do
247 muid <- getLocalPeerCred' addr
248 (mtty,pid) <- getTTYandPID muid
249 user <- getJabberUserForId muid
250 status <- atomically $ newTVar Nothing
251 flgs <- atomically $ newTVar 0
252 profile <- fmap (fromMaybe ".")
253 $ forM ((,) <$> clientsNameForMe <*> toxManager state) $ \(wanted_profile0,toxman) ->
254 case Text.splitAt 43 wanted_profile0 of
255 (pub,".tox") -> do
256 cdir <- ConfigFiles.configPath (L.fromChunks [Text.encodeUtf8 user]) "." ""
257#if !MIN_VERSION_directory(1,2,5)
258 let listDirectory path = filter (`notElem` [".",".."]) <$> getDirectoryContents path
259#endif
260 cfs <- map Text.pack <$> listDirectory cdir `catchIOError` (\e -> return [])
261 let profiles = filter (\f -> Text.toLower f == Text.toLower wanted_profile0) cfs
262 -- dput XMisc $ "Toxmpp profile " ++ show (user,wanted_profile0,profiles,cfs)
263 let wanted_profile = head $ profiles ++ [wanted_profile0]
264 secs <- configText ConfigFiles.getSecrets user wanted_profile
265 case secs of
266 sec:_ | Just s <- decodeSecret (Text.encodeUtf8 sec)
267 , map toLower (show $ key2id $ toPublic s) == map toLower (Text.unpack pub)
268 -> do activateAccount toxman k wanted_profile s
269 dput XMisc $ "loaded tox secret " ++ show sec
270 return wanted_profile
271 _ -> do
272 -- XXX: We should probably fail to connect when an
273 -- invalid Tox profile is used. For now, we'll
274 -- fall back to the Unix account login.
275 dput XMisc "failed to find tox secret"
276 return "."
277 ("*.tox","") -> do
278 dput XMisc $ "TODO: Match single tox key profile or generate first."
279 -- TODO: Match single tox key profile or generate first.
280 _todo
281 _ -> return "."
282 let client = ClientState { clientResource = maybe "fallback" id mtty
283 , clientUser = user
284 , clientProfile = profile
285 , clientPid = pid
286 , clientStatus = status
287 , clientFlags = flgs }
288
289 do -- forward-lookup of the buddies so that it is cached for reversing.
290 buds <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client)
291 forM_ buds $ \bud -> do
292 let (_,h,_) = splitJID bud
293 forkIO $ void $ resolvePeer (manager state $ clientProfile client) h
294
295 atomically $ do
296 modifyTVar' (clients state) $ Map.insert k client
297 let add mb = Just $ maybe (pcSingletonNetworkClient k client)
298 (pcInsertNetworkClient k client)
299 mb
300 modifyTVar' (clientsByUser state) $ Map.alter add (clientUser client)
301 modifyTVar' (clientsByProfile state) $ Map.alter add (clientProfile client)
302
303 localJID (clientUser client) (clientProfile client) (clientResource client)
304
305 where
306 getTTYandPID muid = do
307 -- us <- fmap (map (second fst) . Map.toList) . readTVarIO $ activeUsers state
308 ttypids <- getConsolePids state
309 -- let tailOf3 ((_,a),b) = (a,b)
310 (t,pid) <- case muid of
311 Just (uid,inode) -> identifyTTY' ttypids uid inode
312 Nothing -> return (Nothing,Nothing)
313 let rsc = t `mplus` fmap ( ("pid."<>) . Text.pack . show ) pid
314 return (rsc,pid)
315
316 getJabberUserForId muid =
317 maybe (return "nobody")
318 (\(uid,_) ->
319 handle (\(SomeException _) ->
320 return . (<> "uid.") . Text.pack . show $ uid)
321 $ do
322 user <- fmap userName $ getUserEntryForID uid
323 return (Text.pack user)
324 )
325 muid
326
327-- Perform action with 'ClientState' associated with the given 'ClientAddress'.
328-- If there is no associated 'ClientState', then perform the supplied fallback
329-- action.
330forClient :: PresenceState stat -> ClientAddress -> IO b -> (ClientState -> IO b) -> IO b
331forClient state k fallback f = do
332 mclient <- atomically $ do
333 cs <- readTVar (clients state)
334 return $ Map.lookup k cs
335 maybe fallback f mclient
336
337tellClientHisName :: PresenceState stat -> ClientAddress -> IO Text
338tellClientHisName state k = forClient state k fallback go
339 where
340 fallback = localJID "nobody" "." "fallback"
341 go client = localJID (clientUser client) (clientProfile client) (clientResource client)
342
343toMapUnit :: Ord k => [k] -> Map k ()
344toMapUnit xs = Map.fromList $ map (,()) xs
345
346resolveAllPeers :: Connection.Manager stat Text -> [Text] -> IO (Map PeerAddress ())
347resolveAllPeers man hosts = fmap (toMapUnit . concat) $ Prelude.mapM (fmap (take 1) . resolvePeer man) hosts
348
349
350-- Read a roster file and start trying to connect to all relevent peers.
351rosterGetStuff
352 :: (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString])
353 -> PresenceState stat -> ClientAddress -> IO [Text]
354rosterGetStuff what state k = forClient state k (return [])
355 $ \client -> do
356 jids0 <- configText what (clientUser client) (clientProfile client)
357 let jids = map splitJID jids0
358 -- Using case to bring 'status' type variable to Connection.Manager into scope.
359 case state of
360 PresenceState { server = sv } -> do
361 let conns = manager state $ clientProfile client
362 -- Grok peers to associate with from the roster:
363 let isTox = do (me , ".tox") <- Just $ Text.splitAt 43 (clientProfile client)
364 return me
365 noToxUsers (u,h,r)
366 | Text.isSuffixOf ".tox" h = unsplitJID (Nothing,h,r)
367 | otherwise = unsplitJID (u,h,r)
368 forM_ jids $ \(_,host,_) -> do
369 -- We need either conns :: Connection.Manager TCPStatus Text
370 -- or toxman :: ToxManager ClientAddress
371 -- It is decided by checking hostnames for .tox ending.
372 let policySetter = fromMaybe (Connection.setPolicy conns host) $ do
373 isTox
374 toxman <- toxManager state
375 (them, ".tox") <- Just $ Text.splitAt 43 host
376 meid <- readMaybe $ Text.unpack $ Text.take 43 (clientProfile client)
377 themid <- readMaybe $ Text.unpack them
378 return $ Connection.setPolicy (toxConnections toxman)
379 (ToxContact meid themid)
380 policySetter Connection.TryingToConnect
381 return $ fromMaybe jids0 $ do isTox
382 Just $ map noToxUsers jids
383
384rosterGetBuddies :: PresenceState stat -> ClientAddress -> IO [Text]
385rosterGetBuddies state k = rosterGetStuff ConfigFiles.getBuddies state k
386
387rosterGetSolicited :: PresenceState stat -> ClientAddress -> IO [Text]
388rosterGetSolicited = rosterGetStuff ConfigFiles.getSolicited
389
390-- XXX: Should we be connecting to these peers?
391rosterGetOthers :: PresenceState stat -> ClientAddress -> IO [Text]
392rosterGetOthers = rosterGetStuff ConfigFiles.getOthers
393
394rosterGetSubscribers :: PresenceState stat -> ClientAddress -> IO [Text]
395rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers
396
397data Conn = Conn { connChan :: TChan Stanza
398 , auxData :: ConnectionData }
399
400-- Read config file as Text content rather than UTF8 bytestrings.
401configText :: Functor f =>
402 (ConfigFiles.User -> ConfigFiles.Profile -> f [L.ByteString])
403 -> Text -- user
404 -> Text -- profile
405 -> f [Text] -- items
406configText what u p = fmap (map lazyByteStringToText)
407 $ what (textToLazyByteString u) (Text.unpack p)
408
409getBuddies' :: Text -> Text -> IO [Text]
410getBuddies' = configText ConfigFiles.getBuddies
411getSolicited' :: Text -> Text -> IO [Text]
412getSolicited' = configText ConfigFiles.getSolicited
413
414-- | Obtain from roster all buddies and pending buddies (called solicited
415-- regardless of whether we've yet delivered a friend-request) matching the
416-- supplied side-effecting predicate.
417--
418-- Returned tuple:
419--
420-- * Bool - True if buddy (should send probe).
421-- False if solicited (should send friend-request).
422--
423-- * Maybe Username - Username field of contact.
424--
425-- * Text - Unix user who owns this roster entry.
426--
427-- * Text - Hostname as it appears in roster.
428--
429getBuddiesAndSolicited :: PresenceState stat
430 -> Text -- ^ Config profile: "." or tox host.
431 -> (Text -> IO Bool) -- ^ Return True if you want this hostname.
432 -> IO [(Bool, Maybe UserName, Text, Text)]
433getBuddiesAndSolicited state profile pred
434 -- XXX: The following O(n²) nub may be a little
435 -- too onerous.
436 = fmap nub $ do
437 cbu <- atomically $ readTVar $ clientsByUser state
438 fmap concat $ sequence $ do
439 (user,LocalPresence cmap) <- Map.toList cbu
440 (isbud, getter) <- [(True ,getBuddies' )
441 ,(False,getSolicited')]
442 return $ do
443 buds <- map splitJID <$> getter user profile
444 fmap concat $ forM buds $ \(u,h,r) -> do
445 interested <- pred h
446 if interested
447 then return [(isbud,u,user,h)]
448 else return []
449
450sendProbesAndSolicitations :: PresenceState stat -> PeerAddress -> Local SockAddr -> TChan Stanza -> IO ()
451sendProbesAndSolicitations state k (Local laddr) chan = do
452 prof <- atomically $ do
453 pktc <- readTVar (pkeyToChan state)
454 return $ maybe "." (cdProfile . auxData) $ Map.lookup k pktc
455 -- get all buddies & solicited matching k for all users
456 xs <- getBuddiesAndSolicited state prof $ \case
457 h | ".tox" `Text.isSuffixOf` h -> return False -- Tox probes/solicitations are handled in ToxToXMPP module.
458 h -> do
459 addrs <- nub <$> resolvePeer (manager state $ prof) h
460 return $ k `elem` addrs -- Roster item resolves to /k/ peer.
461 forM_ xs $ \(isbud,u,user,h) -> do
462 let make = if isbud then presenceProbe
463 else presenceSolicitation
464 toh = peerKeyToText k
465 jid = unsplitJID (u,toh,Nothing)
466 me = addrToText laddr -- xmppTellMyNameToPeer
467 from = if isbud then me -- probe from server
468 else -- solicitation from particular user
469 unsplitJID (Just user,me,Nothing)
470 stanza <- make from jid
471 -- send probes for buddies, solicitations for solicited.
472 dput XJabber $ "probing "++show k++" for: " ++ show (isbud,jid)
473 atomically $ writeTChan chan stanza
474 -- reverse xs `seq` return ()
475
476
477newConn :: PresenceState stat -> SockAddr -> ConnectionData -> TChan Stanza -> IO ()
478newConn state saddr cdta outchan =
479 case classifyConnection saddr cdta of
480 Left (pkey,laddr) -> do
481 atomically $ modifyTVar' (pkeyToChan state)
482 $ Map.insert pkey Conn { connChan = outchan
483 , auxData = cdta }
484 sendProbesAndSolicitations state pkey laddr outchan
485 Right (ckey,_) -> do
486 atomically $ modifyTVar' (ckeyToChan state)
487 $ Map.insert ckey Conn { connChan = outchan
488 , auxData = cdta }
489
490delclient :: (Alternative m, Monad m) =>
491 ClientAddress -> m LocalPresence -> m LocalPresence
492delclient k mlp = do
493 lp <- mlp
494 let nc = Map.delete k $ networkClients lp
495 guard $ not (Map.null nc)
496 return $ lp { networkClients = nc }
497
498eofConn :: PresenceState stat -> SockAddr -> ConnectionData -> IO ()
499eofConn state saddr cdta = do
500 case classifyConnection saddr cdta of
501 Left (k,_) -> do
502 h <- case cdType cdta of
503 -- TODO: This should be cached (perhaps by rewriteJIDForClient?) so that we
504 -- guarantee that the OFFLINE message matches the ONLINE message.
505 -- For now, we reverse-resolve the peer key.
506 XMPP -> -- For XMPP peers, informPeerPresence expects a textual
507 -- representation of the IP address to reverse-resolve.
508 return $ peerKeyToText k
509 Tox -> do
510 -- For Tox peers, informPeerPresence expects the actual hostname
511 -- so we will use the one that the peer told us at greeting time.
512 m <- atomically $ swapTVar (cdRemoteName cdta) Nothing
513 case m of
514 Nothing -> do
515 dput XJabber $ "BUG: Tox peer didn't inform us of its name."
516 -- The following fallback behavior is probably wrong.
517 return $ peerKeyToText k
518 Just toxname -> return toxname
519 -- ioToSource terminated.
520 --
521 -- dhtd: Network.Socket.getAddrInfo
522 -- (called with preferred socket type/protocol: AddrInfo
523 -- { addrFlags = [AI_NUMERICHOST], addrFamily = AF_UNSPEC
524 -- , addrSocketType = NoSocketType, addrProtocol = 0
525 -- , addrAddress = <assumed to be undefined>
526 -- , addrCanonName = <assumed to be undefined>}
527 -- , host name: Just "DdhbLjiwaV0GAiGKgesNPbvj2TbhrBHEWEEc5icfvQN.tox"
528 -- , service name: Just "0")
529 -- : does not exist (Name or service not known)
530
531 jids <- atomically $ do
532 rbp <- readTVar (remotesByPeer state)
533 return $ do
534 umap <- maybeToList $ Map.lookup k rbp
535 (u,rp) <- Map.toList umap
536 r <- Map.keys (resources rp)
537 let excludeEmpty "" = Nothing
538 excludeEmpty x = Just x
539 return $ unsplitJID (excludeEmpty u, h, excludeEmpty r)
540 -- EOF PEER PeerAddress [d768:82dd:3e86:a6ba:8fb3:6f9c:6327:75d8%4236342772]:0:
541 -- ["@[d768:82dd:3e86:a6ba:8fb3:6f9c:6327:75d8%4236342772]/"]
542 -- dput XJabber $ "EOF PEER "++show k++": "++show jids
543 forM_ jids $ \jid -> do
544 stanza <- makePresenceStanza "jabber:client" (Just jid) Offline
545 informPeerPresence state k stanza
546 Right (k,_) -> do
547 forClient state k (return ()) $ \client -> do
548 forM_ (toxManager state) $ \toxman -> do
549 case Text.splitAt 43 (clientProfile client) of
550 (pub,".tox") -> deactivateAccount toxman k (clientProfile client)
551 _ -> return ()
552 stanza <- makePresenceStanza "jabber:server" Nothing Offline
553 informClientPresence state k stanza
554 atomically $ do
555 modifyTVar' (clientsByUser state) $ Map.alter (delclient k) (clientUser client)
556 modifyTVar' (clientsByProfile state) $ Map.alter (delclient k) (clientProfile client)
557 atomically $ case classifyConnection saddr cdta of
558 Left (pkey,_) -> modifyTVar' (pkeyToChan state) $ Map.delete pkey
559 Right (ckey,_) -> modifyTVar' (ckeyToChan state) $ Map.delete ckey
560
561{-
562parseRemoteAddress :: Text -> IO (Maybe (Remote SockAddr))
563parseRemoteAddress s = fmap Remote <$> parseAddress s
564-}
565
566-- This attempts to reverse resolve a peers address to give the human-friendly
567-- domain name as it appears in the roster. It prefers host names that occur
568-- in the given list of JIDs, but will fall back to any reverse-resolved name
569-- and if it was unable to reverse the address, it will yield an ip address.
570peerKeyToResolvedName :: Connection.Manager s Text -> [Text] -> PeerAddress -> IO Text
571peerKeyToResolvedName man buds pk = do
572 ns <- reverseAddress man pk
573 let hs = map (\jid -> let (_,h,_)=splitJID jid in h) buds
574 ns' = sortBy (comparing $ not . flip elem hs) ns
575 return $ fromMaybe (peerKeyToText pk) (listToMaybe ns')
576
577
578-- | The given address is taken to be the local address for the socket this JID
579-- came in on. The returned JID parts are suitable for unsplitJID to create a
580-- valid JID for communicating to a client. The returned Bool is True when the
581-- host part refers to this local host (i.e. it equals the given SockAddr).
582-- If there are multiple results, it will prefer one which is a member of the
583-- given list in the last argument.
584rewriteJIDForClient :: Connection.Manager s Text -> Local SockAddr -> Text -> [Text] -> IO (Bool,(Maybe Text,Text,Maybe Text))
585rewriteJIDForClient man (Local laddr) jid buds = do
586 let (n,h,r) = splitJID jid
587 -- dput XJabber $ "rewriteJIDForClient parsing " ++ show h
588 maddr <- parseAddress (strip_brackets h)
589 fromMaybe (return (False,(n,ip6literal h,r))) $ maddr <&> \saddr -> do
590 let mine = sameAddress laddr saddr
591 h' <- if mine then textHostName
592 else peerKeyToResolvedName man buds (addrToPeerKey $ Remote saddr)
593 return (mine,(n,h',r))
594
595-- Given a local address and an IP-address JID, we return True if the JID is
596-- local, False otherwise. Additionally, a list of equivalent hostname JIDS
597-- are returned.
598multiplyJIDForClient :: Connection.Manager s Text -> ClientAddress -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)])
599multiplyJIDForClient man k jid = do
600 let (n,h,r) = splitJID jid
601 -- dput XJabber $ "multiplyJIDForClient parsing " ++ show h
602 maddr <- parseAddress (strip_brackets h)
603 fromMaybe (return (False,[(n,ip6literal h,r)])) $ maddr <&> \saddr -> do
604 let Local laddr = addrFromClientKey k
605 mine = sameAddress laddr saddr
606 names <- if mine then fmap (:[]) textHostName
607 else reverseAddress man (addrToPeerKey $ Remote saddr)
608 return (mine,map (\h' -> (n,h',r)) names)
609
610
611guardPortStrippedAddress :: Text -> Local SockAddr -> IO (Maybe ())
612guardPortStrippedAddress h (Local laddr) = do
613 -- dput XJabber $ "guardPortStrippedAddress parsing " ++ show h
614 maddr <- fmap (fmap (`withPort` 0)) $ parseAddress (strip_brackets h)
615 let laddr' = laddr `withPort` 0
616 return $ maddr >>= guard . (==laddr')
617
618
619-- | Accepts a textual representation of a domainname
620-- JID suitable for client connections, and returns the
621-- coresponding ipv6 address JID suitable for peers paired
622-- with a PeerAddress with the address part of that JID in
623-- binary form. If no suitable address could be resolved
624-- for the given name, Nothing is returned.
625rewriteJIDForPeer :: Connection.Manager s Text -> Text -> IO (Maybe (Text,PeerAddress))
626rewriteJIDForPeer man jid = do
627 let (n,h,r) = splitJID jid
628 maddr <- fmap listToMaybe $ resolvePeer man h
629 return $ flip fmap maddr $ \addr ->
630 let h' = peerKeyToText addr
631 to' = unsplitJID (n,h',r)
632 in (to',addr)
633
634deliverToConsole :: PresenceState stat -> IO () -> Stanza -> IO ()
635deliverToConsole PresenceState{ consoleWriter = Just cw } fail msg = do
636 did1 <- writeActiveTTY cw msg
637 did2 <- writeAllPty cw msg
638 if not (did1 || did2) then fail else return ()
639deliverToConsole _ fail _ = fail
640
641-- | deliver <message/> or error stanza
642deliverMessage :: PresenceState stat
643 -> IO ()
644 -> StanzaWrap (LockedChan Event)
645 -> IO ()
646deliverMessage state fail msg =
647 case stanzaOrigin msg of
648 ClientOrigin senderk _ -> do
649 -- Case 1. Client -> Peer
650 mto <- join $ atomically $ do
651 mclient <- Map.lookup senderk <$> readTVar (clients state)
652 return $ do
653 dput XJabber $ "deliverMessage: to="++show (stanzaTo msg,fmap clientProfile mclient)
654 fromMaybe -- Resolve XMPP peer.
655 (fmap join $ mapM (uncurry $ rewriteJIDForPeer . manager state)
656 $ (,) <$> (clientProfile <$> mclient) <*> stanzaTo msg)
657 $ do
658 client <- mclient
659 to <- stanzaTo msg
660 let (mu,th,rsc) = splitJID to
661 (toxman,me,_) <- weAreTox state client th
662 return $ do
663 dput XJabber $ "deliverMessage: weAreTox="++show me
664 -- In case the client sends us a lower-cased version of the base64
665 -- tox key hostname, we resolve it by comparing it with roster entries.
666 xs <- getBuddiesAndSolicited state (clientProfile client) $ \case
667 rh | (_,".tox") <- Text.splitAt 43 rh
668 , Text.toLower rh == Text.toLower th
669 -> return True
670 _ -> return False
671 fmap join $ forM (listToMaybe xs) $ \(_,rmu,_,h) -> do
672 let (them,_) = Text.splitAt 43 h
673 maddr <- resolveToxPeer toxman me them
674 let to' = unsplitJID (mu,h,rsc)
675 return $ fmap (to',) maddr
676 fromMaybe (do dput XJabber $ "Unable to resolve "++show (stanzaTo msg)
677 fail {- reverse lookup failure -})
678 $ mto <&> \(to',k) -> do
679 chans <- atomically $ readTVar (pkeyToChan state)
680 fromMaybe (do dput XJabber $ "Peer unavailable: "++ show k
681 fail)
682 $ (Map.lookup k chans) <&> \conn -> do
683 -- original 'from' address is discarded.
684 from' <- forClient state senderk (return Nothing)
685 $ return . Just . clientJID conn
686 -- dup <- atomically $ cloneStanza (msg { stanzaTo=Just to', stanzaFrom=Just from' })
687 let dup = (msg { stanzaTo=Just to', stanzaFrom=from' })
688 sendModifiedStanzaToPeer dup (connChan conn)
689 PeerOrigin senderk _ -> do
690 (pchans,cchans) <- atomically $ do
691 pc <- readTVar (pkeyToChan state)
692 cc <- readTVar (ckeyToChan state)
693 return (pc,cc)
694 fromMaybe (do dput XJabber $ "Unknown peer " ++ show senderk
695 fail)
696 $ Map.lookup senderk pchans
697 <&> \(Conn { connChan = sender_chan
698 , auxData = ConnectionData (Left laddr) ctyp cprof _ }) -> do
699 fromMaybe (do dput XJabber $ "Message missing \"to\" attribute."
700 fail)
701 $ (stanzaTo msg) <&> \to -> do
702 (mine,(n,h,r)) <- case (ctyp,cprof) of
703 (Tox,prof) -> let (n,h,r) = splitJID to
704 in return ( h==prof, (n,h,r) )
705 _ -> rewriteJIDForClient (manager state cprof) laddr to []
706 if not mine then do dput XJabber $ "Address mis-match " ++ show (laddr,to)
707 fail
708 else do
709 let to' = unsplitJID (n,h,r)
710 let (cmapVar,ckey) = case ctyp of
711 Tox -> (clientsByProfile state , Just cprof )
712 XMPP -> (clientsByUser state , n )
713 cmap <- atomically . readTVar $ cmapVar
714 chans <- fmap (fromMaybe []) $ do
715 forM (ckey >>= flip Map.lookup cmap) $ \presence_container -> do
716 let ks = Map.keys (networkClients presence_container)
717 chans = do
718 (k,client) <- Map.toList $ networkClients presence_container
719 chan <- maybeToList $ Map.lookup k cchans
720 return (clientProfile client, clientUser client, chan)
721 forM chans $ \(profile,user,chan) -> do
722 buds <- configText ConfigFiles.getBuddies user profile
723 from' <- case ctyp of
724 Tox -> return $ stanzaFrom msg
725 XMPP -> do
726 forM (stanzaFrom msg) $ \from -> do
727 (_,trip) <- rewriteJIDForClient (manager state cprof) laddr from buds
728 return $ unsplitJID trip
729 to' <- case ctyp of
730 XMPP -> return $ stanzaTo msg
731 Tox -> return $ Just $ unsplitJID (Just user, profile, Nothing)
732 return (from',chan)
733 dput XJabber $ "chan count: " ++ show (length chans)
734 if null chans then when (ctyp == XMPP) $ do
735 forM_ (stanzaFrom msg) $ \from -> do
736 from' <- do
737 -- Fallback to "." profile when no clients.
738 buds <- maybe (return [])
739 (\n -> configText ConfigFiles.getBuddies n ".")
740 n
741 (_,trip) <- rewriteJIDForClient (manager state cprof) laddr from buds
742 return . Just $ unsplitJID trip
743 let msg' = msg { stanzaTo=Just to'
744 , stanzaFrom=from' }
745 deliverToConsole state fail msg'
746 else do
747 forM_ chans $ \(from',Conn { connChan=chan}) -> do
748 -- TODO: Cloning isn't really necessary unless there are multiple
749 -- destinations and we should probably transition to minimal cloning,
750 -- or else we should distinguish between announcable stanzas and
751 -- consumable stanzas and announcables use write-only broadcast
752 -- channels that must be cloned in order to be consumed.
753 -- For now, we are doing redundant cloning.
754 let msg' = msg { stanzaTo=Just to'
755 , stanzaFrom=from' }
756 dup <- cloneStanza msg'
757 sendModifiedStanzaToClient dup
758 chan
759
760
761setClientFlag :: PresenceState stat -> ClientAddress -> Int8 -> IO ()
762setClientFlag state k flag =
763 atomically $ do
764 cmap <- readTVar (clients state)
765 forM_ (Map.lookup k cmap) $ \client -> do
766 setClientFlag0 client flag
767
768setClientFlag0 :: ClientState -> Int8 -> STM ()
769setClientFlag0 client flag =
770 modifyTVar' (clientFlags client) (\flgs -> flgs .|. flag)
771
772informSentRoster :: PresenceState stat -> ClientAddress -> IO ()
773informSentRoster state k = do
774 setClientFlag state k cf_interested
775
776
777subscribedPeers :: Connection.Manager s Text -> Text -> Text -> IO [PeerAddress]
778subscribedPeers man user profile = do
779 jids <- configText ConfigFiles.getSubscribers user profile
780 let hosts = map ((\(_,h,_)->h) . splitJID) jids
781 fmap Map.keys $ resolveAllPeers man hosts
782
783-- | this JID is suitable for peers, not clients.
784clientJID :: Conn -> ClientState -> Text
785clientJID con client = unsplitJID ( Just $ clientUser client
786 , either (\(Local a) -> addrToText a) -- my host name, for peers
787 (error $ unlines [ "clientJID wrongly used for client connection!"
788 , "TODO: my host name for clients? nameForClient? localJID?"])
789 $ cdAddr $ auxData con
790 , Just $ clientResource client)
791
792-- | Send presence notification to subscribed peers.
793-- Note that a full JID from address will be added to the
794-- stanza if it is not present.
795informClientPresence :: PresenceState stat
796 -> ClientAddress -> StanzaWrap (LockedChan Event) -> IO ()
797informClientPresence state k stanza = do
798 forClient state k (return ()) $ \client -> do
799 informClientPresence0 state (Just k) client stanza
800
801informClientPresence0 :: PresenceState stat
802 -> Maybe ClientAddress
803 -> ClientState
804 -> StanzaWrap (LockedChan Event)
805 -> IO ()
806informClientPresence0 state mbk client stanza = do
807 dup <- cloneStanza stanza
808 atomically $ writeTVar (clientStatus client) $ Just dup
809 is_avail <- atomically $ clientIsAvailable client
810 when (not is_avail) $ do
811 atomically $ setClientFlag0 client cf_available
812 maybe (return ()) (sendCachedPresence state) mbk
813 addrs <- subscribedPeers (manager state $ clientProfile client) (clientUser client) (clientProfile client)
814 dput XJabber $ "informClientPresence(subscribedPeers) "++show (clientProfile client,addrs)
815 ktc <- atomically $ readTVar (pkeyToChan state)
816 let connected = mapMaybe (flip Map.lookup ktc) addrs
817 forM_ connected $ \con -> do
818 let from' = clientJID con client
819 mto <- maybe (return Nothing)
820 (fmap (fmap fst) . rewriteJIDForPeer (manager state $ clientProfile client))
821 (stanzaTo stanza)
822 dup <- cloneStanza stanza
823 sendModifiedStanzaToPeer dup { stanzaFrom = Just from'
824 , stanzaTo = mto }
825 (connChan con)
826
827informPeerPresence :: PresenceState stat
828 -> PeerAddress
829 -> StanzaWrap (LockedChan Event)
830 -> IO ()
831informPeerPresence state k stanza = do
832 -- Presence must indicate full JID with resource...
833 dput XJabber $ "xmppInformPeerPresence checking from address..."
834 forM_ (stanzaFrom stanza) $ \from -> do
835 let (muser0,h,mresource0) = splitJID from
836 -- We'll allow the case that user and resource are simultaneously
837 -- absent. They will be stored in the remotesByPeer map using the
838 -- empty string. This is to accommodate the tox protocol which didn't
839 -- anticipate a single peer would have multiple users or front-ends.
840 (muser,mresource) = case (muser0,mresource0) of
841 (Nothing,Nothing) -> (Just "", Just "")
842 _ -> (muser0,mresource0)
843 dput XJabber $ "xmppInformPeerPresence from = " ++ show from
844 -- forM_ mresource $ \resource -> do
845 forM_ muser $ \user -> do
846
847 clients <- atomically $ do
848
849 -- Update remotesByPeer...
850 rbp <- readTVar (remotesByPeer state)
851 let umap = maybe Map.empty id $ Map.lookup k rbp
852 rp = case (presenceShow $ stanzaType stanza) of
853 Offline ->
854 maybe Map.empty
855 (\resource ->
856 maybe (Map.empty)
857 (Map.delete resource . resources)
858 $ Map.lookup user umap)
859 mresource
860
861 _ ->maybe Map.empty
862 (\resource ->
863 maybe (Map.singleton resource stanza)
864 (Map.insert resource stanza . resources )
865 $ Map.lookup user umap)
866 mresource
867 umap' = Map.insert user (RemotePresence rp) umap
868
869 fromMaybe (return []) $ case presenceShow $ stanzaType stanza of
870 Offline -> Just ()
871 _ -> mresource >> Just ()
872 <&> \_ -> do
873 writeTVar (remotesByPeer state) $ Map.insert k umap' rbp
874 -- TODO: Store or delete the stanza (remotesByPeer)
875
876 -- all clients, we'll filter available/authorized later
877
878 ktc <- readTVar (ckeyToChan state)
879 cmap <- readTVar (clients state)
880 return $ do
881 (ck,client) <- Map.toList cmap
882 con <- maybeToList $ Map.lookup ck ktc
883 return (ck,con,client)
884 dput XJabber $ "xmppInformPeerPresence (length clients="++show (length clients)++")"
885 (ctyp,cprof) <- atomically $ do
886 mconn <- Map.lookup k <$> readTVar (pkeyToChan state)
887 return $ fromMaybe (XMPP,".") $ do
888 ConnectionData _ ctyp cprof _ <- auxData <$> mconn
889 return (ctyp,cprof)
890 forM_ clients $ \(ck,con,client) -> do
891 -- (TODO: appropriately authorized clients only.)
892 -- For now, all "available" clients (available = sent initial presence)
893 is_avail <- atomically $ clientIsAvailable client
894 when is_avail $ do
895 -- reversing for client: ("DdhbLjiwaV0GAiGKgesNPbvj2TbhrBHEWEEc5icfvQN.tox"
896 -- ,XMPP,"OrjBG.GyWuQhGc1pb0KssgmYAocohFh35Vx8mREC9Nu.tox",".")
897 dput XJabber $ "reversing for client: " ++ show (from,ctyp,clientProfile client,cprof)
898 froms <- case ctyp of
899 Tox | clientProfile client == cprof -> return [from]
900 _ -> do -- flip (maybe $ return [from]) k . const $ do
901 (_,trip) <- multiplyJIDForClient (manager state $ clientProfile client) ck from
902 return (map unsplitJID trip)
903
904 dput XJabber $ "sending to client: " ++ show (stanzaType stanza,froms)
905 forM_ froms $ \from' -> do
906 dup <- cloneStanza stanza
907 sendModifiedStanzaToClient (dup { stanzaFrom=Just from' })
908 (connChan con)
909
910consoleClients :: PresenceState stat -> STM (Map Text ClientState)
911consoleClients PresenceState{ consoleWriter = Just cw } = readTVar (cwClients cw)
912consoleClients _ = return Map.empty
913
914
915answerProbe :: PresenceState stat -> Maybe Text -> PeerAddress -> TChan Stanza -> IO ()
916answerProbe state mto k chan = do
917 -- dput XJabber $ "answerProbe! " ++ show (stanzaType stanza)
918 ktc <- atomically $ readTVar (pkeyToChan state)
919 muser <- fmap join $ sequence $ do
920 to <- mto
921 conn <- Map.lookup k ktc
922 let (mu,h,_) = splitJID to -- TODO: currently resource-id is ignored on presence
923 -- probes. Is this correct? Check the spec.
924 Left laddr = cdAddr $ auxData conn
925 ch = addrToText a where Local a = laddr
926 u <- mu
927 Just $ do
928 guardPortStrippedAddress h laddr
929 <&> maybe Nothing (\_ -> Just (u,conn,ch))
930
931 forM_ muser $ \(u,conn,ch) -> do
932
933 profiles <- releventProfiles (cdType $ auxData conn) u
934 forM_ profiles $ \profile -> do
935
936 -- only subscribed peers should get probe replies
937 let man = manager state $ cdProfile $ auxData conn
938 resolved_subs <- resolvedFromRoster man ConfigFiles.getSubscribers u profile
939 let gaddrs = groupBy sameHost (sort resolved_subs)
940 sameHost a b = (snd a == snd b) -- (==) `on` snd
941 whitelist = do
942 xs <- gaddrs -- group of subscribed jids on the same host
943 x <- take 1 xs -- the host from the group
944 guard $ snd x==k -- only hosts matching the key /k/
945 mapMaybe fst xs -- all users subscribed at the remote peer /k/
946
947 -- TODO: notify remote peer that they are unsubscribed?
948 -- reply <- makeInformSubscription "jabber:server" to from False
949 when (not $ null whitelist) $ do
950
951 replies <- catMaybes <$> do -- runTraversableT $ do
952 cbu <- atomically $ readTVar (clientsByUser state) -- Map Text LocalPresence
953 let lpres = maybeToList $ Map.lookup u cbu
954 cw <- atomically $ consoleClients state -- Map Text ClientState
955 forM ((lpres >>= Map.elems . networkClients) ++ Map.elems cw) $ \clientState -> do
956 -- liftIOMaybe :: IO (Maybe a) -> TraversableT [] IO a
957 mstanza <- atomically $ readTVar (clientStatus clientState)
958 forM mstanza $ \stanza0 -> do
959 stanza <- cloneStanza stanza0
960 let jid = unsplitJID (Just $ clientUser clientState
961 , ch
962 ,Just $ clientResource clientState)
963 return stanza { stanzaFrom = Just jid
964 , stanzaType = (stanzaType stanza)
965 { presenceWhiteList = whitelist }
966 }
967
968 forM_ replies $ \reply -> do
969 sendModifiedStanzaToPeer reply chan
970
971 -- if no presence, send offline message
972 when (null replies) $ do
973 let jid = unsplitJID (Just u,ch,Nothing)
974 pstanza <- makePresenceStanza "jabber:server" (Just jid) Offline
975 atomically $ writeTChan (connChan conn) pstanza
976
977-- Send friend requests and remote presences stored in remotesByPeer to XMPP
978-- clients.
979sendCachedPresence :: PresenceState stat -> ClientAddress -> IO ()
980sendCachedPresence state k = do
981 forClient state k (return ()) $ \client -> do
982 rbp <- atomically $ readTVar (remotesByPeer state)
983 jids <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client)
984 let hosts = map ((\(_,h,_)->h) . splitJID) jids
985 addrs <- resolveAllPeers (manager state $ clientProfile client) hosts
986 let onlines = rbp `Map.intersection` addrs
987 mcon <- atomically $ do ktc <- readTVar (ckeyToChan state)
988 return $ Map.lookup k ktc
989 forM_ mcon $ \con -> do
990 forM_ (Map.toList onlines) $ \(pk, umap) -> do
991 forM_ (Map.toList umap) $ \(user,rp) -> do
992 let h = peerKeyToText pk
993 forM_ (Map.toList $ resources rp) $ \(resource,stanza) -> do
994 let jid = unsplitJID (Just user,h,Just resource)
995 (mine,js) <- multiplyJIDForClient (manager state $ clientProfile client) k jid
996 forM_ js $ \jid -> do
997 let from' = unsplitJID jid
998 dup <- cloneStanza stanza
999 sendModifiedStanzaToClient (dup { stanzaFrom=Just from' })
1000 (connChan con)
1001
1002 pending <- configText ConfigFiles.getPending (clientUser client) (clientProfile client)
1003 hostname <- nameForClient state k
1004 forM_ pending $ \pending_jid -> do
1005 let cjid = unsplitJID ( Just $ clientUser client
1006 , hostname
1007 , Nothing )
1008 ask <- presenceSolicitation pending_jid cjid
1009 sendModifiedStanzaToClient ask (connChan con)
1010
1011 -- Note: relying on self peer connection to send
1012 -- send local buddies.
1013 return ()
1014
1015addToRosterFile ::
1016 Connection.Manager s Text
1017 -> (ConfigFiles.User
1018 -> ConfigFiles.Profile
1019 -> (L.ByteString -> IO (Maybe L.ByteString))
1020 -> Maybe L.ByteString
1021 -> t1)
1022 -> Text -- user
1023 -> Text -- profile
1024 -> Text -> [PeerAddress] -> t1
1025addToRosterFile man doit whose profile to addrs =
1026 modifyRosterFile man doit whose profile to addrs True False
1027
1028removeFromRosterFile ::
1029 Connection.Manager s Text
1030 -> (ConfigFiles.User
1031 -> ConfigFiles.Profile
1032 -> (L.ByteString -> IO (Maybe L.ByteString))
1033 -> Maybe L.ByteString
1034 -> t1)
1035 -> Text -- user
1036 -> Text -- profile
1037 -> Text -> [PeerAddress] -> t1
1038removeFromRosterFile man doit whose profile to addrs =
1039 modifyRosterFile man doit whose profile to addrs False False
1040
1041-- | Sanity-checked roster file manipulation. Primarily, this function handles
1042-- hostname aliases.
1043modifyRosterFile ::
1044 Connection.Manager s Text
1045 -> (ConfigFiles.User
1046 -> ConfigFiles.Profile
1047 -> (L.ByteString -> IO (Maybe L.ByteString))
1048 -> Maybe L.ByteString
1049 -> t1) -- ^ Lower-level modification function
1050 -- indicating which file is being modified.
1051 -- Valid choices from ConfigFiles module:
1052 --
1053 -- * modifySolicited
1054 --
1055 -- * modifyBuddies
1056 --
1057 -- * modifyPending
1058 --
1059 -- * modifySubscribers
1060 -> Text -- ^ user
1061 -> Text -- ^ profile
1062 -> Text -- ^ JID that will be added or removed a hostname
1063 -> [PeerAddress] -- ^ Alias addresses for hostname in the JID.
1064 -> Bool -- ^ True if adding, otherwise False
1065 -> Bool -- ^ True to allow deleting all users at a host.
1066 -> t1
1067modifyRosterFile man doit whose profile to addrs bAdd bWildCard = do
1068 let (mu,_,_) = splitJID to
1069 -- For each jid in the file, this function will decide whether to keep
1070 -- it (possibly modified) which is indicated by Just _ or to remove the
1071 -- item from the file which is indicated by Nothing.
1072 cmp :: L.ByteString -> IO (Maybe L.ByteString)
1073 cmp jid = do
1074 let (msu,stored_h,mr) = splitJID (lazyByteStringToText jid)
1075 keep = return (Just jid) :: IO (Maybe L.ByteString)
1076 delete = return Nothing :: IO (Maybe L.ByteString)
1077 iocheck = do
1078 stored_addrs <- resolvePeer man stored_h -- TODO: don't resolve .tox peers.
1079 case stored_addrs of
1080 [] -> keep -- do not delete if failed to resolve
1081 xs | null (xs \\ addrs) -> delete -- hostname alias, delete
1082 _ -> keep
1083 fmap join $ sequence $ do
1084 guard $ isNothing mr -- delete if resource specified in file.
1085 if mu == msu || bWildCard
1086 then Just iocheck -- do not delete unless hostname alias
1087 else Just keep -- do not delete if user field doesn't match.
1088 doit (textToLazyByteString whose) (Text.unpack profile)
1089 cmp
1090 (guard bAdd >> Just (textToLazyByteString to))
1091
1092
1093clientSubscriptionRequest :: PresenceState stat -> IO () -> ClientAddress -> Stanza -> TChan Stanza -> IO ()
1094clientSubscriptionRequest state fail k stanza chan = do
1095 forClient state k fail $ \client -> do
1096 fromMaybe fail $ (splitJID <$> stanzaTo stanza) <&> \(mu,h,_) -> do
1097 dput XJabber $ "Forwarding solicitation to peer"
1098 let to0 = unsplitJID (mu,h,Nothing) -- deleted resource
1099 cuser = clientUser client
1100 cprof = clientProfile client
1101 man = manager state cprof
1102 mto = if ".tox" `Text.isSuffixOf` cprof
1103 then case parseNoSpamId to0 of
1104 Right toxjid@(NoSpamId nspam _) -> Just ( Text.pack $ '$' : nospam64 nspam
1105 , Text.pack $ show toxjid
1106 , return [] )
1107 Left _ | Text.isSuffixOf ".tox" h -> Nothing
1108 Left _ | Text.all isHexDigit h
1109 && Text.length h == 76 -> Nothing
1110 Left _ -> fmap (\u -> (u, to0 ,resolvePeer man h)) mu
1111 else fmap (\u -> (u, to0 ,resolvePeer man h)) mu
1112 fromMaybe fail $ mto <&> \(u,to,resolv) -> do
1113 -- add to-address to from's solicited
1114 dput XJabber $ unlines [ "to0=" ++ Text.unpack to0
1115 , "to=" ++ show (Text.unpack to) ]
1116 addrs <- resolv
1117 addToRosterFile man ConfigFiles.modifySolicited cuser cprof to addrs
1118 removeFromRosterFile man ConfigFiles.modifyBuddies cuser cprof to addrs
1119 resolved_subs <- resolvedFromRoster man ConfigFiles.getSubscribers cuser cprof
1120 let is_subscribed = not . null $ [ (mu, a) | a <- addrs ]
1121 `intersect` resolved_subs
1122 -- subscribers: "from"
1123 -- buddies: "to"
1124
1125 case state of
1126 PresenceState { server = svVar } -> do
1127
1128 (cktc,pktc,(sv,conns)) <- atomically $ do
1129 cktc <- readTVar $ ckeyToChan state
1130 pktc <- readTVar $ pkeyToChan state
1131 return (cktc,pktc,(server state,man))
1132
1133 -- Update roster for each client.
1134 case stanzaType stanza of
1135 PresenceRequestSubscription True -> do
1136 hostname <- nameForClient state k
1137 let cjid = unsplitJID (Just $ clientUser client, hostname,Nothing)
1138 chans <- clientCons state cktc (clientUser client)
1139 forM_ chans $ \( Conn { connChan=chan }, client ) -> do
1140 -- roster update ask="subscribe"
1141 update <- myMakeRosterUpdate (clientProfile client) cjid to
1142 [ ("ask","subscribe")
1143 , if is_subscribed then ("subscription","from")
1144 else ("subscription","none")
1145 ]
1146 sendModifiedStanzaToClient update chan
1147 when (to /= to0) $ do
1148 removal <- myMakeRosterUpdate (clientProfile client) cjid to0
1149 [ ("subscription","remove") ]
1150 sendModifiedStanzaToClient removal chan
1151 _ -> return ()
1152
1153 -- Send friend request to peer.
1154 let dsts = pktc `Map.intersection` toMapUnit addrs
1155 forM_ (Map.toList dsts) $ \(pk,con) -> do
1156 -- if already connected, send solicitation ...
1157 -- let from = clientJID con client
1158 let Left laddr = cdAddr $ auxData con
1159 from = unsplitJID ( Just $ clientUser client
1160 , (\(Local a) -> addrToText a) $ laddr
1161 , Nothing )
1162 mb <- rewriteJIDForPeer (manager state $ cdProfile $ auxData con) to
1163 forM_ mb $ \(to',addr) -> do
1164 dup <- cloneStanza stanza
1165 sendModifiedStanzaToPeer (dup { stanzaTo = Just to'
1166 , stanzaFrom = Just from })
1167 (connChan con)
1168 let policySetter = fromMaybe (Connection.setPolicy conns h) $ do
1169 (toxman,_,_) <- weAreTox state client h
1170 meid <- readMaybe $ Text.unpack $ Text.take 43 (clientProfile client)
1171 themid <- readMaybe $ Text.unpack h
1172 Just $ Connection.setPolicy (toxConnections toxman) (ToxContact meid themid)
1173 -- Add peer if we are not already associated ...
1174 policySetter Connection.TryingToConnect
1175
1176weAreTox :: PresenceState stat -> ClientState -> Text -> Maybe (ToxManager ClientAddress,Text{- me -},Text{- them -})
1177weAreTox state client h = do
1178 toxman <- toxManager state
1179 (me , ".tox") <- Just $ Text.splitAt 43 (clientProfile client)
1180 (them, ".tox") <- Just $ Text.splitAt 43 h
1181 return (toxman,me,them)
1182
1183resolvedFromRoster
1184 :: Connection.Manager s Text
1185 -> (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString])
1186 -> UserName -> Text -> IO [(Maybe UserName, PeerAddress)]
1187resolvedFromRoster man doit u profile = concat <$> do
1188 subs <- configText doit u profile
1189 forM (splitJID `fmap` subs) $ \(mu,h,_) -> do
1190 addrs <- fmap nub $ resolvePeer man h
1191 return $ map (mu,) addrs
1192
1193clientCons :: PresenceState stat
1194 -> Map ClientAddress t -> Text -> IO [(t, ClientState)]
1195clientCons state ktc u = map snd <$> clientCons' state ktc u
1196
1197clientCons' :: PresenceState stat
1198 -> Map ClientAddress t -> Text -> IO [(ClientAddress,(t, ClientState))]
1199clientCons' state ktc u = do
1200 mlp <- atomically $ do
1201 cmap <- readTVar $ clientsByUser state
1202 return $ Map.lookup u cmap
1203 let ks = do lp <- maybeToList mlp
1204 Map.toList (networkClients lp)
1205 doit (k,client) = do
1206 con <- Map.lookup k ktc
1207 return (k,(con,client))
1208 return $ mapMaybe doit ks
1209
1210releventProfiles :: ConnectionType -> Text -> IO [Text]
1211releventProfiles XMPP _ = return ["."]
1212releventProfiles ctyp user = do
1213 -- TODO: Return all the ".tox" profiles that a user has under his
1214 -- .presence/ directory.
1215 return []
1216
1217peerSubscriptionRequest :: PresenceState stat -> IO () -> PeerAddress -> Stanza -> TChan Stanza -> IO ()
1218peerSubscriptionRequest state fail k stanza chan = do
1219 dput XJabber $ "Handling pending subscription from remote"
1220 fromMaybe fail $ (stanzaFrom stanza) <&> \from -> do
1221 fromMaybe fail $ (stanzaTo stanza) <&> \to -> do
1222 let (mto_u,h,_) = splitJID to
1223 (mfrom_u,from_h,_) = splitJID from
1224 to <- return $ unsplitJID (mto_u,h,Nothing) -- delete resource
1225 from <- return $ unsplitJID (mfrom_u,from_h,Nothing) -- delete resource
1226 (pktc,cktc,cmap) <- atomically $ do
1227 cktc <- readTVar (ckeyToChan state)
1228 pktc <- readTVar (pkeyToChan state)
1229 cmap <- readTVar (clients state)
1230 return (pktc,cktc,cmap)
1231 fromMaybe fail $ (Map.lookup k pktc)
1232 <&> \Conn { auxData=ConnectionData (Left laddr) ctyp profile _ } -> do
1233 (mine,totup) <- case (ctyp,profile) of
1234 (Tox,p) -> let (u,h,r) = splitJID to
1235 in return ( h == p, (u,h,r) )
1236 _ -> rewriteJIDForClient (manager state profile) laddr to []
1237 if not mine then fail else do
1238 (_,fromtup) <- rewriteJIDForClient (manager state profile) laddr from []
1239 fromMaybe fail $ mto_u <&> \u -> do
1240 fromMaybe fail $ mfrom_u <&> \from_u -> do
1241 resolved_subs <- resolvedFromRoster (manager state profile) ConfigFiles.getSubscribers u profile
1242 let already_subscribed = elem (mfrom_u,k) resolved_subs
1243 is_wanted = case stanzaType stanza of
1244 PresenceRequestSubscription b -> b
1245 _ -> False -- Shouldn't happen.
1246 -- Section 8 says (for presence of type "subscribe", the server MUST
1247 -- adhere to the rules defined under Section 3 and summarized under
1248 -- see Appendix A. (pariticularly Appendex A.3.1)
1249 if already_subscribed == is_wanted
1250 then do
1251 -- contact ∈ subscribers --> SHOULD NOT, already handled
1252 -- already subscribed, reply and quit
1253 -- (note: swapping to and from for reply)
1254 reply <- makeInformSubscription "jabber:server" to from is_wanted
1255 sendModifiedStanzaToPeer reply chan
1256 answerProbe state (Just to) k chan
1257 else do
1258
1259 -- TODO: if peer-connection is to self, then auto-approve local user.
1260
1261 -- add from-address to to's pending
1262 addrs <- resolvePeer (manager state profile) from_h
1263
1264 -- Catch exception in case the user does not exist
1265 if null addrs then fail else do
1266
1267 let from' = unsplitJID fromtup
1268
1269 -- Update roster files (subscribe: add to pending, unsubscribe: remove from subscribers).
1270 already_pending <-
1271 if is_wanted then
1272 addToRosterFile (manager state profile) ConfigFiles.modifyPending u profile from' addrs
1273 else do
1274 removeFromRosterFile (manager state profile) ConfigFiles.modifySubscribers u profile from' addrs
1275 reply <- makeInformSubscription "jabber:server" to from is_wanted
1276 sendModifiedStanzaToPeer reply chan
1277 return False
1278
1279 -- contact ∉ subscribers & contact ∈ pending --> SHOULD NOT
1280 when (not already_pending) $ do
1281 -- contact ∉ subscribers & contact ∉ pending --> MUST
1282
1283 chans <- clientCons state cktc u
1284 forM_ chans $ \( Conn { connChan=chan }, client ) -> do
1285 -- send to clients
1286 -- TODO: interested/available clients only?
1287 dup <- cloneStanza stanza
1288 sendModifiedStanzaToClient dup { stanzaFrom = Just $ from'
1289 , stanzaTo = Just $ unsplitJID totup }
1290 chan
1291
1292myMakeRosterUpdate prf tojid contact as
1293 | ".tox" `Text.isSuffixOf` prf
1294 , (Just u,h,r) <- splitJID contact
1295 , ".tox" `Text.isSuffixOf` u = XMPPServer.makeRosterUpdate tojid (unsplitJID (Nothing,h,r)) as
1296myMakeRosterUpdate _ tojid contact as = XMPPServer.makeRosterUpdate tojid contact as
1297
1298
1299clientInformSubscription :: PresenceState stat
1300 -> IO ()
1301 -> ClientAddress
1302 -> StanzaWrap (LockedChan Event)
1303 -> IO ()
1304clientInformSubscription state fail k stanza = do
1305 forClient state k fail $ \client -> do
1306 fromMaybe fail $ (stanzaTo stanza) <&> \to -> do
1307 dput XJabber $ "clientInformSubscription"
1308 let (mu,h,mr) = splitJID to
1309 man = manager state $ clientProfile client
1310 addrs <- resolvePeer man h
1311 -- remove from pending
1312 buds <- resolvedFromRoster man ConfigFiles.getBuddies (clientUser client) (clientProfile client)
1313 let is_buddy = not . null $ map (mu,) addrs `intersect` buds
1314 removeFromRosterFile man ConfigFiles.modifyPending (clientUser client) (clientProfile client) to addrs
1315 let (relationship,addf,remf) =
1316 case stanzaType stanza of
1317 PresenceInformSubscription True ->
1318 ( ("subscription", if is_buddy then "both"
1319 else "from" )
1320 , ConfigFiles.modifySubscribers
1321 , ConfigFiles.modifyOthers )
1322 _ -> ( ("subscription", if is_buddy then "to"
1323 else "none" )
1324 , ConfigFiles.modifyOthers
1325 , ConfigFiles.modifySubscribers )
1326 addToRosterFile man addf (clientUser client) (clientProfile client) to addrs
1327 removeFromRosterFile man remf (clientUser client) (clientProfile client) to addrs
1328
1329 do
1330 cbu <- atomically $ readTVar (clientsByUser state)
1331 dput XJabber $ "cbu = " ++ show (fmap (fmap clientPid . networkClients) cbu)
1332
1333 -- send roster update to clients
1334 (clients,ktc,pktc) <- atomically $ do
1335 cbu <- readTVar (clientsByUser state)
1336 let mlp = Map.lookup (clientUser client) cbu
1337 let cs = maybe [] (Map.toList . networkClients) mlp
1338 ktc <- readTVar (ckeyToChan state)
1339 pktc <- readTVar (pkeyToChan state)
1340 return (cs,ktc,pktc)
1341 forM_ clients $ \(ck, client) -> do
1342 is_intereseted <- atomically $ clientIsInterested client
1343 dput XJabber $ "clientIsInterested: "++show is_intereseted
1344 is_intereseted <- atomically $ clientIsInterested client
1345 when is_intereseted $ do
1346 forM_ (Map.lookup ck ktc) $ \con -> do
1347 hostname <- nameForClient state ck
1348 -- TODO: Should cjid include the resource?
1349 let cjid = unsplitJID (mu, hostname, Nothing)
1350 update <- myMakeRosterUpdate (clientProfile client) cjid to [relationship]
1351 sendModifiedStanzaToClient update (connChan con)
1352
1353 -- notify peer
1354 let dsts = toMapUnit addrs
1355 cdsts = pktc `Map.intersection` dsts
1356 forM_ (Map.toList cdsts) $ \(pk,con) -> do
1357 let from = clientJID con client
1358 to' = unsplitJID (mu, peerKeyToText pk, Nothing)
1359 dup <- cloneStanza stanza
1360 sendModifiedStanzaToPeer (dup { stanzaTo = Just $ to'
1361 , stanzaFrom = Just from })
1362 (connChan con)
1363 answerProbe state (Just from) pk (connChan con)
1364
1365peerInformSubscription :: PresenceState stat
1366 -> IO ()
1367 -> PeerAddress
1368 -> StanzaWrap (LockedChan Event)
1369 -> IO ()
1370peerInformSubscription state fail k stanza = do
1371 dput XJabber $ "TODO: peerInformSubscription"
1372 -- remove from solicited
1373 fromMaybe fail $ (stanzaFrom stanza) <&> \from -> do
1374 (ktc,cktc,cmap) <- atomically $ do
1375 pktc <- readTVar (pkeyToChan state)
1376 cktc <- readTVar (ckeyToChan state)
1377 cmap <- readTVar (clients state)
1378 return (pktc,cktc,cmap)
1379 fromMaybe fail $ Map.lookup k ktc
1380 <&> \(Conn { connChan=sender_chan
1381 , auxData =ConnectionData (Left laddr) ctyp profile _ }) -> do
1382 let man = manager state profile
1383 (from_u,from_h,_) <- case ctyp of
1384 Tox -> return $ splitJID from
1385 XMPP -> snd <$> rewriteJIDForClient man laddr from []
1386 let from'' = unsplitJID (from_u,from_h,Nothing)
1387 muser = do
1388 to <- stanzaTo stanza
1389 let (mu,to_h,to_r) = splitJID to
1390 mu
1391 -- TODO muser = Nothing when wanted=False
1392 -- should probably mean unsubscribed for all users.
1393 -- This would allow us to answer anonymous probes with 'unsubscribed'.
1394 fromMaybe fail $ muser <&> \user -> do
1395
1396 addrs <- resolvePeer man from_h
1397 was_solicited <- removeFromRosterFile man ConfigFiles.modifySolicited user profile from'' addrs
1398
1399 subs <- resolvedFromRoster man ConfigFiles.getSubscribers user profile
1400 let is_sub = not . null $ map (from_u,) addrs `intersect` subs
1401 dput XJabber $ "DEBUG peerInformSubscription (is_sub,typ)=" ++ show (is_sub,stanzaType stanza)
1402 let (relationship,addf,remf) =
1403 case stanzaType stanza of
1404 PresenceInformSubscription True ->
1405 ( ("subscription", if is_sub then "both"
1406 else "to" )
1407 , ConfigFiles.modifyBuddies
1408 , ConfigFiles.modifyOthers )
1409 _ -> ( ("subscription", if is_sub then "from"
1410 else "none")
1411 , ConfigFiles.modifyOthers
1412 , ConfigFiles.modifyBuddies )
1413 addToRosterFile man addf user profile from'' addrs
1414 removeFromRosterFile man remf user profile from'' addrs
1415
1416 chans <- clientCons' state cktc user
1417 forM_ chans $ \(ckey,(Conn { connChan=chan }, client)) -> do
1418 hostname <- nameForClient state ckey
1419 let to' = unsplitJID (Just user, hostname, Nothing)
1420 update <- myMakeRosterUpdate (clientProfile client) to' from'' [relationship]
1421 is_intereseted <- atomically $ clientIsInterested client
1422 when is_intereseted $ do
1423 sendModifiedStanzaToClient update chan
1424 -- TODO: interested/availabe clients only?
1425 dup <- cloneStanza stanza
1426 sendModifiedStanzaToClient dup { stanzaFrom = Just $ from''
1427 , stanzaTo = Just to' }
1428 chan
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-02 23:31:03 +0000