summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Presence/AdaptServer.hs59
-rw-r--r--Presence/XMPPServer.hs48
2 files changed, 24 insertions, 83 deletions
diff --git a/Presence/AdaptServer.hs b/Presence/AdaptServer.hs
index da3ab523..2ef07038 100644
--- a/Presence/AdaptServer.hs
+++ b/Presence/AdaptServer.hs
@@ -3,9 +3,9 @@
3module AdaptServer where 3module AdaptServer where
4 4
5import Data.IORef 5import Data.IORef
6import Debug.Trace 6-- import Debug.Trace
7import Data.HList 7import Data.HList
8import Network.Socket (Socket) 8-- import Network.Socket (Socket)
9import qualified Data.ByteString.Lazy.Char8 as L 9import qualified Data.ByteString.Lazy.Char8 as L
10import ByteStringOperators 10import ByteStringOperators
11 11
@@ -18,46 +18,6 @@ adaptDoCon (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 {- parse error
22 - ( "Expected <? but found <\n in file remote-inbound at line 1 col 1"
23 - , Chunk "<presence from='" Empty ,
24 -
25 - [(file remote-inbound at line 1 col 1 ,<)
26 - ,(file remote-inbound at line 1 col 2 ,presence)
27 - ,(file remote-inbound at line 1 col 11 ,from)
28 - ,(file remote-inbound at line 1 col 15 ,=)
29 - ,(file remote-inbound at line 1 col 16 ,' or ")
30 - ,(file remote-inbound at line 1 col 17 ,Lexical error:
31 - unexpected EOF while looking for closing token '
32 - to match the opening token in file remote-inbound at line 1 col 17)
33 - ]
34 -
35 - )
36 -}
37 -- rs' =
38 -- ,[(file remote-inbound at line 1 col 2 ,presence)
39 -- ,(file remote-inbound at line 1 col 11 ,from)
40 -- ,(file remote-inbound at line 1 col 15 ,=)
41 -- ,(file remote-inbound at line 1 col 16 ,' or ")
42 -- ,(file remote-inbound at line 1 col 17 ,Lexical error:
43 -- unexpected EOF while looking for closing token '
44 -- to match the opening token in file remote-inbound at line 1 col 17)
45 -- ]
46 -- )
47 -- let parse' ls = let (e,rs') = parse ls
48
49 {- parse error ("Expected <? but found <\n in file remote-inbound at line 1 col 1"
50 - ,Chunk "<presence from='" Empty
51 - ,[(file remote-inbound at line 1 col 1 ,<)
52 - ,(file remote-inbound at line 1 col 2 ,presence)
53 - ,(file remote-inbound at line 1 col 11 ,from)
54 - ,(file remote-inbound at line 1 col 15 ,=)
55 - ,(file remote-inbound at line 1 col 16 ,' or ")]
56 - ,[(file remote-inbound at line 1 col 2 ,presence)
57 - ,(file remote-inbound at line 1 col 11 ,from)
58 - ,(file remote-inbound at line 1 col 15 ,=)
59 - ,(file remote-inbound at line 1 col 16 ,' or ")])
60 -}
61 21
62 let contR rem v = do 22 let contR rem v = do
63 writeIORef rsRef rem 23 writeIORef rsRef rem
@@ -67,24 +27,15 @@ adaptDoCon (dropTill,lex,parse) g st bs cont = do
67 case e of 27 case e of
68 Left err -> if null rs' 28 Left err -> if null rs'
69 then contR "" () 29 then contR "" ()
70 else trace ("parse error "++show (err,bs,lexemes,rs')) $ do 30 else -- trace ("parse error "++show (err,bs,lexemes,rs')) $ do
71 contR rem () 31 contR rem ()
72 Right e -> do 32 Right e -> do
73 -- writeIORef rsRef rs' 33 -- writeIORef rsRef rs'
74 g st' e (\() -> loop (dropTill rem rs') rs') 34 g st' e (\() -> loop (dropTill rem rs') rs')
75 loop rem [] = contR "" () 35 loop rem [] = contR "" ()
76 let buf = rs <++> bs 36 let buf = rs <++> bs
77 when (L.length buf < 4096) 37 when (L.length buf < 8192)
78 (loop buf (lex buf)) 38 (loop buf (lex buf))
79 39
80{- 40
81adaptServer ::
82 (Show err, Show raw,Show lexemes)
83 =>
84 (raw -> [lexemes], [lexemes] -> (Either err msg, [lexemes]))
85 -> (Socket -> st -> IO st',
86 st' -> msg -> (()->IO ()) -> IO ())
87 -> (Socket -> st -> IO (HCons (IORef [lexemes]) st'),
88 HCons (IORef [lexemes]) st' -> raw -> (()->IO ()) -> IO ())
89-}
90adaptServer (dropTill,lex,parse) (startCon,doCon) = (adaptStartCon startCon, adaptDoCon (dropTill,lex,parse) doCon) 41adaptServer (dropTill,lex,parse) (startCon,doCon) = (adaptStartCon startCon, adaptDoCon (dropTill,lex,parse) doCon)
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 76c14f52..4f61646f 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -38,7 +38,6 @@ import Text.XML.HaXml.Parse (XParser,xmlParseWith,element,{-doctypedecl,-}proce
38import Text.XML.HaXml.Types as Hax hiding (Element) -- (ElemTag,QName(..),Namespace(..),Element(..),Content(..),AttValue(..)) 38import Text.XML.HaXml.Types as Hax hiding (Element) -- (ElemTag,QName(..),Namespace(..),Element(..),Content(..),AttValue(..))
39import qualified Text.XML.HaXml.Types as Hax (Element(..)) 39import qualified Text.XML.HaXml.Types as Hax (Element(..))
40import Text.XML.HaXml.Posn (Posn, posnLine, posnColumn) 40import Text.XML.HaXml.Posn (Posn, posnLine, posnColumn)
41import Text.XML.HaXml.Lex (TokenT)
42import qualified Text.XML.HaXml.Pretty as PP 41import qualified Text.XML.HaXml.Pretty as PP
43import Text.PrettyPrint 42import Text.PrettyPrint
44import Data.Maybe 43import Data.Maybe
@@ -432,13 +431,25 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do
432 431
433 connected <- liftIO . async $ connect' (unpack peer) port 432 connected <- liftIO . async $ connect' (unpack peer) port
434 433
434 -- We'll cache Presence notifications until the socket
435 -- is ready.
436 cached <- liftIO $ newIORef Map.empty
437
435 sock <- MaybeT . fix $ \loop -> do 438 sock <- MaybeT . fix $ \loop -> do
436 e <- atomically $ orElse 439 e <- atomically $ orElse
437 (fmap Right $ waitSTM connected) 440 (fmap Right $ waitSTM connected)
438 (fmap Left $ readTChan chan) 441 (fmap Left $ readTChan chan)
439 case e of 442 case e of
443 Left (OutBoundPresence (Presence jid Offline)) -> do
444 cached_map <- readIORef cached
445 writeIORef cached (Map.delete jid cached_map)
446 loop
447 Left (OutBoundPresence p@(Presence jid st)) -> do
448 cached_map <- readIORef cached
449 writeIORef cached (Map.insert jid st cached_map)
450 loop
440 Left event -> do 451 Left event -> do
441 L.putStrLn $ "REMOTE-OUT NOT READY: " <++> bshow event 452 L.putStrLn $ "REMOTE-OUT DISCARDED: " <++> bshow event
442 loop 453 loop
443 Right sock -> return sock 454 Right sock -> return sock
444 455
@@ -447,6 +458,12 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do
447 hSetBuffering h NoBuffering 458 hSetBuffering h NoBuffering
448 hPutStrLn h "<stream>" 459 hPutStrLn h "<stream>"
449 L.putStrLn $ "REMOTE-OUT: <stream>" 460 L.putStrLn $ "REMOTE-OUT: <stream>"
461 cache <- fmap Map.assocs . readIORef $ cached
462 writeIORef cached Map.empty -- hint garbage collector: we're done with this
463 forM_ cache $ \(jid,st) -> do
464 let r = xmlifyPresence (Presence jid st)
465 hPutStrLn h r
466 L.putStrLn $ "REMOTE-OUT (cache):\n" <++> r <++> "\n"
450 fix $ \loop -> do 467 fix $ \loop -> do
451 event <- atomically $ readTChan chan 468 event <- atomically $ readTChan chan
452 case event of 469 case event of
@@ -459,33 +476,6 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do
459 L.putStrLn $ "REMOTE-OUT: </stream>" 476 L.putStrLn $ "REMOTE-OUT: </stream>"
460 477
461 478
462 {-
463 pending <- newTVarIO True
464 thread <- forkIO $
465 runMaybeT $ do
466 let port = "5269"
467 sock <- MaybeT $ connect' (unpack peer) port
468 liftIO $ do
469 h <- socketToHandle sock ReadWriteMode
470 hSetBuffering h NoBuffering
471 hPutStrLn h "<stream>"
472 atomically $ writeTVar pending False
473 fix $ \loop -> do
474 event <- atomically $ readTChan chan
475 case event of
476 OutBoundPresence p -> do
477 let r = xmlifyPresence p
478 hPutStrLn h r
479 L.putStrLn $ "REMOTE:\n" <++> r <++> "\n"
480 loop
481 hPutStrLn h "</stream>"
482 fix $ \loop -> do
483 event <- atomically $ readTChan chan
484 when (readTVarIO pending) loop
485 joinThread thread
486 return ()
487 -}
488
489parseJID :: ByteString -> JID 479parseJID :: ByteString -> JID
490parseJID bjid = 480parseJID bjid =
491 let xs = L.splitWith (=='@') bjid 481 let xs = L.splitWith (=='@') bjid