Shared hostname with client-connection.

3 files changed, 55 insertions, 36 deletions

diff --git a/Presence/ByteStringOperators.hs b/Presence/ByteStringOperators.hs
index 2815f05a..9e6cc938 100644
--- a/Presence/ByteStringOperators.hs
+++ b/Presence/ByteStringOperators.hs
@@ -2,6 +2,7 @@ module ByteStringOperators where
 
 import qualified Data.ByteString as S (ByteString)
 import Data.ByteString.Lazy.Char8 as L 
+import Control.Applicative
 
 -- These two were imported to provide an NFData instance.
 import qualified Data.ByteString.Lazy.Internal as L (ByteString(..))
@@ -21,6 +22,13 @@ infixr 5 <.++>
 infixr 5 <++>
 infixr 5 <++.>
 
+a <++$> b = fmap (a<++>) b
+a <$++> b = fmap (<++>b) a
+a <$++$> b = liftA2 (<++>) a b
+infixr 6 <++$>
+infixr 6 <$++>
+infixr 6 <$++$>
+
 Nothing <?++> b = b
 Just a  <?++> b = a <++> b
 infixr 5 <?++>
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 ()
diff --git a/Presence/main.hs b/Presence/main.hs
index 86503a62..e416d7cc 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -46,6 +46,7 @@ import           Data.ByteString.Lazy.Char8 as L (ByteString,putStrLn)
 import qualified Prelude
 import           Prelude hiding (putStrLn)
 import System.Environment
+import qualified Text.Show.ByteString as L
 
 
 data UnixSession = UnixSession {
@@ -79,14 +80,19 @@ instance XMPPSession UnixSession where
                         )
                    muid
         rsc <- readIORef (unix_resource s)
-        let suf = maybe "" ("/"<++>) rsc
-            jid = user <++> "@" <++> host <++> suf
-        L.putStrLn $ "SESSION: jid " <++> jid
-        return jid
+        -- let jid = user <++> "@" <++> host <++?> "/" <++$> rsc
+        L.putStrLn $ "SESSION: jid " <++> L.show (JID (Just user) host rsc)
+        return (JID (Just user) host rsc)
     closeSession _             = L.putStrLn "SESSION: close"
     subscribe session Nothing = do
         let tmvar = greedySubscriber (presence_state session)
-        chan <- atomically $
+        atomically $ subscribeToChan tmvar
+    subscribe session (Just jid) = do
+        let tvar = subscriberMap (presence_state session)
+        atomically $ subscribeToMap tvar jid
+
+
+subscribeToChan tmvar =
             (do (cnt,chan) <- takeTMVar tmvar
                 putTMVar tmvar (cnt+1,chan)
                 chan' <- dupTChan chan
@@ -95,10 +101,8 @@ instance XMPPSession UnixSession where
             (do chan <- newTChan
                 putTMVar tmvar (1,chan)
                 return chan )
-        return chan
-    subscribe session (Just jid) = do
-        let tvar = subscriberMap (presence_state session)
-        atomically $ do
+
+subscribeToMap tvar jid = do
             subs <- readTVar tvar
             let mbchan       = Map.lookup jid subs
             (chan,subs') <-