client connections

2 files changed, 83 insertions, 22 deletions

diff --git a/Presence/EventUtil.hs b/Presence/EventUtil.hs
index a1c48e33..adcae1d3 100644
--- a/Presence/EventUtil.hs
+++ b/Presence/EventUtil.hs
@@ -29,6 +29,12 @@ isServerIQOf (EventBeginElement name attrs) testType
     = True
 isServerIQOf _ _ = False
 
+isClientIQOf (EventBeginElement name attrs) testType 
+    | name=="{jabber:client}iq" 
+    && matchAttrib "type" testType attrs
+    = True
+isClientIQOf _ _ = False
+
 matchAttrib name value attrs = 
     case List.find ( (==name) . fst) attrs of
         Just (_,[ContentText x])   | x==value -> True
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 140c91af..92f59061 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -104,6 +104,8 @@ data Stanza
 data StanzaType = Unrecognized | Ping | Pong
  deriving Show
 
+data StanzaOrigin = LocalPeer | NetworkOrigin ConnectionKey
+
 data Stanza = Stanza
     { stanzaType :: StanzaType
     , stanzaId :: Maybe Text
@@ -112,6 +114,7 @@ data Stanza = Stanza
     , stanzaChan :: TChan XML.Event
     , stanzaClosers ::  TVar (Maybe [XML.Event])
     , stanzaInterrupt :: TMVar ()
+    , stanzaOrigin :: StanzaOrigin
     }
 
 copyToChannel f chan closer_stack = awaitForever copy
@@ -145,6 +148,17 @@ grockStanzaIQGet stanza = do
 
 ioWriteChan c v = liftIO . atomically $ writeTChan c v
 
+
+grokStanza "jabber:server" stanzaTag = 
+            case () of
+                _ | stanzaTag `isServerIQOf` "get" -> grockStanzaIQGet stanzaTag
+                _ -> return $ Just Unrecognized
+
+grokStanza "jabber:client" stanzaTag = 
+            case () of
+                _ | stanzaTag `isClientIQOf` "get" -> grockStanzaIQGet stanzaTag
+                _ -> return $ Just Unrecognized
+
 xmppInbound :: ConnectionKey -> FlagCommand 
                 -> Source IO XML.Event
                 -> TChan Stanza
@@ -152,6 +166,9 @@ xmppInbound :: ConnectionKey -> FlagCommand
                 -> TMVar ()
                 -> Sink XML.Event IO ()
 xmppInbound k pingflag src stanzas output donevar = doNestingXML $ do
+    let namespace = case k of
+                        ClientKey {} -> "jabber:client"
+                        PeerKey {} -> "jabber:server"
     withXML $ \begindoc -> do
     when (begindoc==EventBeginDocument) $ do
     whenJust nextElement $ \xml -> do
@@ -169,16 +186,17 @@ xmppInbound k pingflag src stanzas output donevar = doNestingXML $ do
           let mid   = lookupAttrib "id" (tagAttrs stanzaTag)
               mfrom = lookupAttrib "from" (tagAttrs stanzaTag)
               mto = lookupAttrib "to" (tagAttrs stanzaTag)
-          dispatch <- 
-            case () of
-                _ | stanzaTag `isServerIQOf` "get" -> grockStanzaIQGet stanzaTag
-                _ -> return $ Just Unrecognized
+          dispatch <- grokStanza namespace stanzaTag
           flip (maybe $ return ()) dispatch $ \dispatch -> 
             case dispatch of
               Ping -> do
+                -- TODO: check that the to-address matches this server.
+                -- Otherwise it could be a client-to-client ping or a
+                -- client-to-server for some other server.
+                -- For now, assuming its for the immediate connection.
                 let to = maybe "todo" id mto
                     from = maybe "todo" id mfrom
-                let pong = peerPong mid to from
+                let pong = makePong namespace mid to from
                 -- liftIO $ wlog "got ping, sending pong..."
                 pongChan <- liftIO $ atomically newTChan
                 pongClsrs <- liftIO $ atomically $ newTVar (Just [])
@@ -189,6 +207,7 @@ xmppInbound k pingflag src stanzas output donevar = doNestingXML $ do
                                             , stanzaChan = pongChan
                                             , stanzaClosers = pongClsrs
                                             , stanzaInterrupt = donevar
+                                            , stanzaOrigin = LocalPeer
                                             }
                 void . liftIO . forkIO $ do
                     mapM_ (ioWriteChan pongChan) pong
@@ -202,6 +221,7 @@ xmppInbound k pingflag src stanzas output donevar = doNestingXML $ do
                             , stanzaChan = chan
                             , stanzaClosers = clsrs
                             , stanzaInterrupt = donevar
+                            , stanzaOrigin = NetworkOrigin k
                             }
           awaitCloser stanza_lvl
         liftIO . atomically $ writeTVar clsrs Nothing
