Answer client bind-resource request. Quieted connect-fail messages.

2 files changed, 100 insertions, 46 deletions

diff --git a/Presence/Server.hs b/Presence/Server.hs
index a1c4923b..baf5a1a8 100644
--- a/Presence/Server.hs
+++ b/Presence/Server.hs
@@ -42,7 +42,7 @@ import Control.Monad.Fix
 -- import Control.Monad.STM
 import Control.Monad.Trans.Resource
 import Control.Monad.IO.Class (MonadIO (liftIO))
-import System.IO.Error (ioeGetErrorType)
+import System.IO.Error (ioeGetErrorType,isDoesNotExistError)
 import System.IO 
     ( IOMode(..)
     , hSetBuffering
@@ -311,18 +311,17 @@ server = do
     where 
     forkit = void . forkIO $ do
         proto <- getProtocolNumber "tcp"
-        sock <- bracketOnError
-            (socket (socketFamily addr) Stream proto)
-            (\sock -> do -- only done if there's an error
-                         -- Weird hack: puting the would-be peer address
-                         -- instead of local socketName
+        sock <- socket (socketFamily addr) Stream proto
+        handle (\e -> do -- let t = ioeGetErrorType e
+                         when (isDoesNotExistError e) $ return () -- warn "GOTCHA"
+                         -- warn $ "connect-error: " <> bshow e
                          conkey <- makeConnKey params (sock,addr) -- XXX: ?
                          sClose sock
                          atomically 
                             $ writeTChan (serverEvent server) 
                                 $ (conkey,ConnectFailure addr))
-            $ \sock -> do connect sock addr
-                          return sock
+               $ do
+        connect sock addr
         me <- getSocketName sock
         conkey <- makeConnKey params (sock,me)
         h <- socketToHandle sock ReadWriteMode
@@ -350,9 +349,10 @@ server = do
         fix $ \retryLoop -> do
         utc <- getCurrentTime
         forkIO $ do
-            sock <- bracketOnError
-                (socket (socketFamily addr) Stream proto)
-                (\sock -> do -- only done if there's an error
+            sock <- socket (socketFamily addr) Stream proto
+            handle (\e -> do -- let t = ioeGetErrorType e
+                             when (isDoesNotExistError e) $ return () --  warn "GOTCHA"
+                             -- warn $ "connect-error: " <> bshow e
                              -- Weird hack: puting the would-be peer address
                              -- instead of local socketName
                              conkey <- makeConnKey params (sock,addr) -- XXX: ?
@@ -362,8 +362,8 @@ server = do
                                     $ (conkey,ConnectFailure addr)
                                 retry <- readTVar retryVar
                                 putTMVar resultVar retry)
-                $ \sock -> do connect sock addr
-                              return sock
+                   $ do
+            connect sock addr
             me <- getSocketName sock
             conkey <- makeConnKey params (sock,me)
             h <- socketToHandle sock ReadWriteMode
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 8afc3245..ceb83476 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -37,6 +37,7 @@ import ControlMaybe
 import Nesting
 import EventUtil
 import Server
+import ResourcePolicy (getResourceName)
 
 peerport = 5269
 clientport = 5222
@@ -101,10 +102,10 @@ data Stanza
                    stanzaChan :: TChan (Maybe XML.Event) }
 -}
 
-data StanzaType = Unrecognized | Ping | Pong | BindResource (Maybe Text)
+data StanzaType = Unrecognized | Ping | Pong | RequestResource (Maybe Text) | SetResource
  deriving Show
 
-data StanzaOrigin = LocalPeer | NetworkOrigin ConnectionKey
+data StanzaOrigin = LocalPeer | NetworkOrigin ConnectionKey (TChan Stanza)
 
 data Stanza = Stanza
     { stanzaType :: StanzaType
@@ -141,6 +142,31 @@ prettyPrint prefix =
         =$= CB.lines 
         =$ CL.mapM_ (wlogb . (prefix <>))
 
+sendReply donevar stype reply replychan = do
+    if null reply then return ()
+    else do
+    let stanzaTag = head reply
+        mid   = lookupAttrib "id" (tagAttrs stanzaTag)
+        mfrom = lookupAttrib "from" (tagAttrs stanzaTag)
+        mto = lookupAttrib "to" (tagAttrs stanzaTag)
+    replyStanza <- liftIO . atomically $ do
+        replyChan <- newTChan
+        replyClsrs <- newTVar (Just [])
+        return Stanza { stanzaType = stype
+                      , stanzaId = mid
+                      , stanzaTo = mto      -- todo: should this be reversed?
+                      , stanzaFrom = mfrom  -- todo: should this be reversed?
+                      , stanzaChan = replyChan
+                      , stanzaClosers = replyClsrs
+                      , stanzaInterrupt = donevar
+                      , stanzaOrigin = LocalPeer
+                      }
+    ioWriteChan replychan replyStanza
+    void . liftIO . forkIO $ do
+        mapM_ (ioWriteChan $ stanzaChan replyStanza) reply
+        liftIO . atomically $ writeTVar (stanzaClosers replyStanza) Nothing
+        -- liftIO $ wlog "finished reply stanza"
+
 grokStanzaIQGet :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType)
 grokStanzaIQGet stanza = do
     mtag <- nextElement 
@@ -166,9 +192,9 @@ grokStanzaIQSet stanza = do
             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)
