cached outgoing presence messages until socket becomes available.

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 @@
 module AdaptServer where
 
 import Data.IORef
-import Debug.Trace
+-- import Debug.Trace
 import Data.HList
-import Network.Socket (Socket)
+-- import Network.Socket (Socket)
 import qualified Data.ByteString.Lazy.Char8 as L
 import ByteStringOperators
 
@@ -18,46 +18,6 @@ adaptDoCon (dropTill,lex,parse) g st bs cont = do
     putStrLn $ "packet: " ++ show bs
     let (HCons rsRef st') = st
     rs <- readIORef rsRef
-    {- parse error 
-     - ( "Expected <? but found <\n  in file remote-inbound  at line 1 col 1"
-     - , Chunk "<presence from='" Empty ,
-     -
-     - [(file remote-inbound  at line 1 col 1 ,<)
-     - ,(file remote-inbound  at line 1 col 2 ,presence)
-     - ,(file remote-inbound  at line 1 col 11 ,from)
-     - ,(file remote-inbound  at line 1 col 15 ,=)
-     - ,(file remote-inbound  at line 1 col 16 ,' or ")
-     - ,(file remote-inbound  at line 1 col 17 ,Lexical error:
-     -   unexpected EOF while looking for closing token '
-     -     to match the opening token in file remote-inbound  at line 1 col 17)
-     - ]
-     -
-     - )
-     -}
-    -- rs' =
-    -- ,[(file remote-inbound  at line 1 col 2 ,presence)
-    -- ,(file remote-inbound  at line 1 col 11 ,from)
-    -- ,(file remote-inbound  at line 1 col 15 ,=)
-    -- ,(file remote-inbound  at line 1 col 16 ,' or ")
-    -- ,(file remote-inbound  at line 1 col 17 ,Lexical error:
-    --   unexpected EOF while looking for closing token '
-    --   to match the opening token in file remote-inbound  at line 1 col 17)
-    -- ]
-    -- )
-    -- let parse' ls = let (e,rs') = parse ls
-
-    {- parse error ("Expected <? but found <\n  in file remote-inbound  at line 1 col 1"
-     - ,Chunk "<presence from='" Empty
-     - ,[(file remote-inbound  at line 1 col 1 ,<)
-     - ,(file remote-inbound  at line 1 col 2 ,presence)
-     - ,(file remote-inbound  at line 1 col 11 ,from)
-     - ,(file remote-inbound  at line 1 col 15 ,=)
-     - ,(file remote-inbound  at line 1 col 16 ,' or ")]
-     - ,[(file remote-inbound  at line 1 col 2 ,presence)
-     - ,(file remote-inbound  at line 1 col 11 ,from)
-     - ,(file remote-inbound  at line 1 col 15 ,=)
-     - ,(file remote-inbound  at line 1 col 16 ,' or ")])
-     -}
 
     let contR rem v = do
             writeIORef rsRef rem
@@ -67,24 +27,15 @@ adaptDoCon (dropTill,lex,parse) g st bs cont = do
           case e of
               Left err -> if null rs'
                             then contR "" ()
-                            else trace ("parse error "++show (err,bs,lexemes,rs')) $ do
+                            else -- trace ("parse error "++show (err,bs,lexemes,rs')) $ do
                                     contR rem ()
               Right e -> do
                 -- writeIORef rsRef rs'
                 g st' e (\() -> loop (dropTill rem rs') rs')
         loop rem [] = contR "" ()
     let buf = rs <++> bs
-    when (L.length buf < 4096)
+    when (L.length buf < 8192)
          (loop buf (lex buf))
 
-{-
-adaptServer ::
-  (Show err, Show raw,Show lexemes)
-    =>
-      (raw -> [lexemes], [lexemes] -> (Either err msg, [lexemes]))
-      -> (Socket -> st -> IO st', 
-          st' -> msg -> (()->IO ()) -> IO ())
-      -> (Socket -> st -> IO (HCons (IORef [lexemes]) st'),
-          HCons (IORef [lexemes]) st' -> raw -> (()->IO ()) -> IO ())
--}
+
 adaptServer (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
 import Text.XML.HaXml.Types as Hax hiding (Element) -- (ElemTag,QName(..),Namespace(..),Element(..),Content(..),AttValue(..))
 import qualified Text.XML.HaXml.Types as Hax (Element(..))
 import Text.XML.HaXml.Posn (Posn, posnLine, posnColumn)
-import Text.XML.HaXml.Lex  (TokenT)
 import qualified Text.XML.HaXml.Pretty as PP
 import Text.PrettyPrint
 import Data.Maybe
@@ -432,13 +431,25 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do
 
     connected <- liftIO . async $ connect' (unpack peer) port
 
+    -- We'll cache Presence notifications until the socket
+    -- is ready.
+    cached <- liftIO $ newIORef Map.empty
+
     sock <- MaybeT . fix $ \loop -> do
         e <- atomically $ orElse
                 (fmap Right $ waitSTM connected)
                 (fmap Left  $ readTChan chan)
         case e of
+            Left (OutBoundPresence (Presence jid Offline)) -> do
+                cached_map <- readIORef cached
+                writeIORef cached (Map.delete jid cached_map)
+                loop
+            Left (OutBoundPresence p@(Presence jid st)) -> do
+                cached_map <- readIORef cached
+                writeIORef cached (Map.insert jid st cached_map)
+                loop
             Left event -> do
-                L.putStrLn $ "REMOTE-OUT NOT READY: " <++> bshow event
+                L.putStrLn $ "REMOTE-OUT DISCARDED: " <++> bshow event
                 loop
             Right sock -> return sock
 
@@ -447,6 +458,12 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do
         hSetBuffering h NoBuffering
         hPutStrLn h "<stream>"
         L.putStrLn $ "REMOTE-OUT: <stream>"
+        cache <- fmap Map.assocs . readIORef $ cached
+        writeIORef cached Map.empty -- hint garbage collector: we're done with this
+        forM_ cache $ \(jid,st) -> do
+            let r = xmlifyPresence (Presence jid st)
+            hPutStrLn h r
+            L.putStrLn $ "REMOTE-OUT (cache):\n" <++> r <++> "\n"
         fix $ \loop -> do
             event <- atomically $ readTChan chan
             case event of
@@ -459,33 +476,6 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do
         L.putStrLn $ "REMOTE-OUT: </stream>"
 
 
-    {-
-    pending <- newTVarIO True
-    thread <- forkIO $
-        runMaybeT $ do
-            let port = "5269"
-            sock <- MaybeT $ connect' (unpack peer) port
-            liftIO $ do
-                h <- socketToHandle sock ReadWriteMode
-                hSetBuffering h NoBuffering
-                hPutStrLn h "<stream>"
-                atomically $ writeTVar pending False
-                fix $ \loop -> do
-                    event <- atomically $ readTChan chan
-                    case event of
-                      OutBoundPresence p -> do
-                        let r = xmlifyPresence p
-                        hPutStrLn h r
-                        L.putStrLn $ "REMOTE:\n" <++> r <++> "\n"
-                    loop
-                hPutStrLn h "</stream>"
-    fix $ \loop -> do
-        event <- atomically $ readTChan chan
-        when (readTVarIO pending) loop
-    joinThread thread
-    return ()
-    -}
-
 parseJID :: ByteString -> JID
 parseJID bjid = 
     let xs = L.splitWith (=='@') bjid