Recongize stanza type BindResource

1 files changed, 101 insertions, 36 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 92f59061..8afc3245 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -101,7 +101,7 @@ data Stanza
                    stanzaChan :: TChan (Maybe XML.Event) }
 -}
 
-data StanzaType = Unrecognized | Ping | Pong
+data StanzaType = Unrecognized | Ping | Pong | BindResource (Maybe Text)
  deriving Show
 
 data StanzaOrigin = LocalPeer | NetworkOrigin ConnectionKey
@@ -116,6 +116,9 @@ data Stanza = Stanza
     , stanzaInterrupt :: TMVar ()
     , stanzaOrigin :: StanzaOrigin
     }
+dupStanza stanza = do
+    dupped <- dupTChan (stanzaChan stanza)
+    return stanza { stanzaChan = dupped }
 
 copyToChannel f chan closer_stack = awaitForever copy
  where
@@ -138,34 +141,71 @@ prettyPrint prefix =
         =$= CB.lines 
         =$ CL.mapM_ (wlogb . (prefix <>))
 
-grockStanzaIQGet :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType)
-grockStanzaIQGet stanza = do
+grokStanzaIQGet :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType)
+grokStanzaIQGet stanza = do
     mtag <- nextElement 
     flip (maybe $ return Nothing)  mtag $ \tag -> do
     case tagName tag of
         "{urn:xmpp:ping}ping" -> return $ Just Ping
         _ -> return Nothing
 
+grokStanzaIQResult :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType)
+grokStanzaIQResult stanza = do
+    mtag <- nextElement 
+    flip (maybe $ return (Just Pong))  mtag $ \tag -> do
+    case tagName tag of
+        _ -> return Nothing
+
+grokStanzaIQSet :: XML.Event -> NestingXML o IO (Maybe StanzaType)
+grokStanzaIQSet stanza = do
+    mtag <- nextElement 
+    flip (maybe $ return Nothing)  mtag $ \tag -> do
+    case tagName tag of
+        "{urn:ietf:params:xml:ns:xmpp-bind}bind" -> do
+            mchild <- nextElement
+            case fmap tagName mchild of
+                Just "{urn:ietf:params:xml:ns:xmpp-bind}resource" -> do
+                    rsc <- XML.content -- TODO: MonadThrow???
+                    return . Just $ BindResource (Just rsc)
+                Just _ -> return Nothing
+                Nothing -> return . Just $ BindResource Nothing
+        _ -> return Nothing
+
+
+{-
+C->Unrecognized <iq
+C->Unrecognized   type="set"
+C->Unrecognized   id="purpleae62d88f"
+C->Unrecognized   xmlns="jabber:client">
+C->Unrecognized     <bind xmlns="urn:ietf:params:xml:ns:xmpp-bind"/>
+C->Unrecognized </iq>
+-}
+
 ioWriteChan c v = liftIO . atomically $ writeTChan c v
 
 
 grokStanza "jabber:server" stanzaTag = 
             case () of
-                _ | stanzaTag `isServerIQOf` "get" -> grockStanzaIQGet stanzaTag
+                _ | stanzaTag `isServerIQOf` "get" -> grokStanzaIQGet stanzaTag
+                _ | stanzaTag `isServerIQOf` "result" -> grokStanzaIQResult stanzaTag
                 _ -> return $ Just Unrecognized
 
 grokStanza "jabber:client" stanzaTag = 
             case () of
-                _ | stanzaTag `isClientIQOf` "get" -> grockStanzaIQGet stanzaTag
+                _ | stanzaTag `isClientIQOf` "get" -> grokStanzaIQGet stanzaTag
+                _ | stanzaTag `isClientIQOf` "set" -> grokStanzaIQSet stanzaTag
+                _ | stanzaTag `isClientIQOf` "result" -> grokStanzaIQResult stanzaTag
                 _ -> return $ Just Unrecognized
 
-xmppInbound :: ConnectionKey -> FlagCommand 
+xmppInbound :: Server ConnectionKey
+                -> ConnectionKey
+                -> FlagCommand 
                 -> Source IO XML.Event
                 -> TChan Stanza
                 -> TChan Stanza
                 -> TMVar ()
                 -> Sink XML.Event IO ()
-xmppInbound k pingflag src stanzas output donevar = doNestingXML $ do
+xmppInbound sv k pingflag src stanzas output donevar = doNestingXML $ do
     let namespace = case k of
                         ClientKey {} -> "jabber:client"
                         PeerKey {} -> "jabber:server"
@@ -198,21 +238,35 @@ xmppInbound k pingflag src stanzas output donevar = doNestingXML $ do
                     from = maybe "todo" id mfrom
                 let pong = makePong namespace mid to from
                 -- liftIO $ wlog "got ping, sending pong..."
-                pongChan <- liftIO $ atomically newTChan
-                pongClsrs <- liftIO $ atomically $ newTVar (Just [])
-                ioWriteChan output $ Stanza { stanzaType = Pong
-                                            , stanzaId = mid
-                                            , stanzaTo = mto
-                                            , stanzaFrom = mfrom
-                                            , stanzaChan = pongChan
-                                            , stanzaClosers = pongClsrs
-                                            , stanzaInterrupt = donevar
-                                            , stanzaOrigin = LocalPeer
-                                            }
+                pongStanza <- liftIO . atomically $ do
+                    pongChan <- newTChan
+                    pongClsrs <- newTVar (Just [])
+                    return Stanza { stanzaType = Pong
+                                  , stanzaId = mid
+                                  , stanzaTo = mto
+                                  , stanzaFrom = mfrom
+                                  , stanzaChan = pongChan
+                                  , stanzaClosers = pongClsrs
+                                  , stanzaInterrupt = donevar
+                                  , stanzaOrigin = LocalPeer
+                                  }
+                ioWriteChan output pongStanza
                 void . liftIO . forkIO $ do
