Slightly less picky handshake for peer (nextElement rather than withXML)

1 files changed, 25 insertions, 15 deletions

diff --git a/xmppServer.hs b/xmppServer.hs
index cbd30bda..a6cf2a2b 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -87,24 +87,19 @@ xmppInbound :: ConnectionKey -> FlagCommand
 xmppInbound k pingflag src stanzas = doNestingXML $ do
     withXML $ \begindoc -> do
     when (begindoc==EventBeginDocument) $ do
-    -- liftIO . wlog $ "begin-doc"
-    withXML $ \xml -> do
+    whenJust nextElement $ \xml -> do
     withJust (elementAttrs "stream" xml) $ \stream_attrs -> do
-    -- liftIO . wlog $ "stream: " ++ show (getStreamName xml)
-    -- liftIO . wlog $ "stream atributes: " ++ show stream_attrs
     fix $ \loop -> do
         -- liftIO . wlog $ "waiting for stanza."
         chan <- liftIO $ atomically newTChan
         whenJust nextElement $ \stanza -> do
             stanza_lvl <- nesting
             liftIO . atomically $ writeTChan chan (Just stanza)
-            -- liftIO . wlog $ "stanza: "++show stanza
 
             liftIO . atomically $ writeTChan stanzas $
                 UnrecognizedStanza chan
             doUntilCloser stanza_lvl $ \xml -> do
                 liftIO . atomically $ writeTChan chan (Just xml)
-                -- liftIO . wlog $ "-stanza: " ++ show xml
             liftIO . atomically $ writeTChan chan Nothing
             loop
     
@@ -122,6 +117,15 @@ chanContents ch = do
                 return (x:xs))
               x
 
+readUntilNothing :: TChan (Maybe x) -> IO [x]
+readUntilNothing ch = do
+        x  <- atomically $ readTChan ch
+        maybe (return [])
+              (\x -> do
+                xs <- readUntilNothing ch
+                return (x:xs))
+              x
+
 
 greetPeer =
     [ EventBeginDocument
@@ -136,6 +140,9 @@ goodbyePeer =
     , EventEndDocument
     ]
 
+data XMPPState
+    = PingSlot
+ deriving (Eq,Ord)
 
 
 forkConnection :: ConnectionKey
@@ -152,11 +159,12 @@ forkConnection k pingflag src snk stanzas = do
         atomically $ putTMVar rdone ()
         wlog $ "end reader fork: " ++ show k
     slots <- atomically $ Slotted.new isEventBeginElement isEventEndElement
-    let _ = slots :: Slotted.UpdateStream () XML.Event
-    let slot_src = do
+    needsFlush <- atomically $ newTVar False
+    let _ = slots :: Slotted.UpdateStream XMPPState XML.Event
+    let greet_src = do
             CL.sourceList greetPeer =$= CL.map Chunk
             yield Flush
-            needsFlush <- lift . atomically $ newTVar False
+        slot_src = do
             what <- lift . atomically $ foldr1 orElse
                 [Slotted.pull slots >>= \x -> do
                     writeTVar needsFlush True
@@ -172,7 +180,7 @@ forkConnection k pingflag src snk stanzas = do
                 ,readTMVar rdone >> return (return ())
                 ]
             what
-    forkIO $ do slot_src $$ snk
+    forkIO $ do (greet_src >> slot_src) $$ snk
                 wlog $ "end post-queue fork: " ++ show k
     output <- atomically newTChan
     forkIO $ do
@@ -193,7 +201,9 @@ forkConnection k pingflag src snk stanzas = do
                         what
                 ,do pingflag >>= check
                     return $ do
-                    wlog $ "TODO: send ping"
+                    atomically $ Slotted.push slots (Just PingSlot) $ EventBeginElement "ping" []
+                    atomically $ Slotted.push slots (Just PingSlot) $ EventEndElement "ping"
+                    -- TODO: fix ping
                     loop
                 ,readTMVar rdone >> return (return ())
                 ]
@@ -220,9 +230,9 @@ monitor sv params = do
             RequiresPing -> wlog $ tomsg k "RequiresPing"
             _ -> return ()
       , readTChan stanzas >>= \stanza -> return $ do
-        xs <- chanContents (stanzaChan stanza)
+        xs <- readUntilNothing (stanzaChan stanza)
         wlog ""
-        prettyPrint "STANZA: " (catMaybes xs)
+        prettyPrint "STANZA: " xs
       ]
     action
     loop
@@ -249,8 +259,8 @@ main = runResourceT $ do
     sv <- server
     lift $ do
     peer_params <- return (connectionDefaults peerKey)
-                          { pingInterval = 5000
-                          , timeout = 5000
+                          { pingInterval = 10000
+                          , timeout = 10000
                           , duplex = False }
     client_params <- return $ connectionDefaults clientKey
     forkIO $ monitor sv peer_params