summaryrefslogtreecommitdiff
path: root/Presence
diff options
context:
space:
mode:
Diffstat (limited to 'Presence')
-rw-r--r--Presence/Stanza/Parse.hs3
-rw-r--r--Presence/XMPPServer.hs30
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
88grokPresence ns stanzaTag = do 88grokPresence 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
1197makeErrorStanza :: StanzaFirstTag a => StanzaWrap a -> IO [XML.Event] 1198makeErrorStanza :: StanzaFirstTag a => StanzaWrap a -> IO [XML.Event]
1198makeErrorStanza stanza = do 1199makeErrorStanza stanza = makeErrorStanza' stanza RecipientUnavailable []
1200
1201makeErrorStanza' :: StanzaFirstTag a =>
1202 StanzaWrap a -> StanzaError -> [(Name, [Content])] -> IO [Event]
1203makeErrorStanza' 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