1 files changed, 79 insertions, 38 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index a9e7e336..45b89b3d 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -26,10 +26,11 @@ import Data.Conduit.Blaze (builderToByteStringFlush)
 import qualified Text.XML.Stream.Render as XML
 import qualified Text.XML.Stream.Parse as XML
 import Data.XML.Types as XML
-import Data.Maybe (catMaybes,fromJust)
+import Data.Maybe (catMaybes,fromJust,isNothing)
 import Data.Monoid ( (<>) )
 import Data.Text (Text)
 import qualified Data.Text as Text (pack)
+import Data.Char (toUpper)
 
 import qualified Control.Concurrent.STM.UpdateStream as Slotted
 import ControlMaybe
@@ -40,6 +41,8 @@ import Server
 peerport = 5269
 clientport = 5222
 
+my_uuid = "154ae29f-98f2-4af4-826d-a40c8a188574"
+
 
 -- TODO: http://xmpp.org/rfcs/rfc6120.html#rules-remote-error
 -- client connection
@@ -89,12 +92,27 @@ type FlagCommand = STM Bool
 type ReadCommand = IO (Maybe ByteString)
 type WriteCommand = ByteString -> IO Bool
 
+{-
 data Stanza
     = UnrecognizedStanza { stanzaChan :: TChan (Maybe XML.Event) }
     | PingStanza { stanzaId :: Maybe Text
                  , stanzaChan :: TChan (Maybe XML.Event) }
     | PongStanza { -- stanzaId :: Maybe Text
                    stanzaChan :: TChan (Maybe XML.Event) }
+-}
+
+data StanzaType = Unrecognized | Ping | Pong
+ deriving Show
+
+data Stanza = Stanza
+    { stanzaType :: StanzaType
+    , stanzaId :: Maybe Text
+    , stanzaTo :: Maybe Text
+    , stanzaFrom :: Maybe Text
+    , stanzaChan :: TChan XML.Event
+    , stanzaClosers ::  TVar (Maybe [XML.Event])
+    , stanzaInterrupt :: TMVar ()
+    }
 
 copyToChannel f chan closer_stack = awaitForever copy
  where
@@ -104,10 +122,10 @@ copyToChannel f chan closer_stack = awaitForever copy
             EventBeginDocument {} -> do
                 let clsr = closerFor x
                 liftIO . atomically $
-                    modifyTVar' closer_stack (clsr:)
+                    modifyTVar' closer_stack (fmap (clsr:))
             EventEndDocument {} -> do
                 liftIO . atomically $
-                    modifyTVar' closer_stack (drop 1)
+                    modifyTVar' closer_stack (fmap (drop 1))
             _ -> return ()
         yield x
 
@@ -119,15 +137,12 @@ prettyPrint prefix xs =
         =$= CB.lines 
         $$ CL.mapM_ (wlogb . (prefix <>))
 
-grockStanzaIQGet :: Monad m => XML.Event -> NestingXML o m (Maybe (TChan (Maybe Event) -> Stanza))
+grockStanzaIQGet :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType)
 grockStanzaIQGet stanza = do
-    let mid   = lookupAttrib "id" (tagAttrs stanza)
-        -- mfrom = lookupAttrib "from" (tagAttrs stanza)
     mtag <- nextElement 
     flip (maybe $ return Nothing)  mtag $ \tag -> do
     case tagName tag of
-        "{urn:xmpp:ping}ping" -> do
-            return $ Just (PingStanza mid)
+        "{urn:xmpp:ping}ping" -> return $ Just Ping
         _ -> return Nothing
 
 ioWriteChan c v = liftIO . atomically $ writeTChan c v
@@ -146,33 +161,52 @@ xmppInbound k pingflag src stanzas output donevar = doNestingXML $ do
     fix $ \loop -> do
     -- liftIO . wlog $ "waiting for stanza."
     (chan,clsrs) <- liftIO . atomically $
-        liftM2 (,) newTChan (newTVar [])
-    whenJust nextElement $ \stanza -> do
+        liftM2 (,) newTChan (newTVar (Just []))
+    whenJust nextElement $ \stanzaTag -> do
         stanza_lvl <- nesting
         liftIO . atomically $ do
-            writeTChan chan (Just stanza)
-            modifyTVar' clsrs (closerFor stanza:)
-        copyToChannel Just chan clsrs =$= do
+            writeTChan chan stanzaTag
+            modifyTVar' clsrs (fmap (closerFor stanzaTag:))
+        copyToChannel id chan clsrs =$= do
+          let mid   = lookupAttrib "id" (tagAttrs stanzaTag)
+              mfrom = lookupAttrib "from" (tagAttrs stanzaTag)
+              mto = lookupAttrib "to" (tagAttrs stanzaTag)
           dispatch <- 
             case () of