+                    return . Just $ RequestResource (Just rsc)
                 Just _ -> return Nothing
-                Nothing -> return . Just $ BindResource Nothing
+                Nothing -> return . Just $ RequestResource Nothing
         _ -> return Nothing
 
 
@@ -227,35 +253,31 @@ xmppInbound sv k pingflag src stanzas output donevar = doNestingXML $ do
               mfrom = lookupAttrib "from" (tagAttrs stanzaTag)
               mto = lookupAttrib "to" (tagAttrs stanzaTag)
           dispatch <- grokStanza namespace stanzaTag
-          flip (maybe $ return ()) dispatch $ \dispatch -> 
+          let unrecog = do
+                let stype = Unrecognized
+                s <- liftIO . atomically $ do
+                      return Stanza
+                              { stanzaType = stype
+                              , stanzaId = mid
+                              , stanzaTo = mto
+                              , stanzaFrom = mfrom
+                              , stanzaChan = chan
+                              , stanzaClosers = clsrs
+                              , stanzaInterrupt = donevar
+                              , stanzaOrigin = NetworkOrigin k output
+                              }
+                ioWriteChan stanzas s
+          flip (maybe $ unrecog) 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 = makePong namespace mid to from
-                -- liftIO $ wlog "got ping, sending pong..."
-                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 $ stanzaChan pongStanza) pong
-                    liftIO . atomically $ writeTVar (stanzaClosers pongStanza) Nothing
-                    -- liftIO $ wlog "finished pong stanza"
-                
+                let pongto = maybe "todo" id mfrom
+                    pongfrom = maybe "todo" id mto
+                    pong = makePong namespace mid pongto pongfrom
+                sendReply donevar Pong pong output
                 -- TODO: Remove this, it is only to generate a debug print
                 ioWriteChan stanzas Stanza
                             { stanzaType = Ping
@@ -265,7 +287,7 @@ xmppInbound sv k pingflag src stanzas output donevar = doNestingXML $ do
                             , stanzaChan = chan
                             , stanzaClosers = clsrs
                             , stanzaInterrupt = donevar
-                            , stanzaOrigin = NetworkOrigin k
+                            , stanzaOrigin = NetworkOrigin k output
                             }
               stype -> ioWriteChan stanzas Stanza
                             { stanzaType = stype
@@ -275,7 +297,7 @@ xmppInbound sv k pingflag src stanzas output donevar = doNestingXML $ do
                             , stanzaChan = chan
                             , stanzaClosers = clsrs
                             , stanzaInterrupt = donevar
-                            , stanzaOrigin = NetworkOrigin k
+                            , stanzaOrigin = NetworkOrigin k output
                             }
           awaitCloser stanza_lvl
         liftIO . atomically $ writeTVar clsrs Nothing
