summaryrefslogtreecommitdiff
path: root/dht/Presence/Stanza/Parse.hs
diff options
context:
space:
mode:
Diffstat (limited to 'dht/Presence/Stanza/Parse.hs')
-rw-r--r--dht/Presence/Stanza/Parse.hs277
1 files changed, 277 insertions, 0 deletions
diff --git a/dht/Presence/Stanza/Parse.hs b/dht/Presence/Stanza/Parse.hs
new file mode 100644
index 00000000..58bf7c51
--- /dev/null
+++ b/dht/Presence/Stanza/Parse.hs
@@ -0,0 +1,277 @@
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-02 21:04:15 +0000