1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
|
{-# LANGUAGE FlexibleInstances #-}
module Stanza.Types where
import Control.Concurrent.STM
import Data.Int
import Data.Text
import Data.XML.Types as XML
import Connection (PeerAddress(..))
import ConnectionKey (ClientAddress(..))
import LockedChan
import Nesting (Lang)
type Stanza = StanzaWrap (LockedChan XML.Event)
data StanzaWrap a = Stanza
{ stanzaType :: StanzaType
, stanzaId :: Maybe Text
, stanzaTo :: Maybe Text
, stanzaFrom :: Maybe Text
, stanzaChan :: a
, stanzaClosers :: TVar (Maybe [XML.Event])
, stanzaInterrupt :: TMVar ()
, stanzaOrigin :: StanzaOrigin
}
data StanzaOrigin = LocalPeer
| PeerOrigin PeerAddress (TChan Stanza)
| ClientOrigin ClientAddress (TChan Stanza)
data StanzaType
= Unrecognized
| Ping
| Pong
| RequestResource (Maybe Text) (Maybe Text) -- ^ Client's name for this host followed by client's requested resource id.
| SetResource
| RequestItems (Maybe Text)
| Items
| RequestInfo (Maybe Text)
| Info
| SessionRequest
| UnrecognizedQuery Name
| RequestRoster
| Roster
| RosterEvent { rosterEventType :: RosterEventType
, rosterUser :: Text
, rosterContact :: Text }
| Error StanzaError XML.Event
| PresenceStatus { presenceShow :: JabberShow
, presencePriority :: Maybe Int8
, presenceStatus :: [(Lang,Text)]
, presenceWhiteList :: [Text]
-- ^ A custom extension extension we are using. When a
-- peer answers a presence probe, it also communicates
-- to the remote peer which remote users it believes
-- are subscribed to that presence.
--
-- This is communicated via a space-delimited list in
-- the nonstandard "whitelist" attribute for a
-- <{jabber:server}presence> tag.
--
-- TODO: Use this to update the buddies file so that a
-- client is made aware when a subscription was
-- canceled.
}
| PresenceInformError
| PresenceInformSubscription Bool
| PresenceRequestStatus
| PresenceRequestSubscription Bool
| Message { msgThread :: Maybe MessageThread
, msgLangMap :: [(Lang,LangSpecificMessage)]
}
| NotifyClientVersion { versionName :: Text
, versionVersion :: Text }
| InternalEnableHack ClientHack
| InternalCacheId Text
deriving (Show,Eq)
data RosterEventType
= RequestedSubscription
| NewBuddy -- preceded by PresenceInformSubscription True
| RemovedBuddy -- preceded by PresenceInformSubscription False
| PendingSubscriber -- same as PresenceRequestSubscription
| NewSubscriber
| RejectSubscriber
deriving (Show,Read,Ord,Eq,Enum)
data ClientHack = SimulatedChatErrors
deriving (Show,Read,Ord,Eq,Enum)
data LangSpecificMessage =
LangSpecificMessage { msgBody :: Maybe Text
, msgSubject :: Maybe Text
}
deriving (Show,Eq)
data MessageThread = MessageThread {
msgThreadParent :: Maybe Text,
msgThreadContent :: Text
}
deriving (Show,Eq)
data JabberShow = Offline
| ExtendedAway
| Away
| DoNotDisturb
| Available
| Chatty
deriving (Show,Enum,Ord,Eq,Read)
class StanzaFirstTag a where
-- Peek at the stanza open tag.
stanzaFirstTag :: StanzaWrap a -> IO XML.Event
instance StanzaFirstTag (TChan XML.Event) where
stanzaFirstTag stanza = do
e <-atomically $ peekTChan (stanzaChan stanza)
return e
instance StanzaFirstTag (LockedChan XML.Event) where
stanzaFirstTag stanza = do
e <-atomically $ peekLChan (stanzaChan stanza)
return e
instance StanzaFirstTag XML.Event where
stanzaFirstTag stanza = return (stanzaChan stanza)
data StanzaError
= BadRequest
| Conflict
| FeatureNotImplemented
| Forbidden
| Gone
| InternalServerError
| ItemNotFound
| JidMalformed
| NotAcceptable
| NotAllowed
| NotAuthorized
| PaymentRequired
| RecipientUnavailable
| Redirect
| RegistrationRequired
| RemoteServerNotFound
| RemoteServerTimeout
| ResourceConstraint
| ServiceUnavailable
| SubscriptionRequired
| UndefinedCondition
| UnexpectedRequest
deriving (Show,Enum,Ord,Eq)
xep0086 :: StanzaError -> (Text, Int)
xep0086 e = case e of
BadRequest -> ("modify", 400)
Conflict -> ("cancel", 409)
FeatureNotImplemented -> ("cancel", 501)
Forbidden -> ("auth", 403)
Gone -> ("modify", 302)
InternalServerError -> ("wait", 500)
ItemNotFound -> ("cancel", 404)
JidMalformed -> ("modify", 400)
NotAcceptable -> ("modify", 406)
NotAllowed -> ("cancel", 405)
NotAuthorized -> ("auth", 401)
PaymentRequired -> ("auth", 402)
RecipientUnavailable -> ("wait", 404)
Redirect -> ("modify", 302)
RegistrationRequired -> ("auth", 407)
RemoteServerNotFound -> ("cancel", 404)
RemoteServerTimeout -> ("wait", 504)
ResourceConstraint -> ("wait", 500)
ServiceUnavailable -> ("cancel", 503)
SubscriptionRequired -> ("auth", 407)
UndefinedCondition -> ("", 500)
UnexpectedRequest -> ("wait", 400)
errorText :: StanzaError -> Text
errorText e = case e of
BadRequest -> "Bad request"
Conflict -> "Conflict"
FeatureNotImplemented -> "This feature is not implemented"
Forbidden -> "Forbidden"
Gone -> "Recipient can no longer be contacted"
InternalServerError -> "Internal server error"
ItemNotFound -> "Item not found"
JidMalformed -> "JID Malformed"
NotAcceptable -> "Message was rejected"
NotAllowed -> "Not allowed"
NotAuthorized -> "Not authorized"
PaymentRequired -> "Payment is required"
RecipientUnavailable -> "Recipient is unavailable"
Redirect -> "Redirect"
RegistrationRequired -> "Registration required"
RemoteServerNotFound -> "Recipient's server not found"
RemoteServerTimeout -> "Remote server timeout"
ResourceConstraint -> "The server is low on resources"
ServiceUnavailable -> "The service is unavailable"
SubscriptionRequired -> "A subscription is required"
UndefinedCondition -> "Undefined condition"
UnexpectedRequest -> "Unexpected request"
|
