diff options
Diffstat (limited to 'Presence/XMPPServer.hs')
-rw-r--r-- | Presence/XMPPServer.hs | 29 |
1 files changed, 18 insertions, 11 deletions
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs index f6df1525..0103ba46 100644 --- a/Presence/XMPPServer.hs +++ b/Presence/XMPPServer.hs | |||
@@ -456,22 +456,29 @@ stanzaFromList stype reply = do | |||
456 | mid = stanzaTag >>= lookupAttrib "id" . tagAttrs | 456 | mid = stanzaTag >>= lookupAttrib "id" . tagAttrs |
457 | mfrom = stanzaTag >>= lookupAttrib "from" . tagAttrs | 457 | mfrom = stanzaTag >>= lookupAttrib "from" . tagAttrs |
458 | mto = stanzaTag >>= lookupAttrib "to" . tagAttrs | 458 | mto = stanzaTag >>= lookupAttrib "to" . tagAttrs |
459 | {- | ||
459 | isInternal (InternalEnableHack {}) = True | 460 | isInternal (InternalEnableHack {}) = True |
460 | isInternal (InternalCacheId {}) = True | 461 | isInternal (InternalCacheId {}) = True |
461 | isInternal _ = False | 462 | isInternal _ = False |
462 | atomically $ do | 463 | -} |
463 | donevar <- newEmptyTMVar | 464 | (donevar,replyChan,replyClsrs) <- atomically $ do |
465 | donevar <- newEmptyTMVar -- TMVar () | ||
464 | replyChan <- newLockedChan | 466 | replyChan <- newLockedChan |
465 | replyClsrs <- newTVar (Just []) | 467 | replyClsrs <- newTVar (Just []) |
466 | return Stanza { stanzaType = stype | 468 | return (donevar,replyChan, replyClsrs) |
467 | , stanzaId = mid | 469 | forkIO $ do |
468 | , stanzaTo = mto -- as-is from reply list | 470 | forM_ reply $ atomically . writeLChan replyChan |
469 | , stanzaFrom = mfrom -- as-is from reply list | 471 | atomically $ do putTMVar donevar () |
470 | , stanzaChan = replyChan | 472 | writeTVar replyClsrs Nothing |
471 | , stanzaClosers = replyClsrs | 473 | return Stanza { stanzaType = stype |
472 | , stanzaInterrupt = donevar | 474 | , stanzaId = mid |
473 | , stanzaOrigin = LocalPeer | 475 | , stanzaTo = mto -- as-is from reply list |
474 | } | 476 | , stanzaFrom = mfrom -- as-is from reply list |
477 | , stanzaChan = replyChan | ||
478 | , stanzaClosers = replyClsrs | ||
479 | , stanzaInterrupt = donevar | ||
480 | , stanzaOrigin = LocalPeer | ||
481 | } | ||
475 | 482 | ||
476 | grokStanzaIQGet :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType) | 483 | grokStanzaIQGet :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType) |
477 | grokStanzaIQGet stanza = do | 484 | grokStanzaIQGet stanza = do |