-                    mapM_ (ioWriteChan pongChan) pong
-                    liftIO . atomically $ writeTVar pongClsrs Nothing
+                    mapM_ (ioWriteChan $ stanzaChan pongStanza) pong
+                    liftIO . atomically $ writeTVar (stanzaClosers pongStanza) Nothing
                     -- liftIO $ wlog "finished pong stanza"
+                
+                -- TODO: Remove this, it is only to generate a debug print
+                ioWriteChan stanzas Stanza
+                            { stanzaType = Ping
+                            , stanzaId = mid
+                            , stanzaTo = mto
+                            , stanzaFrom = mfrom
+                            , stanzaChan = chan
+                            , stanzaClosers = clsrs
+                            , stanzaInterrupt = donevar
+                            , stanzaOrigin = NetworkOrigin k
+                            }
               stype -> ioWriteChan stanzas Stanza
                             { stanzaType = stype
                             , stanzaId = mid
@@ -250,16 +304,8 @@ readUntilNothing ch = do
                 return (x:xs))
               x
 
-greet' namespace host =
-    [ EventBeginDocument
-    , EventBeginElement (streamP "stream")
-        [("from",[ContentText host])
-        ,("id",[ContentText "someid"])
-        ,("xmlns",[ContentText namespace])
-        ,("xmlns:stream",[ContentText "http://etherx.jabber.org/streams"])
-        ,("version",[ContentText "1.0"])
-        ]
-    , EventBeginElement (streamP "features") []
+streamFeatures "jabber:client" =
+    [ EventBeginElement (streamP "features") []
     , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind" []
     , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
 
@@ -273,6 +319,20 @@ greet' namespace host =
 
     , EventEndElement (streamP "features")
     ]
+streamFeatures "jabber:server" =
+    []
+
+
+greet' namespace host =
+    [ EventBeginDocument
+    , EventBeginElement (streamP "stream")
+        [("from",[ContentText host])
+        ,("id",[ContentText "someid"])
+        ,("xmlns",[ContentText namespace])
+        ,("xmlns:stream",[ContentText "http://etherx.jabber.org/streams"])
+        ,("version",[ContentText "1.0"])
+        ]
+    ] ++ streamFeatures namespace
 
 greet namespace =
     [ EventBeginDocument
@@ -320,13 +380,14 @@ makePong namespace mid to from =
        ]
 
 
-forkConnection :: ConnectionKey
+forkConnection :: Server ConnectionKey
+                -> ConnectionKey
                 -> FlagCommand
                 -> Source IO XML.Event
                 -> Sink (Flush XML.Event) IO ()
                 -> TChan Stanza
                 ->  IO (TChan Stanza)
-forkConnection k pingflag src snk stanzas = do
+forkConnection sv k pingflag src snk stanzas = do
     let namespace = case k of
                         ClientKey {} -> "jabber:client"
                         PeerKey {} -> "jabber:server"
@@ -361,6 +422,10 @@ forkConnection k pingflag src snk stanzas = do
         fix $ \loop -> do
             what <- atomically $ foldr1 orElse
                 [readTChan output >>= \stanza -> return $ do
+                    dup <- atomically $ dupStanza stanza
+                    stanzaToConduit dup $$ prettyPrint $ case k of
+                        ClientKey {} -> "C<-" <> bshow (stanzaType dup) <> " "
+                        PeerKey {}   -> "P<-" <> bshow (stanzaType dup) <> " "
                     stanzaToConduit stanza
                         $$ awaitForever
                             $ liftIO . atomically . Slotted.push slots Nothing
@@ -385,7 +450,7 @@ forkConnection k pingflag src snk stanzas = do
         wlog $ "end pre-queue fork: " ++ show k
     forkIO $ do
         -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show)
-        src $$ xmppInbound k pingflag src stanzas output rdone
+        src $$ xmppInbound sv k pingflag src stanzas output rdone
         atomically $ putTMVar rdone ()
         wlog $ "end reader fork: " ++ show k
     return output
@@ -446,7 +511,7 @@ monitor sv params = do
             Connection pingflag conread conwrite -> do
                  wlog $ tomsg k "Connection"
                  let (xsrc,xsnk) = xmlStream conread conwrite
-                 forkConnection k pingflag xsrc xsnk stanzas
+                 forkConnection sv k pingflag xsrc xsnk stanzas
                  return ()
             ConnectFailure addr -> do
                 wlog $ tomsg k "ConnectFailure"
@@ -478,8 +543,8 @@ xmppServer :: (MonadResource m, MonadIO m) => m (Server ConnectionKey,Connection
 xmppServer = do
     sv <- server
     let peer_params = (connectionDefaults peerKey)
-                          { pingInterval = 5000
-                          , timeout = 1000
+                          { pingInterval = 15000
+                          , timeout = 2000
                           , duplex = False }
         client_params = (connectionDefaults clientKey)
                           { pingInterval = 0