summaryrefslogtreecommitdiff
path: root/Presence/XMPPServer.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Presence/XMPPServer.hs')
-rw-r--r--Presence/XMPPServer.hs43
1 files changed, 21 insertions, 22 deletions
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index c9decd6c..58dcf430 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -242,7 +242,7 @@ startCon session_factory sock st = do
242 -- a resource is bound. 242 -- a resource is bound.
243 r <- xmlifyPresenceForClient presence 243 r <- xmlifyPresenceForClient presence
244 hPutStrLn h r 244 hPutStrLn h r
245 L.putStrLn $ "\nOUT:\n" <++> r 245 L.putStrLn $ "\nOUT client:\n" <++> r
246 Right (Send r) -> 246 Right (Send r) ->
247 hPutStrLn h r 247 hPutStrLn h r
248 loop 248 loop
@@ -361,14 +361,14 @@ doCon st elem cont = do
361 hsend r = do 361 hsend r = do
362 atomically $ writeTChan cmdChan (Send r) 362 atomically $ writeTChan cmdChan (Send r)
363 -- hPutStrLn h r 363 -- hPutStrLn h r
364 L.putStrLn $ "\nOUT:\n" <++> r 364 L.putStrLn $ "\nOUT client:\n" <++> r
365 -- host <- fmap pack $ getHostName -- Assume localhost for client session JID 365 -- host <- fmap pack $ getHostName -- Assume localhost for client session JID
366 host <- do 366 host <- do
367 jid <- getJID session 367 jid <- getJID session
368 names <- getNamesForPeer (peer jid) 368 names <- getNamesForPeer (peer jid)
369 return (head names) 369 return (head names)
370 370
371 putStrLn $ (Prelude.show $ hang (text "\nIN:") 2 $ pp elem) ++ "\n" 371 putStrLn $ (Prelude.show $ hang (text "\nIN client:") 2 $ pp elem) ++ "\n"
372 372
373 case elem of 373 case elem of
374 OpenTag _ -> 374 OpenTag _ ->
@@ -479,33 +479,33 @@ listenForXmppClients session_factory port st = do
479startPeer session_factory sock st = do 479startPeer session_factory sock st = do
480 let h = hOccursFst st :: Handle 480 let h = hOccursFst st :: Handle
481 name <- fmap bshow $ getPeerName sock 481 name <- fmap bshow $ getPeerName sock
482 L.putStrLn $ "REMOTE-IN: connected " <++> name 482 L.putStrLn $ "IN peer: connected " <++> name
483 let quit = L.putStrLn $ "REMOTE-IN: disconnected " <++> name 483 let quit = L.putStrLn $ "IN peer: disconnected " <++> name
484 session <- newSession session_factory sock h 484 session <- newSession session_factory sock h
485 return ( session .*. ConnectionFinalizer quit .*. st ) 485 return ( session .*. ConnectionFinalizer quit .*. st )
486 486
487doPeer st elem cont = do 487doPeer st elem cont = do
488 let session = hHead st 488 let session = hHead st
489 L.putStrLn $ "REMOTE-IN: received " <++> bshow elem 489 L.putStrLn $ "IN peer: " <++> bshow elem
490 case elem of 490 case elem of
491 Element e@(Elem (N "presence") attrs content) -> do 491 Element e@(Elem (N "presence") attrs content) -> do
492 let jid = fmap pack (lookup (N "from") attrs >>= unattr) 492 let jid = fmap pack (lookup (N "from") attrs >>= unattr)
493 typ = fmap pack (lookup (N "type") attrs >>= unattr) 493 typ = fmap pack (lookup (N "type") attrs >>= unattr)
494 case (jid,typ) of 494 case (jid,typ) of
495 (Just jid,Just "unavailable") -> do 495 (Just jid,Just "unavailable") -> do
496 L.putStrLn $ "INBOUND PRESENCE! Offline jid=" <++> jid 496 L.putStrLn $ "IN peer: PRESENCE! Offline jid=" <++> jid
497 -- parseAddressJID -- convert peer reported user@address to JID data structure 497 -- parseAddressJID -- convert peer reported user@address to JID data structure
498 peer_jid <- parseAddressJID jid 498 peer_jid <- parseAddressJID jid
499 announcePresence session (Presence peer_jid Offline) 499 announcePresence session (Presence peer_jid Offline)
500 (Just jid,Just typ) -> 500 (Just jid,Just typ) ->
501 -- possible probe, ignored for now 501 -- possible probe, ignored for now
502 L.putStrLn $ "INBOUND PRESENCE! "<++>typ<++>" jid="<++>jid 502 L.putStrLn $ "IN peer: PRESENCE! "<++>typ<++>" jid="<++>jid
503 (Just jid,Nothing) -> do 503 (Just jid,Nothing) -> do
504 let string (CString _ s _) = [s] 504 let string (CString _ s _) = [s]
505 stat = listToMaybe . Prelude.concatMap string . tagcontent "show" $ content 505 stat = listToMaybe . Prelude.concatMap string . tagcontent "show" $ content
506 -- Available or Away. 506 -- Available or Away.
507 names <- parseAddressJID jid >>= getNamesForPeer . peer 507 names <- parseAddressJID jid >>= getNamesForPeer . peer
508 L.putStrLn $ "INBOUND PRESENCE! "<++>bshow (stat,names)<++>" avail/away jid=" <++> jid 508 L.putStrLn $ "IN peer: PRESENCE! "<++>bshow (stat,names)<++>" avail/away jid=" <++> jid
509 -- todo: announcePresence 509 -- todo: announcePresence
510 _ -> return () -- putStrLn $ "inbound unhandled: "++show v 510 _ -> return () -- putStrLn $ "inbound unhandled: "++show v
511 cont () 511 cont ()
@@ -553,16 +553,16 @@ sendMessage cons msg peer = do
553 let newEntry = do 553 let newEntry = do
554 chan <- atomically newTChan 554 chan <- atomically newTChan
555 t <- forkIO $ connect_to_server chan peer 555 t <- forkIO $ connect_to_server chan peer
556 L.putStrLn $ "remote-map new: " <++> showPeer peer 556 -- L.putStrLn $ "remote-map new: " <++> showPeer peer
557 return (True,(chan,t)) 557 return (True,(chan,t))
558 (is_new,entry) <- maybe newEntry 558 (is_new,entry) <- maybe newEntry
559 ( \(chan,t) -> do 559 ( \(chan,t) -> do
560 st <- threadStatus t 560 st <- threadStatus t
561 let running = do 561 let running = do
562 L.putStrLn $ "remote-map, thread running: " <++> showPeer peer 562 -- L.putStrLn $ "remote-map, thread running: " <++> showPeer peer
563 return (False,(chan,t)) 563 return (False,(chan,t))
564 died = do 564 died = do
565 L.putStrLn $ "remote-map, thread died("<++>bshow st<++>"): " <++> showPeer peer 565 -- L.putStrLn $ "remote-map, thread died("<++>bshow st<++>"): " <++> showPeer peer
566 newEntry 566 newEntry
567 case st of 567 case st of
568 ThreadRunning -> running 568 ThreadRunning -> running
@@ -571,7 +571,7 @@ sendMessage cons msg peer = do
571 ThreadFinished -> died 571 ThreadFinished -> died
572 ) 572 )
573 found 573 found
574 L.putStrLn $ "sendMessage ->"<++>showPeer peer<++>": "<++>bshow msg 574 -- L.putStrLn $ "sendMessage ->"<++>showPeer peer<++>": "<++>bshow msg
575 atomically $ writeTChan (fst entry) msg 575 atomically $ writeTChan (fst entry) msg
576 when is_new . atomically $ 576 when is_new . atomically $
577 readTVar cons >>= writeTVar cons . Map.insert peer entry 577 readTVar cons >>= writeTVar cons . Map.insert peer entry
@@ -609,23 +609,23 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do
609 h <- socketToHandle sock ReadWriteMode 609 h <- socketToHandle sock ReadWriteMode
610 hSetBuffering h NoBuffering 610 hSetBuffering h NoBuffering
611 hPutStrLn h "<stream>" 611 hPutStrLn h "<stream>"
612 L.putStrLn $ "REMOTE-OUT: <stream>" 612 L.putStrLn $ "OUT peer: <stream>"
613 cache <- fmap Map.assocs . readIORef $ cached 613 cache <- fmap Map.assocs . readIORef $ cached
614 writeIORef cached Map.empty -- hint garbage collector: we're done with this 614 writeIORef cached Map.empty -- hint garbage collector: we're done with this
615 forM_ cache $ \(jid,st) -> do 615 forM_ cache $ \(jid,st) -> do
616 r <- xmlifyPresenceForPeer sock (Presence jid st) 616 r <- xmlifyPresenceForPeer sock (Presence jid st)
617 hPutStrLn h r 617 hPutStrLn h r
618 L.putStrLn $ "REMOTE-OUT (cache):\n" <++> r <++> "\n" 618 L.putStrLn $ "OUT peer: (cache)\n" <++> r <++> "\n"
619 fix $ \loop -> do 619 fix $ \loop -> do
620 event <- atomically $ readTChan chan 620 event <- atomically $ readTChan chan
621 case event of 621 case event of
622 OutBoundPresence p -> do 622 OutBoundPresence p -> do
623 r <- xmlifyPresenceForPeer sock p 623 r <- xmlifyPresenceForPeer sock p
624 hPutStrLn h r 624 hPutStrLn h r
625 L.putStrLn $ "REMOTE-OUT:\n" <++> r <++> "\n" 625 L.putStrLn $ "OUT peer:\n" <++> r <++> "\n"
626 loop 626 loop
627 hPutStrLn h "</stream>" 627 hPutStrLn h "</stream>"
628 L.putStrLn $ "REMOTE-OUT: </stream>" 628 L.putStrLn $ "OUT peer: </stream>"
629 629
630 630
631splitJID :: ByteString -> (Maybe ByteString,ByteString,Maybe ByteString) 631splitJID :: ByteString -> (Maybe ByteString,ByteString,Maybe ByteString)
@@ -653,7 +653,7 @@ parseAddressJID jid = do
653 hints = Just $ defaultHints { addrFlags = [ {- AI_NUMERICHOST, -} AI_CANONNAME ] } 653 hints = Just $ defaultHints { addrFlags = [ {- AI_NUMERICHOST, -} AI_CANONNAME ] }
654 peer_string' = unpack . strip_brackets $ peer_string 654 peer_string' = unpack . strip_brackets $ peer_string
655 peer <- do 655 peer <- do
656 putStrLn $ "getAddrInfo 2 " ++ Prelude.show ( Just (unpack peer_string)) 656 -- putStrLn $ "getAddrInfo 2 " ++ Prelude.show ( Just (unpack peer_string))
657 info <- getAddrInfo hints (Just peer_string') Nothing -- (Just "xmpp-server") 657 info <- getAddrInfo hints (Just peer_string') Nothing -- (Just "xmpp-server")
658 let info0 = head info 658 let info0 = head info
659 return . RemotePeer . addrAddress $ info0 659 return . RemotePeer . addrAddress $ info0
@@ -667,7 +667,7 @@ parseHostNameJID jid = do
667 if peer_string=="localhost" 667 if peer_string=="localhost"
668 then return LocalHost 668 then return LocalHost
669 else do 669 else do
670 putStrLn $ "getAddrInfo 3 " ++ Prelude.show ( Just (unpack peer_string)) 670 -- putStrLn $ "getAddrInfo 3 " ++ Prelude.show ( Just (unpack peer_string))
671 info <- getAddrInfo hints (Just (unpack peer_string)) Nothing -- (Just "xmpp-server") 671 info <- getAddrInfo hints (Just (unpack peer_string)) Nothing -- (Just "xmpp-server")
672 let info0 = head info 672 let info0 = head info
673 cname = addrCanonName info0 673 cname = addrCanonName info0
@@ -737,14 +737,13 @@ seekRemotePeers config chan = do
737 event <- atomically $ readTChan chan 737 event <- atomically $ readTChan chan
738 case event of 738 case event of
739 p@(Presence jid stat) -> do 739 p@(Presence jid stat) -> do
740 L.putStrLn $ "seekRemotePeers: " <++> L.show jid <++> " " <++> bshow stat 740 -- L.putStrLn $ "seekRemotePeers: " <++> L.show jid <++> " " <++> bshow stat
741 runMaybeT $ do 741 runMaybeT $ do
742 u <- MaybeT . return $ name jid 742 u <- MaybeT . return $ name jid
743 subscribers <- liftIO $ do 743 subscribers <- liftIO $ do
744 subs <- getSubscribers config u 744 subs <- getSubscribers config u
745 mapM parseHostNameJID subs 745 mapM parseHostNameJID subs
746 liftIO . L.putStrLn $ "subscribers: " <++> bshow subscribers 746 -- liftIO . L.putStrLn $ "subscribers: " <++> bshow subscribers
747 -- parseJID -- get subscriber list reported user@hostname to JID data structure
748 let peers = Set.map peer (Set.fromList subscribers) 747 let peers = Set.map peer (Set.fromList subscribers)
749 forM_ (Set.toList peers) $ \peer -> do 748 forM_ (Set.toList peers) $ \peer -> do
750 when (is_remote peer) $ 749 when (is_remote peer) $