Merge branch 'master' of samwise:presence

4 files changed, 395 insertions, 82 deletions

diff --git a/Presence/ServerC.hs b/Presence/ServerC.hs
index b16a0099..22104a31 100644
--- a/Presence/ServerC.hs
+++ b/Presence/ServerC.hs
@@ -8,6 +8,7 @@ module ServerC
     , ServerHandle
     , quitListening
     , dummyServerHandle
+    , packetSink
     ) where
 
 import Network.Socket as Socket
@@ -123,13 +124,13 @@ packets h = do
  where
     getPacket h = do { hWaitForInput h (-1) ; hGetNonBlocking h 1024 }
 
-outgoing :: MonadIO m => Handle -> Sink S.ByteString m ()
-outgoing h = do
+packetSink :: MonadIO m => Handle -> Sink S.ByteString m ()
+packetSink h = do
     -- liftIO . L.putStrLn $ "outgoing: waiting"
     mpacket <- await
     -- liftIO . L.putStrLn $ "outgoing: got packet " <++> bshow mpacket
     maybe (return ()) 
-          (\r -> (liftIO . S.hPutStrLn h $ r) >> outgoing h) 
+          (\r -> (liftIO . S.hPutStrLn h $ r) >> packetSink h) 
           mpacket
     
 
@@ -148,5 +149,5 @@ runConn g st (sock,_) = do
         h <- socketToHandle sock ReadWriteMode
         hSetBuffering h NoBuffering
         let doException (SomeException e) = Prelude.putStrLn ("\n\nexception: " ++ show e ++ "\n\n")
-        handle doException (g (restrictSocket sock `HCons` st) (packets h) (outgoing h))
+        handle doException (g (restrictSocket sock `HCons` st) (packets h) (packetSink h))
         hClose h
diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 1a4b0e7b..36630bc7 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -16,8 +16,29 @@ import SocketLike
 import ByteStringOperators
 
 import Data.HList
-import Network.Socket (Family)
-import Network.BSD (PortNumber)
+import Network.Socket 
+    ( Family
+    , connect
+    , socketToHandle
+    , sClose
+    , Socket(..)
+    , socket
+    , SocketType(..)
+    )
+import Network.BSD 
+    ( PortNumber
+    , getHostName
+    , hostName
+    , hostAliases
+    , getProtocolNumber
+    )
+import System.IO
+    ( BufferMode(..)
+    , IOMode(..)
+    , hSetBuffering
+    )
+import Control.Exception
+    ( bracketOnError )
 import Control.Concurrent.STM
 import Data.Conduit
 import qualified Data.Conduit.List as CL
@@ -27,6 +48,8 @@ import qualified Data.ByteString.Char8 as S (pack,putStr,putStrLn,append)
 import qualified Data.ByteString.Lazy.Char8 as L
     ( putStrLn
     , fromChunks
+    , unlines
+    , hPutStrLn
     )
 import Control.Concurrent (forkIO,killThread)
 import Control.Concurrent.Async
@@ -39,7 +62,6 @@ import Control.Monad as Monad
 import Text.XML.Stream.Parse (parseBytes,content)
 import Text.XML.Stream.Render
 import Data.XML.Types as XML
-import Network.BSD (getHostName,hostName,hostAliases)
 import Data.Text.Encoding      as S (decodeUtf8,encodeUtf8)
 import Data.Text.Lazy.Encoding as L (decodeUtf8,encodeUtf8)
 import Data.Text.Lazy (toStrict)
@@ -53,7 +75,13 @@ import Data.Conduit.Blaze
 import Data.List (find)
 import qualified Text.Show.ByteString as L
 import NestingXML
+import           Data.Set as Set (Set)
 import qualified Data.Set as Set
+import qualified Data.Map as Map
+import GHC.Conc 
+    ( threadStatus
+    , ThreadStatus(..)
+    )
 
 data Commands = Send [XML.Event] | QuitThread
  deriving Prelude.Show
@@ -76,11 +104,11 @@ xmlifyPresenceForClient (Presence jid stat) = do
     return (concatMap presenceEvents jidstrs)
  where
     presenceEvents jidstr =
