diff options
Diffstat (limited to 'Presence/Presence.hs')
-rw-r--r-- | Presence/Presence.hs | 1041 |
1 files changed, 1041 insertions, 0 deletions
diff --git a/Presence/Presence.hs b/Presence/Presence.hs new file mode 100644 index 00000000..15775857 --- /dev/null +++ b/Presence/Presence.hs | |||
@@ -0,0 +1,1041 @@ | |||
1 | {-# LANGUAGE ExistentialQuantification #-} | ||
2 | {-# LANGUAGE LambdaCase #-} | ||
3 | {-# LANGUAGE OverloadedStrings #-} | ||
4 | {-# LANGUAGE TupleSections #-} | ||
5 | module Presence where | ||
6 | |||
7 | import System.Environment | ||
8 | import System.Posix.Signals | ||
9 | import Control.Concurrent (threadDelay,forkIO,forkOS,killThread,throwTo) | ||
10 | import Control.Concurrent.STM | ||
11 | import Control.Concurrent.STM.TMVar | ||
12 | import Control.Monad.Trans.Resource (runResourceT) | ||
13 | import Control.Monad.Trans | ||
14 | import Control.Monad.IO.Class (MonadIO, liftIO) | ||
15 | import Network.Socket ( SockAddr(..) ) | ||
16 | import System.Endian (fromBE32) | ||
17 | import Data.List (nub, (\\), intersect, groupBy, sort, sortBy ) | ||
18 | import Data.Ord (comparing ) | ||
19 | import Data.Monoid ( (<>), Sum(..), getSum ) | ||
20 | import qualified Data.Text as Text | ||
21 | import qualified Data.Text.IO as Text | ||
22 | import qualified Data.Text.Encoding as Text | ||
23 | import Control.Monad | ||
24 | import Control.Monad.Fix | ||
25 | import qualified Network.BSD as BSD | ||
26 | import qualified Data.Text as Text | ||
27 | import Data.Text (Text) | ||
28 | import qualified Data.Map as Map | ||
29 | import Data.Map (Map) | ||
30 | import Control.Exception ({-evaluate,-}handle,SomeException(..),bracketOnError,ErrorCall(..)) | ||
31 | import System.IO.Error (isDoesNotExistError) | ||
32 | import System.Posix.User (getUserEntryForID,userName) | ||
33 | import qualified Data.ByteString.Lazy.Char8 as L | ||
34 | import qualified ConfigFiles | ||
35 | import Data.Maybe (maybeToList,listToMaybe,mapMaybe) | ||
36 | import Data.Bits | ||
37 | import Data.Int (Int8) | ||
38 | import Data.XML.Types (Event) | ||
39 | import System.Posix.Types (UserID,CPid) | ||
40 | import Control.Applicative | ||
41 | |||
42 | import LockedChan (LockedChan) | ||
43 | import TraversableT | ||
44 | import UTmp (ProcessID,users) | ||
45 | import LocalPeerCred | ||
46 | import XMPPServer | ||
47 | import PeerResolve | ||
48 | import ConsoleWriter | ||
49 | import ClientState | ||
50 | import Util | ||
51 | import qualified Connection | ||
52 | |||
53 | isPeerKey :: ConnectionKey -> Bool | ||
54 | isPeerKey k = case k of { PeerKey {} -> True ; _ -> False } | ||
55 | |||
56 | isClientKey :: ConnectionKey -> Bool | ||
57 | isClientKey k = case k of { ClientKey {} -> True ; _ -> False } | ||
58 | |||
59 | localJID :: Text -> Text -> IO Text | ||
60 | localJID user resource = do | ||
61 | hostname <- textHostName | ||
62 | return $ user <> "@" <> hostname <> "/" <> resource | ||
63 | |||
64 | data PresenceState = forall status. PresenceState | ||
65 | { clients :: TVar (Map ConnectionKey ClientState) | ||
66 | , clientsByUser :: TVar (Map Text LocalPresence) | ||
67 | , remotesByPeer :: TVar (Map ConnectionKey | ||
68 | (Map UserName RemotePresence)) | ||
69 | , server :: TMVar (XMPPServer, Connection.Manager status Text) | ||
70 | , keyToChan :: TVar (Map ConnectionKey Conn) | ||
71 | , consoleWriter :: Maybe ConsoleWriter | ||
72 | } | ||
73 | |||
74 | |||
75 | newPresenceState cw xmpp = atomically $ do | ||
76 | clients <- newTVar Map.empty | ||
77 | clientsByUser <- newTVar Map.empty | ||
78 | remotesByPeer <- newTVar Map.empty | ||
79 | keyToChan <- newTVar Map.empty | ||
80 | return PresenceState | ||
81 | { clients = clients | ||
82 | , clientsByUser = clientsByUser | ||
83 | , remotesByPeer = remotesByPeer | ||
84 | , keyToChan = keyToChan | ||
85 | , server = xmpp | ||
86 | , consoleWriter = cw | ||
87 | } | ||
88 | |||
89 | |||
90 | presenceHooks state verbosity = XMPPServerParameters | ||
91 | { xmppChooseResourceName = chooseResourceName state | ||
92 | , xmppTellClientHisName = tellClientHisName state | ||
93 | , xmppTellMyNameToClient = textHostName | ||
94 | , xmppTellMyNameToPeer = \addr -> return $ addrToText addr | ||
95 | , xmppTellPeerHisName = return . peerKeyToText | ||
96 | , xmppTellClientNameOfPeer = flip peerKeyToResolvedName | ||
97 | , xmppNewConnection = newConn state | ||
98 | , xmppEOF = eofConn state | ||
99 | , xmppRosterBuddies = rosterGetBuddies state | ||
100 | , xmppRosterSubscribers = rosterGetSubscribers state | ||
101 | , xmppRosterSolicited = rosterGetSolicited state | ||
102 | , xmppRosterOthers = rosterGetOthers state | ||
103 | , xmppSubscribeToRoster = informSentRoster state | ||
104 | , xmppDeliverMessage = deliverMessage state | ||
105 | , xmppInformClientPresence = informClientPresence state | ||
106 | , xmppInformPeerPresence = informPeerPresence state | ||
107 | , xmppAnswerProbe = \k stanza chan -> answerProbe state (stanzaTo stanza) k chan | ||
108 | , xmppClientSubscriptionRequest = clientSubscriptionRequest state | ||
109 | , xmppPeerSubscriptionRequest = peerSubscriptionRequest state | ||
110 | , xmppClientInformSubscription = clientInformSubscription state | ||
111 | , xmppPeerInformSubscription = peerInformSubscription state | ||
112 | , xmppVerbosity = return verbosity | ||
113 | } | ||
114 | |||
115 | |||
116 | data LocalPresence = LocalPresence | ||
117 | { networkClients :: Map ConnectionKey ClientState | ||
118 | -- TODO: loginClients | ||
119 | } | ||
120 | |||
121 | data RemotePresence = RemotePresence | ||
122 | { resources :: Map Text Stanza | ||
123 | -- , localSubscribers :: Map Text () | ||
124 | -- ^ subset of clientsByUser who should be | ||
125 | -- notified about this presence. | ||
126 | } | ||
127 | |||
128 | |||
129 | |||
130 | pcSingletonNetworkClient :: ConnectionKey | ||
131 | -> ClientState -> LocalPresence | ||
132 | pcSingletonNetworkClient key client = | ||
133 | LocalPresence | ||
134 | { networkClients = Map.singleton key client | ||
135 | } | ||
136 | |||
137 | pcInsertNetworkClient :: ConnectionKey -> ClientState -> LocalPresence -> LocalPresence | ||
138 | pcInsertNetworkClient key client pc = | ||
139 | pc { networkClients = Map.insert key client (networkClients pc) } | ||
140 | |||
141 | pcRemoveNewtworkClient :: ConnectionKey | ||
142 | -> LocalPresence -> Maybe LocalPresence | ||
143 | pcRemoveNewtworkClient key pc = if pcIsEmpty pc' then Nothing | ||
144 | else Just pc' | ||
145 | where | ||
146 | pc' = pc { networkClients = Map.delete key (networkClients pc) } | ||
147 | |||
148 | pcIsEmpty :: LocalPresence -> Bool | ||
149 | pcIsEmpty pc = Map.null (networkClients pc) | ||
150 | |||
151 | |||
152 | |||
153 | getConsolePids :: PresenceState -> IO [(Text,ProcessID)] | ||
154 | getConsolePids state = do | ||
155 | us <- UTmp.users | ||
156 | return $ map (\(_,tty,pid)->(lazyByteStringToText tty,pid)) us | ||
157 | |||
158 | identifyTTY' :: [(Text, ProcessID)] | ||
159 | -> System.Posix.Types.UserID | ||
160 | -> L.ByteString | ||
161 | -> IO (Maybe Text, Maybe System.Posix.Types.CPid) | ||
162 | identifyTTY' ttypids uid inode = ttypid | ||
163 | where ttypids' = map (\(tty,pid)->(L.fromChunks [Text.encodeUtf8 tty], pid)) ttypids | ||
164 | ttypid = fmap textify $ identifyTTY ttypids' uid inode | ||
165 | textify (tty,pid) = (fmap lazyByteStringToText tty, pid) | ||
166 | |||
167 | chooseResourceName :: PresenceState | ||
168 | -> ConnectionKey -> SockAddr -> t -> IO Text | ||
169 | chooseResourceName state k addr desired = do | ||
170 | muid <- getLocalPeerCred' addr | ||
171 | (mtty,pid) <- getTTYandPID muid | ||
172 | user <- getJabberUserForId muid | ||
173 | status <- atomically $ newTVar Nothing | ||
174 | flgs <- atomically $ newTVar 0 | ||
175 | let client = ClientState { clientResource = maybe "fallback" id mtty | ||
176 | , clientUser = user | ||
177 | , clientPid = pid | ||
178 | , clientStatus = status | ||
179 | , clientFlags = flgs } | ||
180 | |||
181 | do -- forward-lookup of the buddies so that it is cached for reversing. | ||
182 | buds <- configText ConfigFiles.getBuddies (clientUser client) | ||
183 | forM_ buds $ \bud -> do | ||
184 | let (_,h,_) = splitJID bud | ||
185 | forkIO $ void $ resolvePeer h | ||
186 | |||
187 | atomically $ do | ||
188 | modifyTVar' (clients state) $ Map.insert k client | ||
189 | modifyTVar' (clientsByUser state) $ flip Map.alter (clientUser client) | ||
190 | $ \mb -> Just $ maybe (pcSingletonNetworkClient k client) | ||
191 | (pcInsertNetworkClient k client) | ||
192 | mb | ||
193 | |||
194 | localJID (clientUser client) (clientResource client) | ||
195 | |||
196 | where | ||
197 | getTTYandPID muid = do | ||
198 | -- us <- fmap (map (second fst) . Map.toList) . readTVarIO $ activeUsers state | ||
199 | ttypids <- getConsolePids state | ||
200 | -- let tailOf3 ((_,a),b) = (a,b) | ||
201 | (t,pid) <- case muid of | ||
202 | Just (uid,inode) -> identifyTTY' ttypids uid inode | ||
203 | Nothing -> return (Nothing,Nothing) | ||
204 | let rsc = t `mplus` fmap ( ("pid."<>) . Text.pack . show ) pid | ||
205 | return (rsc,pid) | ||
206 | |||
207 | getJabberUserForId muid = | ||
208 | maybe (return "nobody") | ||
209 | (\(uid,_) -> | ||
210 | handle (\(SomeException _) -> | ||
211 | return . (<> "uid.") . Text.pack . show $ uid) | ||
212 | $ do | ||
213 | user <- fmap userName $ getUserEntryForID uid | ||
214 | return (Text.pack user) | ||
215 | ) | ||
216 | muid | ||
217 | |||
218 | forClient :: PresenceState | ||
219 | -> ConnectionKey -> IO b -> (ClientState -> IO b) -> IO b | ||
220 | forClient state k fallback f = do | ||
221 | mclient <- atomically $ do | ||
222 | cs <- readTVar (clients state) | ||
223 | return $ Map.lookup k cs | ||
224 | maybe fallback f mclient | ||
225 | |||
226 | tellClientHisName :: PresenceState -> ConnectionKey -> IO Text | ||
227 | tellClientHisName state k = forClient state k fallback go | ||
228 | where | ||
229 | fallback = localJID "nobody" "fallback" | ||
230 | go client = localJID (clientUser client) (clientResource client) | ||
231 | |||
232 | toMapUnit :: Ord k => [k] -> Map k () | ||
233 | toMapUnit xs = Map.fromList $ map (,()) xs | ||
234 | |||
235 | resolveAllPeers :: [Text] -> IO (Map SockAddr ()) | ||
236 | resolveAllPeers hosts = fmap (toMapUnit . concat) $ Prelude.mapM (fmap (take 1) . resolvePeer) hosts | ||
237 | |||
238 | |||
239 | rosterGetStuff | ||
240 | :: (L.ByteString -> IO [L.ByteString]) | ||
241 | -> PresenceState -> ConnectionKey -> IO [Text] | ||
242 | rosterGetStuff what state k = forClient state k (return []) | ||
243 | $ \client -> do | ||
244 | jids <- configText what (clientUser client) | ||
245 | let hosts = map ((\(_,h,_)->h) . splitJID) jids | ||
246 | case state of | ||
247 | PresenceState { server = svVar } -> do | ||
248 | (sv,conns) <- atomically $ takeTMVar svVar | ||
249 | -- Grok peers to associate with from the roster: | ||
250 | forM_ hosts $ \host -> Connection.setPolicy conns host Connection.TryingToConnect | ||
251 | atomically $ putTMVar svVar (sv,conns) | ||
252 | return jids | ||
253 | |||
254 | rosterGetBuddies :: PresenceState -> ConnectionKey -> IO [Text] | ||
255 | rosterGetBuddies state k = rosterGetStuff ConfigFiles.getBuddies state k | ||
256 | |||
257 | rosterGetSolicited :: PresenceState -> ConnectionKey -> IO [Text] | ||
258 | rosterGetSolicited = rosterGetStuff ConfigFiles.getSolicited | ||
259 | |||
260 | rosterGetOthers :: PresenceState -> ConnectionKey -> IO [Text] | ||
261 | rosterGetOthers = rosterGetStuff ConfigFiles.getOthers | ||
262 | |||
263 | rosterGetSubscribers :: PresenceState -> ConnectionKey -> IO [Text] | ||
264 | rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers | ||
265 | |||
266 | data Conn = Conn { connChan :: TChan Stanza | ||
267 | , auxAddr :: SockAddr } | ||
268 | |||
269 | configText :: Functor f => | ||
270 | (L.ByteString -> f [L.ByteString]) -> Text -> f [Text] | ||
271 | configText what u = fmap (map lazyByteStringToText) | ||
272 | $ what (textToLazyByteString u) | ||
273 | |||
274 | getBuddies' :: Text -> IO [Text] | ||
275 | getBuddies' = configText ConfigFiles.getBuddies | ||
276 | getSolicited' :: Text -> IO [Text] | ||
277 | getSolicited' = configText ConfigFiles.getSolicited | ||
278 | |||
279 | sendProbesAndSolicitations :: PresenceState | ||
280 | -> ConnectionKey -> SockAddr -> TChan Stanza -> IO () | ||
281 | sendProbesAndSolicitations state k laddr chan = do | ||
282 | -- get all buddies & solicited matching k for all users | ||
283 | xs <- runTraversableT $ do | ||
284 | cbu <- lift $ atomically $ readTVar $ clientsByUser state | ||
285 | user <- liftT $ Map.keys cbu | ||
286 | (isbud,getter) <- liftT [(True ,getBuddies' ) | ||
287 | ,(False,getSolicited')] | ||
288 | bud <- liftMT $ getter user | ||
289 | let (u,h,r) = splitJID bud | ||
290 | addr <- liftMT $ nub `fmap` resolvePeer h | ||
291 | liftT $ guard (PeerKey addr == k) | ||
292 | -- Note: Earlier I was tempted to do all the IO | ||
293 | -- within the TraversableT monad. That apparently | ||
294 | -- is a bad idea. Perhaps due to laziness and an | ||
295 | -- unforced list? Instead, we will return a list | ||
296 | -- of (Bool,Text) for processing outside. | ||
297 | return (isbud,u,if isbud then "" else user) | ||
298 | -- XXX: The following O(n²) nub may be a little | ||
299 | -- too onerous. | ||
300 | forM_ (nub xs) $ \(isbud,u,user) -> do | ||
301 | let make = if isbud then presenceProbe | ||
302 | else presenceSolicitation | ||
303 | toh = peerKeyToText k | ||
304 | jid = unsplitJID (u,toh,Nothing) | ||
305 | me = addrToText laddr | ||
306 | from = if isbud then me -- probe from server | ||
307 | else -- solicitation from particular user | ||
308 | unsplitJID (Just user,me,Nothing) | ||
309 | stanza <- make from jid | ||
310 | -- send probes for buddies, solicitations for solicited. | ||
311 | putStrLn $ "probing "++show k++" for: " ++ show (isbud,jid) | ||
312 | atomically $ writeTChan chan stanza | ||
313 | -- reverse xs `seq` return () | ||
314 | |||
315 | newConn :: PresenceState -> ConnectionKey -> SockAddr -> TChan Stanza -> IO () | ||
316 | newConn state k addr outchan = do | ||
317 | atomically $ modifyTVar' (keyToChan state) | ||
318 | $ Map.insert k Conn { connChan = outchan | ||
319 | , auxAddr = addr } | ||
320 | when (isPeerKey k) | ||
321 | $ sendProbesAndSolicitations state k addr outchan | ||
322 | |||
323 | delclient :: (Alternative m, Monad m) => | ||
324 | ConnectionKey -> m LocalPresence -> m LocalPresence | ||
325 | delclient k mlp = do | ||
326 | lp <- mlp | ||
327 | let nc = Map.delete k $ networkClients lp | ||
328 | guard $ not (Map.null nc) | ||
329 | return $ lp { networkClients = nc } | ||
330 | |||
331 | eofConn :: PresenceState -> ConnectionKey -> IO () | ||
332 | eofConn state k = do | ||
333 | atomically $ modifyTVar' (keyToChan state) $ Map.delete k | ||
334 | case k of | ||
335 | ClientKey {} -> do | ||
336 | forClient state k (return ()) $ \client -> do | ||
337 | stanza <- makePresenceStanza "jabber:server" Nothing Offline | ||
338 | informClientPresence state k stanza | ||
339 | atomically $ do | ||
340 | modifyTVar' (clientsByUser state) | ||
341 | $ Map.alter (delclient k) (clientUser client) | ||
342 | PeerKey {} -> do | ||
343 | let h = peerKeyToText k | ||
344 | jids <- atomically $ do | ||
345 | rbp <- readTVar (remotesByPeer state) | ||
346 | return $ do | ||
347 | umap <- maybeToList $ Map.lookup k rbp | ||
348 | (u,rp) <- Map.toList umap | ||
349 | r <- Map.keys (resources rp) | ||
350 | return $ unsplitJID (Just u, h, Just r) | ||
351 | forM_ jids $ \jid -> do | ||
352 | stanza <- makePresenceStanza "jabber:client" (Just jid) Offline | ||
353 | informPeerPresence state k stanza | ||
354 | |||
355 | {- | ||
356 | rewriteJIDForClient1:: Text -> IO (Maybe ((Maybe Text,Text,Maybe Text),SockAddr)) | ||
357 | rewriteJIDForClient1 jid = do | ||
358 | let (n,h,r) = splitJID jid | ||
359 | maddr <- fmap listToMaybe $ resolvePeer h | ||
360 | flip (maybe $ return Nothing) maddr $ \addr -> do | ||
361 | h' <- peerKeyToResolvedName (PeerKey addr) | ||
362 | return $ Just ((n,h',r), addr) | ||
363 | -} | ||
364 | |||
365 | -- | The given address is taken to be the local address for the socket this JID | ||
366 | -- came in on. The returned JID parts are suitable for unsplitJID to create a | ||
367 | -- valid JID for communicating to a client. The returned Bool is True when the | ||
368 | -- host part refers to this local host (i.e. it equals the given SockAddr). | ||
369 | -- If there are multiple results, it will prefer one which is a member of the | ||
370 | -- given list in the last argument. | ||
371 | rewriteJIDForClient :: SockAddr -> Text -> [Text] -> IO (Bool,(Maybe Text,Text,Maybe Text)) | ||
372 | rewriteJIDForClient laddr jid buds = do | ||
373 | let (n,h,r) = splitJID jid | ||
374 | maddr <- parseAddress (strip_brackets h) | ||
375 | flip (maybe $ return (False,(n,ip6literal h,r))) maddr $ \addr -> do | ||
376 | let mine = laddr `withPort` 0 == addr `withPort` 0 | ||
377 | h' <- if mine then textHostName | ||
378 | else peerKeyToResolvedName buds (PeerKey addr) | ||
379 | return (mine,(n,h',r)) | ||
380 | |||
381 | peerKeyToResolvedName :: [Text] -> ConnectionKey -> IO Text | ||
382 | peerKeyToResolvedName buds k@(ClientKey { localAddress=addr }) = return "ErrorClIeNt1" | ||
383 | peerKeyToResolvedName buds pk = do | ||
384 | ns <- peerKeyToResolvedNames pk | ||
385 | let hs = map (\jid -> let (_,h,_)=splitJID jid in h) buds | ||
386 | ns' = sortBy (comparing $ not . flip elem hs) ns | ||
387 | return $ maybe (peerKeyToText pk) id (listToMaybe ns') | ||
388 | |||
389 | |||
390 | multiplyJIDForClient :: SockAddr -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)]) | ||
391 | multiplyJIDForClient laddr jid = do | ||
392 | let (n,h,r) = splitJID jid | ||
393 | maddr <- parseAddress (strip_brackets h) | ||
394 | flip (maybe $ return (False,[(n,ip6literal h,r)])) maddr $ \addr -> do | ||
395 | let mine = sameAddress laddr addr | ||
396 | names <- if mine then fmap (:[]) textHostName | ||
397 | else peerKeyToResolvedNames (PeerKey addr) | ||
398 | return (mine,map (\h' -> (n,h',r)) names) | ||
399 | |||
400 | |||
401 | addrTextToKey :: Text -> IO (Maybe ConnectionKey) | ||
402 | addrTextToKey h = do | ||
403 | maddr <- parseAddress (strip_brackets h) | ||
404 | return (fmap PeerKey maddr) | ||
405 | |||
406 | guardPortStrippedAddress :: Text -> SockAddr -> IO (Maybe ()) | ||
407 | guardPortStrippedAddress h laddr = do | ||
408 | maddr <- fmap (fmap (`withPort` 0)) $ parseAddress (strip_brackets h) | ||
409 | let laddr' = laddr `withPort` 0 | ||
410 | return $ maddr >>= guard . (==laddr') | ||
411 | |||
412 | |||
413 | -- | Accepts a textual representation of a domainname | ||
414 | -- JID suitable for client connections, and returns the | ||
415 | -- coresponding ipv6 address JID suitable for peers paired | ||
416 | -- with a SockAddr with the address part of that JID in | ||
417 | -- binary form. If no suitable address could be resolved | ||
418 | -- for the given name, Nothing is returned. | ||
419 | rewriteJIDForPeer :: Text -> IO (Maybe (Text,SockAddr)) | ||
420 | rewriteJIDForPeer jid = do | ||
421 | let (n,h,r) = splitJID jid | ||
422 | maddr <- fmap listToMaybe $ resolvePeer h | ||
423 | return $ flip fmap maddr $ \addr -> | ||
424 | let h' = addrToText addr | ||
425 | to' = unsplitJID (n,h',r) | ||
426 | in (to',addr) | ||
427 | |||
428 | deliverToConsole :: PresenceState -> IO () -> Stanza -> IO () | ||
429 | deliverToConsole PresenceState{ consoleWriter = Just cw } fail msg = do | ||
430 | did1 <- writeActiveTTY cw msg | ||
431 | did2 <- writeAllPty cw msg | ||
432 | if not (did1 || did2) then fail else return () | ||
433 | deliverToConsole _ fail _ = fail | ||
434 | |||
435 | -- | deliver <message/> or error stanza | ||
436 | deliverMessage :: PresenceState | ||
437 | -> IO () | ||
438 | -> StanzaWrap (LockedChan Event) | ||
439 | -> IO () | ||
440 | deliverMessage state fail msg = | ||
441 | case stanzaOrigin msg of | ||
442 | NetworkOrigin senderk@(ClientKey {}) _ -> do | ||
443 | -- Case 1. Client -> Peer | ||
444 | mto <- do | ||
445 | flip (maybe $ return Nothing) (stanzaTo msg) $ \to -> do | ||
446 | rewriteJIDForPeer to | ||
447 | flip (maybe fail {- reverse lookup failure -}) | ||
448 | mto | ||
449 | $ \(to',addr) -> do | ||
450 | let k = PeerKey addr | ||
451 | chans <- atomically $ readTVar (keyToChan state) | ||
452 | flip (maybe fail) (Map.lookup k chans) $ \(Conn { connChan=chan | ||
453 | , auxAddr=laddr }) -> do | ||
454 | (n,r) <- forClient state senderk (return (Nothing,Nothing)) | ||
455 | $ \c -> return (Just (clientUser c), Just (clientResource c)) | ||
456 | -- original 'from' address is discarded. | ||
457 | let from' = unsplitJID (n,addrToText laddr,r) | ||
458 | -- dup <- atomically $ cloneStanza (msg { stanzaTo=Just to', stanzaFrom=Just from' }) | ||
459 | let dup = (msg { stanzaTo=Just to', stanzaFrom=Just from' }) | ||
460 | sendModifiedStanzaToPeer dup chan | ||
461 | NetworkOrigin senderk@(PeerKey {}) _ -> do | ||
462 | key_to_chan <- atomically $ readTVar (keyToChan state) | ||
463 | flip (maybe fail) (Map.lookup senderk key_to_chan) | ||
464 | $ \(Conn { connChan=sender_chan | ||
465 | , auxAddr=laddr }) -> do | ||
466 | flip (maybe fail) (stanzaTo msg) $ \to -> do | ||
467 | (mine,(n,h,r)) <- rewriteJIDForClient laddr to [] | ||
468 | if not mine then fail else do | ||
469 | let to' = unsplitJID (n,h,r) | ||
470 | cmap <- atomically . readTVar $ clientsByUser state | ||
471 | (from',chans,ks) <- do | ||
472 | flip (maybe $ return (Nothing,[],[])) n $ \n -> do | ||
473 | buds <- configText ConfigFiles.getBuddies n | ||
474 | from' <- do | ||
475 | flip (maybe $ return Nothing) (stanzaFrom msg) $ \from -> do | ||
476 | (_,trip) <- rewriteJIDForClient laddr from buds | ||
477 | return . Just $ unsplitJID trip | ||
478 | let nope = return (from',[],[]) | ||
479 | flip (maybe nope) (Map.lookup n cmap) $ \presence_container -> do | ||
480 | let ks = Map.keys (networkClients presence_container) | ||
481 | chans = mapMaybe (flip Map.lookup key_to_chan) ks | ||
482 | return (from',chans,ks) | ||
483 | putStrLn $ "chan count: " ++ show (length chans) | ||
484 | let msg' = msg { stanzaTo=Just to' | ||
485 | , stanzaFrom=from' } | ||
486 | if null chans then deliverToConsole state fail msg' else do | ||
487 | forM_ chans $ \Conn { connChan=chan} -> do | ||
488 | putStrLn $ "sending "++show (stanzaId msg)++" to clients "++show ks | ||
489 | -- TODO: Cloning isn't really neccessary unless there are multiple | ||
490 | -- destinations and we should probably transition to minimal cloning, | ||
491 | -- or else we should distinguish between announcable stanzas and | ||
492 | -- consumable stanzas and announcables use write-only broadcast | ||
493 | -- channels that must be cloned in order to be consumed. | ||
494 | -- For now, we are doing redundant cloning. | ||
495 | dup <- cloneStanza msg' | ||
496 | sendModifiedStanzaToClient dup | ||
497 | chan | ||
498 | |||
499 | |||
500 | setClientFlag :: PresenceState -> ConnectionKey -> Int8 -> IO () | ||
501 | setClientFlag state k flag = | ||
502 | atomically $ do | ||
503 | cmap <- readTVar (clients state) | ||
504 | flip (maybe $ return ()) (Map.lookup k cmap) $ \client -> do | ||
505 | setClientFlag0 client flag | ||
506 | |||
507 | setClientFlag0 :: ClientState -> Int8 -> STM () | ||
508 | setClientFlag0 client flag = | ||
509 | modifyTVar' (clientFlags client) (\flgs -> flgs .|. flag) | ||
510 | |||
511 | informSentRoster :: PresenceState -> ConnectionKey -> IO () | ||
512 | informSentRoster state k = do | ||
513 | setClientFlag state k cf_interested | ||
514 | |||
515 | |||
516 | subscribedPeers :: Text -> IO [SockAddr] | ||
517 | subscribedPeers user = do | ||
518 | jids <- configText ConfigFiles.getSubscribers user | ||
519 | let hosts = map ((\(_,h,_)->h) . splitJID) jids | ||
520 | fmap Map.keys $ resolveAllPeers hosts | ||
521 | |||
522 | -- | this JID is suitable for peers, not clients. | ||
523 | clientJID :: Conn -> ClientState -> Text | ||
524 | clientJID con client = unsplitJID ( Just $ clientUser client | ||
525 | , addrToText $ auxAddr con | ||
526 | , Just $ clientResource client) | ||
527 | |||
528 | -- | Send presence notification to subscribed peers. | ||
529 | -- Note that a full JID from address will be added to the | ||
530 | -- stanza if it is not present. | ||
531 | informClientPresence :: PresenceState | ||
532 | -> ConnectionKey -> StanzaWrap (LockedChan Event) -> IO () | ||
533 | informClientPresence state k stanza = do | ||
534 | forClient state k (return ()) $ \client -> do | ||
535 | informClientPresence0 state (Just k) client stanza | ||
536 | |||
537 | informClientPresence0 :: PresenceState | ||
538 | -> Maybe ConnectionKey | ||
539 | -> ClientState | ||
540 | -> StanzaWrap (LockedChan Event) | ||
541 | -> IO () | ||
542 | informClientPresence0 state mbk client stanza = do | ||
543 | dup <- cloneStanza stanza | ||
544 | atomically $ writeTVar (clientStatus client) $ Just dup | ||
545 | is_avail <- atomically $ clientIsAvailable client | ||
546 | when (not is_avail) $ do | ||
547 | atomically $ setClientFlag0 client cf_available | ||
548 | maybe (return ()) (sendCachedPresence state) mbk | ||
549 | addrs <- subscribedPeers (clientUser client) | ||
550 | ktc <- atomically $ readTVar (keyToChan state) | ||
551 | let connected = mapMaybe (flip Map.lookup ktc . PeerKey) addrs | ||
552 | forM_ connected $ \con -> do | ||
553 | let from' = clientJID con client | ||
554 | mto <- runTraversableT $ do | ||
555 | to <- liftT $ stanzaTo stanza | ||
556 | (to',_) <- liftMT $ rewriteJIDForPeer to | ||
557 | return to' | ||
558 | dup <- cloneStanza stanza | ||
559 | sendModifiedStanzaToPeer dup { stanzaFrom = Just from' | ||
560 | , stanzaTo = mto } | ||
561 | (connChan con) | ||
562 | |||
563 | informPeerPresence :: PresenceState | ||
564 | -> ConnectionKey | ||
565 | -> StanzaWrap (LockedChan Event) | ||
566 | -> IO () | ||
567 | informPeerPresence state k stanza = do | ||
568 | -- Presence must indicate full JID with resource... | ||
569 | putStrLn $ "xmppInformPeerPresence checking from address..." | ||
570 | flip (maybe $ return ()) (stanzaFrom stanza) $ \from -> do | ||
571 | let (muser,h,mresource) = splitJID from | ||
572 | putStrLn $ "xmppInformPeerPresence from = " ++ show from | ||
573 | -- flip (maybe $ return ()) mresource $ \resource -> do | ||
574 | flip (maybe $ return ()) muser $ \user -> do | ||
575 | |||
576 | clients <- atomically $ do | ||
577 | |||
578 | -- Update remotesByPeer... | ||
579 | rbp <- readTVar (remotesByPeer state) | ||
580 | let umap = maybe Map.empty id $ Map.lookup k rbp | ||
581 | rp = case (presenceShow $ stanzaType stanza) of | ||
582 | Offline -> | ||
583 | maybe Map.empty | ||
584 | (\resource -> | ||
585 | maybe (Map.empty) | ||
586 | (Map.delete resource . resources) | ||
587 | $ Map.lookup user umap) | ||
588 | mresource | ||
589 | |||
590 | _ ->maybe Map.empty | ||
591 | (\resource -> | ||
592 | maybe (Map.singleton resource stanza) | ||
593 | (Map.insert resource stanza . resources ) | ||
594 | $ Map.lookup user umap) | ||
595 | mresource | ||
596 | umap' = Map.insert user (RemotePresence rp) umap | ||
597 | |||
598 | flip (maybe $ return []) (case presenceShow $ stanzaType stanza of | ||
599 | Offline -> Just () | ||
600 | _ -> mresource >> Just ()) | ||
601 | $ \_ -> do | ||
602 | writeTVar (remotesByPeer state) $ Map.insert k umap' rbp | ||
603 | -- TODO: Store or delete the stanza (remotesByPeer) | ||
604 | |||
605 | -- all clients, we'll filter available/authorized later | ||
606 | |||
607 | ktc <- readTVar (keyToChan state) | ||
608 | runTraversableT $ do | ||
609 | (ck,client) <- liftMT $ fmap Map.toList $ readTVar (clients state) | ||
610 | con <- liftMaybe $ Map.lookup ck ktc | ||
611 | return (ck,con,client) | ||
612 | putStrLn $ "xmppInformPeerPresence (length clients="++show (length clients)++")" | ||
613 | forM_ clients $ \(ck,con,client) -> do | ||
614 | -- (TODO: appropriately authorized clients only.) | ||
615 | -- For now, all "available" clients (available = sent initial presence) | ||
616 | is_avail <- atomically $ clientIsAvailable client | ||
617 | when is_avail $ do | ||
618 | putStrLn $ "reversing for client: " ++ show from | ||
619 | froms <- do -- flip (maybe $ return [from]) k . const $ do | ||
620 | let ClientKey laddr = ck | ||
621 | (_,trip) <- multiplyJIDForClient laddr from | ||
622 | return (map unsplitJID trip) | ||
623 | |||
624 | putStrLn $ "sending to client: " ++ show (stanzaType stanza,froms) | ||
625 | forM_ froms $ \from' -> do | ||
626 | dup <- cloneStanza stanza | ||
627 | sendModifiedStanzaToClient (dup { stanzaFrom=Just from' }) | ||
628 | (connChan con) | ||
629 | |||
630 | consoleClients :: PresenceState -> STM (Map Text ClientState) | ||
631 | consoleClients PresenceState{ consoleWriter = Just cw } = readTVar (cwClients cw) | ||
632 | consoleClients _ = return Map.empty | ||
633 | |||
634 | |||
635 | answerProbe :: PresenceState | ||
636 | -> Maybe Text -> ConnectionKey -> TChan Stanza -> IO () | ||
637 | answerProbe state mto k chan = do | ||
638 | -- putStrLn $ "answerProbe! " ++ show (stanzaType stanza) | ||
639 | ktc <- atomically $ readTVar (keyToChan state) | ||
640 | muser <- runTraversableT $ do | ||
641 | to <- liftT $ mto | ||
642 | conn <- liftT $ Map.lookup k ktc | ||
643 | let (mu,h,_) = splitJID to -- TODO: currently resource-id is ignored on presence | ||
644 | -- probes. Is this correct? Check the spec. | ||
645 | liftMT $ guardPortStrippedAddress h (auxAddr conn) | ||
646 | u <- liftT mu | ||
647 | let ch = addrToText (auxAddr conn) | ||
648 | return (u,conn,ch) | ||
649 | |||
650 | flip (maybe $ return ()) muser $ \(u,conn,ch) -> do | ||
651 | |||
652 | resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u | ||
653 | let gaddrs = groupBy (\a b -> snd a == snd b) (sort resolved_subs) | ||
654 | whitelist = do | ||
655 | xs <- gaddrs | ||
656 | x <- take 1 xs | ||
657 | guard $ snd x==k | ||
658 | mapMaybe fst xs | ||
659 | |||
660 | -- -- only subscribed peers should get probe replies | ||
661 | -- addrs <- subscribedPeers u | ||
662 | |||
663 | -- TODO: notify remote peer that they are unsubscribed? | ||
664 | -- reply <- makeInformSubscription "jabber:server" to from False | ||
665 | when (not $ null whitelist) $ do | ||
666 | |||
667 | replies <- runTraversableT $ do | ||
668 | cbu <- lift . atomically $ readTVar (clientsByUser state) | ||
669 | let lpres = maybeToList $ Map.lookup u cbu | ||
670 | cw <- lift . atomically $ consoleClients state | ||
671 | clientState <- liftT $ (lpres >>= Map.elems . networkClients) | ||
672 | ++ Map.elems cw | ||
673 | stanza <- liftIOMaybe $ atomically (readTVar (clientStatus clientState)) | ||
674 | stanza <- lift $ cloneStanza stanza | ||
675 | let jid = unsplitJID (Just $ clientUser clientState | ||
676 | , ch | ||
677 | ,Just $ clientResource clientState) | ||
678 | return stanza { stanzaFrom = Just jid | ||
679 | , stanzaType = (stanzaType stanza) | ||
680 | { presenceWhiteList = whitelist } | ||
681 | } | ||
682 | |||
683 | forM_ replies $ \reply -> do | ||
684 | sendModifiedStanzaToPeer reply chan | ||
685 | |||
686 | -- if no presence, send offline message | ||
687 | when (null replies) $ do | ||
688 | let jid = unsplitJID (Just u,ch,Nothing) | ||
689 | pstanza <- makePresenceStanza "jabber:server" (Just jid) Offline | ||
690 | atomically $ writeTChan (connChan conn) pstanza | ||
691 | |||
692 | sendCachedPresence :: PresenceState -> ConnectionKey -> IO () | ||
693 | sendCachedPresence state k = do | ||
694 | forClient state k (return ()) $ \client -> do | ||
695 | rbp <- atomically $ readTVar (remotesByPeer state) | ||
696 | jids <- configText ConfigFiles.getBuddies (clientUser client) | ||
697 | let hosts = map ((\(_,h,_)->h) . splitJID) jids | ||
698 | addrs <- resolveAllPeers hosts | ||
699 | let onlines = rbp `Map.intersection` Map.mapKeys PeerKey addrs | ||
700 | ClientKey laddr = k | ||
701 | mcon <- atomically $ do ktc <- readTVar (keyToChan state) | ||
702 | return $ Map.lookup k ktc | ||
703 | flip (maybe $ return ()) mcon $ \con -> do | ||
704 | -- me <- textHostName | ||
705 | forM_ (Map.toList onlines) $ \(pk, umap) -> do | ||
706 | forM_ (Map.toList umap) $ \(user,rp) -> do | ||
707 | let h = peerKeyToText pk | ||
708 | forM_ (Map.toList $ resources rp) $ \(resource,stanza) -> do | ||
709 | let jid = unsplitJID (Just user,h,Just resource) | ||
710 | (mine,js) <- multiplyJIDForClient laddr jid | ||
711 | forM_ js $ \jid -> do | ||
712 | let from' = unsplitJID jid | ||
713 | dup <- cloneStanza stanza | ||
714 | sendModifiedStanzaToClient (dup { stanzaFrom=Just from' }) | ||
715 | (connChan con) | ||
716 | |||
717 | pending <- configText ConfigFiles.getPending (clientUser client) | ||
718 | hostname <- textHostName | ||
719 | forM_ pending $ \pending_jid -> do | ||
720 | let cjid = unsplitJID ( Just $ clientUser client | ||
721 | , hostname | ||
722 | , Nothing ) | ||
723 | ask <- presenceSolicitation pending_jid cjid | ||
724 | sendModifiedStanzaToClient ask (connChan con) | ||
725 | |||
726 | -- Note: relying on self peer connection to send | ||
727 | -- send local buddies. | ||
728 | return () | ||
729 | |||
730 | addToRosterFile :: (MonadPlus t, Traversable t) => | ||
731 | (L.ByteString -> (L.ByteString -> IO (t L.ByteString)) | ||
732 | -> Maybe L.ByteString | ||
733 | -> t1) | ||
734 | -> Text -> Text -> [SockAddr] -> t1 | ||
735 | addToRosterFile doit whose to addrs = | ||
736 | modifyRosterFile doit whose to addrs True | ||
737 | |||
738 | removeFromRosterFile :: (MonadPlus t, Traversable t) => | ||
739 | (L.ByteString -> (L.ByteString -> IO (t L.ByteString)) | ||
740 | -> Maybe L.ByteString | ||
741 | -> t1) | ||
742 | -> Text -> Text -> [SockAddr] -> t1 | ||
743 | removeFromRosterFile doit whose to addrs = | ||
744 | modifyRosterFile doit whose to addrs False | ||
745 | |||
746 | modifyRosterFile :: (Traversable t, MonadPlus t) => | ||
747 | (L.ByteString -> (L.ByteString -> IO (t L.ByteString)) | ||
748 | -> Maybe L.ByteString | ||
749 | -> t1) | ||
750 | -> Text -> Text -> [SockAddr] -> Bool -> t1 | ||
751 | modifyRosterFile doit whose to addrs bAdd = do | ||
752 | let (mu,_,_) = splitJID to | ||
753 | cmp jid = runTraversableT $ do | ||
754 | let (msu,stored_h,mr) = splitJID (lazyByteStringToText jid) | ||
755 | -- Delete from file if a resource is present in file | ||
756 | (\f -> maybe f (const mzero) mr) $ do | ||
757 | -- Delete from file if no user is present in file | ||
758 | flip (maybe mzero) msu $ \stored_u -> do | ||
759 | -- do not delete anything if no user was specified | ||
760 | flip (maybe $ return jid) mu $ \u -> do | ||
761 | -- do not delete if stored user is same as specified | ||
762 | if stored_u /= u then return jid else do | ||
763 | stored_addrs <- lift $ resolvePeer stored_h | ||
764 | -- do not delete if failed to resolve | ||
765 | if null stored_addrs then return jid else do | ||
766 | -- delete if specified address matches stored | ||
767 | if null (stored_addrs \\ addrs) then mzero else do | ||
768 | -- keep | ||
769 | return jid | ||
770 | doit (textToLazyByteString whose) | ||
771 | cmp | ||
772 | (guard bAdd >> Just (textToLazyByteString to)) | ||
773 | |||
774 | clientSubscriptionRequest :: PresenceState -> IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO () | ||
775 | clientSubscriptionRequest state fail k stanza chan = do | ||
776 | forClient state k fail $ \client -> do | ||
777 | flip (maybe fail) (stanzaTo stanza) $ \to -> do | ||
778 | putStrLn $ "Forwarding solictation to peer" | ||
779 | let (mu,h,_) = splitJID to | ||
780 | to <- return $ unsplitJID (mu,h,Nothing) -- delete resource | ||
781 | flip (maybe fail) mu $ \u -> do | ||
782 | -- add to-address to from's solicited | ||
783 | addrs <- resolvePeer h | ||
784 | addToRosterFile ConfigFiles.modifySolicited (clientUser client) to addrs | ||
785 | removeFromRosterFile ConfigFiles.modifyBuddies (clientUser client) to addrs | ||
786 | resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers (clientUser client) | ||
787 | let is_subscribed = not . null $ intersect (map ((mu,).PeerKey) addrs) resolved_subs | ||
788 | -- subscribers: "from" | ||
789 | -- buddies: "to" | ||
790 | |||
791 | case state of | ||
792 | PresenceState { server = svVar } -> do | ||
793 | |||
794 | (ktc,(sv,conns)) <- atomically $ | ||
795 | liftM2 (,) (readTVar $ keyToChan state) | ||
796 | (takeTMVar svVar) | ||
797 | |||
798 | case stanzaType stanza of | ||
799 | PresenceRequestSubscription True -> do | ||
800 | hostname <- textHostName | ||
801 | let cjid = unsplitJID (Just $ clientUser client, hostname,Nothing) | ||
802 | chans <- clientCons state ktc (clientUser client) | ||
803 | forM_ chans $ \( Conn { connChan=chan }, client ) -> do | ||
804 | -- roster update ask="subscribe" | ||
805 | update <- makeRosterUpdate cjid to | ||
806 | [ ("ask","subscribe") | ||
807 | , if is_subscribed then ("subscription","from") | ||
808 | else ("subscription","none") | ||
809 | ] | ||
810 | sendModifiedStanzaToClient update chan | ||
811 | _ -> return () | ||
812 | |||
813 | let dsts = Map.fromList $ map ((,()) . PeerKey) addrs | ||
814 | cdsts = ktc `Map.intersection` dsts | ||
815 | forM_ (Map.toList cdsts) $ \(pk,con) -> do | ||
816 | -- if already connected, send solicitation ... | ||
817 | -- let from = clientJID con client | ||
818 | let from = unsplitJID ( Just $ clientUser client | ||
819 | , addrToText $ auxAddr con | ||
820 | , Nothing ) | ||
821 | mb <- rewriteJIDForPeer to | ||
822 | flip (maybe $ return ()) mb $ \(to',addr) -> do | ||
823 | dup <- cloneStanza stanza | ||
824 | sendModifiedStanzaToPeer (dup { stanzaTo = Just to' | ||
825 | , stanzaFrom = Just from }) | ||
826 | (connChan con) | ||
827 | let addrm = Map.fromList (map (,()) addrs) | ||
828 | -- Add peer if we are not already associated ... | ||
829 | Connection.setPolicy conns h Connection.TryingToConnect | ||
830 | atomically $ putTMVar svVar (sv,conns) | ||
831 | |||
832 | |||
833 | resolvedFromRoster | ||
834 | :: (L.ByteString -> IO [L.ByteString]) | ||
835 | -> UserName -> IO [(Maybe UserName, ConnectionKey)] | ||
836 | resolvedFromRoster doit u = do | ||
837 | subs <- configText doit u | ||
838 | runTraversableT $ do | ||
839 | (mu,h,_) <- liftT $ splitJID `fmap` subs | ||
840 | addr <- liftMT $ fmap nub $ resolvePeer h | ||
841 | return (mu,PeerKey addr) | ||
842 | |||
843 | clientCons :: PresenceState | ||
844 | -> Map ConnectionKey t -> Text -> IO [(t, ClientState)] | ||
845 | clientCons state ktc u = do | ||
846 | mlp <- atomically $ do | ||
847 | cmap <- readTVar $ clientsByUser state | ||
848 | return $ Map.lookup u cmap | ||
849 | let ks = do lp <- maybeToList mlp | ||
850 | Map.toList (networkClients lp) | ||
851 | doit (k,client) = do | ||
852 | con <- Map.lookup k ktc | ||
853 | return (con,client) | ||
854 | return $ mapMaybe doit ks | ||
855 | |||
856 | peerSubscriptionRequest :: PresenceState -> IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO () | ||
857 | peerSubscriptionRequest state fail k stanza chan = do | ||
858 | putStrLn $ "Handling pending subscription from remote" | ||
859 | flip (maybe fail) (stanzaFrom stanza) $ \from -> do | ||
860 | flip (maybe fail) (stanzaTo stanza) $ \to -> do | ||
861 | let (mto_u,h,_) = splitJID to | ||
862 | (mfrom_u,from_h,_) = splitJID from | ||
863 | to <- return $ unsplitJID (mto_u,h,Nothing) -- delete resource | ||
864 | from <- return $ unsplitJID (mfrom_u,from_h,Nothing) -- delete resource | ||
865 | ktc <- atomically . readTVar $ keyToChan state | ||
866 | flip (maybe fail) (Map.lookup k ktc) | ||
867 | $ \Conn { auxAddr=laddr } -> do | ||
868 | (mine,totup) <- rewriteJIDForClient laddr to [] | ||
869 | if not mine then fail else do | ||
870 | (_,fromtup) <- rewriteJIDForClient laddr from [] | ||
871 | flip (maybe fail) mto_u $ \u -> do | ||
872 | flip (maybe fail) mfrom_u $ \from_u -> do | ||
873 | resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u | ||
874 | let already_subscribed = elem (mfrom_u,k) resolved_subs | ||
875 | is_wanted = case stanzaType stanza of | ||
876 | PresenceRequestSubscription b -> b | ||
877 | _ -> False -- Shouldn't happen. | ||
878 | -- Section 8 says (for presence of type "subscribe", the server MUST | ||
879 | -- adhere to the rules defined under Section 3 and summarized under | ||
880 | -- see Appendix A. (pariticularly Appendex A.3.1) | ||
881 | if already_subscribed == is_wanted | ||
882 | then do | ||
883 | -- contact ∈ subscribers --> SHOULD NOT, already handled | ||
884 | -- already subscribed, reply and quit | ||
885 | -- (note: swapping to and from for reply) | ||
886 | reply <- makeInformSubscription "jabber:server" to from is_wanted | ||
887 | sendModifiedStanzaToPeer reply chan | ||
888 | answerProbe state (Just to) k chan | ||
889 | else do | ||
890 | |||
891 | -- TODO: if peer-connection is to self, then auto-approve local user. | ||
892 | |||
893 | -- add from-address to to's pending | ||
894 | addrs <- resolvePeer from_h | ||
895 | |||
896 | -- Catch exception in case the user does not exist | ||
897 | if null addrs then fail else do | ||
898 | |||
899 | let from' = unsplitJID fromtup | ||
900 | |||
901 | already_pending <- | ||
902 | if is_wanted then | ||
903 | addToRosterFile ConfigFiles.modifyPending u from' addrs | ||
904 | else do | ||
905 | removeFromRosterFile ConfigFiles.modifySubscribers u from' addrs | ||
906 | reply <- makeInformSubscription "jabber:server" to from is_wanted | ||
907 | sendModifiedStanzaToPeer reply chan | ||
908 | return False | ||
909 | |||
910 | -- contact ∉ subscribers & contact ∈ pending --> SHOULD NOT | ||
911 | when (not already_pending) $ do | ||
912 | -- contact ∉ subscribers & contact ∉ pending --> MUST | ||
913 | |||
914 | chans <- clientCons state ktc u | ||
915 | forM_ chans $ \( Conn { connChan=chan }, client ) -> do | ||
916 | -- send to clients | ||
917 | -- TODO: interested/available clients only? | ||
918 | dup <- cloneStanza stanza | ||
919 | sendModifiedStanzaToClient dup { stanzaFrom = Just $ from' | ||
920 | , stanzaTo = Just $ unsplitJID totup } | ||
921 | chan | ||
922 | |||
923 | |||
924 | clientInformSubscription :: PresenceState | ||
925 | -> IO () | ||
926 | -> ConnectionKey | ||
927 | -> StanzaWrap (LockedChan Event) | ||
928 | -> IO () | ||
929 | clientInformSubscription state fail k stanza = do | ||
930 | forClient state k fail $ \client -> do | ||
931 | flip (maybe fail) (stanzaTo stanza) $ \to -> do | ||
932 | putStrLn $ "clientInformSubscription" | ||
933 | let (mu,h,mr) = splitJID to | ||
934 | addrs <- resolvePeer h | ||
935 | -- remove from pending | ||
936 | buds <- resolvedFromRoster ConfigFiles.getBuddies (clientUser client) | ||
937 | let is_buddy = not . null $ map ((mu,) . PeerKey) addrs `intersect` buds | ||
938 | removeFromRosterFile ConfigFiles.modifyPending (clientUser client) to addrs | ||
939 | let (relationship,addf,remf) = | ||
940 | case stanzaType stanza of | ||
941 | PresenceInformSubscription True -> | ||
942 | ( ("subscription", if is_buddy then "both" | ||
943 | else "from" ) | ||
944 | , ConfigFiles.modifySubscribers | ||
945 | , ConfigFiles.modifyOthers ) | ||
946 | _ -> ( ("subscription", if is_buddy then "to" | ||
947 | else "none" ) | ||
948 | , ConfigFiles.modifyOthers | ||
949 | , ConfigFiles.modifySubscribers ) | ||
950 | addToRosterFile addf (clientUser client) to addrs | ||
951 | removeFromRosterFile remf (clientUser client) to addrs | ||
952 | |||
953 | do | ||
954 | cbu <- atomically $ readTVar (clientsByUser state) | ||
955 | putStrLn $ "cbu = " ++ show (fmap (fmap clientPid . networkClients) cbu) | ||
956 | |||
957 | -- send roster update to clients | ||
958 | (clients,ktc) <- atomically $ do | ||
959 | cbu <- readTVar (clientsByUser state) | ||
960 | let mlp = Map.lookup (clientUser client) cbu | ||
961 | let cs = maybe [] (Map.toList . networkClients) mlp | ||
962 | ktc <- readTVar (keyToChan state) | ||
963 | return (cs,ktc) | ||
964 | forM_ clients $ \(ck, client) -> do | ||
965 | is_intereseted <- atomically $ clientIsInterested client | ||
966 | putStrLn $ "clientIsInterested: "++show is_intereseted | ||
967 | is_intereseted <- atomically $ clientIsInterested client | ||
968 | when is_intereseted $ do | ||
969 | flip (maybe $ return ()) (Map.lookup ck ktc) $ \con -> do | ||
970 | hostname <- textHostName | ||
971 | -- TODO: Should cjid include the resource? | ||
972 | let cjid = unsplitJID (mu, hostname, Nothing) | ||
973 | update <- makeRosterUpdate cjid to [relationship] | ||
974 | sendModifiedStanzaToClient update (connChan con) | ||
975 | |||
976 | -- notify peer | ||
977 | let dsts = Map.fromList $ map ((,()) . PeerKey) addrs | ||
978 | cdsts = ktc `Map.intersection` dsts | ||
979 | forM_ (Map.toList cdsts) $ \(pk,con) -> do | ||
980 | let from = clientJID con client | ||
981 | to' = unsplitJID (mu, peerKeyToText pk, Nothing) | ||
982 | dup <- cloneStanza stanza | ||
983 | sendModifiedStanzaToPeer (dup { stanzaTo = Just $ to' | ||
984 | , stanzaFrom = Just from }) | ||
985 | (connChan con) | ||
986 | answerProbe state (Just from) pk (connChan con) | ||
987 | |||
988 | peerInformSubscription :: PresenceState | ||
989 | -> IO () | ||
990 | -> ConnectionKey | ||
991 | -> StanzaWrap (LockedChan Event) | ||
992 | -> IO () | ||
993 | peerInformSubscription state fail k stanza = do | ||
994 | putStrLn $ "TODO: peerInformSubscription" | ||
995 | -- remove from solicited | ||
996 | flip (maybe fail) (stanzaFrom stanza) $ \from -> do | ||
997 | ktc <- atomically $ readTVar (keyToChan state) | ||
998 | flip (maybe fail) (Map.lookup k ktc) | ||
999 | $ \(Conn { connChan=sender_chan | ||
1000 | , auxAddr=laddr }) -> do | ||
1001 | (_,(from_u,from_h,_)) <- rewriteJIDForClient laddr from [] | ||
1002 | let from'' = unsplitJID (from_u,from_h,Nothing) | ||
1003 | muser = do | ||
1004 | to <- stanzaTo stanza | ||
1005 | let (mu,to_h,to_r) = splitJID to | ||
1006 | mu | ||
1007 | -- TODO muser = Nothing when wanted=False | ||
1008 | -- should probably mean unsubscribed for all users. | ||
1009 | -- This would allow us to answer anonymous probes with 'unsubscribed'. | ||
1010 | flip (maybe fail) muser $ \user -> do | ||
1011 | addrs <- resolvePeer from_h | ||
1012 | was_solicited <- removeFromRosterFile ConfigFiles.modifySolicited user from'' addrs | ||
1013 | subs <- resolvedFromRoster ConfigFiles.getSubscribers user | ||
1014 | let is_sub = not . null $ map ((from_u,) . PeerKey) addrs `intersect` subs | ||
1015 | let (relationship,addf,remf) = | ||
1016 | case stanzaType stanza of | ||
1017 | PresenceInformSubscription True -> | ||
1018 | ( ("subscription", if is_sub then "both" | ||
1019 | else "to" ) | ||
1020 | , ConfigFiles.modifyBuddies | ||
1021 | , ConfigFiles.modifyOthers ) | ||
1022 | _ -> ( ("subscription", if is_sub then "from" | ||
1023 | else "none") | ||
1024 | , ConfigFiles.modifyOthers | ||
1025 | , ConfigFiles.modifyBuddies ) | ||
1026 | addToRosterFile addf user from'' addrs | ||
1027 | removeFromRosterFile remf user from'' addrs | ||
1028 | |||
1029 | hostname <- textHostName | ||
1030 | let to' = unsplitJID (Just user, hostname, Nothing) | ||
1031 | chans <- clientCons state ktc user | ||
1032 | forM_ chans $ \(Conn { connChan=chan }, client) -> do | ||
1033 | update <- makeRosterUpdate to' from'' [relationship] | ||
1034 | is_intereseted <- atomically $ clientIsInterested client | ||
1035 | when is_intereseted $ do | ||
1036 | sendModifiedStanzaToClient update chan | ||
1037 | -- TODO: interested/availabe clients only? | ||
1038 | dup <- cloneStanza stanza | ||
1039 | sendModifiedStanzaToClient dup { stanzaFrom = Just $ from'' | ||
1040 | , stanzaTo = Just to' } | ||
1041 | chan | ||