summaryrefslogtreecommitdiff
path: root/Presence/XMPP.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Presence/XMPP.hs')
-rw-r--r--Presence/XMPP.hs35
1 files changed, 18 insertions, 17 deletions
diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 4c8beec4..36630bc7 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -130,8 +130,8 @@ greet host =
130 ,("version",[ContentText "1.0"]) 130 ,("version",[ContentText "1.0"])
131 ] 131 ]
132 , EventBeginElement (streamP "features") [] 132 , EventBeginElement (streamP "features") []
133 , EventBeginElement "bind" [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])] 133 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind" []
134 , EventEndElement "bind" 134 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
135 135
136 {- 136 {-
137 -- , " <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>" 137 -- , " <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>"
@@ -149,6 +149,7 @@ greet host =
149mawait :: Monad m => MaybeT (ConduitM i o m) i 149mawait :: Monad m => MaybeT (ConduitM i o m) i
150mawait = MaybeT await 150mawait = MaybeT await
151 151
152-- Note: This function ignores name space qualification
152elementAttrs expected (EventBeginElement name attrs) 153elementAttrs expected (EventBeginElement name attrs)
153 | nameLocalName name==expected 154 | nameLocalName name==expected
154 = return attrs 155 = return attrs
@@ -437,15 +438,16 @@ prettyPrint prefix xs =
437 438
438toClient :: MonadIO m => TChan Presence -> TChan Commands -> Source m [XML.Event] 439toClient :: MonadIO m => TChan Presence -> TChan Commands -> Source m [XML.Event]
439toClient pchan cmdChan = fix $ \loop -> do 440toClient pchan cmdChan = fix $ \loop -> do
441 let send xs = yield xs >> prettyPrint ">C: " xs
440 event <- liftIO . atomically $ 442 event <- liftIO . atomically $
441 orElse (fmap Left $ readTChan pchan) 443 orElse (fmap Left $ readTChan pchan)
442 (fmap Right $ readTChan cmdChan) 444 (fmap Right $ readTChan cmdChan)
443 case event of 445 case event of
444 Right QuitThread -> return () 446 Right QuitThread -> return ()
445 Right (Send xs) -> yield xs >> prettyPrint ">C: " xs >> loop 447 Right (Send xs) -> send xs >> loop
446 Left presence -> do 448 Left presence -> do
447 xs <- liftIO $ xmlifyPresenceForClient presence 449 xs <- liftIO $ xmlifyPresenceForClient presence
448 yield xs 450 send xs
449 loop 451 loop
450 452
451handleClient 453handleClient
@@ -580,11 +582,14 @@ matchAttribMaybe name (Just value) attrs =
580matchAttribMaybe name Nothing attrs 582matchAttribMaybe name Nothing attrs
581 | find ( (==name) . fst) attrs==Nothing 583 | find ( (==name) . fst) attrs==Nothing
582 = True 584 = True
585matchAttribMaybe name Nothing attrs
586 | otherwise
587 = False
583 588
584presenceTypeOffline = Just "unavailable" 589presenceTypeOffline = Just "unavailable"
585presenceTypeOnline = Nothing 590presenceTypeOnline = Nothing
586 591
587isPresence (EventBeginElement name attrs) testType 592isPresenceOf (EventBeginElement name attrs) testType
588 | name=="{jabber:server}presence" 593 | name=="{jabber:server}presence"
589 && matchAttribMaybe "type" testType attrs 594 && matchAttribMaybe "type" testType attrs
590 = True 595 = True
@@ -611,7 +616,7 @@ fromPeer session = doNestingXML $ do
611 withJust mb $ \xs -> prettyPrint "P: " (toList xs) 616 withJust mb $ \xs -> prettyPrint "P: " (toList xs)
612 case () of 617 case () of
613 _ | stanza `isPresenceOf` presenceTypeOnline 618 _ | stanza `isPresenceOf` presenceTypeOnline
614 -> handlePeerPresence session stanza True 619 -> log "peer online!" >> handlePeerPresence session stanza True
615 _ | stanza `isPresenceOf` presenceTypeOffline 620 _ | stanza `isPresenceOf` presenceTypeOffline
616 -> handlePeerPresence session stanza False 621 -> handlePeerPresence session stanza False
617 _ -> unhandledStanza 622 _ -> unhandledStanza
@@ -681,34 +686,30 @@ greetPeer =
681 [ EventBeginDocument 686 [ EventBeginDocument
682 , EventBeginElement (streamP "stream") 687 , EventBeginElement (streamP "stream")
683 [("xmlns",[ContentText "jabber:server"]) 688 [("xmlns",[ContentText "jabber:server"])
684 ,("xmlns:stream",[ContentText "http://etherx.jabber.org/streams"])
685 ,("version",[ContentText "1.0"]) 689 ,("version",[ContentText "1.0"])
686 ] 690 ]
687 ] 691 ]
688 692
689goodbyePeer = 693goodbyePeer =
690 [ EventEndElement "{jabber:server}stream" 694 [ EventEndElement (streamP "stream")
691 , EventEndDocument 695 , EventEndDocument
692 ] 696 ]
693 697
694toPeer sock cache chan = do 698toPeer sock cache chan = do
695 let log = liftIO . L.putStrLn . ("(>P) " <++>) 699 let -- log = liftIO . L.putStrLn . ("(>P) " <++>)
696 yield greetPeer 700 send xs = yield xs >> prettyPrint ">P: " xs
697 log "<stream>" 701 send greetPeer
698 forM_ cache $ \(jid,st) -> do 702 forM_ cache $ \(jid,st) -> do
699 r <- lift $ xmlifyPresenceForPeer sock (Presence jid st) 703 r <- lift $ xmlifyPresenceForPeer sock (Presence jid st)
700 yield r 704 send r
701 log $ "(cache) \n" <++> bshow r
702 fix $ \loop -> do 705 fix $ \loop -> do
703 event <- lift . atomically $ readTChan chan 706 event <- lift . atomically $ readTChan chan
704 case event of 707 case event of
705 OutBoundPresence p -> do 708 OutBoundPresence p -> do
706 r <- lift $ xmlifyPresenceForPeer sock p 709 r <- lift $ xmlifyPresenceForPeer sock p
707 yield r 710 send r
708 log (bshow r)
709 loop 711 loop
710 yield goodbyePeer 712 send goodbyePeer
711 log "</stream>"
712 713
713handleOutgoingToPeer sock cache chan snk = do 714handleOutgoingToPeer sock cache chan snk = do
714#ifdef RENDERFLUSH 715#ifdef RENDERFLUSH