diff options
Diffstat (limited to 'Presence/XMPPServer.hs')
-rw-r--r-- | Presence/XMPPServer.hs | 43 |
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 | |||
479 | startPeer session_factory sock st = do | 479 | startPeer 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 | ||
487 | doPeer st elem cont = do | 487 | doPeer 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 | ||
631 | splitJID :: ByteString -> (Maybe ByteString,ByteString,Maybe ByteString) | 631 | splitJID :: 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) $ |