diff options
Diffstat (limited to 'Presence/XMPPServer.hs')
-rw-r--r-- | Presence/XMPPServer.hs | 15 |
1 files changed, 14 insertions, 1 deletions
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs index df2945d6..03a167ee 100644 --- a/Presence/XMPPServer.hs +++ b/Presence/XMPPServer.hs | |||
@@ -77,7 +77,6 @@ import ControlMaybe | |||
77 | import LockedChan | 77 | import LockedChan |
78 | import PeerResolve | 78 | import PeerResolve |
79 | 79 | ||
80 | |||
81 | peerport :: PortNumber | 80 | peerport :: PortNumber |
82 | peerport = 5269 | 81 | peerport = 5269 |
83 | clientport :: PortNumber | 82 | clientport :: PortNumber |
@@ -212,6 +211,7 @@ enableClientHacks "irssi-xmpp" version replyto = do | |||
212 | replyto | 211 | replyto |
213 | enableClientHacks _ _ _ = return () | 212 | enableClientHacks _ _ _ = return () |
214 | 213 | ||
214 | cacheMessageId :: Text -> TChan Stanza -> IO () | ||
215 | cacheMessageId id' replyto = do | 215 | cacheMessageId id' replyto = do |
216 | wlog $ "Caching id " ++ Text.unpack id' | 216 | wlog $ "Caching id " ++ Text.unpack id' |
217 | donevar <- atomically newEmptyTMVar | 217 | donevar <- atomically newEmptyTMVar |
@@ -309,6 +309,7 @@ prettyPrint prefix = | |||
309 | swapNamespace :: Monad m => Text -> Text -> ConduitM Event Event m () | 309 | swapNamespace :: Monad m => Text -> Text -> ConduitM Event Event m () |
310 | swapNamespace old new = awaitForever (yield . swapit old new) | 310 | swapNamespace old new = awaitForever (yield . swapit old new) |
311 | 311 | ||
312 | swapit :: Text -> Text -> Event -> Event | ||
312 | swapit old new (EventBeginElement n as) | nameNamespace n==Just old = | 313 | swapit old new (EventBeginElement n as) | nameNamespace n==Just old = |
313 | EventBeginElement (n { nameNamespace = Just new }) as | 314 | EventBeginElement (n { nameNamespace = Just new }) as |
314 | swapit old new (EventEndElement n) | nameNamespace n==Just old = | 315 | swapit old new (EventEndElement n) | nameNamespace n==Just old = |
@@ -759,6 +760,7 @@ grokStanza "jabber:client" stanzaTag = | |||
759 | mkname :: Text -> Text -> XML.Name | 760 | mkname :: Text -> Text -> XML.Name |
760 | mkname namespace name = (Name name (Just namespace) Nothing) | 761 | mkname namespace name = (Name name (Just namespace) Nothing) |
761 | 762 | ||
763 | makeInformSubscription :: Text -> Text -> Text -> Bool -> IO Stanza | ||
762 | makeInformSubscription namespace from to approved = | 764 | makeInformSubscription namespace from to approved = |
763 | stanzaFromList (PresenceInformSubscription approved) | 765 | stanzaFromList (PresenceInformSubscription approved) |
764 | $ [ EventBeginElement (mkname namespace "presence") | 766 | $ [ EventBeginElement (mkname namespace "presence") |
@@ -768,6 +770,7 @@ makeInformSubscription namespace from to approved = | |||
768 | else "unsubscribed" ] | 770 | else "unsubscribed" ] |
769 | , EventEndElement (mkname namespace "presence")] | 771 | , EventEndElement (mkname namespace "presence")] |
770 | 772 | ||
773 | makePresenceStanza :: Text -> Maybe Text -> JabberShow -> IO Stanza | ||
771 | makePresenceStanza namespace mjid pstat = do | 774 | makePresenceStanza namespace mjid pstat = do |
772 | stanzaFromList PresenceStatus { presenceShow = pstat | 775 | stanzaFromList PresenceStatus { presenceShow = pstat |
773 | , presencePriority = Nothing | 776 | , presencePriority = Nothing |
@@ -794,6 +797,7 @@ makePresenceStanza namespace mjid pstat = do | |||
794 | , EventContent (ContentText stat) | 797 | , EventContent (ContentText stat) |
795 | , EventEndElement "{jabber:client}show" ] | 798 | , EventEndElement "{jabber:client}show" ] |
796 | 799 | ||
800 | makeRosterUpdate :: Text -> Text -> [(Name, Text)] -> IO Stanza | ||
797 | makeRosterUpdate tojid contact as = do | 801 | makeRosterUpdate tojid contact as = do |
798 | let attrs = map (uncurry attr) as | 802 | let attrs = map (uncurry attr) as |
799 | stanzaFromList Unrecognized | 803 | stanzaFromList Unrecognized |
@@ -957,6 +961,7 @@ streamFeatures "jabber:server" = | |||
957 | greet' :: Text -> Text -> [XML.Event] | 961 | greet' :: Text -> Text -> [XML.Event] |
958 | greet' namespace host = EventBeginDocument : greet'' namespace host | 962 | greet' namespace host = EventBeginDocument : greet'' namespace host |
959 | 963 | ||
964 | greet'' :: Text -> Text -> [Event] | ||
960 | greet'' namespace host = | 965 | greet'' namespace host = |
961 | [ EventBeginElement (streamP "stream") | 966 | [ EventBeginElement (streamP "stream") |
962 | [("from",[ContentText host]) | 967 | [("from",[ContentText host]) |
@@ -1088,6 +1093,7 @@ goodbye = | |||
1088 | , EventEndDocument | 1093 | , EventEndDocument |
1089 | ] | 1094 | ] |
1090 | 1095 | ||
1096 | simulateChatError :: StanzaError -> Maybe Text -> [Event] | ||
1091 | simulateChatError err mfrom = | 1097 | simulateChatError err mfrom = |
1092 | [ EventBeginElement "{jabber:client}message" | 1098 | [ EventBeginElement "{jabber:client}message" |
1093 | ((maybe id (\t->(attr "from" t:)) mfrom) | 1099 | ((maybe id (\t->(attr "from" t:)) mfrom) |
@@ -1108,10 +1114,13 @@ simulateChatError err mfrom = | |||
1108 | ] | 1114 | ] |
1109 | 1115 | ||
1110 | 1116 | ||
1117 | presenceSolicitation :: Text -> Text -> IO Stanza | ||
1111 | presenceSolicitation = presenceStanza (PresenceRequestSubscription True) "subscribe" | 1118 | presenceSolicitation = presenceStanza (PresenceRequestSubscription True) "subscribe" |
1112 | 1119 | ||
1120 | presenceProbe :: Text -> Text -> IO Stanza | ||
1113 | presenceProbe = presenceStanza PresenceRequestStatus "probe" | 1121 | presenceProbe = presenceStanza PresenceRequestStatus "probe" |
1114 | 1122 | ||
1123 | presenceStanza :: StanzaType -> Text -> Text -> Text -> IO Stanza | ||
1115 | presenceStanza stanza_type type_attr me jid = | 1124 | presenceStanza stanza_type type_attr me jid = |
1116 | stanzaFromList stanza_type | 1125 | stanzaFromList stanza_type |
1117 | [ EventBeginElement "{jabber:server}presence" | 1126 | [ EventBeginElement "{jabber:server}presence" |
@@ -1431,6 +1440,8 @@ data StanzaError | |||
1431 | | UnexpectedRequest | 1440 | | UnexpectedRequest |
1432 | deriving (Show,Enum,Ord,Eq) | 1441 | deriving (Show,Enum,Ord,Eq) |
1433 | 1442 | ||
1443 | xep0086 :: | ||
1444 | forall t t1. (Num t1, IsString t) => StanzaError -> (t, t1) | ||
1434 | xep0086 e = | 1445 | xep0086 e = |
1435 | case e of | 1446 | case e of |
1436 | BadRequest -> ("modify", 400) | 1447 | BadRequest -> ("modify", 400) |
@@ -1482,10 +1493,12 @@ errorText e = | |||
1482 | UndefinedCondition -> "Undefined condition" | 1493 | UndefinedCondition -> "Undefined condition" |
1483 | UnexpectedRequest -> "Unexpected request" | 1494 | UnexpectedRequest -> "Unexpected request" |
1484 | 1495 | ||
1496 | eventContent :: Maybe [Content] -> Text | ||
1485 | eventContent cs = maybe "" (foldr1 (<>) . map content1) cs | 1497 | eventContent cs = maybe "" (foldr1 (<>) . map content1) cs |
1486 | where content1 (ContentText t) = t | 1498 | where content1 (ContentText t) = t |
1487 | content1 (ContentEntity t) = t | 1499 | content1 (ContentEntity t) = t |
1488 | 1500 | ||
1501 | errorTagLocalName :: forall a. Show a => a -> Text | ||
1489 | errorTagLocalName e = Text.pack . drop 1 $ do | 1502 | errorTagLocalName e = Text.pack . drop 1 $ do |
1490 | c <- show e | 1503 | c <- show e |
1491 | if 'A' <= c && c <= 'Z' | 1504 | if 'A' <= c && c <= 'Z' |