summaryrefslogtreecommitdiff
path: root/Presence/XMPP.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Presence/XMPP.hs')
-rw-r--r--Presence/XMPP.hs1461
1 files changed, 1461 insertions, 0 deletions
diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
new file mode 100644
index 00000000..eab57da5
--- /dev/null
+++ b/Presence/XMPP.hs
@@ -0,0 +1,1461 @@
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE ViewPatterns #-}
4{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE CPP #-}
6module XMPP
7 ( module XMPPTypes
8 , listenForXmppClients
9 , listenForRemotePeers
10 , newServerConnections
11 , seekRemotePeers
12 , quitListening
13 , OutBoundMessage(..)
14 , OutgoingConnections
15 , CachedMessages
16 , toPeer
17 , newOutgoingConnections
18 , sendMessage
19 ) where
20
21import ServerC
22import XMPPTypes
23import ByteStringOperators
24import ControlMaybe
25import XMLToByteStrings
26import SendMessage
27import Logging
28import Todo
29
30import Data.Maybe (catMaybes)
31import Data.HList hiding (hHead)
32import Network.Socket ( Family )
33import Control.Concurrent.STM
34import Control.Concurrent.STM.Delay
35import Data.Conduit
36import Data.Maybe
37import Data.ByteString (ByteString)
38import qualified Data.ByteString.Lazy.Char8 as L
39 ( fromChunks
40 )
41import Control.Concurrent.Async
42import Control.Exception as E ( finally )
43import System.IO.Error (isDoesNotExistError)
44import Control.Monad.IO.Class
45import Control.Monad.Trans.Class
46import Control.Monad.Trans.Maybe
47import Text.XML.Stream.Parse (def,parseBytes,content)
48import Data.XML.Types as XML
49import qualified Data.Text as S (Text,takeWhile)
50import Data.Text.Encoding as S (decodeUtf8,encodeUtf8)
51import Data.Text.Lazy.Encoding as L (decodeUtf8)
52import Data.Text.Lazy (toStrict)
53import qualified Data.Sequence as Seq
54import Data.Foldable (toList)
55import Data.List (find)
56import qualified Text.Show.ByteString as L
57import NestingXML
58import Data.Set as Set (Set,(\\))
59import qualified Data.Set as Set
60import qualified Data.Map as Map
61import Data.Map as Map (Map)
62
63#if MIN_VERSION_HList(0,3,0)
64#define HCONS HCons'
65#else
66#define HCONS HCons
67#endif
68
69hHead (HCONS x _) = x
70
71textToByteString x = L.fromChunks [S.encodeUtf8 x]
72
73
74
75xmlifyPresenceForClient :: Presence -> IO [XML.Event]
76xmlifyPresenceForClient (Presence jid stat) = do
77 let n = name jid
78 rsc = resource jid
79 names <- getNamesForPeer (peer jid)
80 let tostr p = L.decodeUtf8 $ n <$++> "@" <?++> L.fromChunks [p] <++?> "/" <++$> rsc
81 jidstrs = fmap (toStrict . tostr) names
82 return (concatMap presenceEvents jidstrs)
83 where
84 presenceEvents jidstr =
85 [ EventBeginElement "{jabber:client}presence" (("from",[ContentText jidstr]):typ stat) ]
86 ++ ( shw stat >>= jabberShow ) ++
87 [ EventEndElement "{jabber:client}presence" ]
88 typ Offline = [("type",[ContentText "unavailable"])]
89 typ _ = []
90 shw ExtendedAway = ["xa"]
91 shw Chatty = ["chat"]
92 shw Away = ["away"]
93 shw DoNotDisturb = ["dnd"]
94 shw _ = []
95 jabberShow stat =
96 [ EventBeginElement "{jabber:client}show" []
97 , EventContent (ContentText stat)
98 , EventEndElement "{jabber:client}show" ]
99
100prefix ## name = Name name Nothing (Just prefix)
101
102streamP name = Name name (Just "http://etherx.jabber.org/streams") (Just "stream")
103
104greet host =
105 [ EventBeginDocument
106 , EventBeginElement (streamP "stream")
107 [("from",[ContentText host])
108 ,("id",[ContentText "someid"])
109 ,("xmlns",[ContentText "jabber:client"])
110 ,("xmlns:stream",[ContentText "http://etherx.jabber.org/streams"])
111 ,("version",[ContentText "1.0"])
112 ]
113 , EventBeginElement (streamP "features") []
114 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind" []
115 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
116
117 {-
118 -- , " <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>"
119 , " <mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>"
120 -- , " <mechanism>DIGEST-MD5</mechanism>"
121 , " <mechanism>PLAIN</mechanism>"
122 , " </mechanisms> "
123 -}
124
125 , EventEndElement (streamP "features")
126 ]
127
128
129-- type Consumer i m r = forall o. ConduitM i o m r
130mawait :: Monad m => MaybeT (ConduitM i o m) i
131mawait = MaybeT await
132
133-- Note: This function ignores name space qualification
134elementAttrs expected (EventBeginElement name attrs)
135 | nameLocalName name==expected
136 = return attrs
137elementAttrs _ _ = mzero
138
139eventIsBeginElement (EventBeginElement _ _) = True
140eventIsBeginElement _ = False
141
142eventIsEndElement (EventEndElement _) = True
143eventIsEndElement _ = False
144
145filterMapElement::
146 (Monad m, MonadPlus mp) =>
147 (Event -> mp a) -> Event -> mp a -> MaybeT (ConduitM Event o m) (mp a)
148filterMapElement ret opentag empty = loop (empty `mplus` ret opentag) 1
149 where
150 loop ts 0 = return ts
151 loop ts cnt = do
152 tag <- mawait
153 let ts' = mplus ts (ret tag)
154 case () of
155 _ | eventIsEndElement tag -> loop ts' (cnt-1)
156 _ | eventIsBeginElement tag -> loop ts' (cnt+1)
157 _ -> loop ts' cnt
158
159gatherElement ::
160 (Monad m, MonadPlus mp) =>
161 Event -> mp Event -> NestingXML o m (mp Event)
162gatherElement opentag empty = loop (empty `mplus` return opentag) 1
163 where
164 loop ts 0 = return ts
165 loop ts cnt = do
166 maybeXML (return ts) $ \tag -> do
167 let ts' = mplus ts (return tag)
168 case () of
169 _ | eventIsEndElement tag -> loop ts' (cnt-1)
170 _ | eventIsBeginElement tag -> loop ts' (cnt+1)
171 _ -> loop ts' cnt
172
173
174voidMaybeT body = (>> return ()) . runMaybeT $ body
175fixMaybeT f = (>> return ()) . runMaybeT . fix $ f
176
177iq_bind_reply id jid =
178 [ EventBeginElement "{jabber:client}iq" [("type",[ContentText "result"]),("id",[ContentText id])]
179
180 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
181 [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])]
182 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}jid" []
183 , EventContent (ContentText jid)
184 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}jid"
185 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
186 , EventEndElement "{jabber:client}iq"
187 ]
188
189uncontent cs = head $ map getText cs
190 where
191 getText (ContentText x) = x
192 getText (ContentEntity x ) = x
193
194tagAttrs (EventBeginElement _ xs) = xs
195tagAttrs _ = []
196
197tagName (EventBeginElement n _) = n
198tagName _ = ""
199
200handleIQSetBind session cmdChan stanza_id = do
201 mchild <- nextElement
202 rsc <- case mchild of
203 Just child -> do
204 let unhandledBind = do
205 liftIO $ debugStr $ "unhandled-bind: "++show child
206 return ""
207 case tagName child of
208 "{urn:ietf:params:xml:ns:xmpp-bind}resource"
209 -> do
210 rsc <- lift content
211 return . textToByteString $ rsc
212 _ -> unhandledBind
213 Nothing -> do
214 liftIO $ debugStr $ "empty bind request!"
215 return ""
216 liftIO $ do
217 debugL $ "iq-set-bind-resource " <++> rsc
218 setResource session rsc
219 jid <- getJID session
220 atomically $ do
221 writeTChan cmdChan (Send $ iq_bind_reply stanza_id (toStrict $ L.decodeUtf8 $ L.show jid) )
222 writeTChan cmdChan BoundToResource
223 forCachedPresence session $ \presence -> do
224 xs <- xmlifyPresenceForClient presence
225 atomically . writeTChan cmdChan . Send $ xs
226
227
228iq_session_reply host stanza_id =
229 [ EventBeginElement "{jabber:client}iq"
230 [("id",[ContentText stanza_id])
231 ,("from",[ContentText host])
232 ,("type",[ContentText "result"])
233 ]
234 , EventEndElement "{jabber:client}iq"
235 ]
236
237handleIQSetSession session cmdChan stanza_id = do
238 host <- liftIO $ do
239 jid <- getJID session
240 names <- getNamesForPeer (peer jid)
241 return (S.decodeUtf8 . head $ names)
242 liftIO . atomically . writeTChan cmdChan . Send $ iq_session_reply host stanza_id
243
244handleIQSet session cmdChan tag = do
245 withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do
246 whenJust nextElement $ \child -> do
247 let unhandledSet = liftIO $ debugStr ("iq-set: "++show (stanza_id,child))
248 case tagName child of
249 "{urn:ietf:params:xml:ns:xmpp-bind}bind"
250 -> handleIQSetBind session cmdChan stanza_id
251 "{urn:ietf:params:xml:ns:xmpp-session}session"
252 -> handleIQSetSession session cmdChan stanza_id
253 _ -> unhandledSet
254
255matchAttrib name value attrs =
256 case find ( (==name) . fst) attrs of
257 Just (_,[ContentText x]) | x==value -> True
258 Just (_,[ContentEntity x]) | x==value -> True
259 _ -> False
260
261lookupAttrib name attrs =
262 case find ( (==name) . fst) attrs of
263 Just (_,[ContentText x]) -> Just x
264 Just (_,[ContentEntity x]) -> Just x
265 _ -> Nothing
266
267iqTypeSet = "set"
268iqTypeGet = "get"
269iqTypeResult = "result"
270iqTypeError = "error"
271
272isIQOf (EventBeginElement name attrs) testType
273 | name=="{jabber:client}iq"
274 && matchAttrib "type" testType attrs
275 = True
276isIQOf _ _ = False
277
278isServerIQOf (EventBeginElement name attrs) testType
279 | name=="{jabber:server}iq"
280 && matchAttrib "type" testType attrs
281 = True
282isServerIQOf _ _ = False
283
284iq_service_unavailable host iq_id mjid req =
285 [ EventBeginElement "{jabber:client}iq"
286 [("type",[ContentText "error"])
287 ,("id",[ContentText iq_id])
288 -- , TODO: set "from" if isJust mjid
289 ]
290 , EventBeginElement req []
291 , EventEndElement req
292 , EventBeginElement "{jabber:client}error" [("type",[ContentText "cancel"])]
293 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable" []
294 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable"
295 , EventEndElement "{jabber:client}error"
296 , EventEndElement "{jabber:client}iq"
297 ]
298
299attr name value = (name,[ContentText value])
300attrbs name value = (name,[ContentText (toStrict . L.decodeUtf8 $ value)])
301
302
303getRoster session iqid = do
304 let getlist f = do
305 bs <- f session
306 -- js <- mapM parseHostNameJID bs
307 return (Set.fromList bs) -- js)
308 buddies <- getlist getMyBuddies
309 subscribers <- getlist getMySubscribers
310 solicited <- getlist getMySolicited
311 subnone0 <- getlist getMyOthers
312 let subnone = subnone0 \\ (Set.union buddies subscribers)
313 let subto = buddies \\ subscribers
314 let subfrom = subscribers \\ buddies
315 let subboth = Set.intersection buddies subscribers
316 -- solicited -> ask='subscribe'
317 jid <- getJID session
318 let dest = toStrict . L.decodeUtf8 . bshow $ jid
319 let items= (xmlify solicited "to" subto)
320 ++(xmlify solicited "from" subfrom)
321 ++(xmlify solicited "both" subboth)
322 ++(xmlify solicited "none" subnone)
323 openiq = [EventBeginElement "{jabber:client}iq"
324 [ attr "id" iqid
325 , attr "to" dest
326 , attr "type" "result" ]
327 ,EventBeginElement "{jabber:iq:roster}query"
328 [] -- todo: ver?
329 ]
330 closeiq = [EventEndElement "{jabber:iq:roster}query"
331 ,EventEndElement "{jabber:client}iq"]
332 return $ openiq ++ items ++ closeiq
333 where
334 xmlify solicited stype set = flip concatMap (Set.toList set)
335 $ \jid ->
336 [ EventBeginElement "item"
337 ([ attr "jid" (toStrict . L.decodeUtf8 $ jid)
338 , attr "subscription" stype
339 ]++if Set.member jid solicited
340 then [attr "ask" "subscribe"]
341 else [] )
342 , EventEndElement "item"
343 ]
344
345handleIQGet session cmdChan tag = do
346 withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do
347 whenJust nextElement $ \child -> do
348 host <- liftIO $ do
349 jid <- getJID session
350 names <- getNamesForPeer (peer jid)
351 return (S.decodeUtf8 . head $ names)
352 let unhandledGet req = do
353 liftIO $ debugStr ("iq-get: "++show (stanza_id,child))
354 liftIO . atomically . writeTChan cmdChan . Send $ iq_service_unavailable host stanza_id Nothing req
355 case tagName child of
356 -- "{http://jabber.org/protocol/disco#items}query" -> liftIO $ debugStr "iq-get-query-items"
357 "{urn:xmpp:ping}ping" -> liftIO $ do
358 let mjid = lookupAttrib "from" (tagAttrs tag)
359 let pong = [ EventBeginElement "{jabber:client}iq"
360 $ (case mjid of
361 Just jid -> (attr "to" jid :)
362 _ -> id )
363 [ attr "type" "result"
364 , attr "id" stanza_id
365 , attr "from" host
366 ]
367 , EventEndElement "{jabber:client}iq"
368 ]
369 atomically . writeTChan cmdChan . Send $ pong
370 "{jabber:iq:roster}query" -> liftIO $ do
371 debugStr $ "REQUESTED ROSTER " ++ show tag
372 roster <- getRoster session stanza_id
373 atomically $ do
374 writeTChan cmdChan InterestedInRoster
375 writeTChan cmdChan . Send $ roster
376 sendPending session
377 req -> unhandledGet req
378
379
380handleClientPresence session stanza = do
381 -- online (Available or Away)
382 let log = liftIO . debugL . ("(C) " <++>)
383 log $ "handleClientPresence "<++>bshow stanza
384 jid <- liftIO $ getJID session
385 -- cjid <- liftIO $ parseAddressJID (textToByteString jid)
386 let parseChildren stat = do
387 child <- nextElement
388 log $ " child: "<++> bshow child
389 case child of
390 Just tag | tagName tag=="{jabber:client}show"
391 -> fmap toStat (lift content)
392 Just tag | otherwise -> parseChildren stat
393 Nothing -> return stat
394 toStat "away" = Away
395 toStat "xa" = ExtendedAway
396 toStat "dnd" = DoNotDisturb
397 toStat "chat" = Chatty
398
399 stat' <- parseChildren Available
400 liftIO $ setPresence session stat'
401 log $ "requesting presence: "<++>bshow stat'
402 return ()
403
404
405fromClient :: (MonadThrow m,MonadIO m, JabberClientSession session) =>
406 session -> TChan ClientCommands -> Sink XML.Event m ()
407fromClient session cmdChan = doNestingXML $ do
408 let log = liftIO . debugL . ("(C) " <++>)
409 send = liftIO . atomically . writeTChan cmdChan . Send
410 withXML $ \begindoc -> do
411 when (begindoc==EventBeginDocument) $ do
412 log "begin-doc"
413 withXML $ \xml -> do
414 withJust (elementAttrs "stream" xml) $ \stream_attrs -> do
415 log $ "stream atributes: " <++> bshow stream_attrs
416 host <- liftIO $ do
417 jid <- getJID session
418 names <- getNamesForPeer (peer jid)
419 return (S.decodeUtf8 . head $ names)
420 send $ greet host
421
422 fix $ \loop -> do
423 log "waiting for stanza."
424 whenJust nextElement $ \stanza -> do
425 stanza_lvl <- nesting
426
427 liftIO . debugStr $ "stanza: "++show stanza
428
429 let unhandledStanza = do
430 xs <- gatherElement stanza Seq.empty
431 prettyPrint "unhandled-C: " (toList xs)
432 case () of
433 _ | stanza `isIQOf` iqTypeSet -> handleIQSet session cmdChan stanza
434 _ | stanza `isIQOf` iqTypeGet -> handleIQGet session cmdChan stanza
435 _ | stanza `isClientPresenceOf` presenceTypeSubscribe
436 -> clientRequestsSubscription session cmdChan stanza
437 _ | stanza `isClientPresenceOf` presenceTypeSubscribed
438 -> clientApprovesSubscription session stanza
439 _ | stanza `isClientPresenceOf` presenceTypeUnsubscribed
440 -> clientRejectsSubscription session stanza
441 _ | stanza `isClientPresenceOf` presenceTypeOnline
442 -> handleClientPresence session stanza
443 _ | isMessageStanza stanza -> handleClientMessage session stanza
444 _ | otherwise -> unhandledStanza
445
446 awaitCloser stanza_lvl
447 loop
448
449 log $ "end of stream"
450 withXML $ \xml -> do
451 log $ "end-of-document: " <++> bshow xml
452
453
454rosterPush to contact attrs = do
455 let n = name to
456 rsc = resource to
457 names <- getNamesForPeer (peer to)
458 let tostr p = L.decodeUtf8 $ n <$++> "@" <?++> L.fromChunks [p] <++?> "/" <++$> rsc
459 jidstrs = fmap (toStrict . tostr) names
460 tojid = head jidstrs
461 return
462 [ EventBeginElement "{jabber:client}iq"
463 [ attr "to" tojid
464 , attr "id" "someid"
465 , attr "type" "set"
466 ]
467 , EventBeginElement "{jabber:iq:roster}query" []
468 , EventBeginElement "{jabber:iq:roster}item" (attr "jid" contact : attrs)
469 , EventEndElement "{jabber:iq:roster}item"
470 , EventEndElement "{jabber:iq:roster}query"
471 , EventEndElement "{jabber:client}iq"
472 ]
473
474data EventsForClient = CmdChan ClientCommands
475 | PChan Presence
476 | RChan RosterEvent
477
478toClient :: (MonadIO m, JabberClientSession session ) =>
479 session -> TChan Presence -> TChan ClientCommands -> TChan RosterEvent -> Source m [XML.Event]
480toClient session pchan cmdChan rchan = toClient' False False
481 where
482 toClient' isBound isInterested = do
483 let loop = toClient' isBound isInterested
484 send xs = yield xs >> prettyPrint ">C: " xs
485 event <- liftIO . atomically $
486 foldr1 orElse [fmap CmdChan $ readTChan cmdChan
487 ,fmap RChan $ readTChan rchan
488 ,fmap PChan $ readTChan pchan
489 ]
490 case event of
491 CmdChan QuitThread -> return ()
492 CmdChan (Send xs) -> send xs >> loop
493 CmdChan BoundToResource -> toClient' True isInterested
494 CmdChan InterestedInRoster -> do
495 liftIO . debugStr $ "Roster: interested"
496 toClient' isBound True
497 CmdChan (Chat msg) -> do
498 xs <- liftIO $ xmlifyMessageForClient msg
499 send xs
500 loop
501 -- CmdChan cmd -> liftIO (debugStr $ "unhandled event: "++show cmd) >> loop
502 RChan (RequestedSubscription who contact) -> do
503 jid <- liftIO $ getJID session
504 when (isInterested && Just who==name jid) $ do
505 r <- liftIO $ rosterPush jid (toStrict . L.decodeUtf8 $ contact) [attr "ask" "subscribe"]
506 send r
507 loop
508 RChan (NewBuddy who contact) -> do
509 liftIO . debugStr $ "Roster push: NewBuddy "++show (isInterested,who,contact)
510 (jid,me) <- liftIO $ do
511 jid <- getJID session
512 me <- asHostNameJID jid
513 return (jid,me)
514 withJust me $ \me -> do
515 when (isInterested && Just who==name jid) $ do
516 send [ EventBeginElement "{jabber:client}presence"
517 [ attrbs "from" contact
518 , attrbs "to" me
519 , attr "type" "subscribed"
520 ]
521 , EventEndElement "{jabber:client}presence" ]
522 let f True = "both"
523 f False = "to"
524 subscription <- fmap f (liftIO $ isSubscribed session contact)
525 r <- liftIO . handleIO (\e -> debugStr ("Roster NewBuddy error: "++show e) >> return []) $ do
526 rosterPush jid
527 (toStrict . L.decodeUtf8 $ contact)
528 [attr "subscription" subscription]
529 send r
530 loop
531 RChan (RemovedBuddy who contact) -> do
532 liftIO . debugStr $ "Roster push: RemovedBuddy "++show (isInterested,who,contact)
533 (jid,me) <- liftIO $ do
534 jid <- getJID session
535 me <- asHostNameJID jid
536 return (jid,me)
537 withJust me $ \me -> do
538 when (isInterested && Just who==name jid) $ do
539 send [ EventBeginElement "{jabber:client}presence"
540 [ attrbs "from" contact
541 , attrbs "to" me
542 , attr "type" "unsubscribed"
543 ]
544 , EventEndElement "{jabber:client}presence" ]
545 let f True = "from"
546 f False = "none"
547 subscription <- fmap f (liftIO $ isSubscribed session contact)
548 r <- liftIO . handleIO (\e -> debugStr ("Roster RemovedBuddy error: "++show e) >> return []) $ do
549 rosterPush jid
550 (toStrict . L.decodeUtf8 $ contact)
551 [attr "subscription" subscription]
552 send r
553 loop
554 RChan (NewSubscriber who contact) -> do
555 liftIO . debugStr $ "Roster push: NewSubscriber "++show (isInterested,who,contact)
556 (jid,me) <- liftIO $ do
557 jid <- getJID session
558 me <- asHostNameJID jid
559 return (jid,me)
560 withJust me $ \me -> do
561 when (isInterested && Just who==name jid) $ do
562 let f True = "both"
563 f False = "from"
564 subscription <- fmap f (liftIO $ isBuddy session contact)
565 r <- liftIO . handleIO (\e -> debugStr ("Roster NewSubscriber error: "++show e) >> return []) $ do
566 rosterPush jid
567 (toStrict . L.decodeUtf8 $ contact)
568 [attr "subscription" subscription]
569 send r
570 loop
571 RChan (RejectSubscriber who contact) -> do
572 liftIO . debugStr $ "Roster push: RejectSubscriber "++show (isInterested,who,contact)
573 (jid,me) <- liftIO $ do
574 jid <- getJID session
575 me <- asHostNameJID jid
576 return (jid,me)
577 withJust me $ \me -> do
578 when (isInterested && Just who==name jid) $ do
579 let f True = "to"
580 f False = "none"
581 subscription <- fmap f (liftIO $ isBuddy session contact)
582 r <- liftIO . handleIO (\e -> debugStr ("Roster RejectSubscriber error: "++show e) >> return []) $ do
583 rosterPush jid
584 (toStrict . L.decodeUtf8 $ contact)
585 [attr "subscription" subscription]
586 send r
587 loop
588 RChan (PendingSubscriber who contact) -> do
589 liftIO . debugStr $ "Roster: Pending buddy "++show (isInterested,who,contact)
590 (jid,me) <- liftIO $ do
591 jid <- getJID session
592 me <- asHostNameJID jid
593 return (jid,me)
594 withJust me $ \me -> do
595 when (isInterested && Just who==name jid) $ do
596 send [ EventBeginElement "{jabber:client}presence"
597 [ attrbs "from" contact
598 , attrbs "to" me
599 , attr "type" "subscribe"
600 ]
601 , EventEndElement "{jabber:client}presence" ]
602 loop
603 PChan presence -> do
604 when isBound $ do
605 xs <- liftIO $ xmlifyPresenceForClient presence
606 send xs
607 loop
608
609
610{-
611handleClient
612 :: (SocketLike sock, HHead l (XMPPClass session),
613 JabberClientSession session) =>
614 HCONS sock (HCONS t l) -> Source IO ByteString -> Sink ByteString IO () -> IO ()
615-}
616handleClient st src snk = do
617#if MIN_VERSION_HList(0,3,0)
618 let HCons' sock (HCons' _ st') = st
619#else
620 let HCons sock (HCons _ st') = st
621#endif
622 session_factory = hHead st'
623 pname <- getPeerName sock
624 session <- newSession session_factory sock
625 debugStr $ "PEER NAME: "++Prelude.show pname
626 pchan <- subscribe session Nothing
627 rchan <- subscribeToRoster session
628 let cmdChan = clientChannel session
629
630 writer <- async ( toClient session pchan cmdChan rchan `xmlToByteStrings` snk )
631 finally ( src $= parseBytes def $$ fromClient session cmdChan )
632 $ do
633 atomically $ writeTChan cmdChan QuitThread
634 wait writer
635 closeSession session
636
637{-
638listenForXmppClients ::
639 (HList l, HHead l (XMPPClass session), HExtend e1 l2 l1,
640 HExtend e l1 (HCONS PortNumber l), JabberClientSession session) =>
641 Family -> e1 -> e -> l2 -> IO ServerHandle
642-}
643listenForXmppClients addr_family session_factory port st = do
644#if MIN_VERSION_HList(0,3,0)
645 doServer (HCons' addr_family $ HCons' port $ HCons' session_factory st) handleClient
646#else
647 doServer (HCons addr_family $ HCons port $ HCons session_factory st) handleClient
648#endif
649
650
651{-
652listenForRemotePeers
653 :: (HList l, HHead l (XMPPPeerClass session),
654 HExtend e l1 (HCONS PortNumber l), HExtend e1 l2 l1,
655 JabberPeerSession session) =>
656 Family -> e1 -> e -> l2 -> IO ServerHandle
657-}
658listenForRemotePeers addrfamily session_factory port st = do
659#if MIN_VERSION_HList(0,3,0)
660 doServer (HCons' addrfamily $ HCons' port $ HCons' session_factory st) handlePeer
661#else
662 doServer (HCons addrfamily $ HCons port $ HCons session_factory st) handlePeer
663#endif
664
665{-
666handlePeer
667 :: (HHead l (XMPPPeerClass session),
668 JabberPeerSession session) =>
669 HCONS RestrictedSocket (HCONS t1 l) -> Source IO ByteString -> t -> IO ()
670-}
671handlePeer st src snk = do
672#if MIN_VERSION_HList(0,3,0)
673 let HCons' sock (HCons' _ st') = st
674#else
675 let HCons sock (HCons _ st') = st
676#endif
677 session_factory = hHead st'
678 name <- fmap bshow $ getPeerName sock
679 debugL $ "(P) connected " <++> name
680 session <- newPeerSession session_factory sock
681
682 didClose <- newTVarIO False
683 finally ( src $= parseBytes def $$ fromPeer sock session didClose )
684 $ do
685 debugL $ "(P) disconnected " <++> name
686 didc <- readTVarIO didClose
687 when (not didc) $ closePeerSession session
688
689
690handlePeerPresence session stanza False = do
691 -- Offline
692 liftIO . debugStr $ "PEER-OFFLINE: "++show stanza
693 withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do
694 peer_jid <- liftIO $ parseAddressJID (textToByteString jid)
695 liftIO . debugStr $ "PEER-OFFLINE-JID: "++show peer_jid
696 liftIO $ announcePresence session (Presence peer_jid Offline)
697handlePeerPresence session stanza True = do
698 -- online (Available or Away)
699 let log = liftIO . debugL . ("(P) " <++>)
700 withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do
701 pjid <- liftIO $ parseAddressJID (textToByteString jid)
702 -- stat <- show element content
703 let parseChildren stat = do
704 child <- nextElement
705 case child of
706 Just tag | tagName tag=="{jabber:server}show"
707 -> fmap toStat (lift content)
708 Just tag | otherwise -> parseChildren stat
709 Nothing -> return stat
710 toStat "away" = Away
711 toStat "xa" = ExtendedAway
712 toStat "dnd" = DoNotDisturb
713 toStat "chat" = Chatty
714
715 stat' <- parseChildren Available
716 liftIO . debugStr $ "announcing peer online: "++show (pjid,stat')
717 liftIO $ announcePresence session (Presence pjid stat')
718 log $ bshow (Presence pjid stat')
719
720handlePeerMessage session stanza = do
721 withJust (lookupAttrib "from" (tagAttrs stanza)) $ \fromstr-> do
722 withJust (lookupAttrib "to" (tagAttrs stanza)) $ \tostr -> do
723 fromjid <- liftIO $ parseAddressJID (textToByteString fromstr)
724 tojid <- liftIO $ parseAddressJID (textToByteString tostr)
725 let log = liftIO . debugL . ("(P) " <++>)
726 log $ "handlePeerMessage "<++>bshow stanza
727 msg <- parseMessage ("{jabber:server}body"
728 ,"{jabber:server}subject"
729 ,"{jabber:server}thread"
730 )
731 log
732 fromjid
733 tojid
734 stanza
735 liftIO $ sendChatToClient session msg
736
737matchAttribMaybe name (Just value) attrs =
738 case find ( (==name) . fst) attrs of
739 Just (_,[ContentText x]) | x==value -> True
740 Just (_,[ContentEntity x]) | x==value -> True
741 _ -> False
742matchAttribMaybe name Nothing attrs
743 | find ( (==name) . fst) attrs==Nothing
744 = True
745matchAttribMaybe name Nothing attrs
746 | otherwise
747 = False
748
749presenceTypeOffline = Just "unavailable"
750presenceTypeOnline = Nothing
751presenceTypeProbe = Just "probe"
752presenceTypeSubscribe = Just "subscribe"
753presenceTypeSubscribed = Just "subscribed"
754presenceTypeUnsubscribed = Just "unsubscribed"
755
756isPresenceOf (EventBeginElement name attrs) testType
757 | name=="{jabber:server}presence"
758 && matchAttribMaybe "type" testType attrs
759 = True
760isPresenceOf _ _ = False
761
762isMessageStanza (EventBeginElement name attrs)
763 | name=="{jabber:client}message"
764 = True
765isMessageStanza (EventBeginElement name attrs)
766 | name=="{jabber:server}message"
767 = True
768isMessageStanza _ = False
769
770isClientPresenceOf (EventBeginElement name attrs) testType
771 | name=="{jabber:client}presence"
772 && matchAttribMaybe "type" testType attrs
773 = True
774isClientPresenceOf _ _ = False
775
776
777handlePresenceProbe session stanza = do
778 withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to -> do
779 -- withJust (lookupAttrib "from" (tagAttrs stanza)) $ \from -> do
780 jid <- liftIO $ parseAddressJID $ textToByteString to
781 withJust (name jid) $ \user -> do
782 liftIO $ debugL $ "RECEIVED PROBE "<++>bshow (peerAddress session,to)
783 liftIO $ do
784 subs <- getSubscribers (peerSessionFactory session) user
785 liftIO $ debugL $ "subscribers for "<++>bshow user<++>": " <++>bshow subs
786 forM_ subs $ \jidstr -> do
787 handleIO_ (return ()) $ do
788 debugL $ "parsing " <++>jidstr
789 sub <- parseHostNameJID jidstr
790 debugStr $ "comparing " ++show (peer sub , peerAddress session)
791 when (peer sub == discardPort (peerAddress session)) $ do
792 ps <- userStatus session user
793 -- todo: Consider making this a directed presence
794 forM_ ps $ \p -> do
795 debugStr ("PROBE-REPLY: "++show p)
796 mapM_ (sendPeerMessage session . OutBoundPresence) ps
797 return ()
798
799subscribeToPresence subscribers peer_jid user = do
800 pjid <- parseAddressJID peer_jid
801 if Set.member pjid subscribers
802 then return ()
803 else return ()
804
805bare (JID n host _) = JID n host Nothing
806
807presenceErrorRemoteNotFound iqid from to = return
808 [ EventBeginElement "{stream:client}presence"
809 ( case iqid of { Nothing -> id; Just iqid -> ( attr "id" iqid :) }
810 $ [ attr "from" to
811 , attr "type" "error"
812 ] )
813 , EventBeginElement "{stream:client}error"
814 [ attr "type" "modify"]
815 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-stanzas}remote-server-not-found"
816 []
817 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-stanzas}remote-server-not-found"
818 , EventEndElement "{stream:client}error"
819 , EventEndElement "{stream:client}presence"
820 ]
821
822presenceSubscribed from = return
823 [ EventBeginElement "{stream:client}presence"
824 [ attr "from" from
825 , attr "type" "subscribed"
826 ]
827 , EventEndElement "{stream:client}presence"
828 ]
829
830clientRequestsSubscription session cmdChan stanza = do
831 liftIO $ do
832 debugStr $ "CLIENT PRESENCE SUBSCRIBE " ++ show stanza
833 withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str0 -> do
834 let to_str = S.takeWhile (/='/') to_str0
835 from = lookupAttrib "from" (tagAttrs stanza)
836 iqid = lookupAttrib "id" (tagAttrs stanza)
837 let handleError e | isDoesNotExistError e = do
838 debugStr $ "remote-server-not-found"
839 r <- presenceErrorRemoteNotFound iqid from to_str
840 atomically $ writeTChan cmdChan (Send r)
841 handleError e = do
842 debugStr $ "ERROR: "++ show e
843 handleIO handleError $ do
844 let to_str' = textToByteString to_str
845 to_jid <- fmap bare $ parseHostNameJID to_str'
846 if (is_remote . peer) to_jid
847 then do
848 addSolicited session to_str' to_jid
849 debugStr $ "added to solicited: " ++ show to_jid
850 else do
851 -- addLocalSubscriber session to_str
852 -- self <- getJID session
853 r <- presenceSubscribed to_str -- self
854 atomically $ writeTChan cmdChan (Send r)
855 return ()
856
857
858stanzaFromTo ::
859 JabberPeerSession session =>
860 session -> Event -> IO (Maybe (JID, JID))
861stanzaFromTo session stanza =
862 let lookup key = fmap textToByteString (lookupAttrib key (tagAttrs stanza))
863 parse jidstr = handleIO_ (return Nothing) (fmap Just $ parseAddressJID jidstr)
864 in case liftM2 (,) (lookup "from") (lookup "to") of
865 Nothing -> return Nothing
866 Just (from,to) -> do
867 mfrom <- parse from
868 mto <- parse to
869 case liftM2 (,) mfrom mto of
870 Nothing -> return Nothing
871 Just (from,to) -> do
872 let fromjid = JID (name from) (peerAddress session) Nothing
873 return $ Just (fromjid,to)
874
875peerRequestsSubsription session stanza = do
876 liftIO $ debugStr $ "PEER PRESENCE SUBSCRIBE " ++ show stanza
877
878 whenJust (liftIO . handleIO (\e -> debugStr ("peerRequestsSubsription: "++show e) >> return Nothing)
879 $ stanzaFromTo session stanza) $ \(fromjid,tojid) -> do
880 withJust (name tojid) $ \user -> do
881
882 subs <- liftIO $ do
883 subs <- getSubscribers (peerSessionFactory session) user
884 msubs <- flip mapM subs $ \str -> do
885 handleIO_ (return Nothing)
886 (fmap Just $ parseHostNameJID str)
887 return (catMaybes msubs)
888 if elem fromjid subs
889 then do
890 liftIO . debugL $ bshow fromjid <++> " already subscribed to " <++> user
891 -- if already subscribed, reply
892 liftIO $ do
893 sendPeerMessage session (Approval tojid fromjid)
894 ps <- userStatus session user
895 -- todo: consider making this a directed presence
896 mapM_ (sendPeerMessage session . OutBoundPresence) ps
897 else
898 liftIO $ processRequest session user fromjid
899
900clientApprovesSubscription session stanza = do
901 liftIO $ debugStr $ "CLIENT APPROVES SUBSCRIPTION"
902 withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str -> do
903 liftIO $ approveSubscriber session (textToByteString to_str)
904
905clientRejectsSubscription session stanza = do
906 liftIO $ debugStr $ "CLIENT REJECTS SUBSCRIPTION"
907 withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str -> do
908 liftIO $ rejectSubscriber session (textToByteString to_str)
909
910peerApprovesSubscription session stanza = do
911 liftIO $ debugStr $ "PEER APPROVES SUBSCRIPTION"
912 whenJust (liftIO . handleIO (\e -> debugStr ("peerApprovesSubscription: "++show e) >> return Nothing)
913 $ stanzaFromTo session stanza) $ \(fromjid,tojid) -> do
914 withJust (name tojid) $ \user -> do
915 liftIO $ processApproval session user fromjid
916
917peerRejectsSubscription session stanza = do
918 liftIO $ debugStr $ "PEER REJECTS SUBSCRIPTION"
919 whenJust (liftIO . handleIO (\e -> debugStr ("peerRejectsSubscription: "++show e) >> return Nothing)
920 $ stanzaFromTo session stanza) $ \(fromjid,tojid) -> do
921 withJust (name tojid) $ \user -> do
922 liftIO $ processRejection session user fromjid
923
924handlePeerIQGet :: (JabberPeerSession session, MonadIO m) =>
925 session -> XML.Event -> NestingXML o m ()
926handlePeerIQGet session tag = do
927 -- TODO: Pings should not require an id field.
928 withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do
929 whenJust nextElement $ \child -> do
930 let unhandledGet req = do
931 liftIO $ debugStr ("iq-peer-get: "++show (stanza_id,child))
932 liftIO $
933 sendPeerMessage session (Unsupported (JID Nothing LocalHost Nothing)
934 (JID Nothing (peerAddress session) Nothing)
935 (Just (ContentText stanza_id))
936 req)
937 -- Client equiv: liftIO . atomically . writeTChan cmdChan . Send $ iq_service_unavailable host stanza_id Nothing req
938 case tagName child of
939 -- "{http://jabber.org/protocol/disco#items}query" -> liftIO $ debugStr "iq-get-query-items"
940 "{urn:xmpp:ping}ping" -> liftIO $ do
941 sendPeerMessage session (Pong (JID Nothing LocalHost Nothing)
942 (JID Nothing (peerAddress session) Nothing)
943 (Just (ContentText stanza_id)))
944 -- Client equiv: atomically . writeTChan cmdChan . Send $ pong
945 return ()
946
947 req -> unhandledGet req
948
949fromPeer :: (MonadThrow m,MonadIO m, JabberPeerSession session) =>
950 RestrictedSocket -> session -> TVar Bool -> Sink XML.Event m ()
951fromPeer sock session didClose = doNestingXML $ do
952 let log = liftIO . debugL . ("(P) " <++>)
953 withXML $ \begindoc -> do
954 when (begindoc==EventBeginDocument) $ do
955 log "begin-doc"
956 withXML $ \xml -> do
957 withJust (elementAttrs "stream" xml) $ \stream_attrs -> do
958 log $ "stream atributes: " <++> bshow stream_attrs
959
960 let doTimeout = Thunk $ do
961 atomically $ writeTVar didClose True
962 closePeerSession session
963
964 fix $ \loop -> do
965 log "waiting for stanza."
966 whenJust nextElement $ \stanza -> do
967 stanza_lvl <- nesting
968
969 liftIO $ sendPeerMessage session (ActivityBump doTimeout) -- reset ping timer
970
971 let unhandledStanza = do
972 xs <- gatherElement stanza Seq.empty
973 prettyPrint "P: " (toList xs)
974 case () of
975 _ | stanza `isServerIQOf` iqTypeGet -> handlePeerIQGet session stanza
976 _ | stanza `isPresenceOf` presenceTypeOnline
977 -> handlePeerPresence session stanza True
978 _ | stanza `isPresenceOf` presenceTypeOffline
979 -> handlePeerPresence session stanza False
980 _ | stanza `isPresenceOf` presenceTypeProbe
981 -> handlePresenceProbe session stanza
982 _ | stanza `isPresenceOf` presenceTypeSubscribe
983 -> peerRequestsSubsription session stanza
984 _ | stanza `isPresenceOf` presenceTypeSubscribed
985 -> peerApprovesSubscription session stanza
986 _ | stanza `isPresenceOf` presenceTypeUnsubscribed
987 -> peerRejectsSubscription session stanza
988 _ | isMessageStanza stanza
989 -> handlePeerMessage session stanza
990 _ -> unhandledStanza
991
992 awaitCloser stanza_lvl
993 loop
994
995 log $ "end of stream"
996 withXML $ \xml -> do
997 log $ "end-of-document: " <++> bshow xml
998
999
1000
1001
1002newServerConnections = newTVar Map.empty
1003
1004data CachedMessages = CachedMessages
1005 { presences :: Map JID JabberShow
1006 , probes :: Map JID (Set (Bool,JID)) -- False means solicitation rather than probe
1007 , approvals :: Map JID (Set (Bool,JID) ) -- False means rejection rather than approval
1008 }
1009
1010instance CommandCache CachedMessages where
1011 type CacheableCommand CachedMessages = OutBoundMessage
1012 emptyCache = CachedMessages Map.empty Map.empty Map.empty
1013
1014 updateCache (OutBoundPresence (Presence jid Offline)) cache =
1015 cache { presences=Map.delete jid . presences $ cache }
1016 updateCache (OutBoundPresence p@(Presence jid st)) cache =
1017 cache { presences=Map.insert jid st . presences $ cache }
1018 updateCache (PresenceProbe from to) cache =
1019 cache { probes = mmInsert (True,from) to $ probes cache }
1020 updateCache (Solicitation from to) cache =
1021 cache { probes= mmInsert (False,from) to $ probes cache }
1022 updateCache (Approval from to) cache =
1023 cache { approvals= mmInsert (True,from) to $ approvals cache }
1024 updateCache (Rejection from to) cache =
1025 cache { approvals= mmInsert (False,from) to $ approvals cache }
1026 updateCache (OutBoundMessage msg) cache = cache -- TODO: cache chat?
1027 updateCache (Pong _ _ _) cache = trace "(DISCARDING Pong)" cache -- pings are not cached
1028 updateCache (Unsupported _ _ _ _) cache = cache -- error messages are not cached
1029 updateCache (ActivityBump sock) cache = cache
1030
1031instance ThreadChannelCommand OutBoundMessage where
1032 isQuitCommand Disconnect = True
1033 isQuitCommand _ = False
1034
1035mmInsert val key mm = Map.alter f key mm
1036 where
1037 f Nothing = Just $ Set.singleton val
1038 f (Just set) = Just $ Set.insert val set
1039
1040
1041greetPeer =
1042 [ EventBeginDocument
1043 , EventBeginElement (streamP "stream")
1044 [ attr "xmlns" "jabber:server"
1045 , attr "version" "1.0"
1046 ]
1047 ]
1048
1049goodbyePeer =
1050 [ EventEndElement (streamP "stream")
1051 , EventEndDocument
1052 ]
1053
1054peerJidTextLocal sock jid = do
1055 addr <- getSocketName sock
1056 return . toStrict . L.decodeUtf8
1057 $ name jid <$++> "@"
1058 <?++> showPeer (RemotePeer addr)
1059 <++?> "/" <++$> resource jid
1060
1061peerJidTextRemote sock jid = do
1062 addr <- getPeerName sock
1063 return . toStrict . L.decodeUtf8
1064 $ name jid <$++> "@"
1065 <?++> showPeer (RemotePeer addr)
1066 <++?> "/" <++$> resource jid
1067
1068presenceStanza sock fromjid tojid typ = do
1069 from <- peerJidTextLocal sock fromjid
1070 let to = toStrict . L.decodeUtf8
1071 $ name tojid <$++> "@"
1072 <?++> showPeer (peer tojid)
1073 return
1074 [ EventBeginElement "{jabber:server}presence"
1075 [ attr "from" from
1076 , attr "to" to
1077 , attr "type" typ
1078 ]
1079 , EventEndElement "{jabber:server}presence"
1080 ]
1081
1082
1083toPeer
1084 :: SocketLike sock =>
1085 sock
1086 -> CachedMessages
1087 -> TChan OutBoundMessage
1088 -> (Maybe OutBoundMessage -> IO ())
1089 -> ConduitM i [Event] IO ()
1090toPeer sock cache chan fail = do
1091 let -- log = liftIO . debugL . ("(>P) " <++>)
1092 send xs = yield xs >> prettyPrint ">P: " xs -- >> return (3::Int)
1093 checkConnection cmd = do
1094 liftIO $ catchIO (getPeerName sock >> return ())
1095 (\_ -> fail . Just $ cmd)
1096 sendOrFail getXML cmd = do
1097 checkConnection cmd
1098 r <- liftIO $ getXML
1099 -- handleIO (\e -> debugStr ("ERROR: "++show e) >> return []) getXML
1100 yieldOr r (fail . Just $ cmd)
1101 prettyPrint ">P: " r
1102 sendPresence presence =
1103 sendOrFail (xmlifyPresenceForPeer sock presence)
1104 (OutBoundPresence presence)
1105 sendProbe from to =
1106 sendOrFail (presenceStanza sock from to "probe")
1107 (PresenceProbe from to)
1108 sendSolicitation from to =
1109 sendOrFail (presenceStanza sock from to "subscribe")
1110 (Solicitation from to)
1111 sendApproval approve from to =
1112 sendOrFail (presenceStanza sock from to
1113 (if approve then "subscribed" else "unsubscribed"))
1114 (if approve then Approval from to
1115 else Rejection from to)
1116 sendMessage msg =
1117 sendOrFail (xmlifyMessageForPeer sock msg)
1118 (OutBoundMessage msg)
1119
1120 sendPong from to mid = do
1121 liftIO . debugL $ "SEND PONG"
1122 sendOrFail (xmlifyPong sock from to mid)
1123 (Pong from to mid)
1124 where
1125 xmlifyPong sock from to mid = do
1126 fromjid <- peerJidTextLocal sock to
1127 tojid <- peerJidTextRemote sock to
1128 return $ [ EventBeginElement "{jabber:server}iq"
1129 $ (case mid of
1130 Just c -> (("id",[c]):)
1131 _ -> id )
1132 [ attr "type" "result"
1133 , attr "to" tojid
1134 , attr "from" fromjid
1135 ]
1136 , EventEndElement "{jabber:server}iq"
1137 ]
1138 sendUnsupported from to mid tag =
1139 sendOrFail (xmlifyUnsupported sock from to mid tag)
1140 (Unsupported from to mid tag)
1141 where
1142 xmlifyUnsupported sock from to mid req = do
1143 fromjid <- peerJidTextLocal sock to
1144 tojid <- peerJidTextRemote sock to
1145 return $
1146 [ EventBeginElement "{jabber:server}iq"
1147 $ (case mid of
1148 Just c -> (("id",[c]):)
1149 _ -> id )
1150 [("type",[ContentText "error"])
1151 , attr "to" tojid
1152 , attr "from" fromjid
1153 ]
1154 , EventBeginElement req []
1155 , EventEndElement req
1156 , EventBeginElement "{jabber:server}error" [("type",[ContentText "cancel"])]
1157 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable" []
1158 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable"
1159 , EventEndElement "{jabber:server}error"
1160 , EventEndElement "{jabber:server}iq"
1161 ]
1162
1163
1164 send greetPeer
1165 forM_ (Map.assocs . approvals $ cache) $ \(to,froms) -> do
1166 forM_ (Set.toList froms) $ \(approve,from) -> do
1167 liftIO $ debugL "sending cached approval/rejection..."
1168 sendApproval approve from to
1169 forM_ (Map.assocs . presences $ cache) $ \(jid,st) -> do
1170 sendPresence (Presence jid st)
1171 forM_ (Map.assocs . probes $ cache) $ \(to,froms) -> do
1172 forM_ (Set.toList froms) $ \(got,from) -> do
1173 if got
1174 then do
1175 liftIO $ debugL "sending cached probe..."
1176 sendProbe from to
1177 else do
1178 liftIO $ debugL "sending cached solicitation..."
1179 sendSolicitation from to
1180
1181
1182 let five_sec = 5 * 1000000 :: Int
1183 pingref <- liftIO $ do
1184 ping_timer <- liftIO $ newDelay five_sec
1185 newTVarIO (ping_timer,0::Int)
1186
1187 sockref <- liftIO $ atomically newEmptyTMVar
1188 let bump fromsock = do
1189 remote <- liftIO $ catchIO (fmap Just $ getPeerName sock)
1190 (\_ -> return Nothing)
1191 debugL $ "PING BUMP" <++?> fmap (showPeer . RemotePeer) remote
1192 timer <- atomically $ do
1193 tryTakeTMVar sockref
1194 putTMVar sockref fromsock
1195 (timer,v) <- readTVar pingref
1196 writeTVar pingref (timer,0)
1197 return timer
1198 updateDelay timer five_sec
1199 waitPing = do
1200 (timer,v) <- readTVar pingref
1201 waitDelay timer
1202 return v
1203
1204 fix $ \loop -> do
1205 liftIO . debugStr $ "LOOP waiting..."
1206 event <- lift . atomically $ orElse (Left `fmap` readTChan chan)
1207 (Right `fmap` waitPing)
1208 liftIO . debugStr $ "LOOP event = " ++ show event
1209 let sendPing n = do
1210 case n of
1211 0 -> do
1212 ping <- liftIO makePing
1213 yield ping
1214 liftIO . debugL $ "SEND PING"
1215 prettyPrint ">P: " ping
1216 ping_timer <- liftIO $ newDelay five_sec
1217 liftIO . atomically $ writeTVar pingref (ping_timer,1)
1218 loop
1219 1 -> do
1220 remote <- liftIO $ getPeerName sock
1221 liftIO . debugL $ "PING TIMEOUT: " <++> showPeer (RemotePeer remote)
1222 fromsock <- liftIO $ atomically $ readTMVar sockref
1223 -- liftIO $ sClose fromsock
1224 liftIO $ runThunk fromsock
1225
1226 return () -- PING TIMEOUT (loop quits)
1227 x -> error ("What? "++show x)
1228 where makePing = do
1229 addr <- getSocketName sock
1230 remote <- getPeerName sock
1231 let from = toStrict . L.decodeUtf8 . showPeer $ RemotePeer addr
1232 to = toStrict . L.decodeUtf8 . showPeer $ RemotePeer remote
1233 mid = Just (ContentText "iduno")
1234 return $
1235 [ EventBeginElement "{jabber:server}iq"
1236 $ (case mid of
1237 Just c -> (("id",[c]):)
1238 _ -> id )
1239 [ ("type",[ContentText "get"])
1240 , attr "to" to
1241 , attr "from" from
1242 ]
1243 , EventBeginElement "{urn:xmpp:ping}ping" []
1244 , EventEndElement "{urn:xmpp:ping}ping"
1245 , EventEndElement "{jabber:server}iq" ]
1246 chanEvent event = do
1247 case event of
1248 OutBoundPresence p -> sendPresence p
1249 PresenceProbe from to -> do
1250 liftIO $ debugL "sending live probe..."
1251 sendProbe from to
1252 Solicitation from to -> do
1253 liftIO $ debugL "sending live solicitation..."
1254 sendSolicitation from to
1255 Approval from to -> do
1256 liftIO . debugL $ "sending approval "<++>bshow (from,to)
1257 sendApproval True from to
1258 Rejection from to -> do
1259 liftIO . debugL $ "sending rejection "<++>bshow (from,to)
1260 sendApproval False from to
1261 OutBoundMessage msg -> sendMessage msg
1262 Pong from to mid -> do
1263 liftIO . debugL $ "sending pong "<++>bshow (from,to)
1264 sendPong from to mid
1265 Unsupported from to mid tag -> sendUnsupported from to mid tag
1266 Disconnect -> return ()
1267 ActivityBump fromsock -> liftIO (bump fromsock)
1268 when (not . isQuitCommand $ event) loop
1269 either chanEvent sendPing event
1270 return ()
1271 -- send goodbyePeer -- TODO: why does this cause an exception?
1272 -- Text/XML/Stream/Render.hs:169:5-15:
1273 -- Irrefutable pattern failed for pattern (sl : s')
1274
1275
1276
1277
1278seekRemotePeers :: JabberPeerSession config =>
1279 XMPPPeerClass config -> TChan Presence -> OutgoingConnections CachedMessages -> IO b0
1280seekRemotePeers config chan server_connections = do
1281 fix $ \loop -> do
1282 event <- atomically $ readTChan chan
1283 case event of
1284 p@(Presence jid stat) | not (is_remote (peer jid)) -> do
1285 -- debugL $ "seekRemotePeers: " <++> L.show jid <++> " " <++> bshow stat
1286 runMaybeT $ do
1287 u <- MaybeT . return $ name jid
1288 subscribers <- liftIO $ do
1289 subs <- getSubscribers config u
1290 mapM parseHostNameJID subs
1291 -- liftIO . debugL $ "subscribers: " <++> bshow subscribers
1292 let peers = Set.map peer (Set.fromList subscribers)
1293 forM_ (Set.toList peers) $ \peer -> do
1294 when (is_remote peer) $
1295 liftIO $ sendMessage server_connections (OutBoundPresence p) peer
1296 _ -> return (Just ())
1297 loop
1298
1299xmlifyPresenceForPeer sock (Presence jid stat) = do
1300 addr <- getSocketName sock
1301 let n = name jid
1302 rsc = resource jid
1303 jidstr = toStrict . L.decodeUtf8
1304 $ n <$++> "@" <?++> showPeer (RemotePeer addr) <++?> "/" <++$> rsc
1305 return $
1306 [ EventBeginElement "{jabber:server}presence"
1307 (attr "from" jidstr:typ stat) ]
1308 ++ ( shw stat >>= jabberShow ) ++
1309 [ EventEndElement "{jabber:server}presence" ]
1310 where
1311 typ Offline = [attr "type" "unavailable"]
1312 typ _ = []
1313
1314 shw ExtendedAway = ["xa"]
1315 shw Chatty = ["chat"]
1316 shw Away = ["away"]
1317 shw DoNotDisturb = ["dnd"]
1318 shw _ = []
1319 jabberShow stat =
1320 [ EventBeginElement "{jabber:server}show" []
1321 , EventContent (ContentText stat)
1322 , EventEndElement "{jabber:server}show" ]
1323
1324xmlifyMessageForClient msg = do
1325 let tojid = msgTo msg
1326 fromjid = msgFrom msg
1327 tonames <- getNamesForPeer (peer tojid)
1328 fromnames <- getNamesForPeer (peer fromjid)
1329 let mk_str ns jid = toStrict . L.decodeUtf8 $ name jid <$++> "@" <?++> L.fromChunks [head ns] <++?> "/" <++$> resource jid
1330 to_str = mk_str tonames tojid
1331 from_str = mk_str fromnames fromjid
1332 tags = ( "{jabber:client}subject"
1333 , "{jabber:client}body"
1334 )
1335 return $
1336 [ EventBeginElement "{jabber:client}message"
1337 [ attr "from" from_str
1338 , attr "to" to_str
1339 ]
1340 ]
1341 ++ xmlifyMsgElements tags (msgLangMap msg) ++
1342 [ EventEndElement "{jabber:client}message" ]
1343
1344
1345xmlifyMessageForPeer sock msg = do
1346 addr <- getSocketName sock
1347 remote <- getPeerName sock
1348 let n = name (msgFrom msg)
1349 rsc = resource (msgFrom msg)
1350 jidstr = toStrict . L.decodeUtf8
1351 $ n <$++> "@" <?++> showPeer (RemotePeer addr) <++?> "/" <++$> rsc
1352 tostr = toStrict . L.decodeUtf8
1353 $ name (msgTo msg) <$++> "@"
1354 <?++> showPeer (RemotePeer remote) <++?> "/"
1355 <++$> resource (msgTo msg)
1356 tags = ( "{jabber:server}subject"
1357 , "{jabber:server}body"
1358 )
1359 return $
1360 [ EventBeginElement "{jabber:server}message"
1361 [ attr "from" jidstr
1362 , attr "to" tostr
1363 ]
1364 ]
1365 ++ xmlifyMsgElements tags (msgLangMap msg) ++
1366 [ EventEndElement "{jabber:server}message" ]
1367
1368xmlifyMsgElements tags langmap = concatMap (uncurry (langElements tags)) . Map.toList $ langmap
1369
1370langElements (subjecttag,bodytag) lang msg =
1371 ( maybeToList (msgSubject msg)
1372 >>= wrap subjecttag )
1373 ++ ( maybeToList (msgBody msg)
1374 >>= wrap bodytag )
1375 ++ ( Set.toList (msgElements msg)
1376 >>= wrapTriple )
1377 where
1378 wrap name content =
1379 [ EventBeginElement name
1380 ( if lang/="" then [attr "xml:lang" lang]
1381 else [] )
1382 , EventContent (ContentText content)
1383 , EventEndElement name
1384 ]
1385 wrapTriple (name,attrs,content) =
1386 [ EventBeginElement name attrs -- Note: we assume lang specified in attrs
1387 , EventContent (ContentText content)
1388 , EventEndElement name
1389 ]
1390
1391
1392handleClientMessage session stanza = do
1393 let log = liftIO . debugL . ("(C) " <++>)
1394 log $ "handleClientMessage "<++>bshow stanza
1395 from <- liftIO $ getJID session
1396 withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str -> do
1397 log $ " to = "<++>bshow to_str
1398 tojid <- liftIO $ parseHostNameJID (textToByteString to_str)
1399 msg <- parseMessage ("{jabber:client}body"
1400 ,"{jabber:client}subject"
1401 ,"{jabber:client}thread"
1402 )
1403 log
1404 from
1405 tojid
1406 stanza
1407 liftIO $ sendChat session msg
1408
1409{-
1410unhandled-C: <message
1411unhandled-C: type="chat"
1412unhandled-C: id="purplea0a7fd24"
1413unhandled-C: to="user@vm2"
1414unhandled-C: xmlns="jabber:client">
1415unhandled-C: <active xmlns="http://jabber.org/protocol/chatstates"/>
1416unhandled-C: <body>
1417unhandled-C: hello dude
1418unhandled-C: </body>
1419unhandled-C: </message>
1420-}
1421parseMessage (bodytag,subjecttag,threadtag) log from tojid stanza = do
1422 let emptyMsg = LangSpecificMessage { msgBody=Nothing, msgSubject=Nothing, msgElements=Set.empty }
1423 parseChildren (th,cmap) = do
1424 child <- nextElement
1425 lvl <- nesting
1426 xmllang <- xmlLang
1427 let lang = maybe "" id xmllang
1428 let c = maybe emptyMsg id (Map.lookup lang cmap)
1429 log $ " child: "<++> bshow child
1430 case child of
1431 Just tag | tagName tag==bodytag
1432 -> do
1433 txt <- lift content
1434 awaitCloser lvl
1435 parseChildren (th,Map.insert lang (c { msgBody=Just txt }) cmap)
1436 Just tag | tagName tag==subjecttag
1437 -> do
1438 txt <- lift content
1439 awaitCloser lvl
1440 parseChildren (th,Map.insert lang (c { msgSubject=Just txt }) cmap)
1441 Just tag | tagName tag==threadtag
1442 -> do
1443 txt <- lift content
1444 awaitCloser lvl
1445 parseChildren (th {msgThreadContent=txt},cmap)
1446 Just tag -> do
1447 let nm = tagName tag
1448 attrs = tagAttrs tag
1449 elems = msgElements c
1450 txt <- lift content
1451 awaitCloser lvl
1452 parseChildren (th,Map.insert lang (c {msgElements=Set.insert (nm,attrs,txt) elems}) cmap)
1453 Nothing -> return (th,cmap)
1454 (th,langmap) <- parseChildren ( MessageThread {msgThreadParent=Nothing, msgThreadContent=""}
1455 , Map.empty )
1456 return Message {
1457 msgTo = tojid,
1458 msgFrom = from,
1459 msgLangMap = langmap,
1460 msgThread = if msgThreadContent th/="" then Just th else Nothing
1461 }
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-24 03:21:49 +0000