1 files changed, 183 insertions, 39 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 387b223e..aa3140e5 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -21,6 +21,9 @@ import Data.ByteString.Lazy.Char8 as L
     ( hPutStrLn
     , unlines
     , lines
+    , uncons
+    , takeWhile
+    , concat
     , splitWith
     , drop
     , ByteString
@@ -57,19 +60,69 @@ import Data.Binary.Builder as B
 import Data.Binary.Put
 import qualified Data.Map as Map
 import GHC.Conc
-import Network.BSD
+import Network.BSD hiding (getHostByAddr)
 import Control.Concurrent.Async
 import qualified Data.Set as Set
+import GetHostByAddr
+
+data Peer = LocalHost | RemotePeer SockAddr
+  deriving (Eq,Prelude.Show)
+
+instance Ord Peer where
+    LocalHost <= _  
+      = True
+    RemotePeer (SockAddrUnix a) <= RemotePeer (SockAddrUnix b)
+      = a <= b
+    RemotePeer (SockAddrUnix _) <= _
+      = True
+    RemotePeer (SockAddrInet aport a) <= RemotePeer (SockAddrInet bport b)
+      = (a,aport) <= (b,bport)
+    RemotePeer (SockAddrInet aport a) <= _
+      = True
+    RemotePeer (SockAddrInet6 aport aflow a ascope) <= RemotePeer (SockAddrInet6 bport bflow b bscope)
+      = (a,aport,ascope,aflow) <= (b,bport,bscope,bflow)
+    a <= b = False
 
 -- | Jabber ID (JID) datatype
 data JID = JID { name :: Maybe ByteString
-               , server :: ByteString
+               , peer :: Peer
                , resource :: Maybe ByteString
                }
- deriving (Ord,Eq)
+ deriving (Eq,Ord)
+
+is_remote (RemotePeer _) = True
+is_remote _              = False
+
+getNamesForPeer :: Peer -> IO [ByteString]
+getNamesForPeer LocalHost = fmap ((:[]) . pack) getHostName
+getNamesForPeer peer@(RemotePeer addr) = do
+    {-
+    let hints = Just $ defaultHints { addrFlags = [ AI_CANONNAME ] }
+    L.putStrLn $ "getAddrInfo 1 " <++> showPeer peer
+    infos <- getAddrInfo hints (Just . unpack . showPeer $ peer) Nothing
+    return . map pack . mapMaybe addrCanonName $ infos
+    -}
+    -- ent <- getHostByName (unpack . showPeer $ peer)
+    ent <- getHostByAddr addr --  AF_UNSPEC addr
+    let names = hostName ent : hostAliases ent
+    return . map pack $ names
+
+
+showPeer :: Peer -> ByteString
+showPeer LocalHost = "localhost"
+showPeer (RemotePeer addr@(SockAddrInet _ _)) = pack $ stripColon (Prelude.show addr)
+ where stripColon s = pre where (pre,port) = break (==':') s
+showPeer (RemotePeer addr@(SockAddrInet6 _ _ _ _)) = pack $ stripColon (Prelude.show addr)
+ where stripColon s = if null bracket then pre else pre ++ "]"
+          where
+            (pre,bracket) = break (==']') s
+
+peerAddr :: Peer -> SockAddr
+peerAddr (RemotePeer addr) = addr
+-- peerAddr LocalHost = throw exception
 
 instance L.Show JID where
-    showp (JID n s r ) = putBuilder . B.fromLazyByteString $ n <$++> "@" <?++> s <++?>  "/" <++$> r
+    showp (JID n s r ) = putBuilder . B.fromLazyByteString $ n <$++> "@" <?++> showPeer s <++?>  "/" <++$> r
 
 instance Prelude.Show JID where
     show jid = L.unpack $ L.show jid
@@ -87,12 +140,38 @@ data JabberShow = Offline
 data Presence = Presence JID JabberShow
  deriving Prelude.Show
 
-xmlifyPresence (Presence jid stat) = L.unlines 
-  [ "<presence from='" <++> L.show jid <++> "' " <++> typ stat <++> ">"
-  , "<show>" <++> shw stat <++> "</show>"
-  , "</presence>"
-  ]
+xmlifyPresenceForPeer sock (Presence jid stat) = do
+    -- TODO: accept socket argument and determine local ip address
+    --       connected to this peer.
+    addr <- getSocketName sock
+    let n = name jid
+        rsc = resource jid
+        jid_str = n <$++> "@" <?++> showPeer (RemotePeer addr) <++?>  "/" <++$> rsc 
+    return . L.unlines $
+      [ "<presence from='" <++> jid_str <++> "' " <++> typ stat <++> ">"
+      , "<show>" <++> shw stat <++> "</show>"
+      , "</presence>"
+      ]
+ where
+    typ Offline = " type='unavailable'"
+    typ _       = ""
+    shw Available = "chat"
+    shw Away      = "away"
+    shw Offline   = "away" -- Is this right?
+
+xmlifyPresenceForClient (Presence jid stat) = do
+    let n   = name jid
+        rsc = resource jid
+    names <- getNamesForPeer (peer jid)
+    let tostr p = n <$++> "@" <?++> p <++?>  "/" <++$> rsc
+        jidstrs = fmap tostr names
+    return (L.concat $ map doit jidstrs)
  where
+    doit jidstr = L.unlines 
+      [ "<presence from='" <++> jidstr <++> "' " <++> typ stat <++> ">"
+      , "<show>" <++> shw stat <++> "</show>"
+      , "</presence>"
+      ]
     typ Offline = " type='unavailable'"
     typ _       = ""
     shw Available = "chat"
@@ -160,7 +239,7 @@ startCon session_factory sock st  = do
                     L.putStrLn $ "PRESENCE: " <++> bshow presence
                     -- TODO: it violates spec to send presence information before
                     --  a resource is bound.
-                    let r = xmlifyPresence presence
+                    r <- xmlifyPresenceForClient presence
                     hPutStrLn h r
                     L.putStrLn $ "\nOUT:\n" <++> r
                 Right (Send r) ->
@@ -282,7 +361,11 @@ doCon st elem cont = do
                 atomically $ writeTChan cmdChan (Send r)
                 -- hPutStrLn h r
                 L.putStrLn $ "\nOUT:\n" <++> r
-        host <- fmap server $ getJID session
+        -- host <- fmap pack $ getHostName -- Assume localhost for client session JID
+        host <- do
+            jid <- getJID session
+            names <- getNamesForPeer (peer jid)
+            return (head names)
         
         putStrLn $ (Prelude.show $ hang (text "\nIN:") 2 $ pp elem) ++ "\n"
 
@@ -369,16 +452,18 @@ doPeer st elem cont = do
         case (jid,typ) of
           (Just jid,Just "unavailable") -> do
             L.putStrLn $ "INBOUND PRESENCE! Offline jid=" <++> jid
-            announcePresence session (Presence (parseJID jid) Offline)
+            -- parseAddressJID -- convert peer reported user@address to JID data structure
+            peer_jid <- parseAddressJID jid
+            announcePresence session (Presence peer_jid Offline)
           (Just jid,Just typ) -> 
             -- possible probe, ignored for now
             L.putStrLn $ "INBOUND PRESENCE! "<++>typ<++>" jid="<++>jid
           (Just jid,Nothing) -> do
             let string (CString _ s _) = [s]
-                show = listToMaybe . Prelude.concatMap string . tagcontent "show" $ content
-
+                stat = listToMaybe . Prelude.concatMap string . tagcontent "show" $ content
             -- Available or Away.
-            L.putStrLn $ "INBOUND PRESENCE! avail/away jid=" <++> jid
+            names <- parseAddressJID jid >>= getNamesForPeer  . peer
+            L.putStrLn $ "INBOUND PRESENCE! "<++>bshow (stat,names)<++>" avail/away jid=" <++> jid
             -- todo: announcePresence
       _ -> return () -- putStrLn $ "inbound unhandled: "++show v
     cont ()
@@ -426,16 +511,16 @@ sendMessage cons msg peer = do
     let newEntry = do
           chan <- atomically newTChan
           t <- forkIO $ connect_to_server chan peer
-          L.putStrLn $ "remote-map new: " <++> peer
+          L.putStrLn $ "remote-map new: " <++> showPeer peer
           return (True,(chan,t))
     (is_new,entry) <- maybe newEntry
           ( \(chan,t) -> do 
                         st <- threadStatus t
                         let running = do
-                                L.putStrLn $ "remote-map, thread running: " <++> peer
+                                L.putStrLn $ "remote-map, thread running: " <++> showPeer peer
                                 return (False,(chan,t))
                             died = do
-                                L.putStrLn $ "remote-map, thread died("<++>bshow st<++>"): " <++> peer
+                                L.putStrLn $ "remote-map, thread died("<++>bshow st<++>"): " <++> showPeer peer
                                 newEntry 
                         case st of 
                           ThreadRunning   -> running
@@ -444,7 +529,7 @@ sendMessage cons msg peer = do
                           ThreadFinished  -> died
                         )
           found
-    L.putStrLn $ "sendMessage ->"<++>peer<++>": "<++>bshow msg
+    L.putStrLn $ "sendMessage ->"<++>showPeer peer<++>": "<++>bshow msg
     atomically $ writeTChan (fst entry) msg
     when is_new . atomically $
         readTVar cons >>= writeTVar cons . Map.insert peer entry
@@ -452,7 +537,7 @@ sendMessage cons msg peer = do
 connect_to_server chan peer = (>> return ()) . runMaybeT $ do
     let port = "5269"
 
-    connected <- liftIO . async $ connect' (unpack peer) port
+    connected <- liftIO . async $ connect' (peerAddr peer) port
 
     -- We'll cache Presence notifications until the socket
     -- is ready.
@@ -486,14 +571,14 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do
         cache <- fmap Map.assocs . readIORef $ cached
         writeIORef cached Map.empty -- hint garbage collector: we're done with this
         forM_ cache $ \(jid,st) -> do
-            let r = xmlifyPresence (Presence jid st)
+            r <- xmlifyPresenceForPeer sock (Presence jid st)
             hPutStrLn h r
             L.putStrLn $ "REMOTE-OUT (cache):\n" <++> r <++> "\n"
         fix $ \loop -> do
             event <- atomically $ readTChan chan
             case event of
               OutBoundPresence p -> do
-                let r = xmlifyPresence p
+                r <- xmlifyPresenceForPeer sock p
                 hPutStrLn h r
                 L.putStrLn $ "REMOTE-OUT:\n" <++> r <++> "\n"
             loop
@@ -501,34 +586,90 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do
         L.putStrLn $ "REMOTE-OUT: </stream>"
 
 
-parseJID :: ByteString -> JID
-parseJID bjid = 
+splitJID :: ByteString -> (Maybe ByteString,ByteString,Maybe ByteString)
+splitJID bjid = 
     let xs = L.splitWith (=='@') bjid
         ys = L.splitWith (=='/') (last xs)
-        (name,server) 
+        server = head ys
+        name
             = case xs of
-                (n:s:_) -> (Just n,s)
-                (s:_)   -> (Nothing,s)
+                (n:s:_) -> Just n
+                (s:_)   -> Nothing
         rsrc = case ys of
                 (s:_:_) -> Just $ last ys
                 _       -> Nothing
-    in JID name server rsrc
-
-connect' :: HostName -> ServiceName -> IO (Maybe Socket)
-connect' host serv = do
+    in (name,server,rsrc)
+
+strip_brackets s = 
+    case L.uncons s of
+      Just ('[',t) -> L.takeWhile (/=']') t
+      _            -> s
+
+parseAddressJID :: ByteString -> IO JID
+parseAddressJID jid = do
+    let (name,peer_string,rsc) = splitJID jid
+        hints = Just $ defaultHints { addrFlags = [ {- AI_NUMERICHOST, -} AI_CANONNAME ] }
+        peer_string' = unpack . strip_brackets $ peer_string
+    peer <- do
+        putStrLn $ "getAddrInfo 2 " ++ Prelude.show ( Just (unpack peer_string))
+        info <- getAddrInfo hints (Just peer_string') Nothing -- (Just "xmpp-server")
+        let info0 = head info
+        return . RemotePeer . addrAddress $ info0
+    return $ JID name peer rsc
+
+parseHostNameJID :: ByteString -> IO JID
+parseHostNameJID jid = do
+    let (name,peer_string,rsc) = splitJID jid
+        hints = Just $ defaultHints { addrFlags = [ AI_CANONNAME ] }
+    peer <- do
+        if peer_string=="localhost"
+          then return LocalHost
+          else do
+            putStrLn $ "getAddrInfo 3 " ++ Prelude.show ( Just (unpack peer_string))
+            info <- getAddrInfo hints (Just (unpack peer_string)) Nothing -- (Just "xmpp-server")
+            let info0 = head info
+                cname = addrCanonName info0
+            if cname==Just "localhost"
+              then return LocalHost
+              else do
+                self <- getHostName
+                return $ if Just self==cname
+                          then LocalHost 
+                          else RemotePeer (addrAddress info0)
+    return $ JID name peer rsc
+
+socketFamily (SockAddrInet _ _)      = AF_INET
+socketFamily (SockAddrInet6 _ _ _ _) = AF_INET6
+socketFamily (SockAddrUnix _)        = AF_UNIX
+
+connect' :: SockAddr -> ServiceName -> IO (Maybe Socket)
+connect' addr serv = do
     proto <- getProtocolNumber "tcp"
+    {-
+    -- Given (host :: HostName) ...
     let hints = defaultHints { addrFlags = [AI_ADDRCONFIG]
                              , addrProtocol = proto
                              , addrSocketType = Stream }
     addrs <- getAddrInfo (Just hints) (Just host) (Just serv)
     firstSuccessful $ map tryToConnect addrs
+    -}
+    let getport (SockAddrInet port _) = port
+        getport (SockAddrInet6 port _ _ _) = port
+    let port = getport addr
+    let withPort (SockAddrInet _ a)      port = SockAddrInet port a
+        withPort (SockAddrInet6 _ a b c) port = SockAddrInet6 port a b c
+    let doException (SomeException e) = do
+            L.putStrLn $  "\nFailed to reach "<++> showPeer (RemotePeer addr) <++> " on port "<++>bshow port<++>": " <++> bshow e
+            return Nothing
+    handle doException
+         $ tryToConnect proto (addr `withPort` 5269)
   where
-  tryToConnect addr =
+  tryToConnect proto addr =
     bracketOnError
-        (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
+        (socket (socketFamily addr) Stream proto)
         (sClose )  -- only done if there's an error
         (\sock -> do
-          connect sock (addrAddress addr)
+          connect sock addr
           return (Just sock) -- socketToHandle sock ReadWriteMode
         )
 
@@ -547,8 +688,8 @@ firstSuccessful (p:ps) = catchIO p $ \e ->
 
 
 seekRemotePeers :: XMPPConfig config =>
-     (ByteString -> Bool) -> config -> TChan Presence -> IO b0
-seekRemotePeers is_peer config chan = do
+     config -> TChan Presence -> IO b0
+seekRemotePeers config chan = do
     server_connections <- newServerConnections
     fix $ \loop -> do
         event <- atomically $ readTChan chan
@@ -557,10 +698,13 @@ seekRemotePeers is_peer config chan = do
               L.putStrLn $ "seekRemotePeers: " <++> L.show jid <++> " " <++> bshow stat
               runMaybeT $ do
                   u <- MaybeT . return $ name jid
-                  subscribers <- liftIO $ getSubscribers config u
+                  subscribers <- liftIO $ do
+                    subs <- getSubscribers config u
+                    mapM parseHostNameJID subs
                   liftIO . L.putStrLn $ "subscribers: " <++> bshow subscribers
-                  let peers = Set.map (server . parseJID) (Set.fromList subscribers)
+                  -- parseJID -- get subscriber list reported user@hostname to JID data structure
+                  let peers = Set.map peer (Set.fromList subscribers)
                   forM_ (Set.toList peers) $ \peer -> do
-                    when (is_peer peer) $
+                    when (is_remote peer) $
                         liftIO $ sendMessage server_connections (OutBoundPresence p) peer
         loop