diff options
Diffstat (limited to 'Presence')
-rw-r--r-- | Presence/Stanza/Parse.hs | 3 | ||||
-rw-r--r-- | Presence/XMPPServer.hs | 30 |
2 files changed, 28 insertions, 5 deletions
diff --git a/Presence/Stanza/Parse.hs b/Presence/Stanza/Parse.hs index af95530f..0335556b 100644 --- a/Presence/Stanza/Parse.hs +++ b/Presence/Stanza/Parse.hs | |||
@@ -88,7 +88,8 @@ grokPresence | |||
88 | grokPresence ns stanzaTag = do | 88 | grokPresence ns stanzaTag = do |
89 | let typ = lookupAttrib "type" (tagAttrs stanzaTag) | 89 | let typ = lookupAttrib "type" (tagAttrs stanzaTag) |
90 | case typ of | 90 | case typ of |
91 | Nothing -> parsePresenceStatus ns stanzaTag | 91 | Nothing -> -- Note: Possibly join-chat stanza. |
92 | parsePresenceStatus ns stanzaTag | ||
92 | Just "unavailable" -> fmap (fmap (\p -> p {presenceShow=Offline})) | 93 | Just "unavailable" -> fmap (fmap (\p -> p {presenceShow=Offline})) |
93 | $ parsePresenceStatus ns stanzaTag | 94 | $ parsePresenceStatus ns stanzaTag |
94 | Just "error" -> return . Just $ PresenceInformError | 95 | Just "error" -> return . Just $ PresenceInformError |
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs index a0d5a69b..1cf41f66 100644 --- a/Presence/XMPPServer.hs +++ b/Presence/XMPPServer.hs | |||
@@ -2,6 +2,7 @@ | |||
2 | {-# LANGUAGE DoAndIfThenElse #-} | 2 | {-# LANGUAGE DoAndIfThenElse #-} |
3 | {-# LANGUAGE ExistentialQuantification #-} | 3 | {-# LANGUAGE ExistentialQuantification #-} |
4 | {-# LANGUAGE FlexibleInstances #-} | 4 | {-# LANGUAGE FlexibleInstances #-} |
5 | {-# LANGUAGE MultiWayIf #-} | ||
5 | {-# LANGUAGE OverloadedStrings #-} | 6 | {-# LANGUAGE OverloadedStrings #-} |
6 | {-# LANGUAGE RankNTypes #-} | 7 | {-# LANGUAGE RankNTypes #-} |
7 | {-# LANGUAGE TupleSections #-} | 8 | {-# LANGUAGE TupleSections #-} |
@@ -1195,7 +1196,11 @@ eventContent cs = maybe "" (foldr1 (<>) . map content1) cs | |||
1195 | content1 (ContentEntity t) = t | 1196 | content1 (ContentEntity t) = t |
1196 | 1197 | ||
1197 | makeErrorStanza :: StanzaFirstTag a => StanzaWrap a -> IO [XML.Event] | 1198 | makeErrorStanza :: StanzaFirstTag a => StanzaWrap a -> IO [XML.Event] |
1198 | makeErrorStanza stanza = do | 1199 | makeErrorStanza stanza = makeErrorStanza' stanza RecipientUnavailable [] |
1200 | |||
1201 | makeErrorStanza' :: StanzaFirstTag a => | ||
1202 | StanzaWrap a -> StanzaError -> [(Name, [Content])] -> IO [Event] | ||
1203 | makeErrorStanza' stanza err attrs = do | ||
1199 | startTag <- stanzaFirstTag stanza | 1204 | startTag <- stanzaFirstTag stanza |
1200 | let n = tagName startTag | 1205 | let n = tagName startTag |
1201 | endTag = EventEndElement n | 1206 | endTag = EventEndElement n |
@@ -1212,7 +1217,6 @@ makeErrorStanza stanza = do | |||
1212 | (tagName startTag) | 1217 | (tagName startTag) |
1213 | (Map.toList amap3) | 1218 | (Map.toList amap3) |
1214 | -- err = Gone -- FeatureNotImplemented -- UndefinedCondition -- RecipientUnavailable | 1219 | -- err = Gone -- FeatureNotImplemented -- UndefinedCondition -- RecipientUnavailable |
1215 | err = RecipientUnavailable | ||
1216 | errname = n { nameLocalName = "error" } | 1220 | errname = n { nameLocalName = "error" } |
1217 | -- errattrs = [attr "type" "wait"] -- "modify"] | 1221 | -- errattrs = [attr "type" "wait"] -- "modify"] |
1218 | errorAttribs e xs = ys ++ xs -- todo replace instead of append | 1222 | errorAttribs e xs = ys ++ xs -- todo replace instead of append |
@@ -1221,7 +1225,7 @@ makeErrorStanza stanza = do | |||
1221 | errorTagName = Name { nameNamespace = Just "urn:ietf:params:xml:ns:xmpp-stanzas" | 1225 | errorTagName = Name { nameNamespace = Just "urn:ietf:params:xml:ns:xmpp-stanzas" |
1222 | , nameLocalName = errorTagLocalName err | 1226 | , nameLocalName = errorTagLocalName err |
1223 | , namePrefix = Nothing } | 1227 | , namePrefix = Nothing } |
1224 | errattrs = errorAttribs err [] | 1228 | errattrs = errorAttribs err attrs |
1225 | {- | 1229 | {- |
1226 | let wlogd v s = do | 1230 | let wlogd v s = do |
1227 | wlog $ "error "++show (lookupAttrib "id" $ tagAttrs startTag)++" " ++ v ++ " = " ++ show s | 1231 | wlog $ "error "++show (lookupAttrib "id" $ tagAttrs startTag)++" " ++ v ++ " = " ++ show s |
@@ -1404,7 +1408,25 @@ applyStanza sv quitVar xmpp stanza = case stanzaOrigin stanza of | |||
1404 | sendRoster stanza xmpp k replyto | 1408 | sendRoster stanza xmpp k replyto |
1405 | xmppSubscribeToRoster xmpp k | 1409 | xmppSubscribeToRoster xmpp k |
1406 | PresenceStatus {} -> do | 1410 | PresenceStatus {} -> do |
1407 | xmppInformClientPresence xmpp k stanza | 1411 | let mucs = xmppGroupChat xmpp |
1412 | me <- xmppTellMyNameToClient xmpp k | ||
1413 | if | Available <- presenceShow (stanzaType stanza) | ||
1414 | , Just to <- stanzaTo stanza | ||
1415 | , (Just room,h,mnick) <- splitJID to | ||
1416 | , let roomjid = unsplitJID ((Just room,h,Nothing)) | ||
1417 | , Service (Just _) mucname muc <- lookupService me mucs roomjid | ||
1418 | -> case mnick of | ||
1419 | Nothing -> do | ||
1420 | -- Missing nick. | ||
1421 | reply <- makeErrorStanza' stanza JidMalformed | ||
1422 | [ ("by", [ContentText roomjid]) ] | ||
1423 | sendReply quitVar (Error JidMalformed (head reply)) reply replyto | ||
1424 | Just nick -> do | ||
1425 | -- TODO: join chat | ||
1426 | return () | ||
1427 | | otherwise -> do | ||
1428 | -- Handle presence stanza that is not a chatroom join. | ||
1429 | xmppInformClientPresence xmpp k stanza | ||
1408 | PresenceRequestSubscription {} -> do | 1430 | PresenceRequestSubscription {} -> do |
1409 | let fail = return () -- todo | 1431 | let fail = return () -- todo |
1410 | xmppClientSubscriptionRequest xmpp fail k stanza replyto | 1432 | xmppClientSubscriptionRequest xmpp fail k stanza replyto |