Merge branch 'master' of samwise:presence

1 files changed, 84 insertions, 2 deletions

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
+