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
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
|
module Stanza.Parse (grokStanza,errorTagLocalName) where
import Control.Concurrent.STM
import Control.Monad
import Data.Char
import Data.Function
import Data.Maybe
import qualified Data.Text as Text (pack, unpack, words)
;import Data.Text (Text)
import Control.Monad.Catch (MonadThrow)
import Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Data.Map as Map
import Data.XML.Types as XML
import qualified Text.XML.Stream.Parse as XML
import Control.Concurrent.STM.Util
import ControlMaybe (handleIO_, (<&>))
import EventUtil
import Nesting
import Stanza.Types
-- | Identify an XMPP stanza based on the open-tag.
grokStanza :: Text -> XML.Event -> NestingXML o IO (Maybe StanzaType)
grokStanza "jabber:server" stanzaTag =
case () of
_ | stanzaTag `isServerIQOf` "get" -> grokStanzaIQGet stanzaTag
_ | stanzaTag `isServerIQOf` "result" -> grokStanzaIQResult stanzaTag
_ | tagName stanzaTag == "{jabber:server}presence" -> grokPresence "jabber:server" stanzaTag
_ | tagName stanzaTag == "{jabber:server}message" -> grokMessage "jabber:server" stanzaTag
_ -> return $ Just Unrecognized
grokStanza "jabber:client" stanzaTag =
case () of
_ | stanzaTag `isClientIQOf` "get" -> grokStanzaIQGet stanzaTag
_ | stanzaTag `isClientIQOf` "set" -> grokStanzaIQSet stanzaTag
_ | stanzaTag `isClientIQOf` "result" -> grokStanzaIQResult stanzaTag
_ | tagName stanzaTag == "{jabber:client}presence" -> grokPresence "jabber:client" stanzaTag
_ | tagName stanzaTag == "{jabber:client}message" -> grokMessage "jabber:client" stanzaTag
_ -> return $ Just Unrecognized
grokStanzaIQGet :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType)
grokStanzaIQGet stanza = do
mtag <- nextElement
forM mtag $ \tag -> do
case tagName tag of
"{urn:xmpp:ping}ping" -> return Ping
"{jabber:iq:roster}query" -> return RequestRoster
name -> return $ UnrecognizedQuery name
grokStanzaIQResult :: XML.Event -> NestingXML o IO (Maybe StanzaType)
grokStanzaIQResult stanza = do
mtag <- nextElement
fromMaybe (return $ Just Pong) $ mtag <&> \tag -> do
case tagName tag of
"{jabber:iq:version}query" | nameNamespace (tagName stanza)==Just "jabber:client"
-> parseClientVersion
_ -> return Nothing
grokStanzaIQSet :: XML.Event -> NestingXML o IO (Maybe StanzaType)
grokStanzaIQSet stanza = do
mtag <- nextElement
case tagName <$> mtag of
Just "{urn:ietf:params:xml:ns:xmpp-bind}bind"
-> do mchild <- nextElement
case tagName <$> mchild of
Just "{urn:ietf:params:xml:ns:xmpp-bind}resource"
-> do rsc <- XML.content -- TODO: MonadThrow???
return . Just $ RequestResource Nothing (Just rsc)
Just _ -> return Nothing
Nothing -> return . Just $ RequestResource Nothing Nothing
Just "{urn:ietf:params:xml:ns:xmpp-session}session"
-> return $ Just SessionRequest
_ -> return Nothing
grokPresence
:: ( MonadThrow m
, MonadIO m
) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
grokPresence ns stanzaTag = do
let typ = lookupAttrib "type" (tagAttrs stanzaTag)
case typ of
Nothing -> parsePresenceStatus ns stanzaTag
Just "unavailable" -> fmap (fmap (\p -> p {presenceShow=Offline}))
$ parsePresenceStatus ns stanzaTag
Just "error" -> return . Just $ PresenceInformError
Just "unsubscribed" -> return . Just $ PresenceInformSubscription False
Just "subscribed" -> return . Just $ PresenceInformSubscription True
Just "probe" -> return . Just $ PresenceRequestStatus
Just "unsubscribe" -> return . Just $ PresenceRequestSubscription False
Just "subscribe" -> return . Just $ PresenceRequestSubscription True
_ -> return Nothing
grokMessage
:: ( MonadThrow m
, MonadIO m
) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
grokMessage ns stanzaTag = do
let typ = lookupAttrib "type" (tagAttrs stanzaTag)
case typ of
Just "error" -> do
mb <- findErrorTag ns
return $ do
e <- mb
return $ Error e stanzaTag
_ -> do t <- parseMessage ns stanzaTag
return $ Just t
parseClientVersion :: NestingXML o IO (Maybe StanzaType)
parseClientVersion = parseit Nothing Nothing
where
reportit mname mver = return $ do
name <- mname
ver <- mver
return NotifyClientVersion { versionName=name, versionVersion=ver }
parseit :: Maybe Text -> Maybe Text -> NestingXML o IO (Maybe StanzaType)
parseit mname mver = do
mtag <- nextElement
fromMaybe (reportit mname mver) $ mtag <&> \tag -> do
case tagName tag of
"{jabber:iq:version}name" -> do
x <- XML.content
parseit (Just x) mver
"{jabber:iq:version}version" -> do
x <- XML.content
parseit mname (Just x)
_ -> parseit mname mver
parsePresenceStatus
:: ( MonadThrow m
, MonadIO m
) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
parsePresenceStatus ns stanzaTag = do
let toStat "away" = Away
toStat "xa" = ExtendedAway
toStat "dnd" = DoNotDisturb
toStat "chat" = Chatty
showv <- liftIO . atomically $ newTVar Available
priov <- liftIO . atomically $ newTVar Nothing
statusv <- liftIO . atomically $ newTChan
fix $ \loop -> do
mtag <- nextElement
forM_ mtag $ \tag -> do
when (nameNamespace (tagName tag) == Just ns) $ do
case nameLocalName (tagName tag) of
"show" -> do t <- XML.content
liftIO . atomically $ writeTVar showv (toStat t)
"priority" -> do t <- XML.content
liftIO . handleIO_ (return ()) $ do
prio <- readIO (Text.unpack t)
atomically $ writeTVar priov (Just prio)
"status" -> do t <- XML.content
lang <- xmlLang
ioWriteChan statusv (maybe "" id lang,t)
_ -> return ()
loop
show <- liftIO . atomically $ readTVar showv
prio <- liftIO . atomically $ readTVar priov
status <- liftIO $ chanContents statusv -- Could use unsafeInterleaveIO to
-- avoid multiple passes, but whatever.
let wlist = do
w <- maybeToList $ lookupAttrib "whitelist" (tagAttrs stanzaTag)
Text.words w
return . Just $ PresenceStatus { presenceShow = show
, presencePriority = prio
, presenceStatus = status
, presenceWhiteList = wlist
}
parseMessage
:: ( MonadThrow m
, MonadIO m
) => Text -> XML.Event -> NestingXML o m StanzaType
parseMessage ns stanza = do
let bodytag = Name { nameNamespace = Just ns
, nameLocalName = "body"
, namePrefix = Nothing }
subjecttag = Name { nameNamespace = Just ns
, nameLocalName = "subject"
, namePrefix = Nothing }
threadtag = Name { nameNamespace = Just ns
, nameLocalName = "thread"
, namePrefix = Nothing }
let emptyMsg = LangSpecificMessage { msgBody=Nothing, msgSubject=Nothing }
parseChildren (th,cmap) = do
child <- nextElement
lvl <- nesting
xmllang <- xmlLang
let lang = maybe "" id xmllang
let c = maybe emptyMsg id (Map.lookup lang cmap)
-- log $ " child: "<> bshow child
case child of
Just tag | tagName tag==bodytag
-> do
txt <- XML.content
awaitCloser lvl
parseChildren (th,Map.insert lang (c { msgBody=Just txt }) cmap)
Just tag | tagName tag==subjecttag
-> do
txt <- XML.content
awaitCloser lvl
parseChildren (th,Map.insert lang (c { msgSubject=Just txt }) cmap)
Just tag | tagName tag==threadtag
-> do
txt <- XML.content
awaitCloser lvl
parseChildren (th {msgThreadContent=txt},cmap)
Just tag -> do
-- let nm = tagName tag
-- attrs = tagAttrs tag
-- -- elems = msgElements c
-- txt <- XML.content
awaitCloser lvl
parseChildren (th,Map.insert lang c cmap)
Nothing -> return (th,cmap)
(th,langmap) <- parseChildren ( MessageThread {msgThreadParent=Nothing, msgThreadContent=""}
, Map.empty )
return Message {
msgLangMap = Map.toList langmap,
msgThread = if msgThreadContent th/="" then Just th else Nothing
}
findErrorTag :: Monad m => Text -> NestingXML o m (Maybe StanzaError)
findErrorTag ns = do
x <- nextElement
fmap join $ forM x $ \x ->
case tagName x of
n | nameNamespace n==Just ns && nameLocalName n=="error"
-> do
mtag <- findConditionTag
return $ do
tag <- {- trace ("mtag = "++show mtag) -} mtag
let t = nameLocalName (tagName tag)
conditionFromText t
_ -> findErrorTag ns
findConditionTag :: Monad m => NestingXML o m (Maybe XML.Event)
findConditionTag = do
mx <- nextElement
fmap join $ forM mx $ \x -> do
case nameNamespace (tagName x) of
Just "urn:ietf:params:xml:ns:xmpp-stanzas" -> return (Just x)
_ -> findConditionTag
conditionFromText :: Text -> Maybe StanzaError
conditionFromText t = fmap fst $ listToMaybe ss
where
es = [BadRequest .. UnexpectedRequest]
ts = map (\e->(e,errorTagLocalName e)) es
ss = dropWhile ((/=t) . snd) ts
-- | Converts a CamelCase constructor to a hyphenated lower-case name for use
-- as an xml tag.
errorTagLocalName :: StanzaError -> Text
errorTagLocalName e = Text.pack . drop 1 $ do
c <- show e
if 'A' <= c && c <= 'Z'
then [ '-', chr( ord c - ord 'A' + ord 'a') ]
else return c
|