-      [ EventBeginElement "presence" (("from",[ContentText jidstr]):typ stat)
-      , EventBeginElement "show" []
+      [ EventBeginElement "{jabber:client}presence" (("from",[ContentText jidstr]):typ stat)
+      , EventBeginElement "{jabber:client}show" []
       , EventContent (ContentText . shw $ stat)
-      , EventEndElement "show"
-      , EventEndElement "presence"
+      , EventEndElement "{jabber:client}show"
+      , EventEndElement "{jabber:client}presence"
       ]
     typ Offline = [("type",[ContentText "unavailable"])]
     typ _       = []
@@ -102,8 +130,8 @@ greet host =
         ,("version",[ContentText "1.0"])
         ]
     , EventBeginElement (streamP "features") []
-    , EventBeginElement "bind" [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])]
-    , EventEndElement   "bind"
+    , 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'/>"
@@ -121,6 +149,7 @@ greet host =
 mawait :: Monad m => MaybeT (ConduitM i o m) i
 mawait = MaybeT await
 
+-- Note: This function ignores name space qualification
 elementAttrs expected (EventBeginElement name attrs)
     | nameLocalName name==expected 
     = return attrs
@@ -409,15 +438,16 @@ prettyPrint prefix xs =
 
 toClient :: MonadIO m => TChan Presence -> TChan Commands -> Source m [XML.Event]
 toClient pchan cmdChan = fix $ \loop -> do
+    let send xs = yield xs >> prettyPrint ">C: " xs
     event <- liftIO . atomically $ 
               orElse (fmap Left  $ readTChan pchan)
                      (fmap Right $ readTChan cmdChan)
     case event of
       Right QuitThread -> return ()
-      Right (Send xs)  -> yield xs >> prettyPrint ">C: " xs >> loop
+      Right (Send xs)  -> send xs >> loop
       Left  presence   -> do 
         xs <- liftIO $ xmlifyPresenceForClient presence
-        yield xs
+        send xs
         loop
 
 handleClient
@@ -501,7 +531,7 @@ handlePeer st src snk = do
     jids <- newTVarIO Set.empty
     session <- newSession session_factory sock
 
-    finally ( src $= parseBytes def $$ fromPeer session )
+    finally ( src $= parseBytes def $$ fromPeer (session,jids) )
         $ do 
             L.putStrLn $ "(P) disconnected " <++> name
             js <- fmap Set.toList (readTVarIO jids)
@@ -509,8 +539,64 @@ handlePeer st src snk = do
             forM_ js $ announcePresence session . offline
             closeSession session
 
