summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Presence/AdaptServer.hs6
-rw-r--r--Presence/Server.hs4
-rw-r--r--Presence/XMPPServer.hs43
3 files changed, 26 insertions, 27 deletions
diff --git a/Presence/AdaptServer.hs b/Presence/AdaptServer.hs
index 3b57266c..eca4cb1e 100644
--- a/Presence/AdaptServer.hs
+++ b/Presence/AdaptServer.hs
@@ -15,7 +15,7 @@ adaptStartCon start sock st = do
15 return (HCons rsRef st') 15 return (HCons rsRef st')
16 16
17adaptDoCon showlex (dropTill,lex,parse) g st bs cont = do 17adaptDoCon showlex (dropTill,lex,parse) g st bs cont = do
18 putStrLn $ "packet: " ++ show bs 18 -- putStrLn $ "packet: " ++ show bs
19 let (HCons rsRef st') = st 19 let (HCons rsRef st') = st
20 rs <- readIORef rsRef 20 rs <- readIORef rsRef
21 21
@@ -27,11 +27,11 @@ adaptDoCon showlex (dropTill,lex,parse) g st bs cont = do
27 case e of 27 case e of
28 Left err -> if null rs' 28 Left err -> if null rs'
29 then contR "" () 29 then contR "" ()
30 else trace ("parse error "++show (err,bs,showlex lexemes,showlex rs')) $ do 30 else -- trace ("parse error "++show (err,bs,showlex lexemes,showlex rs')) $ do
31 contR rem () 31 contR rem ()
32 Right e -> do 32 Right e -> do
33 -- writeIORef rsRef rs' 33 -- writeIORef rsRef rs'
34 g st' e (\() -> do { putStrLn ("LOOP "++showlex rs'); loop (dropTill rem rs') rs' }) 34 g st' e (\() -> do { {- putStrLn ("LOOP "++showlex rs'); -} loop (dropTill rem rs') rs' })
35 loop rem [] = contR "" () 35 loop rem [] = contR "" ()
36 let buf = rs <++> bs 36 let buf = rs <++> bs
37 when (L.length buf < 8192) 37 when (L.length buf < 8192)
diff --git a/Presence/Server.hs b/Presence/Server.hs
index a9bd4112..b611fae8 100644
--- a/Presence/Server.hs
+++ b/Presence/Server.hs
@@ -60,8 +60,8 @@ doServer
60 -> IO Socket 60 -> IO Socket
61-} 61-}
62doServer port g startCon = do 62doServer port g startCon = do
63 -- doServer' AF_INET port g startCon
64 doServer' AF_INET6 port g startCon 63 doServer' AF_INET6 port g startCon
64 -- doServer' AF_INET port g startCon
65 65
66doServer' family port g startCon = runServer2 port (runConn2 g) 66doServer' family port g startCon = runServer2 port (runConn2 g)
67 where 67 where
@@ -88,7 +88,7 @@ doServer' family port g startCon = runServer2 port (runConn2 g)
88 setSocketOption sock ReuseAddr 1 88 setSocketOption sock ReuseAddr 1
89 case family of 89 case family of
90 AF_INET -> bindSocket sock (SockAddrInet port iNADDR_ANY) 90 AF_INET -> bindSocket sock (SockAddrInet port iNADDR_ANY)
91 AF_INET6 -> bindSocket sock (SockAddrInet6 port 0 iN6ADDR_ANY 8) 91 AF_INET6 -> bindSocket sock (SockAddrInet6 port 0 iN6ADDR_ANY 0)
92 listen sock 2 92 listen sock 2
93 forkIO $ do 93 forkIO $ do
94 mainLoop sock (ConnId 0) go 94 mainLoop sock (ConnId 0) go
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) $