@@ -230,16 +250,39 @@ 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") []
+    , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind" []
+    , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
+
+    {-
+    -- , "  <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>"
+    , " <mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>"
+    -- , " <mechanism>DIGEST-MD5</mechanism>"
+    , " <mechanism>PLAIN</mechanism>"
+    , " </mechanisms> "
+    -}
+
+    , EventEndElement (streamP "features")
+    ]
 
-greetPeer =
+greet namespace =
     [ EventBeginDocument
     , EventBeginElement (streamP "stream")
-        [ attr "xmlns"   "jabber:server"
+        [ attr "xmlns"   namespace
         , attr "version" "1.0"
         ]
     ]
 
-goodbyePeer = 
+goodbye = 
     [ EventEndElement (streamP "stream")
     , EventEndDocument
     ]
@@ -248,10 +291,11 @@ data XMPPState
     = PingSlot
  deriving (Eq,Ord)
 
+mkname namespace name = (Name name (Just namespace) Nothing)
 
-peerPing :: Maybe Text -> Text -> Text -> [XML.Event]
-peerPing mid to from = 
-       [ EventBeginElement "{jabber:server}iq"
+makePing :: Text -> Maybe Text -> Text -> Text -> [XML.Event]
+makePing namespace mid to from = 
+       [ EventBeginElement (mkname namespace "iq")
          $ (case mid of
             Just c -> (("id",[ContentText c]):)
             _      -> id               )
@@ -261,10 +305,10 @@ peerPing mid to from =
             ]
        , EventBeginElement "{urn:xmpp:ping}ping" []
        , EventEndElement "{urn:xmpp:ping}ping"
-       , EventEndElement "{jabber:server}iq" ]
+       , EventEndElement $ mkname namespace "iq"]
 
-peerPong mid to from =
-       [ EventBeginElement "{jabber:server}iq"
+makePong namespace mid to from =
+       [ EventBeginElement (mkname namespace "iq")
          $(case mid of
                Just c -> (("id",[ContentText c]):)
                _      -> id)
@@ -272,7 +316,7 @@ peerPong mid to from =
                , attr "to"   to
                , attr "from" from
                ]
-       , EventEndElement "{jabber:server}iq"
+       , EventEndElement (mkname namespace "iq")
        ]
 
 
@@ -283,12 +327,15 @@ forkConnection :: ConnectionKey
                 -> TChan Stanza
                 ->  IO (TChan Stanza)
 forkConnection k pingflag src snk stanzas = do
+    let namespace = case k of
+                        ClientKey {} -> "jabber:client"
+                        PeerKey {} -> "jabber:server"
     rdone <- atomically newEmptyTMVar
     slots <- atomically $ Slotted.new isEventBeginElement isEventEndElement
     needsFlush <- atomically $ newTVar False
     let _ = slots :: Slotted.UpdateStream XMPPState XML.Event
     let greet_src = do
-            CL.sourceList greetPeer =$= CL.map Chunk
+            CL.sourceList (greet' namespace "localhost") =$= CL.map Chunk
             yield Flush
         slot_src = do
             what <- lift . atomically $ foldr1 orElse
@@ -324,11 +371,13 @@ forkConnection k pingflag src snk stanzas = do
                         from = "todo" -- Look it up from Server object
                                       -- or pass it with Connection event.
                         mid = Just "ping"
-                        ping = peerPing mid to from
+                        ping = makePing namespace mid to from
                     mapM_ (atomically . Slotted.push slots (Just $ PingSlot))
                           ping
                     wlog ""
-                    CL.sourceList ping $$ prettyPrint "P<-Ping "
+                    CL.sourceList ping $$ prettyPrint $ case k of
+                        ClientKey {} -> "C<-Ping"
+                        PeerKey {} -> "P<-Ping "
                     loop
                 ,readTMVar rdone >> return (return ())
                 ]
@@ -409,7 +458,11 @@ monitor sv params = do
             RequiresPing -> return () -- wlog $ tomsg k "RequiresPing"
             _ -> return ()
       , readTChan stanzas >>= \stanza -> return $ do
-        let typ = Strict8.pack $ "P->"++(show (stanzaType stanza))++" "
+        let typ = Strict8.pack $ c ++ "->"++(show (stanzaType stanza))++" "
+            c = case stanzaOrigin stanza of
+                    LocalPeer -> "*"
+                    NetworkOrigin (ClientKey {}) -> "C"
+                    NetworkOrigin (PeerKey {}) -> "P"
         wlog ""
         stanzaToConduit stanza $$ prettyPrint typ
       ]
@@ -428,10 +481,12 @@ xmppServer = do
                           { pingInterval = 5000
                           , timeout = 1000
                           , duplex = False }
-        client_params = connectionDefaults clientKey
+        client_params = (connectionDefaults clientKey)
+                          { pingInterval = 0
+                          , timeout = 0
+                          }
     liftIO $ do
         forkIO $ monitor sv peer_params
         control sv (Listen peerport peer_params)
-        -- todo
-        -- control sv (Listen clientport client_params)
+        control sv (Listen clientport client_params)
     return (sv,peer_params)