+
+handlePeerPresence (session,jids) stanza False = do
+    -- Offline
+    withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do
+    peer_jid <- liftIO $ parseAddressJID (L.fromChunks [S.encodeUtf8 jid])
+    liftIO . atomically $ do
+        jids_ <- readTVar jids
+        writeTVar jids (Set.delete peer_jid jids_)
+    liftIO $ announcePresence session (Presence peer_jid Offline)
+handlePeerPresence (session,jids) stanza True = do
+    -- online (Available or Away)
+    let log  = liftIO . L.putStrLn . ("(P) " <++>)
+    withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do
+    pjid <- liftIO $ parseAddressJID (L.fromChunks [S.encodeUtf8 jid])
+    -- stat <- show element content
+    let parseChildren stat = do
+            child <- nextElement
+            case child of
+                Just tag | tagName tag=="{jabber:server}show"
+                                      -> fmap toStat (lift content)
+                Just tag | otherwise  -> parseChildren stat
+                Nothing -> return stat
+        toStat "away" = Away
+        toStat "xa"   = Away -- TODO: xa
+        toStat "dnd"  = Away -- TODO: dnd
+        toStat "chat" = Available
+
+    stat' <- parseChildren Available
+
+    liftIO . atomically $ do
+        jids_ <- readTVar jids
+        writeTVar jids (Set.insert pjid jids_)
+    liftIO $ announcePresence session (Presence pjid stat')
+    log $ bshow (Presence pjid stat')
+
+matchAttribMaybe name (Just value) attrs = 
+    case find ( (==name) . fst) attrs of
+        Just (_,[ContentText x])   | x==value -> True
+        Just (_,[ContentEntity x]) | x==value -> True
+        _                                     -> False
+matchAttribMaybe name Nothing attrs  
+    | find ( (==name) . fst) attrs==Nothing
+    = True
+matchAttribMaybe name Nothing attrs  
+    | otherwise
+    = False
+
+presenceTypeOffline = Just "unavailable"
+presenceTypeOnline  = Nothing
+
+isPresenceOf (EventBeginElement name attrs) testType
+    | name=="{jabber:server}presence"
+    && matchAttribMaybe "type" testType attrs
+    = True
+isPresenceOf _ _ = False
+
 fromPeer :: (MonadThrow m,MonadIO m, XMPPSession session) => 
-    session -> Sink XML.Event m ()
+    (session, TVar (Set JID))  -> Sink XML.Event m ()
 fromPeer session = doNestingXML $ do
     let log  = liftIO . L.putStrLn . ("(P) " <++>)
     withXML $ \begindoc -> do
@@ -525,6 +611,16 @@ fromPeer session = doNestingXML $ do
         whenJust nextElement $ \stanza -> do
             stanza_lvl <- nesting
 
+            let unhandledStanza = do
+                    mb <- lift . runMaybeT $ gatherElement stanza Seq.empty
+                    withJust mb $ \xs -> prettyPrint "P: " (toList xs)
+            case () of
+              _ | stanza `isPresenceOf` presenceTypeOnline
+                    -> log "peer online!" >> handlePeerPresence session stanza True
+              _ | stanza `isPresenceOf` presenceTypeOffline
+                    -> handlePeerPresence session stanza False
+              _ -> unhandledStanza
+
             awaitCloser stanza_lvl
             loop
 
@@ -534,9 +630,206 @@ fromPeer session = doNestingXML $ do
 
 
 
+{-
 seekRemotePeers :: XMPPConfig config =>
      config -> TChan Presence -> IO ()
 seekRemotePeers config chan = do
     putStrLn "unimplemented: seekRemotePeers"
     -- TODO
     return ()
+-}
+
+data OutBoundMessage = OutBoundPresence Presence
+ deriving Prelude.Show
+
+newServerConnections = atomically $ newTVar Map.empty
+
+connect_to_server chan peer = (>> return ()) . runMaybeT $ do
+    let port = 5269 :: Int
+
+    connected <- liftIO . async $ connect' (peerAddr peer) port
+
+    -- We'll cache Presence notifications until the socket
+    -- is ready.
+    cached <- liftIO $ newIORef Map.empty
+
+    sock <- MaybeT . fix $ \loop -> do
+        e <- atomically $ orElse
+                (fmap Right $ waitSTM connected)
+                (fmap Left  $ readTChan chan)
+        case e of
+            Left (OutBoundPresence (Presence jid Offline)) -> do
+                cached_map <- readIORef cached
+                writeIORef cached (Map.delete jid cached_map)
+                loop
+            Left (OutBoundPresence p@(Presence jid st)) -> do
+                cached_map <- readIORef cached
+                writeIORef cached (Map.insert jid st cached_map)
+                loop
+            {-
+            Left event -> do
+                L.putStrLn $ "REMOTE-OUT DISCARDED: " <++> bshow event
+                loop
+            -}
+            Right sock -> return sock
+
+    liftIO $ do
+        h <- socketToHandle sock ReadWriteMode
+        hSetBuffering h NoBuffering
+        let snk = packetSink h
+        cache <- fmap Map.assocs . readIORef $ cached
+        writeIORef cached Map.empty -- hint garbage collector: we're done with this
+        handleOutgoingToPeer (restrictSocket sock) cache chan snk
+
+
+greetPeer =
+    [ EventBeginDocument
+    , EventBeginElement (streamP "stream")
+        [("xmlns",[ContentText "jabber:server"])
+        ,("version",[ContentText "1.0"])
+        ]
+    ]
+
+goodbyePeer = 
+    [ EventEndElement (streamP "stream")
+    , EventEndDocument
+    ]
+
+toPeer sock cache chan = do
+    let -- log     = liftIO . L.putStrLn . ("(>P) " <++>)
+        send xs = yield xs >> prettyPrint ">P: " xs
+    send greetPeer
+    forM_ cache $ \(jid,st) -> do
+        r <- lift $ xmlifyPresenceForPeer sock (Presence jid st)
+        send r
+    fix $ \loop -> do
+        event <- lift . atomically $ readTChan chan
+        case event of
+          OutBoundPresence p -> do
+            r <- lift $ xmlifyPresenceForPeer sock p
+            send r
+        loop
+    send goodbyePeer
+
+handleOutgoingToPeer sock cache chan snk = do
+#ifdef RENDERFLUSH
+    toPeer sock cache chan 
+        $$  flushList
+        =$= renderBuilderFlush def
+        =$= builderToByteStringFlush
+        =$= discardFlush
+         =$ snk
+#else
+    toPeer sock cache chan $$ renderChunks =$ snk
+#endif
+
+connect' :: SockAddr -> Int -> IO (Maybe Socket)
+connect' addr port = 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 withPort (SockAddrInet _ a)      port = SockAddrInet (toEnum port) a
+        withPort (SockAddrInet6 _ a b c) port = SockAddrInet6 (toEnum 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` port)
+  where
+  tryToConnect proto addr =
+    bracketOnError
+        (socket (socketFamily addr) Stream proto)
+        (sClose )  -- only done if there's an error
+        (\sock -> do
+          connect sock addr
+          return (Just sock) -- socketToHandle sock ReadWriteMode
+        )
+
+
+
+sendMessage cons msg peer = do
+    found <- atomically $ do
+        consmap <- readTVar cons
+        return (Map.lookup peer consmap)
+    let newEntry = do
+          chan <- atomically newTChan
+          t <- forkIO $ connect_to_server chan 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: " <++> showPeer peer
+                                return (False,(chan,t))
+                            died = do
+                                -- L.putStrLn $ "remote-map, thread died("<++>bshow st<++>"): " <++> showPeer peer
+                                newEntry 
+                        case st of 
+                          ThreadRunning   -> running
+                          ThreadBlocked _ -> running
+                          ThreadDied      -> died
+                          ThreadFinished  -> died
+                        )
+          found
+    -- L.putStrLn $ "sendMessage ->"<++>showPeer peer<++>": "<++>bshow msg
+    atomically $ writeTChan (fst entry) msg
+    when is_new . atomically $
+        readTVar cons >>= writeTVar cons . Map.insert peer entry
+
+
+
+seekRemotePeers :: XMPPConfig config =>
+     config -> TChan Presence -> IO b0
+seekRemotePeers config chan = do
+    server_connections <- newServerConnections
+    fix $ \loop -> do
+        event <- atomically $ readTChan chan
+        case event of
+            p@(Presence jid stat) | not (is_remote (peer jid)) -> do
+              -- L.putStrLn $ "seekRemotePeers: " <++> L.show jid <++> " " <++> bshow stat
+              runMaybeT $ do
+                  u <- MaybeT . return $ name jid
+                  subscribers <- liftIO $ do
+                    subs <- getSubscribers config u
+                    mapM parseHostNameJID subs
+                  -- liftIO . L.putStrLn $ "subscribers: " <++> bshow subscribers
+                  let peers = Set.map peer (Set.fromList subscribers)
+                  forM_ (Set.toList peers) $ \peer -> do
+                    when (is_remote peer) $
+                        liftIO $ sendMessage server_connections (OutBoundPresence p) peer
+                  -- TODO: send presence probes for buddies
+                  -- TODO: cache remote presences for clients
+            _ -> return (Just ())
+        loop 
+
+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
+        jidstr = toStrict . L.decodeUtf8 
+                  $ n <$++> "@" <?++> showPeer (RemotePeer addr) <++?>  "/" <++$> rsc 
+    return 
+      [ EventBeginElement "{jabber:server}presence" 
+            (("from",[ContentText jidstr]):typ stat)
+      , EventBeginElement "{jabber:server}show" []
+      , EventContent (ContentText . shw $ stat)
+      , EventEndElement "{jabber:server}show"
+      , EventEndElement "{jabber:server}presence"
+      ]
+ where
+    typ Offline = [("type",[ContentText "unavailable"])]
+    typ _       = []
+    shw Available = "chat"
+    shw Away      = "away"
+    shw Offline   = "away" -- Is this right?
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index f607989d..ff50ab1c 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -67,9 +67,6 @@ import qualified Data.Set as Set
 import GetHostByAddr
 import XMPPTypes
 
-is_remote (RemotePeer _) = True
-is_remote _              = False
-
 getNamesForPeer :: Peer -> IO [ByteString]
 getNamesForPeer LocalHost = fmap ((:[]) . pack) getHostName
 getNamesForPeer peer@(RemotePeer addr) = do
@@ -85,10 +82,6 @@ getNamesForPeer peer@(RemotePeer addr) = do
     return . map pack $ names
 
 
-peerAddr :: Peer -> SockAddr
-peerAddr (RemotePeer addr) = addr
--- peerAddr LocalHost = throw exception
-
 
 xmlifyPresenceForPeer sock (Presence jid stat) = do
     -- TODO: accept socket argument and determine local ip address
@@ -587,62 +580,6 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do
         L.putStrLn $ "OUT peer: </stream>"
 
 
-splitJID :: ByteString -> (Maybe ByteString,ByteString,Maybe ByteString)
-splitJID bjid = 
-    let xs = L.splitWith (=='@') bjid
-        ys = L.splitWith (=='/') (last xs)
-        server = head ys
-        name
-            = case xs of
-                (n:s:_) -> Just n
-                (s:_)   -> Nothing
-        rsrc = case ys of
-                (s:_:_) -> Just $ last ys
-                _       -> Nothing
-    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 -> Int -> IO (Maybe Socket)
 connect' addr port = do
     proto <- getProtocolNumber "tcp"
diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs
index e3bbfd16..8af1018c 100644
--- a/Presence/XMPPTypes.hs
+++ b/Presence/XMPPTypes.hs
@@ -2,10 +2,28 @@
 {-# LANGUAGE TypeFamilies        #-}
 module XMPPTypes where
 
-import Network.Socket (Socket,SockAddr(..))
+import Network.Socket 
+    ( Socket
+    , Family(..)
+    , SockAddr(..)
+    , getAddrInfo
+    , addrCanonName
+    , addrAddress
+    , defaultHints
+    , AddrInfo(..)
+    , AddrInfoFlag(..)
+    )
+import Network.BSD (getHostName)
 import System.IO (Handle)
 import Control.Concurrent.STM (TChan)
-import Data.ByteString.Lazy.Char8 as L  (ByteString,unpack,pack)
+import Data.ByteString.Lazy.Char8 as L  
+    ( ByteString
+    , unpack
+    , pack 
+    , splitWith
+    , uncons
+    , takeWhile
+    )
 import Text.Show.ByteString as L
 import Data.Binary.Builder as B
 import Data.Binary.Put
@@ -82,4 +100,68 @@ showPeer (RemotePeer addr@(SockAddrInet6 _ _ _ _)) = pack $ stripColon (Prelude.
           where
             (pre,bracket) = break (==']') s
 
+is_remote (RemotePeer _) = True
+is_remote _              = False
+
+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
+
+splitJID :: ByteString -> (Maybe ByteString,ByteString,Maybe ByteString)
+splitJID bjid = 
+    let xs = L.splitWith (=='@') bjid
+        ys = L.splitWith (=='/') (last xs)
+        server = head ys
+        name
+            = case xs of
+                (n:s:_) -> Just n
+                (s:_)   -> Nothing
+        rsrc = case ys of
+                (s:_:_) -> Just $ last ys
+                _       -> Nothing
+    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
+
+peerAddr :: Peer -> SockAddr
+peerAddr (RemotePeer addr) = addr
+-- peerAddr LocalHost = throw exception
+
+socketFamily (SockAddrInet _ _)      = AF_INET
+socketFamily (SockAddrInet6 _ _ _ _) = AF_INET6
+socketFamily (SockAddrUnix _)        = AF_UNIX
+