Shared hostname with client-connection.

1 files changed, 34 insertions, 27 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 6d7841ff..6c0b609e 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -44,6 +44,9 @@ import Control.DeepSeq
 import Control.Concurrent.STM
 import Control.Concurrent
 import Control.Exception
+import Text.Show.ByteString as L
+import Data.Binary.Builder as B
+import Data.Binary.Put
 
 -- | Jabber ID (JID) datatype
 data JID = JID { name :: Maybe ByteString
@@ -52,8 +55,11 @@ data JID = JID { name :: Maybe ByteString
                }
  deriving (Ord,Eq)
 
-instance Show JID where
-    show (JID n s r ) = L.unpack $ fmap (<++>"@") n <?++> s <++?> fmap ("/"<++>) r
+instance L.Show JID where
+    showp (JID n s r ) = putBuilder . B.fromLazyByteString $ n <$++> "@" <?++> s <++?>  "/" <++$> r
+
+instance Prelude.Show JID where
+    show jid = L.unpack $ L.show jid
 
 instance NFData JID where
     rnf v@(JID n s r) = n `seq` s `seq` r `seq` ()
@@ -63,13 +69,13 @@ jid user host rsrc = JID (Just user) host (Just rsrc)
 data JabberShow = Offline
                 | Away
                 | Available
- deriving (Show,Enum,Ord,Eq,Read)
+ deriving (Prelude.Show,Enum,Ord,Eq,Read)
 
 data Presence = Presence JID JabberShow
- deriving Show
+ deriving Prelude.Show
 
 xmlifyPresence (Presence jid stat) = L.unlines 
-  [ "<presence from='" <++> bshow jid <++> "' " <++> typ stat <++> ">"
+  [ "<presence from='" <++> L.show jid <++> "' " <++> typ stat <++> ">"
   , "<show>" <++> shw stat <++> "</show>"
   , "</presence>"
   ]
@@ -88,7 +94,7 @@ class XMPPSession session where
     data XMPPClass session
     newSession   :: XMPPClass session -> Socket -> Handle -> IO session
     setResource  :: session -> ByteString -> IO ()
-    getJID       :: session -> IO ByteString
+    getJID       :: session -> IO JID
     closeSession :: session -> IO ()
     subscribe :: session -> Maybe JID -> IO (TChan Presence)
 
@@ -114,15 +120,15 @@ greet host = L.unlines
 -- data TaggedXMPPSession s = TaggedXMPPSession s
 
 data Commands = Send ByteString
- deriving Show
+ deriving Prelude.Show
 
 startCon session_factory sock st  = do
     let h = hOccursFst st :: Handle 
     cred <- getLocalPeerCred sock
-    Prelude.putStrLn $ "PEER CRED: "++show cred
+    Prelude.putStrLn $ "PEER CRED: "++Prelude.show cred
     pname <- getPeerName sock
     session <- newSession session_factory sock h
-    Prelude.putStrLn $ "PEER NAME: "++show pname
+    Prelude.putStrLn $ "PEER NAME: "++Prelude.show pname
     pchan <- subscribe session Nothing
     cmdChan <- atomically newTChan
     reader <- forkIO $
@@ -150,9 +156,7 @@ startCon session_factory sock st  = do
 
 iq_query_unavailable host id mjid xmlns kind = L.unlines $
     [ "<iq type='error'"
-    , "    from='" <++> host <++> "'"
-    , case mjid of  Just jid -> "    to='" <++> jid <++> "'"
-                    Nothing  -> ""
+    , "    from='" <++> host <++> "'" <++?> " to='" <++$> mjid <$++> "'"
     , "    id='" <++> id <++> "'>"
     , "  <" <++> kind <++> " xmlns='" <++> xmlns <++> "'/>"
     , "  <error type='cancel'>"
@@ -195,11 +199,10 @@ iq_session_reply host id = L.unlines $
     , "    /> "
     ]
 
+{-
 iqresult_info host id mjid = L.unlines $
     [ "<iq type='result'"
-    , "    from='" <++> host <++> "'"
-    , case mjid of  Just jid -> "    to='" <++> jid <++> "'"
-                    Nothing  -> ""
+    , "    from='" <++> host <++> "'" <++?> " to='" <++$> mjid <$++> "'"
     , "    id='" <++> id <++> "'>"
     , "  <query xmlns='http://jabber.org/protocol/disco#info'>"
     , "    <identity"
@@ -211,10 +214,12 @@ iqresult_info host id mjid = L.unlines $
     , "  </query>"
     , "</iq>"
     ]
+-}
 
 iqresponse session host (Elem _ attrs content) = runMaybeT $ do
     id <- MaybeT . return $ fmap pack (lookup (N "id") attrs >>= unattr) 
     typ <- MaybeT . return $ fmap pack (lookup (N "type") attrs >>= unattr)
+    host <- fmap server $ getJID session
     case typ of
       "set" -> do
         let string (CString _ s _) = [s]
@@ -224,7 +229,7 @@ iqresponse session host (Elem _ attrs content) = runMaybeT $ do
                 liftIO $ do
                  setResource session rsrc
                  jid <- getJID session
-                 return $ iq_bind_reply id jid )
+                 return $ iq_bind_reply id (L.show jid) )
               (do
                 guard (hasElem "session" content)
                 return (iq_session_reply host id))
