summaryrefslogtreecommitdiff
path: root/Presence/Stanza/Parse.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Presence/Stanza/Parse.hs')
-rw-r--r--Presence/Stanza/Parse.hs261
1 files changed, 261 insertions, 0 deletions
diff --git a/Presence/Stanza/Parse.hs b/Presence/Stanza/Parse.hs
new file mode 100644
index 00000000..50e1e25b
--- /dev/null
+++ b/Presence/Stanza/Parse.hs
@@ -0,0 +1,261 @@
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.Type
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 name -> return $ UnrecognizedQuery name
50
51grokStanzaIQResult :: XML.Event -> NestingXML o IO (Maybe StanzaType)
52grokStanzaIQResult stanza = do
53 mtag <- nextElement
54 fromMaybe (return $ Just Pong) $ mtag <&> \tag -> do
55 case tagName tag of
56 "{jabber:iq:version}query" | nameNamespace (tagName stanza)==Just "jabber:client"
57 -> parseClientVersion
58 _ -> return Nothing
59
60grokStanzaIQSet :: XML.Event -> NestingXML o IO (Maybe StanzaType)
61grokStanzaIQSet stanza = do
62 mtag <- nextElement
63 case tagName <$> mtag of
64 Just "{urn:ietf:params:xml:ns:xmpp-bind}bind"
65 -> do mchild <- nextElement
66 case tagName <$> mchild of
67 Just "{urn:ietf:params:xml:ns:xmpp-bind}resource"
68 -> do rsc <- XML.content -- TODO: MonadThrow???
69 return . Just $ RequestResource Nothing (Just rsc)
70 Just _ -> return Nothing
71 Nothing -> return . Just $ RequestResource Nothing Nothing
72 Just "{urn:ietf:params:xml:ns:xmpp-session}session"
73 -> return $ Just SessionRequest
74 _ -> return Nothing
75
76grokPresence
77 :: ( MonadThrow m
78 , MonadIO m
79 ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
80grokPresence ns stanzaTag = do
81 let typ = lookupAttrib "type" (tagAttrs stanzaTag)
82 case typ of
83 Nothing -> parsePresenceStatus ns stanzaTag
84 Just "unavailable" -> fmap (fmap (\p -> p {presenceShow=Offline}))
85 $ parsePresenceStatus ns stanzaTag
86 Just "error" -> return . Just $ PresenceInformError
87 Just "unsubscribed" -> return . Just $ PresenceInformSubscription False
88 Just "subscribed" -> return . Just $ PresenceInformSubscription True
89 Just "probe" -> return . Just $ PresenceRequestStatus
90 Just "unsubscribe" -> return . Just $ PresenceRequestSubscription False
91 Just "subscribe" -> return . Just $ PresenceRequestSubscription True
92 _ -> return Nothing
93
94grokMessage
95 :: ( MonadThrow m
96 , MonadIO m
97 ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
98grokMessage ns stanzaTag = do
99 let typ = lookupAttrib "type" (tagAttrs stanzaTag)
100 case typ of
101 Just "error" -> do
102 mb <- findErrorTag ns
103 return $ do
104 e <- mb
105 return $ Error e stanzaTag
106 _ -> do t <- parseMessage ns stanzaTag
107 return $ Just t
108
109parseClientVersion :: NestingXML o IO (Maybe StanzaType)
110parseClientVersion = parseit Nothing Nothing
111 where
112 reportit mname mver = return $ do
113 name <- mname
114 ver <- mver
115 return NotifyClientVersion { versionName=name, versionVersion=ver }
116 parseit :: Maybe Text -> Maybe Text -> NestingXML o IO (Maybe StanzaType)
117 parseit mname mver = do
118 mtag <- nextElement
119 fromMaybe (reportit mname mver) $ mtag <&> \tag -> do
120 case tagName tag of
121 "{jabber:iq:version}name" -> do
122 x <- XML.content
123 parseit (Just x) mver
124 "{jabber:iq:version}version" -> do
125 x <- XML.content
126 parseit mname (Just x)
127 _ -> parseit mname mver
128
129parsePresenceStatus
130 :: ( MonadThrow m
131 , MonadIO m
132 ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
133parsePresenceStatus ns stanzaTag = do
134
135 let toStat "away" = Away
136 toStat "xa" = ExtendedAway
137 toStat "dnd" = DoNotDisturb
138 toStat "chat" = Chatty
139
140 showv <- liftIO . atomically $ newTVar Available
141 priov <- liftIO . atomically $ newTVar Nothing
142 statusv <- liftIO . atomically $ newTChan
143 fix $ \loop -> do
144 mtag <- nextElement
145 forM_ mtag $ \tag -> do
146 when (nameNamespace (tagName tag) == Just ns) $ do
147 case nameLocalName (tagName tag) of
148 "show" -> do t <- XML.content
149 liftIO . atomically $ writeTVar showv (toStat t)
150 "priority" -> do t <- XML.content
151 liftIO . handleIO_ (return ()) $ do
152 prio <- readIO (Text.unpack t)
153 atomically $ writeTVar priov (Just prio)
154 "status" -> do t <- XML.content
155 lang <- xmlLang
156 ioWriteChan statusv (maybe "" id lang,t)
157 _ -> return ()
158 loop
159 show <- liftIO . atomically $ readTVar showv
160 prio <- liftIO . atomically $ readTVar priov
161 status <- liftIO $ chanContents statusv -- Could use unsafeInterleaveIO to
162 -- avoid multiple passes, but whatever.
163 let wlist = do
164 w <- maybeToList $ lookupAttrib "whitelist" (tagAttrs stanzaTag)
165 Text.words w
166 return . Just $ PresenceStatus { presenceShow = show
167 , presencePriority = prio
168 , presenceStatus = status
169 , presenceWhiteList = wlist
170 }
171parseMessage
172 :: ( MonadThrow m
173 , MonadIO m
174 ) => Text -> XML.Event -> NestingXML o m StanzaType
175parseMessage ns stanza = do
176 let bodytag = Name { nameNamespace = Just ns
177 , nameLocalName = "body"
178 , namePrefix = Nothing }
179 subjecttag = Name { nameNamespace = Just ns
180 , nameLocalName = "subject"
181 , namePrefix = Nothing }
182 threadtag = Name { nameNamespace = Just ns
183 , nameLocalName = "thread"
184 , namePrefix = Nothing }
185 let emptyMsg = LangSpecificMessage { msgBody=Nothing, msgSubject=Nothing }
186 parseChildren (th,cmap) = do
187 child <- nextElement
188 lvl <- nesting
189 xmllang <- xmlLang
190 let lang = maybe "" id xmllang
191 let c = maybe emptyMsg id (Map.lookup lang cmap)
192 -- log $ " child: "<> bshow child
193 case child of
194 Just tag | tagName tag==bodytag
195 -> do
196 txt <- XML.content
197 awaitCloser lvl
198 parseChildren (th,Map.insert lang (c { msgBody=Just txt }) cmap)
199 Just tag | tagName tag==subjecttag
200 -> do
201 txt <- XML.content
202 awaitCloser lvl
203 parseChildren (th,Map.insert lang (c { msgSubject=Just txt }) cmap)
204 Just tag | tagName tag==threadtag
205 -> do
206 txt <- XML.content
207 awaitCloser lvl
208 parseChildren (th {msgThreadContent=txt},cmap)
209 Just tag -> do
210 -- let nm = tagName tag
211 -- attrs = tagAttrs tag
212 -- -- elems = msgElements c
213 -- txt <- XML.content
214 awaitCloser lvl
215 parseChildren (th,Map.insert lang c cmap)
216 Nothing -> return (th,cmap)
217 (th,langmap) <- parseChildren ( MessageThread {msgThreadParent=Nothing, msgThreadContent=""}
218 , Map.empty )
219 return Message {
220 msgLangMap = Map.toList langmap,
221 msgThread = if msgThreadContent th/="" then Just th else Nothing
222 }
223
224findErrorTag :: Monad m => Text -> NestingXML o m (Maybe StanzaError)
225findErrorTag ns = do
226 x <- nextElement
227 fmap join $ forM x $ \x ->
228 case tagName x of
229 n | nameNamespace n==Just ns && nameLocalName n=="error"
230 -> do
231 mtag <- findConditionTag
232 return $ do
233 tag <- {- trace ("mtag = "++show mtag) -} mtag
234 let t = nameLocalName (tagName tag)
235 conditionFromText t
236 _ -> findErrorTag ns
237
238findConditionTag :: Monad m => NestingXML o m (Maybe XML.Event)
239findConditionTag = do
240 mx <- nextElement
241 fmap join $ forM mx $ \x -> do
242 case nameNamespace (tagName x) of
243 Just "urn:ietf:params:xml:ns:xmpp-stanzas" -> return (Just x)
244 _ -> findConditionTag
245
246conditionFromText :: Text -> Maybe StanzaError
247conditionFromText t = fmap fst $ listToMaybe ss
248 where
249 es = [BadRequest .. UnexpectedRequest]
250 ts = map (\e->(e,errorTagLocalName e)) es
251 ss = dropWhile ((/=t) . snd) ts
252
253-- | Converts a CamelCase constructor to a hyphenated lower-case name for use
254-- as an xml tag.
255errorTagLocalName :: StanzaError -> Text
256errorTagLocalName e = Text.pack . drop 1 $ do
257 c <- show e
258 if 'A' <= c && c <= 'Z'
259 then [ '-', chr( ord c - ord 'A' + ord 'a') ]
260 else return c
261
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 16:01:22 +0000