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