summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Presence/ServerC.hs4
-rw-r--r--Presence/XMPP.hs20
2 files changed, 22 insertions, 2 deletions
diff --git a/Presence/ServerC.hs b/Presence/ServerC.hs
index ae0bf154..b16a0099 100644
--- a/Presence/ServerC.hs
+++ b/Presence/ServerC.hs
@@ -125,9 +125,9 @@ packets h = do
125 125
126outgoing :: MonadIO m => Handle -> Sink S.ByteString m () 126outgoing :: MonadIO m => Handle -> Sink S.ByteString m ()
127outgoing h = do 127outgoing h = do
128 liftIO . L.putStrLn $ "outgoing: waiting" 128 -- liftIO . L.putStrLn $ "outgoing: waiting"
129 mpacket <- await 129 mpacket <- await
130 liftIO . L.putStrLn $ "outgoing: got packet " <++> bshow mpacket 130 -- liftIO . L.putStrLn $ "outgoing: got packet " <++> bshow mpacket
131 maybe (return ()) 131 maybe (return ())
132 (\r -> (liftIO . S.hPutStrLn h $ r) >> outgoing h) 132 (\r -> (liftIO . S.hPutStrLn h $ r) >> outgoing h)
133 mpacket 133 mpacket
diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index e15b10cc..5435c913 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -282,6 +282,23 @@ handleIQSetBind session cmdChan stanza_id = do
282 atomically $ writeTChan cmdChan (Send $ iq_bind_reply stanza_id (toStrict $ L.decodeUtf8 $ L.show jid) ) 282 atomically $ writeTChan cmdChan (Send $ iq_bind_reply stanza_id (toStrict $ L.decodeUtf8 $ L.show jid) )
283 _ -> unhandledBind 283 _ -> unhandledBind
284 284
285
286iq_session_reply host stanza_id =
287 [ EventBeginElement "{jabber:client}iq"
288 [("id",[ContentText stanza_id])
289 ,("from",[ContentText host])
290 ,("type",[ContentText "result"])
291 ]
292 , EventEndElement "{jabber:client}iq"
293 ]
294
295handleIQSetSession session cmdChan stanza_id = do
296 host <- liftIO $ do
297 jid <- getJID session
298 names <- getNamesForPeer (peer jid)
299 return (S.decodeUtf8 . head $ names)
300 liftIO . atomically . writeTChan cmdChan . Send $ iq_session_reply host stanza_id
301
285handleIQSet session cmdChan tag = do 302handleIQSet session cmdChan tag = do
286 withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do 303 withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do
287 whenJust nextElement $ \child -> do 304 whenJust nextElement $ \child -> do
@@ -289,6 +306,8 @@ handleIQSet session cmdChan tag = do
289 case tagName child of 306 case tagName child of
290 "{urn:ietf:params:xml:ns:xmpp-bind}bind" 307 "{urn:ietf:params:xml:ns:xmpp-bind}bind"
291 -> handleIQSetBind session cmdChan stanza_id 308 -> handleIQSetBind session cmdChan stanza_id
309 "{urn:ietf:params:xml:ns:xmpp-session}session"
310 -> handleIQSetSession session cmdChan stanza_id
292 _ -> unhandledSet 311 _ -> unhandledSet
293 312
294matchAttrib name value attrs = 313matchAttrib name value attrs =
@@ -329,6 +348,7 @@ fromClient session cmdChan = doNestingXML $ do
329 send $ greet host 348 send $ greet host
330 349
331 fix $ \loop -> do 350 fix $ \loop -> do
351 log "waiting for stanza."
332 whenJust nextElement $ \stanza -> do 352 whenJust nextElement $ \stanza -> do
333 stanza_lvl <- nesting 353 stanza_lvl <- nesting
334 354