@@ -234,11 +239,11 @@ iqresponse session host (Elem _ attrs content) = runMaybeT $ do
         xmlns <- MaybeT . return $ fmap pack $ listToMaybe . astring $ as
         let servicekind = case tag of { (N s) -> pack s ; _ -> "query" }
         case xmlns of
-            "urn:xmpp:ping" -> do
-                let to = case fmap pack (lookup (N "from") attrs >>= unattr) of
-                            Just jid -> "to='" <++> jid <++> "' "
-                            Nothing  -> ""
-                return $ "<iq from='" <++> host <++> "' " <++> to <++> "id='" <++> id <++> "' type='result'/>"
+            "urn:xmpp:ping" ->
+                return $ 
+                    "<iq from='" <++> host 
+                    <++> ("' " <++?> "to='" <++$> fmap pack (lookup (N "from") attrs >>= unattr) <$++> "' ")
+                    <++> "id='" <++> id <++> "' type='result'/>"
 
             _ -> return (iq_query_unavailable host id Nothing xmlns servicekind)
       _ -> MaybeT (return Nothing)
@@ -256,14 +261,14 @@ presence_response host (Elem _ attrs content) = do
 
 doCon st elem cont = do
         let h = hOccursFst st :: Handle 
-            host = "localhost"
             (session,cmdChan) = hHead st
             hsend r = do
                 atomically $ writeTChan cmdChan (Send r)
                 -- hPutStrLn h r
                 L.putStrLn $ "\nOUT:\n" <++> r
-
-        putStrLn $ (show $ hang (text "\nIN:") 2 $ pp elem) ++ "\n"
+        host <- fmap server $ getJID session
+        
+        putStrLn $ (Prelude.show $ hang (text "\nIN:") 2 $ pp elem) ++ "\n"
 
         case elem of
             OpenTag _ -> 
@@ -282,7 +287,7 @@ doCon st elem cont = do
 
         cont ()
 
-instance Show Hax.ElemTag where
+instance Prelude.Show Hax.ElemTag where
     show _ = "elemtag"
 
 data XmppObject
@@ -290,10 +295,10 @@ data XmppObject
     | ProcessingInstruction Hax.ProcessingInstruction
     | OpenTag ElemTag
     | CloseTag ()
- deriving Show
+ deriving Prelude.Show
 
 pp (Element e) = PP.element e
-pp o = fromString (show o)
+pp o = fromString (Prelude.show o)
 
 streamName = QN (Namespace {nsPrefix= "stream" , nsURI="http://etherx.jabber.org/streams" }) "stream" 
 
@@ -349,3 +354,5 @@ listenForRemotePeers session_factory port st = do
              dopkt
              start
 
+seekRemotePeers session_factory st = do
+    return ()