-                _ | stanza `isServerIQOf` "get" -> grockStanzaIQGet stanza
-                _ -> return $ Just UnrecognizedStanza
+                _ | stanzaTag `isServerIQOf` "get" -> grockStanzaIQGet stanzaTag
+                _ -> return $ Just Unrecognized
           flip (maybe $ return ()) dispatch $ \dispatch -> 
-            case dispatch chan of
-              d@(PingStanza {}) -> do
-                let to = "todo"
-                    from = "todo"
-                let pong = peerPong (stanzaId d) to from
-                liftIO $ wlog "got ping, sending pong..."
+            case dispatch of
+              Ping -> do
+                let to = maybe "todo" id mto
+                    from = maybe "todo" id mfrom
+                let pong = peerPong mid to from
+                -- liftIO $ wlog "got ping, sending pong..."
                 pongChan <- liftIO $ atomically newTChan
-                ioWriteChan output (PongStanza pongChan)
+                pongClsrs <- liftIO $ atomically $ newTVar (Just [])
+                ioWriteChan output $ Stanza { stanzaType = Pong
+                                            , stanzaId = mid
+                                            , stanzaTo = mto
+                                            , stanzaFrom = mfrom
+                                            , stanzaChan = pongChan
+                                            , stanzaClosers = pongClsrs
+                                            , stanzaInterrupt = donevar
+                                            }
                 void . liftIO . forkIO $ do
-                    mapM_ (ioWriteChan pongChan . Just) pong
-                    ioWriteChan pongChan Nothing
-                    liftIO $ wlog "finished pong stanza"
-              disp -> ioWriteChan stanzas disp
+                    mapM_ (ioWriteChan pongChan) pong
+                    liftIO . atomically $ writeTVar pongClsrs Nothing
+                    -- liftIO $ wlog "finished pong stanza"
+              stype -> ioWriteChan stanzas Stanza
+                            { stanzaType = stype
+                            , stanzaId = mid
+                            , stanzaTo = mto
+                            , stanzaFrom = mfrom
+                            , stanzaChan = chan
+                            , stanzaClosers = clsrs
+                            , stanzaInterrupt = donevar
+                            }
           awaitCloser stanza_lvl
-        ioWriteChan chan Nothing
+        liftIO . atomically $ writeTVar clsrs Nothing
         loop
     
 
@@ -283,15 +317,20 @@ forkConnection k pingflag src snk stanzas = do
             what <- atomically $ foldr1 orElse
                 [readTChan output >>= \stanza -> return $ do
                     let xchan = stanzaChan stanza
+                        xfin = stanzaClosers stanza
                     fix $ \inner -> do
-                        what <- atomically $ orElse
-                            (readTChan xchan >>= \mxml -> return $ do
-                                case mxml of
-                                  Just xml -> do
-                                    atomically $ Slotted.push slots Nothing xml
-                                    inner
-                                  Nothing -> loop)
-                            (readTMVar rdone >> return (return ()))
+                        what <- atomically $ foldr1 orElse
+                            [readTChan xchan >>= \xml -> return $ do
+                                atomically $ Slotted.push slots Nothing xml
+                                inner
+                            ,do mb <- readTVar xfin
+                                cempty <- isEmptyTChan xchan
+                                if isNothing mb
+                                    then if cempty then return loop else retry
+                                    else retry -- todo: send closers
+                            ,do isEmptyTChan xchan >>= check
+                                readTMVar rdone
+                                return (return ())]
                         what
                 ,do pingflag >>= check
                     return $ do
@@ -303,7 +342,7 @@ forkConnection k pingflag src snk stanzas = do
                     mapM_ (atomically . Slotted.push slots (Just $ PingSlot))
                           ping
                     wlog ""
-                    prettyPrint "P<- " ping
+                    prettyPrint "P<-PING " ping
                     loop
                 ,readTMVar rdone >> return (return ())
                 ]
@@ -363,9 +402,11 @@ monitor sv params = do
             RequiresPing -> return () -- wlog $ tomsg k "RequiresPing"
             _ -> return ()
       , readTChan stanzas >>= \stanza -> return $ do
-        xs <- readUntilNothing (stanzaChan stanza)
+        -- xs <- readUntilNothing (stanzaChan stanza)
+        xs <- chanContents (stanzaChan stanza)
+        let typ = Strict8.pack $ "P->"++(show (stanzaType stanza))++" "
         wlog ""
-        prettyPrint "P-> " xs
+        prettyPrint typ xs
       ]
     action
     loop