summaryrefslogtreecommitdiff
path: root/Presence/Stanza
diff options
context:
space:
mode:
Diffstat (limited to 'Presence/Stanza')
-rw-r--r--Presence/Stanza/Build.hs155
-rw-r--r--Presence/Stanza/Parse.hs277
-rw-r--r--Presence/Stanza/Types.hs257
3 files changed, 0 insertions, 689 deletions
diff --git a/Presence/Stanza/Build.hs b/Presence/Stanza/Build.hs
deleted file mode 100644
index 16552428..00000000
--- a/Presence/Stanza/Build.hs
+++ /dev/null
@@ -1,155 +0,0 @@
1{-# LANGUAGE CPP #-}
2module Stanza.Build where
3
4import Control.Monad
5import Control.Concurrent.STM
6import Data.Maybe
7import Data.Text (Text)
8import Data.XML.Types as XML
9
10#ifdef THREAD_DEBUG
11import Control.Concurrent.Lifted.Instrument
12#else
13import Control.Concurrent
14import GHC.Conc (labelThread)
15#endif
16
17import EventUtil
18import LockedChan
19import Stanza.Types
20
21makeMessage :: Text -> Text -> Text -> Text -> IO Stanza
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 =
26 stanzaFromList typ
27 $ [ EventBeginElement (mkname namespace "message")
28 $ addMessageType msgtyp
29 [ attr "from" from
30 , attr "to" to
31 ]
32 , EventBeginElement (mkname namespace "body") []
33 , EventContent (ContentText bod)
34 , EventEndElement (mkname namespace "body")
35 , EventEndElement (mkname namespace "message") ]
36 where
37 typ = Message { msgThread = Nothing
38 , msgLangMap = [("", lsm)]
39 , msgType = msgtyp
40 }
41 lsm = LangSpecificMessage
42 { msgBody = Just bod
43 , msgSubject = Nothing }
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
50makeInformSubscription :: Text -> Text -> Text -> Bool -> IO Stanza
51makeInformSubscription namespace from to approved =
52 stanzaFromList (PresenceInformSubscription approved)
53 $ [ EventBeginElement (mkname namespace "presence")
54 [ attr "from" from
55 , attr "to" to
56 , attr "type" $ if approved then "subscribed"
57 else "unsubscribed" ]
58 , EventEndElement (mkname namespace "presence")]
59
60makePresenceStanza :: Text -> Maybe Text -> JabberShow -> IO Stanza
61makePresenceStanza ns mjid pstat = makePresenceStanzaEx ns mjid pstat []
62
63makePresenceStanzaEx :: Text -> Maybe Text -> JabberShow -> [XML.Event]-> IO Stanza
64makePresenceStanzaEx namespace mjid pstat es = do
65 stanzaFromList PresenceStatus { presenceShow = pstat
66 , presencePriority = Nothing
67 , presenceStatus = []
68 , presenceWhiteList = []
69 }
70 $ [ EventBeginElement (mkname namespace "presence")
71 (setFrom $ typ pstat) ]
72 ++ (shw pstat >>= jabberShow) ++ es ++
73 [ EventEndElement (mkname namespace "presence")]
74 where
75 setFrom = maybe id
76 (\jid -> (attr "from" jid :) )
77 mjid
78 typ Offline = [attr "type" "unavailable"]
79 typ _ = []
80 shw ExtendedAway = ["xa"]
81 shw Chatty = ["chat"]
82 shw Away = ["away"]
83 shw DoNotDisturb = ["dnd"]
84 shw _ = []
85 jabberShow stat =
86 [ EventBeginElement "{jabber:client}show" []
87 , EventContent (ContentText stat)
88 , EventEndElement "{jabber:client}show" ]
89
90makeRosterUpdate :: Text -> Text -> [(Name, Text)] -> IO Stanza
91makeRosterUpdate tojid contact as = do
92 let attrs = map (uncurry attr) as
93 stanzaFromList Unrecognized
94 [ EventBeginElement "{jabber:client}iq"
95 [ attr "to" tojid
96 , attr "id" "someid"
97 , attr "type" "set"
98 ]
99 , EventBeginElement "{jabber:iq:roster}query" []
100 , EventBeginElement "{jabber:iq:roster}item" (attr "jid" contact : attrs)
101 , EventEndElement "{jabber:iq:roster}item"
102 , EventEndElement "{jabber:iq:roster}query"
103 , EventEndElement "{jabber:client}iq"
104 ]
105
106makePong :: Text -> Maybe Text -> Text -> Text -> [XML.Event]
107makePong namespace mid to from =
108 -- Note: similar to session reply
109 [ EventBeginElement (mkname namespace "iq")
110 $(case mid of
111 Just c -> (("id",[ContentText c]):)
112 _ -> id)
113 [ attr "type" "result"
114 , attr "to" to
115 , attr "from" from
116 ]
117 , EventEndElement (mkname namespace "iq")
118 ]
119
120
121mkname :: Text -> Text -> XML.Name
122mkname namespace name = (Name name (Just namespace) Nothing)
123
124
125stanzaFromList :: StanzaType -> [Event] -> IO Stanza
126stanzaFromList stype reply = do
127 let stanzaTag = listToMaybe reply
128 mid = stanzaTag >>= lookupAttrib "id" . tagAttrs
129 mfrom = stanzaTag >>= lookupAttrib "from" . tagAttrs
130 mto = stanzaTag >>= lookupAttrib "to" . tagAttrs
131 {-
132 isInternal (InternalEnableHack {}) = True
133 isInternal (InternalCacheId {}) = True
134 isInternal _ = False
135 -}
136 (donevar,replyChan,replyClsrs) <- atomically $ do
137 donevar <- newEmptyTMVar -- TMVar ()
138 replyChan <- newLockedChan
139 replyClsrs <- newTVar (Just [])
140 return (donevar,replyChan, replyClsrs)
141 t <- forkIO $ do
142 forM_ reply $ atomically . writeLChan replyChan
143 atomically $ do putTMVar donevar ()
144 writeTVar replyClsrs Nothing
145 labelThread t $ concat $ "stanza." : take 1 (words $ show stype)
146 return Stanza { stanzaType = stype
147 , stanzaId = mid
148 , stanzaTo = mto -- as-is from reply list
149 , stanzaFrom = mfrom -- as-is from reply list
150 , stanzaChan = replyChan
151 , stanzaClosers = replyClsrs
152 , stanzaInterrupt = donevar
153 , stanzaOrigin = LocalPeer
154 }
155
diff --git a/Presence/Stanza/Parse.hs b/Presence/Stanza/Parse.hs
deleted file mode 100644
index 58bf7c51..00000000
--- a/Presence/Stanza/Parse.hs
+++ /dev/null
@@ -1,277 +0,0 @@
1module Stanza.Parse (grokStanza,errorTagLocalName) where
2
3import Control.Concurrent.STM
4import Control.Monad
5import Data.Char
6import Data.Function
7import Data.Maybe
8import qualified Data.Text as Text (pack, unpack, words)
9 ;import Data.Text (Text)
10
11import Control.Monad.Catch (MonadThrow)
12import Control.Monad.IO.Class (MonadIO, liftIO)
13import qualified Data.Map as Map
14import Data.XML.Types as XML
15import qualified Text.XML.Stream.Parse as XML
16
17import Control.Concurrent.STM.Util
18import ControlMaybe (handleIO_, (<&>))
19import EventUtil
20import Nesting
21import Stanza.Types
22
23-- | Identify an XMPP stanza based on the open-tag.
24grokStanza :: Text -> XML.Event -> NestingXML o IO (Maybe StanzaType)
25grokStanza "jabber:server" stanzaTag =
26 case () of
27 _ | stanzaTag `isServerIQOf` "get" -> grokStanzaIQGet stanzaTag
28 _ | stanzaTag `isServerIQOf` "result" -> grokStanzaIQResult stanzaTag
29 _ | tagName stanzaTag == "{jabber:server}presence" -> grokPresence "jabber:server" stanzaTag
30 _ | tagName stanzaTag == "{jabber:server}message" -> grokMessage "jabber:server" stanzaTag
31 _ -> return $ Just Unrecognized
32
33grokStanza "jabber:client" stanzaTag =
34 case () of
35 _ | stanzaTag `isClientIQOf` "get" -> grokStanzaIQGet stanzaTag
36 _ | stanzaTag `isClientIQOf` "set" -> grokStanzaIQSet stanzaTag
37 _ | stanzaTag `isClientIQOf` "result" -> grokStanzaIQResult stanzaTag
38 _ | tagName stanzaTag == "{jabber:client}presence" -> grokPresence "jabber:client" stanzaTag
39 _ | tagName stanzaTag == "{jabber:client}message" -> grokMessage "jabber:client" stanzaTag
40 _ -> return $ Just Unrecognized
41
42grokStanzaIQGet :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType)
43grokStanzaIQGet stanza = do
44 mtag <- nextElement
45 forM mtag $ \tag -> do
46 case tagName tag of
47 "{urn:xmpp:ping}ping" -> return Ping
48 "{jabber:iq:roster}query" -> return RequestRoster
49 "{http://jabber.org/protocol/disco#items}query"
50 -> return $ RequestItems $ lookupAttrib "node" $ tagAttrs tag
51 "{http://jabber.org/protocol/disco#info}query"
52 -> return $ RequestInfo $ lookupAttrib "node" $ tagAttrs tag
53 name -> return $ UnrecognizedQuery name
54
55grokStanzaIQResult :: XML.Event -> NestingXML o IO (Maybe StanzaType)
56grokStanzaIQResult stanza = do
57 mtag <- nextElement
58 fromMaybe (return $ Just Pong) $ mtag <&> \tag -> do
59 case tagName tag of
60 "{jabber:iq:version}query" | nameNamespace (tagName stanza)==Just "jabber:client"
61 -> parseClientVersion
62 "{http://jabber.org/protocol/disco#items}query"
63 -> return $ Just Items
64 "{http://jabber.org/protocol/disco#info}query"
65 -> return $ Just Info
66 _ -> return Nothing
67
68grokStanzaIQSet :: XML.Event -> NestingXML o IO (Maybe StanzaType)
69grokStanzaIQSet stanza = do
70 mtag <- nextElement
71 case tagName <$> mtag of
72 Just "{urn:ietf:params:xml:ns:xmpp-bind}bind"
73 -> do mchild <- nextElement
74 case tagName <$> mchild of
75 Just "{urn:ietf:params:xml:ns:xmpp-bind}resource"
76 -> do rsc <- XML.content -- TODO: MonadThrow???
77 return . Just $ RequestResource Nothing (Just rsc)
78 Just _ -> return Nothing
79 Nothing -> return . Just $ RequestResource Nothing Nothing
80 Just "{urn:ietf:params:xml:ns:xmpp-session}session"
81 -> return $ Just SessionRequest
82 _ -> return Nothing
83
84grokPresence
85 :: ( MonadThrow m
86 , MonadIO m
87 ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
88grokPresence ns stanzaTag = do
89 let typ = lookupAttrib "type" (tagAttrs stanzaTag)
90 case typ of
91 Nothing -> -- Note: Possibly join-chat stanza.
92 parsePresenceStatus ns stanzaTag
93 Just "unavailable" -> fmap (fmap (\p -> p {presenceShow=Offline}))
94 $ parsePresenceStatus ns stanzaTag
95 Just "error" -> return . Just $ PresenceInformError
96 Just "unsubscribed" -> return . Just $ PresenceInformSubscription False
97 Just "subscribed" -> return . Just $ PresenceInformSubscription True
98 Just "probe" -> return . Just $ PresenceRequestStatus
99 Just "unsubscribe" -> return . Just $ PresenceRequestSubscription False
100 Just "subscribe" -> return . Just $ PresenceRequestSubscription True
101 _ -> return Nothing
102
103grokMessage
104 :: ( MonadThrow m
105 , MonadIO m
106 ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
107grokMessage ns stanzaTag = do
108 let typ = lookupAttrib "type" (tagAttrs stanzaTag)
109 case typ of
110 Just "error" -> do
111 mb <- findErrorTag ns
112 return $ do
113 e <- mb
114 return $ Error e stanzaTag
115 _ -> do t <- parseMessage ns stanzaTag
116 return $ Just t
117
118parseClientVersion :: NestingXML o IO (Maybe StanzaType)
119parseClientVersion = parseit Nothing Nothing
120 where
121 reportit mname mver = return $ do
122 name <- mname
123 ver <- mver
124 return NotifyClientVersion { versionName=name, versionVersion=ver }
125 parseit :: Maybe Text -> Maybe Text -> NestingXML o IO (Maybe StanzaType)
126 parseit mname mver = do
127 mtag <- nextElement
128 fromMaybe (reportit mname mver) $ mtag <&> \tag -> do
129 case tagName tag of
130 "{jabber:iq:version}name" -> do
131 x <- XML.content
132 parseit (Just x) mver
133 "{jabber:iq:version}version" -> do
134 x <- XML.content
135 parseit mname (Just x)
136 _ -> parseit mname mver
137
138parsePresenceStatus
139 :: ( MonadThrow m
140 , MonadIO m
141 ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
142parsePresenceStatus ns stanzaTag = do
143
144 let toStat "away" = Away
145 toStat "xa" = ExtendedAway
146 toStat "dnd" = DoNotDisturb
147 toStat "chat" = Chatty
148
149 showv <- liftIO . atomically $ newTVar Available
150 priov <- liftIO . atomically $ newTVar Nothing
151 statusv <- liftIO . atomically $ newTChan
152 fix $ \loop -> do
153 mtag <- nextElement
154 forM_ mtag $ \tag -> do
155 when (nameNamespace (tagName tag) == Just ns) $ do
156 case nameLocalName (tagName tag) of
157 "show" -> do t <- XML.content
158 liftIO . atomically $ writeTVar showv (toStat t)
159 "priority" -> do t <- XML.content
160 liftIO . handleIO_ (return ()) $ do
161 prio <- readIO (Text.unpack t)
162 atomically $ writeTVar priov (Just prio)
163 "status" -> do t <- XML.content
164 lang <- xmlLang
165 ioWriteChan statusv (maybe "" id lang,t)
166 _ -> return ()
167 loop
168 show <- liftIO . atomically $ readTVar showv
169 prio <- liftIO . atomically $ readTVar priov
170 status <- liftIO $ chanContents statusv -- Could use unsafeInterleaveIO to
171 -- avoid multiple passes, but whatever.
172 let wlist = do
173 w <- maybeToList $ lookupAttrib "whitelist" (tagAttrs stanzaTag)
174 Text.words w
175 return . Just $ PresenceStatus { presenceShow = show
176 , presencePriority = prio
177 , presenceStatus = status
178 , presenceWhiteList = wlist
179 }
180parseMessage
181 :: ( MonadThrow m
182 , MonadIO m
183 ) => Text -> XML.Event -> NestingXML o m StanzaType
184parseMessage ns stanza = do
185 let bodytag = Name { nameNamespace = Just ns
186 , nameLocalName = "body"
187 , namePrefix = Nothing }
188 subjecttag = Name { nameNamespace = Just ns
189 , nameLocalName = "subject"
190 , namePrefix = Nothing }
191 threadtag = Name { nameNamespace = Just ns
192 , nameLocalName = "thread"
193 , namePrefix = Nothing }
194 let emptyMsg = LangSpecificMessage { msgBody=Nothing, msgSubject=Nothing }
195 parseChildren (th,cmap) = do
196 child <- nextElement
197 lvl <- nesting
198 xmllang <- xmlLang
199 let lang = maybe "" id xmllang
200 let c = maybe emptyMsg id (Map.lookup lang cmap)
201 -- log $ " child: "<> bshow child
202 case child of
203 Just tag | tagName tag==bodytag
204 -> do
205 txt <- XML.content
206 awaitCloser lvl
207 parseChildren (th,Map.insert lang (c { msgBody=Just txt }) cmap)
208 Just tag | tagName tag==subjecttag
209 -> do
210 txt <- XML.content
211 awaitCloser lvl
212 parseChildren (th,Map.insert lang (c { msgSubject=Just txt }) cmap)
213 Just tag | tagName tag==threadtag
214 -> do
215 txt <- XML.content
216 awaitCloser lvl
217 parseChildren (th {msgThreadContent=txt},cmap)
218 Just tag -> do
219 -- let nm = tagName tag
220 -- attrs = tagAttrs tag
221 -- -- elems = msgElements c
222 -- txt <- XML.content
223 awaitCloser lvl
224 parseChildren (th,Map.insert lang c cmap)
225 Nothing -> return (th,cmap)
226 (th,langmap) <- parseChildren ( MessageThread {msgThreadParent=Nothing, msgThreadContent=""}
227 , Map.empty )
228 return Message {
229 msgLangMap = Map.toList langmap,
230 msgThread = if msgThreadContent th/="" then Just th else Nothing,
231 msgType = parseMessageType $ lookupAttrib "type" (tagAttrs stanza)
232 }
233
234parseMessageType :: Maybe Text -> MessageType
235parseMessageType (Just "chat") = ChatMsg
236parseMessageType (Just "groupchat") = GroupChatMsg
237parseMessageType (Just "headline") = HeadlineMsg
238parseMessageType _ = NormalMsg
239
240findErrorTag :: Monad m => Text -> NestingXML o m (Maybe StanzaError)
241findErrorTag ns = do
242 x <- nextElement
243 fmap join $ forM x $ \x ->
244 case tagName x of
245 n | nameNamespace n==Just ns && nameLocalName n=="error"
246 -> do
247 mtag <- findConditionTag
248 return $ do
249 tag <- {- trace ("mtag = "++show mtag) -} mtag
250 let t = nameLocalName (tagName tag)
251 conditionFromText t
252 _ -> findErrorTag ns
253
254findConditionTag :: Monad m => NestingXML o m (Maybe XML.Event)
255findConditionTag = do
256 mx <- nextElement
257 fmap join $ forM mx $ \x -> do
258 case nameNamespace (tagName x) of
259 Just "urn:ietf:params:xml:ns:xmpp-stanzas" -> return (Just x)
260 _ -> findConditionTag
261
262conditionFromText :: Text -> Maybe StanzaError
263conditionFromText t = fmap fst $ listToMaybe ss
264 where
265 es = [BadRequest .. UnexpectedRequest]
266 ts = map (\e->(e,errorTagLocalName e)) es
267 ss = dropWhile ((/=t) . snd) ts
268
269-- | Converts a CamelCase constructor to a hyphenated lower-case name for use
270-- as an xml tag.
271errorTagLocalName :: StanzaError -> Text
272errorTagLocalName e = Text.pack . drop 1 $ do
273 c <- show e
274 if 'A' <= c && c <= 'Z'
275 then [ '-', chr( ord c - ord 'A' + ord 'a') ]
276 else return c
277
diff --git a/Presence/Stanza/Types.hs b/Presence/Stanza/Types.hs
deleted file mode 100644
index 7275c8ab..00000000
--- a/Presence/Stanza/Types.hs
+++ /dev/null
@@ -1,257 +0,0 @@
1{-# LANGUAGE FlexibleInstances #-}
2module Stanza.Types where
3
4import Control.Concurrent.STM
5import Data.Int
6import Data.Text
7import Data.XML.Types as XML
8
9import Connection (PeerAddress(..))
10import ConnectionKey (ClientAddress(..))
11import LockedChan
12import Nesting (Lang)
13
14type Stanza = StanzaWrap (LockedChan XML.Event)
15
16data StanzaWrap a = Stanza
17 { stanzaType :: StanzaType
18 , stanzaId :: Maybe Text
19 , stanzaTo :: Maybe Text
20 , stanzaFrom :: Maybe Text
21 , stanzaChan :: a
22 , stanzaClosers :: TVar (Maybe [XML.Event])
23 , stanzaInterrupt :: TMVar ()
24 , stanzaOrigin :: StanzaOrigin
25 }
26
27data StanzaOrigin = LocalPeer
28 | PeerOrigin PeerAddress (TChan Stanza)
29 | ClientOrigin ClientAddress (TChan Stanza)
30
31data StanzaType
32 = Unrecognized
33 | Ping
34 | Pong
35 | RequestResource (Maybe Text) (Maybe Text) -- ^ Client's name for this host followed by client's requested resource id.
36 | SetResource
37 | RequestItems (Maybe Text)
38 | Items
39 | RequestInfo (Maybe Text)
40 | Info
41 | SessionRequest
42 | UnrecognizedQuery Name
43 | RequestRoster
44 | Roster
45 | RosterEvent { rosterEventType :: RosterEventType
46 , rosterUser :: Text
47 , rosterContact :: Text }
48 | Error StanzaError XML.Event
49 | PresenceStatus { presenceShow :: JabberShow
50 , presencePriority :: Maybe Int8
51 , presenceStatus :: [(Lang,Text)]
52 , presenceWhiteList :: [Text]
53 -- ^ A custom extension extension we are using. When a
54 -- peer answers a presence probe, it also communicates
55 -- to the remote peer which remote users it believes
56 -- are subscribed to that presence.
57 --
58 -- This is communicated via a space-delimited list in
59 -- the nonstandard "whitelist" attribute for a
60 -- <{jabber:server}presence> tag.
61 --
62 -- TODO: Use this to update the buddies file so that a
63 -- client is made aware when a subscription was
64 -- canceled.
65 }
66
67 | PresenceInformError
68 | PresenceInformSubscription Bool
69 | PresenceRequestStatus
70 | PresenceRequestSubscription Bool
71 | Message { msgThread :: Maybe MessageThread
72 , msgLangMap :: [(Lang,LangSpecificMessage)]
73 , msgType :: MessageType
74 }
75 | NotifyClientVersion { versionName :: Text
76 , versionVersion :: Text }
77 | InternalEnableHack ClientHack
78 | InternalCacheId Text
79 deriving (Show,Eq)
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
135data RosterEventType
136 = RequestedSubscription
137 | NewBuddy -- preceded by PresenceInformSubscription True
138 | RemovedBuddy -- preceded by PresenceInformSubscription False
139 | PendingSubscriber -- same as PresenceRequestSubscription
140 | NewSubscriber
141 | RejectSubscriber
142 deriving (Show,Read,Ord,Eq,Enum)
143
144data ClientHack = SimulatedChatErrors
145 deriving (Show,Read,Ord,Eq,Enum)
146
147
148data LangSpecificMessage =
149 LangSpecificMessage { msgBody :: Maybe Text
150 , msgSubject :: Maybe Text
151 }
152 deriving (Show,Eq)
153
154data MessageThread = MessageThread {
155 msgThreadParent :: Maybe Text,
156 msgThreadContent :: Text
157 }
158 deriving (Show,Eq)
159
160
161data JabberShow = Offline
162 | ExtendedAway
163 | Away
164 | DoNotDisturb
165 | Available
166 | Chatty
167 deriving (Show,Enum,Ord,Eq,Read)
168
169class StanzaFirstTag a where
170 -- Peek at the stanza open tag.
171 stanzaFirstTag :: StanzaWrap a -> IO XML.Event
172instance StanzaFirstTag (TChan XML.Event) where
173 stanzaFirstTag stanza = do
174 e <-atomically $ peekTChan (stanzaChan stanza)
175 return e
176instance StanzaFirstTag (LockedChan XML.Event) where
177 stanzaFirstTag stanza = do
178 e <-atomically $ peekLChan (stanzaChan stanza)
179 return e
180instance StanzaFirstTag XML.Event where
181 stanzaFirstTag stanza = return (stanzaChan stanza)
182
183data StanzaError
184 = BadRequest
185 | Conflict
186 | FeatureNotImplemented
187 | Forbidden
188 | Gone
189 | InternalServerError
190 | ItemNotFound
191 | JidMalformed
192 | NotAcceptable
193 | NotAllowed
194 | NotAuthorized
195 | PaymentRequired
196 | RecipientUnavailable
197 | Redirect
198 | RegistrationRequired
199 | RemoteServerNotFound
200 | RemoteServerTimeout
201 | ResourceConstraint
202 | ServiceUnavailable
203 | SubscriptionRequired
204 | UndefinedCondition
205 | UnexpectedRequest
206 deriving (Show,Enum,Ord,Eq)
207
208xep0086 :: StanzaError -> (Text, Int)
209xep0086 e = case e of
210 BadRequest -> ("modify", 400)
211 Conflict -> ("cancel", 409)
212 FeatureNotImplemented -> ("cancel", 501)
213 Forbidden -> ("auth", 403)
214 Gone -> ("modify", 302)
215 InternalServerError -> ("wait", 500)
216 ItemNotFound -> ("cancel", 404)
217 JidMalformed -> ("modify", 400)
218 NotAcceptable -> ("modify", 406)
219 NotAllowed -> ("cancel", 405)
220 NotAuthorized -> ("auth", 401)
221 PaymentRequired -> ("auth", 402)
222 RecipientUnavailable -> ("wait", 404)
223 Redirect -> ("modify", 302)
224 RegistrationRequired -> ("auth", 407)
225 RemoteServerNotFound -> ("cancel", 404)
226 RemoteServerTimeout -> ("wait", 504)
227 ResourceConstraint -> ("wait", 500)
228 ServiceUnavailable -> ("cancel", 503)
229 SubscriptionRequired -> ("auth", 407)
230 UndefinedCondition -> ("", 500)
231 UnexpectedRequest -> ("wait", 400)
232
233errorText :: StanzaError -> Text
234errorText e = case e of
235 BadRequest -> "Bad request"
236 Conflict -> "Conflict"
237 FeatureNotImplemented -> "This feature is not implemented"
238 Forbidden -> "Forbidden"
239 Gone -> "Recipient can no longer be contacted"
240 InternalServerError -> "Internal server error"
241 ItemNotFound -> "Item not found"
242 JidMalformed -> "JID Malformed"
243 NotAcceptable -> "Message was rejected"
244 NotAllowed -> "Not allowed"
245 NotAuthorized -> "Not authorized"
246 PaymentRequired -> "Payment is required"
247 RecipientUnavailable -> "Recipient is unavailable"
248 Redirect -> "Redirect"
249 RegistrationRequired -> "Registration required"
250 RemoteServerNotFound -> "Recipient's server not found"
251 RemoteServerTimeout -> "Remote server timeout"
252 ResourceConstraint -> "The server is low on resources"
253 ServiceUnavailable -> "The service is unavailable"
254 SubscriptionRequired -> "A subscription is required"
255 UndefinedCondition -> "Undefined condition"
256 UnexpectedRequest -> "Unexpected request"
257
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-13 16:27:07 +0000