@@ -334,6 +356,22 @@ greet' namespace host =
         ]
     ] ++ streamFeatures namespace
 
+consid Nothing = id
+consid (Just sid) = (("id",[ContentText sid]):)
+
+iq_bind_reply :: Maybe Text -> Text -> [XML.Event]
+iq_bind_reply mid jid =
+    [ EventBeginElement "{jabber:client}iq" (consid mid [("type",[ContentText "result"])])
+    , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
+        [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])]
+    , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}jid" []
+    , EventContent (ContentText jid)
+    , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}jid"
+    , EventEndElement  "{urn:ietf:params:xml:ns:xmpp-bind}bind"
+    , EventEndElement "{jabber:client}iq"
+    ]
+
+{-
 greet namespace =
     [ EventBeginDocument
     , EventBeginElement (streamP "stream")
@@ -341,6 +379,7 @@ greet namespace =
         , attr "version" "1.0"
         ]
     ]
+-}
 
 goodbye = 
     [ EventEndElement (streamP "stream")
@@ -403,12 +442,14 @@ forkConnection sv k pingflag src snk stanzas = do
                 [Slotted.pull slots >>= \x -> do
                     writeTVar needsFlush True
                     return $ do
+                    -- liftIO $ wlog $ "yielding Chunk: " ++ show x
                     yield (Chunk x)
                     slot_src
                 ,do Slotted.isEmpty slots >>= check
                     readTVar needsFlush >>= check
                     writeTVar needsFlush False
                     return $ do
+                    -- liftIO $ wlog "yielding Flush"
                     yield Flush
                     slot_src
                 ,readTMVar rdone >> return (return ())
@@ -501,9 +542,14 @@ stanzaToConduit stanza = do
                 return (return ())]
         what
 
+socketFromKey :: Server k -> k -> IO Socket
+socketFromKey sv k = do
+    return todo
+
 monitor sv params = do
     chan <- return $ serverEvent sv
     stanzas <- atomically newTChan
+    quitVar <- atomically newEmptyTMVar
     fix $ \loop -> do
     action <- atomically $ foldr1 orElse
       [ readTChan chan >>= \(k,e) -> return $ do 
@@ -513,8 +559,7 @@ monitor sv params = do
                  let (xsrc,xsnk) = xmlStream conread conwrite
                  forkConnection sv k pingflag xsrc xsnk stanzas
                  return ()
-            ConnectFailure addr -> do
-                wlog $ tomsg k "ConnectFailure"
+            ConnectFailure addr -> return () -- wlog $ tomsg k "ConnectFailure"
             EOF        -> wlog $ tomsg k "EOF"
             HalfConnection In -> do
                 wlog $ tomsg k "ReadOnly"
@@ -523,13 +568,22 @@ monitor sv params = do
             RequiresPing -> return () -- wlog $ tomsg k "RequiresPing"
             _ -> return ()
       , readTChan stanzas >>= \stanza -> return $ do
+        forkIO $ do
+            case (stanzaType stanza,stanzaOrigin stanza) of
+                (RequestResource wanted, NetworkOrigin k@(ClientKey{}) replyto) -> do
+                    sock <- socketFromKey sv k
+                    rsc <- getResourceName sock wanted
+                    let reply = iq_bind_reply (stanzaId stanza) rsc
+                    sendReply quitVar SetResource reply replyto
+                _ -> return ()
         let typ = Strict8.pack $ c ++ "->"++(show (stanzaType stanza))++" "
             c = case stanzaOrigin stanza of
                     LocalPeer -> "*"
-                    NetworkOrigin (ClientKey {}) -> "C"
-                    NetworkOrigin (PeerKey {}) -> "P"
+                    NetworkOrigin (ClientKey {}) _ -> "C"
+                    NetworkOrigin (PeerKey {})   _ -> "P"
         wlog ""
         stanzaToConduit stanza $$ prettyPrint typ
+        
       ]
     action
     loop