summaryrefslogtreecommitdiff
path: root/Presence
diff options
context:
space:
mode:
Diffstat (limited to 'Presence')
-rw-r--r--Presence/Chat.hs26
-rw-r--r--Presence/LocalChat.hs4
-rw-r--r--Presence/MUC.hs4
-rw-r--r--Presence/Stanza/Build.hs22
-rw-r--r--Presence/Stanza/Parse.hs9
-rw-r--r--Presence/Stanza/Types.hs55
-rw-r--r--Presence/XMPPServer.hs111
7 files changed, 198 insertions, 33 deletions
diff --git a/Presence/Chat.hs b/Presence/Chat.hs
index 172c5242..b7343b5a 100644
--- a/Presence/Chat.hs
+++ b/Presence/Chat.hs
@@ -76,6 +76,7 @@ newtype RoomHandle = RH (TVar (Maybe ChatTransaction))
76 76
77data JoinedRoom k = JoinedRoom 77data JoinedRoom k = JoinedRoom
78 { joinedRoom :: Room k 78 { joinedRoom :: Room k
79 , joinedNick :: Text
79 , roomHandle :: RoomHandle 80 , roomHandle :: RoomHandle
80 , roomTransactions :: TChan ChatTransaction 81 , roomTransactions :: TChan ChatTransaction
81 } 82 }
@@ -110,29 +111,28 @@ joinRoom k room jid nick = do
110 v <- newTVar (Just $ ChatTransaction no jid nick [Join]) 111 v <- newTVar (Just $ ChatTransaction no jid nick [Join])
111 modifyTVar' (roomDesiredTransaction room) $ Map.insert k v 112 modifyTVar' (roomDesiredTransaction room) $ Map.insert k v
112 c <- dupTChan (roomChan room) 113 c <- dupTChan (roomChan room)
113 return $ JoinedRoom room (RH v) c 114 return $ JoinedRoom room nick (RH v) c
114 115
115partRoom :: JoinedRoom k -> Maybe Text -> Text -> STM () 116partRoom :: JoinedRoom k -> Maybe Text -> STM ()
116partRoom (JoinedRoom room (RH v) c) jid nick = do 117partRoom (JoinedRoom room nick (RH v) c) jid = do
117 writeTVar v Nothing -- Cancel pending chat. 118 writeTVar v Nothing -- Cancel pending chat.
118 sendChat (JoinedRoom room (RH v) c) jid nick [Part] 119 sendChat (JoinedRoom room nick (RH v) c) jid [Part]
119 return () 120 return ()
120 121
121sendChat :: JoinedRoom k -> Maybe Text -> Text -> [ChatEvent] -> STM Bool 122sendChat :: JoinedRoom k -> Maybe Text -> [ChatEvent] -> STM Bool
122sendChat (JoinedRoom room (RH v) _) jid nick chat = do 123sendChat (JoinedRoom room nick (RH v) _) jid chat = do
123 mpending <- readTVar v 124 mpending <- readTVar v
125 no <- readTVar $ roomFutureSeqNo room
124 case mpending of 126 case mpending of
125 Nothing -> do 127 Just (ChatTransaction no' _ _ _) | no' >= no -> return False
126 no <- readTVar $ roomFutureSeqNo room 128 _ -> do
127 writeTVar v (Just $ ChatTransaction no jid nick chat) 129 writeTVar v (Just $ ChatTransaction no jid nick chat)
128 return True 130 return True
129 Just pending -> do
130 return False
131 131
132-- | Blocks until a transaction occurs. Optionally, a failed transaction will 132-- | Blocks until a transaction occurs. Optionally, a failed transaction will
133-- be automatically renewed. 133-- be automatically renewed.
134readRoom :: Ord k => k -> JoinedRoom k -> STM (Bool, ChatTransaction) 134readRoom :: Ord k => k -> JoinedRoom k -> STM (Bool, ChatTransaction)
135readRoom k (JoinedRoom room (RH v) c) = do 135readRoom k (JoinedRoom room _ (RH v) c) = do
136 mpending <- readTVar v 136 mpending <- readTVar v
137 final <- readTChan c 137 final <- readTChan c
138 case mpending of 138 case mpending of
@@ -198,7 +198,7 @@ roomCommit room k t = do
198 modifyTVar' (roomFutureSeqNo room) succ 198 modifyTVar' (roomFutureSeqNo room) succ
199 writeTChan (roomChan room) t 199 writeTChan (roomChan room) t
200 v <- validateTransaction room k t 200 v <- validateTransaction room k t
201 trace ("roomCommit " ++ show v) $ return () 201 trace ("roomCommit " ++ show v ++ " " ++ show t) $ return ()
202 case v of 202 case v of
203 Valid Outside Inside -> do 203 Valid Outside Inside -> do
204 modifyTVar' (roomMembers room) $ Map.insert (chatSender t) PerMember 204 modifyTVar' (roomMembers room) $ Map.insert (chatSender t) PerMember
@@ -209,7 +209,7 @@ roomCommit room k t = do
209 modifyTVar' (roomMembers room) $ Map.delete (chatSender t) 209 modifyTVar' (roomMembers room) $ Map.delete (chatSender t)
210 fin 210 fin
211 Valid _ _ -> fin 211 Valid _ _ -> fin
212 _ -> return () 212 bad -> trace ("validateTransaction: " ++ show bad) $ return ()
213 213
214roomPending :: Ord k => Room k -> STM (Map k ChatTransaction) 214roomPending :: Ord k => Room k -> STM (Map k ChatTransaction)
215roomPending room = do 215roomPending room = do
diff --git a/Presence/LocalChat.hs b/Presence/LocalChat.hs
index 39195fc9..eab54a03 100644
--- a/Presence/LocalChat.hs
+++ b/Presence/LocalChat.hs
@@ -47,10 +47,10 @@ chatevents rsvar = do
47 ps <- roomPending r 47 ps <- roomPending r
48 trace ("roomPending " ++ show ps) $ return () 48 trace ("roomPending " ++ show ps) $ return ()
49 case Map.toList ps of 49 case Map.toList ps of
50 (k,t):_ -> do 50 (k,t):ts -> do
51 roomCommit r k t 51 roomCommit r k t
52 return $ do 52 return $ do
53 dput XJabber $ "fuck " ++ show (k,t) 53 dput XJabber $ "committed " ++ show (length ts,k,t)
54 _ -> retry 54 _ -> retry
55 return $ foldl1 (>>) ios 55 return $ foldl1 (>>) ios
56 56
diff --git a/Presence/MUC.hs b/Presence/MUC.hs
index 76c53391..639e834b 100644
--- a/Presence/MUC.hs
+++ b/Presence/MUC.hs
@@ -42,8 +42,8 @@ mucReservedNick muc rkey = atomically $ do
42 Nothing -> return Nothing 42 Nothing -> return Nothing
43 Just r -> return $ Just $ \jid -> atomically $ roomReservedNick r jid 43 Just r -> return $ Just $ \jid -> atomically $ roomReservedNick r jid
44 44
45mucJoinRoom :: MUC -> Text{-JID-} -> Text{-nick-} -> Text{-room-} -> ClientAddress -> IO (JoinedRoom ClientAddress) 45mucJoinRoom :: MUC -> Text{-JID-} -> Text{-nick-} -> Text{-room-} -> ClientAddress -> STM (JoinedRoom ClientAddress)
46mucJoinRoom muc jid nick rkey k = atomically $ do 46mucJoinRoom muc jid nick rkey k = do
47 mr <- Map.lookup rkey <$> readTVar (mucRooms muc) 47 mr <- Map.lookup rkey <$> readTVar (mucRooms muc)
48 case mr of 48 case mr of
49 Nothing -> do 49 Nothing -> do
diff --git a/Presence/Stanza/Build.hs b/Presence/Stanza/Build.hs
index e02684f5..16552428 100644
--- a/Presence/Stanza/Build.hs
+++ b/Presence/Stanza/Build.hs
@@ -19,24 +19,34 @@ import LockedChan
19import Stanza.Types 19import Stanza.Types
20 20
21makeMessage :: Text -> Text -> Text -> Text -> IO Stanza 21makeMessage :: Text -> Text -> Text -> Text -> IO Stanza
22makeMessage namespace from to bod = 22makeMessage namespace from to bod = makeMessageEx namespace from to NormalMsg bod
23
24makeMessageEx :: Text -> Text -> Text -> MessageType -> Text -> IO Stanza
25makeMessageEx namespace from to msgtyp bod =
23 stanzaFromList typ 26 stanzaFromList typ
24 $ [ EventBeginElement (mkname namespace "message") 27 $ [ EventBeginElement (mkname namespace "message")
25 [ attr "from" from 28 $ addMessageType msgtyp
26 , attr "to" to 29 [ attr "from" from
27 ] 30 , attr "to" to
31 ]
28 , EventBeginElement (mkname namespace "body") [] 32 , EventBeginElement (mkname namespace "body") []
29 , EventContent (ContentText bod) 33 , EventContent (ContentText bod)
30 , EventEndElement (mkname namespace "body") 34 , EventEndElement (mkname namespace "body")
31 , EventEndElement (mkname namespace "message") ] 35 , EventEndElement (mkname namespace "message") ]
32 where 36 where
33 typ = Message { msgThread = Nothing 37 typ = Message { msgThread = Nothing
34 , msgLangMap = [("", lsm)] 38 , msgLangMap = [("", lsm)]
39 , msgType = msgtyp
35 } 40 }
36 lsm = LangSpecificMessage 41 lsm = LangSpecificMessage
37 { msgBody = Just bod 42 { msgBody = Just bod
38 , msgSubject = Nothing } 43 , msgSubject = Nothing }
39 44
45addMessageType ChatMsg attrs = ("type",[ContentText "chat"]) : attrs
46addMessageType GroupChatMsg attrs = ("type",[ContentText "groupchat"]) : attrs
47addMessageType HeadlineMsg attrs = ("type",[ContentText "headline"]) : attrs
48addMessageType _ attrs = attrs
49
40makeInformSubscription :: Text -> Text -> Text -> Bool -> IO Stanza 50makeInformSubscription :: Text -> Text -> Text -> Bool -> IO Stanza
41makeInformSubscription namespace from to approved = 51makeInformSubscription namespace from to approved =
42 stanzaFromList (PresenceInformSubscription approved) 52 stanzaFromList (PresenceInformSubscription approved)
diff --git a/Presence/Stanza/Parse.hs b/Presence/Stanza/Parse.hs
index b025f418..58bf7c51 100644
--- a/Presence/Stanza/Parse.hs
+++ b/Presence/Stanza/Parse.hs
@@ -227,9 +227,16 @@ parseMessage ns stanza = do
227 , Map.empty ) 227 , Map.empty )
228 return Message { 228 return Message {
229 msgLangMap = Map.toList langmap, 229 msgLangMap = Map.toList langmap,
230 msgThread = if msgThreadContent th/="" then Just th else Nothing 230 msgThread = if msgThreadContent th/="" then Just th else Nothing,
231 msgType = parseMessageType $ lookupAttrib "type" (tagAttrs stanza)
231 } 232 }
232 233
234parseMessageType :: Maybe Text -> MessageType
235parseMessageType (Just "chat") = ChatMsg
236parseMessageType (Just "groupchat") = GroupChatMsg
237parseMessageType (Just "headline") = HeadlineMsg
238parseMessageType _ = NormalMsg
239
233findErrorTag :: Monad m => Text -> NestingXML o m (Maybe StanzaError) 240findErrorTag :: Monad m => Text -> NestingXML o m (Maybe StanzaError)
234findErrorTag ns = do 241findErrorTag ns = do
235 x <- nextElement 242 x <- nextElement
diff --git a/Presence/Stanza/Types.hs b/Presence/Stanza/Types.hs
index 6c5b8867..7275c8ab 100644
--- a/Presence/Stanza/Types.hs
+++ b/Presence/Stanza/Types.hs
@@ -70,6 +70,7 @@ data StanzaType
70 | PresenceRequestSubscription Bool 70 | PresenceRequestSubscription Bool
71 | Message { msgThread :: Maybe MessageThread 71 | Message { msgThread :: Maybe MessageThread
72 , msgLangMap :: [(Lang,LangSpecificMessage)] 72 , msgLangMap :: [(Lang,LangSpecificMessage)]
73 , msgType :: MessageType
73 } 74 }
74 | NotifyClientVersion { versionName :: Text 75 | NotifyClientVersion { versionName :: Text
75 , versionVersion :: Text } 76 , versionVersion :: Text }
@@ -77,6 +78,60 @@ data StanzaType
77 | InternalCacheId Text 78 | InternalCacheId Text
78 deriving (Show,Eq) 79 deriving (Show,Eq)
79 80
81data MessageType
82 = NormalMsg -- ^ The message is a standalone message that is sent outside
83 -- the context of a one-to-one conversation or groupchat, and
84 -- to which it is expected that the recipient will reply.
85 -- Typically a receiving client will present a message of type
86 -- "normal" in an interface that enables the recipient to
87 -- reply, but without a conversation history. The default
88 -- value of the 'type' attribute is "normal".
89
90 | ChatMsg -- ^ The message is sent in the context of a one-to-one chat
91 -- session. Typically an interactive client will present a
92 -- message of type "chat" in an interface that enables one-to-one
93 -- chat between the two parties, including an appropriate
94 -- conversation history. Detailed recommendations regarding
95 -- one-to-one chat sessions are provided under Section 5.1.
96
97 | GroupChatMsg -- ^ The message is sent in the context of a multi-user chat
98 -- environment (similar to that of [IRC]). Typically a
99 -- receiving client will present a message of type
100 -- "groupchat" in an interface that enables many-to-many
101 -- chat between the parties, including a roster of parties
102 -- in the chatroom and an appropriate conversation history.
103 -- For detailed information about XMPP-based groupchat,
104 -- refer to [XEP‑0045].
105
106 | HeadlineMsg -- ^ The message provides an alert, a notification, or other
107 -- transient information to which no reply is expected (e.g.,
108 -- news headlines, sports updates, near-real-time market
109 -- data, or syndicated content). Because no reply to the
110 -- message is expected, typically a receiving client will
111 -- present a message of type "headline" in an interface that
112 -- appropriately differentiates the message from standalone
113 -- messages, chat messages, and groupchat messages (e.g., by
114 -- not providing the recipient with the ability to reply). If
115 -- the 'to' address is the bare JID, the receiving server
116 -- SHOULD deliver the message to all of the recipient's
117 -- available resources with non-negative presence priority
118 -- and MUST deliver the message to at least one of those
119 -- resources; if the 'to' address is a full JID and there is
120 -- a matching resource, the server MUST deliver the message
121 -- to that resource; otherwise the server MUST either
122 -- silently ignore the message or return an error (see
123 -- Section 8).
124
125 -- | ErrorMsg -- The message is generated by an entity that experiences an
126 -- error when processing a message received from another entity (for
127 -- details regarding stanza error syntax, refer to [XMPP‑CORE]). A client
128 -- that receives a message of type "error" SHOULD present an appropriate
129 -- interface informing the original sender regarding the nature of the
130 -- error.
131
132 deriving (Show,Read,Ord,Eq,Enum)
133
134
80data RosterEventType 135data RosterEventType
81 = RequestedSubscription 136 = RequestedSubscription
82 | NewBuddy -- preceded by PresenceInformSubscription True 137 | NewBuddy -- preceded by PresenceInformSubscription True
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index e44ae37b..d26e8c03 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -1364,6 +1364,28 @@ monitor sv params xmpp = do
1364 , EventEndElement "{http://jabber.org/protocol/muc#user}x" 1364 , EventEndElement "{http://jabber.org/protocol/muc#user}x"
1365 ] 1365 ]
1366 ioWriteChan replyto stanza 1366 ioWriteChan replyto stanza
1367 Part -> do
1368 stanza <- makePresenceStanzaEx "jabber:client" (Just $ roomjid muckey me rkey cnick) Offline
1369 $ [ EventBeginElement "{http://jabber.org/protocol/muc#user}x" [] ]
1370 ++ (do guard mine
1371 [ EventBeginElement "{http://jabber.org/protocol/muc#user}status"
1372 [ ("code",[ContentText "110"]) -- self-presence code.
1373 ]
1374 , EventEndElement "{http://jabber.org/protocol/muc#user}status" ])
1375 ++ [ EventEndElement "{http://jabber.org/protocol/muc#user}x" ]
1376 ioWriteChan replyto stanza
1377 when mine $ atomically $ do
1378 jrs <- readTVar joined_rooms
1379 let m = Map.findWithDefault Map.empty k jrs
1380 m' = Map.delete (rkey,muckey) m
1381 jrs' = if Map.null m' then Map.delete k jrs
1382 else Map.insert k m' jrs
1383 writeTVar joined_rooms jrs'
1384 Talk talk -> do
1385 them <- xmppTellClientHisName xmpp k
1386 stanza <- makeMessageEx "jabber:client" (roomjid muckey me rkey cnick) them GroupChatMsg talk
1387 ioWriteChan replyto stanza
1388 return ()
1367 _ -> return () 1389 _ -> return ()
1368 ] 1390 ]
1369 action 1391 action
@@ -1409,7 +1431,7 @@ data ServiceMatch a
1409 | TopLevelService -- ^ This server's exact hostname. 1431 | TopLevelService -- ^ This server's exact hostname.
1410 1432
1411 1433
1412lookupService :: Text -> Map.Map Text a -> Text -> (ServiceMatch a) 1434lookupService :: Text {- ^ hostname -} -> Map.Map Text a {- ^ service map -} -> Text {- ^ JID -} -> (ServiceMatch a)
1413lookupService me mucs to = case Text.toLower to of 1435lookupService me mucs to = case Text.toLower to of
1414 nm | nm == Text.toLower me 1436 nm | nm == Text.toLower me
1415 -> TopLevelService 1437 -> TopLevelService
@@ -1432,7 +1454,9 @@ applyStanza :: Server PeerAddress ConnectionData releaseKey Event
1432 -> StanzaWrap (LockedChan Event) 1454 -> StanzaWrap (LockedChan Event)
1433 -> IO () 1455 -> IO ()
1434 1456
1435applyStanza sv joined_rooms quitVar xmpp stanza = case stanzaOrigin stanza of 1457applyStanza sv joined_rooms quitVar xmpp stanza = do
1458 dput XJabber $ "applyStanza: " ++ show (stanzaType stanza)
1459 case stanzaOrigin stanza of
1436 ClientOrigin k replyto -> 1460 ClientOrigin k replyto ->
1437 case stanzaType stanza of 1461 case stanzaType stanza of
1438 RequestResource clientsNameForMe wanted -> do 1462 RequestResource clientsNameForMe wanted -> do
@@ -1479,8 +1503,7 @@ applyStanza sv joined_rooms quitVar xmpp stanza = case stanzaOrigin stanza of
1479 PresenceStatus {} -> do 1503 PresenceStatus {} -> do
1480 let mucs = xmppGroupChat xmpp 1504 let mucs = xmppGroupChat xmpp
1481 me <- xmppTellMyNameToClient xmpp k 1505 me <- xmppTellMyNameToClient xmpp k
1482 if | Available <- presenceShow (stanzaType stanza) 1506 if | Just to <- stanzaTo stanza
1483 , Just to <- stanzaTo stanza
1484 , (Just room,h,mnick) <- splitJID to 1507 , (Just room,h,mnick) <- splitJID to
1485 , let roomjid = unsplitJID ((Just room,h,Nothing)) 1508 , let roomjid = unsplitJID ((Just room,h,Nothing))
1486 , Service (Just _) mucname muc <- lookupService me mucs roomjid 1509 , Service (Just _) mucname muc <- lookupService me mucs roomjid
@@ -1490,13 +1513,34 @@ applyStanza sv joined_rooms quitVar xmpp stanza = case stanzaOrigin stanza of
1490 reply <- makeErrorStanza' stanza JidMalformed 1513 reply <- makeErrorStanza' stanza JidMalformed
1491 [ ("by", [ContentText roomjid]) ] 1514 [ ("by", [ContentText roomjid]) ]
1492 sendReply quitVar (Error JidMalformed (head reply)) reply replyto 1515 sendReply quitVar (Error JidMalformed (head reply)) reply replyto
1493 Just nick -> do 1516 Just nick -> case presenceShow (stanzaType stanza) of
1494 jid <- xmppTellClientHisName xmpp k 1517 Available -> do
1495 r <- mucJoinRoom muc jid nick room k -- stanza 1518 jid <- xmppTellClientHisName xmpp k
1496 atomically $ do 1519 join $ atomically $ do
1497 jrs <- readTVar joined_rooms 1520 jrs <- readTVar joined_rooms
1498 let m = Map.findWithDefault Map.empty k jrs 1521 let m = Map.findWithDefault Map.empty k jrs
1499 writeTVar joined_rooms $ Map.insert k (Map.insert (room,mucname) (replyto,r) m) jrs 1522 case Map.lookup (room,mucname) m of
1523 Nothing -> do r <- mucJoinRoom muc jid nick room k -- stanza
1524 jrs <- readTVar joined_rooms
1525 let m = Map.findWithDefault Map.empty k jrs
1526 writeTVar joined_rooms $ Map.insert k (Map.insert (room,mucname) (replyto,r) m) jrs
1527 return $ return ()
1528 Just r -> return $ dput XJabber "MUC: already joined."
1529 Offline -> do
1530 jid <- xmppTellClientHisName xmpp k
1531 atomically $ do
1532 jrs <- readTVar joined_rooms
1533 let m = Map.findWithDefault Map.empty k jrs
1534 case Map.lookup (room,mucname) m of
1535 Just (_,r) -> do
1536 partRoom r (Just jid) -- joinedNick r == nick
1537 {-
1538 let m' = Map.delete (room,mucname) m
1539 jrs' = if Map.null m' then Map.delete k jrs
1540 else Map.insert k m' jrs
1541 writeTVar joined_rooms jrs'
1542 -}
1543 _ -> return ()
1500 | otherwise -> do 1544 | otherwise -> do
1501 -- Handle presence stanza that is not a chatroom join. 1545 -- Handle presence stanza that is not a chatroom join.
1502 xmppInformClientPresence xmpp k stanza 1546 xmppInformClientPresence xmpp k stanza
@@ -1541,6 +1585,24 @@ applyStanza sv joined_rooms quitVar xmpp stanza = case stanzaOrigin stanza of
1541 let reply = makeNodeInfo (stanzaId stanza) "x-roomuser-item" (room <> "@" <> a <> "." <> me) 1585 let reply = makeNodeInfo (stanzaId stanza) "x-roomuser-item" (room <> "@" <> a <> "." <> me)
1542 (stanzaFrom stanza) n 1586 (stanzaFrom stanza) n
1543 return (Info, reply) 1587 return (Info, reply)
1588 (Service (Just room) a muc) | Just "http://jabber.org/protocol/muc#traffic" <- mnode
1589 -> do
1590 dput XJabber $ "TODO: 18.1.1 Allowable Traffic"
1591 reply <- makeErrorStanza' stanza FeatureNotImplemented
1592 [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ]
1593 return (Error FeatureNotImplemented (head reply), reply)
1594 (Service (Just room) a muc) | Just "http://jabber.org/protocol/muc#rooms" <- mnode
1595 -> do
1596 dput XJabber $ "TODO: 6.7 Discovering Client Support for MUC"
1597 reply <- makeErrorStanza' stanza FeatureNotImplemented
1598 [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ]
1599 return (Error FeatureNotImplemented (head reply), reply)
1600 (Service (Just room) a muc) | Just nodename <- mnode
1601 -> do
1602 dput XJabber $ "Uknown info node: " ++ Text.unpack nodename
1603 reply <- makeErrorStanza' stanza FeatureNotImplemented
1604 [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ]
1605 return (Error FeatureNotImplemented (head reply), reply)
1544 TopLevelService 1606 TopLevelService
1545 -> case mnode of 1607 -> case mnode of
1546 Just _ -> unavail 1608 Just _ -> unavail
@@ -1579,6 +1641,36 @@ applyStanza sv joined_rooms quitVar xmpp stanza = case stanzaOrigin stanza of
1579 me <- xmppTellMyNameToClient xmpp k 1641 me <- xmppTellMyNameToClient xmpp k
1580 let reply = iq_service_unavailable (stanzaId stanza) me query 1642 let reply = iq_service_unavailable (stanzaId stanza) me query
1581 sendReply quitVar (Error ServiceUnavailable (head reply)) reply replyto 1643 sendReply quitVar (Error ServiceUnavailable (head reply)) reply replyto
1644 Message { msgType = GroupChatMsg } -> do
1645 let mucs = xmppGroupChat xmpp
1646 me <- xmppTellMyNameToClient xmpp k
1647 if | Just to <- stanzaTo stanza
1648 , (Just room,h,mnick) <- splitJID to
1649 , let roomjid = unsplitJID ((Just room,h,Nothing))
1650 , Service (Just _) mucname muc <- lookupService me mucs roomjid
1651 -> case mnick of
1652 Nothing -> do
1653 -- Send message.
1654 jid <- xmppTellClientHisName xmpp k -- This should match stanzaFrom
1655 join $ atomically $ do
1656 jrs <- readTVar joined_rooms
1657 let m = Map.findWithDefault Map.empty k jrs
1658 case Map.lookup (room,mucname) m of
1659 Just (_,r) -> do
1660 let RH v = roomHandle r
1661 oldt <- readTVar v
1662 expected <- readTVar (roomFutureSeqNo $ joinedRoom r)
1663 b <- sendChat r (Just jid) $ do
1664 (_,msg) <- msgLangMap (stanzaType stanza)
1665 talk <- maybeToList $ msgBody msg
1666 [ Talk talk ]
1667 return $ dput XJabber $ "sendChat: " ++ show (b,expected,oldt,msgLangMap (stanzaType stanza))
1668 _ -> return $ dput XJabber $ "uknown room" ++ show (room,mucname)
1669 Just nick -> do
1670 -- Private message. TODO
1671 dput XJabber $ "TODO: Private messasge. " ++ show nick
1672
1673 | otherwise -> dput XJabber $ "Failed groupchat parse. to=" ++ show (stanzaTo stanza)
1582 Message {} -> do 1674 Message {} -> do
1583 -- wlog $ "LANGMAP "++show (stanzaId stanza, msgLangMap (stanzaType stanza)) 1675 -- wlog $ "LANGMAP "++show (stanzaId stanza, msgLangMap (stanzaType stanza))
1584 maybe (return ()) (flip cacheMessageId replyto) $ do 1676 maybe (return ()) (flip cacheMessageId replyto) $ do
@@ -1615,6 +1707,7 @@ forwardStanza quitVar xmpp stanza = do
1615 -- let newStream = greet'' "jabber:client" "blackbird" 1707 -- let newStream = greet'' "jabber:client" "blackbird"
1616 -- sendReply quitVar Error newStream replyto 1708 -- sendReply quitVar Error newStream replyto
1617 case stanzaType stanza of 1709 case stanzaType stanza of
1710 Message { msgType = GroupChatMsg } -> return () -- Group chat handled elsewhere.
1618 Message {} -> do 1711 Message {} -> do
1619 case stanzaOrigin stanza of 1712 case stanzaOrigin stanza of
1620 LocalPeer {} -> return () 1713 LocalPeer {} -> return ()