From 7e366d341712adf6c895610166acf70ea67ceef2 Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Mon, 17 Feb 2014 17:59:41 -0500
Subject: Find peers from buddy lists.

---
 xmppServer.hs | 76 +++++++++++++++++++++++++++++++++++++++++++++++------------
 1 file changed, 61 insertions(+), 15 deletions(-)

diff --git a/xmppServer.hs b/xmppServer.hs
index e787f973..8f13e2d8 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
 import System.Posix.Signals
 import Control.Concurrent.STM
+import Control.Concurrent.STM.TMVar
 import Control.Monad.Trans.Resource (runResourceT)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Network.Socket
@@ -8,9 +10,10 @@ import Network.Socket
     , getAddrInfo
     , defaultHints
     , addrFlags
-    , AddrInfoFlag(AI_CANONNAME)
-    , SockAddr
+    , AddrInfoFlag(AI_CANONNAME,AI_V4MAPPED)
+    , SockAddr(..)
     )
+import System.Endian (fromBE32)
 import Data.Monoid ( (<>) )
 import qualified Data.Text as Text
 import qualified Data.Text.IO as Text
@@ -29,7 +32,25 @@ import qualified ConfigFiles
 import UTmp (ProcessID,users)
 import LocalPeerCred
 import XMPPServer
-import Server
+-- import Server
+
+
+splitJID :: Text -> (Maybe Text,Text,Maybe Text)
+splitJID bjid = 
+    let xs = splitAll '@' bjid
+        ys = splitAll '/' (last xs)
+        splitAll c bjid = take 1 xs0 ++ map (Text.drop 1) (drop 1 xs0)
+            where xs0 = Text.groupBy (\x y-> y/=c) bjid
+        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)
+
 
 textHostName = fmap Text.pack BSD.getHostName
 
@@ -46,8 +67,21 @@ data ClientState = ClientState
 data PresenceState = PresenceState
     { clients :: TVar (Map ConnectionKey ClientState)
     , associatedPeers :: TVar (Map SockAddr ())
+    , server :: TMVar XMPPServer
     }
 
+
+make6mapped4 addr@(SockAddrInet6 {}) = addr
+make6mapped4 addr@(SockAddrInet port a) = SockAddrInet6 port 0 (0,0,0xFFFF,fromBE32 a) 0
+
+resolvePeer :: Text -> IO [SockAddr]
+resolvePeer addrtext = do
+        fmap (map $ make6mapped4 . addrAddress) $ 
+            getAddrInfo (Just $ defaultHints { addrFlags = [ AI_CANONNAME, AI_V4MAPPED ]})
+                    (Just $ Text.unpack addrtext)
+                    (Just "5269")
+
+
 getConsolePids :: PresenceState -> IO [(Text,ProcessID)]
 getConsolePids state = do --  return [("tty7", 23)] -- todo
     us <- UTmp.users
@@ -106,11 +140,29 @@ tellClientHisName state k = forClient state k fallback go
     fallback  = localJID "nobody" "fallback"
     go client = localJID (clientUser client) (clientResource client)
 
+toMapUnit xs = Map.fromList $ map (,()) xs
+
+resolveAllPeers hosts = fmap (toMapUnit . concat) $ mapM (fmap (take 1) . resolvePeer) hosts
+
 rosterGetStuff what state k = forClient state k (return [])
     $ \client -> do
-    fmap (map lazyByteStringToText)
-        $ what (textToLazyByteString $ clientUser client)
-
+    jids <- 
+        fmap (map lazyByteStringToText)
+            $ what (textToLazyByteString $ clientUser client)
+    let hosts = map ((\(_,h,_)->h) . splitJID) jids
+    addrs <- resolveAllPeers hosts 
+    peers <- atomically $ readTVar (associatedPeers state)
+    addrs <- return $ addrs `Map.difference` peers
+    sv <- atomically $ takeTMVar $ server state
+    forM_ (Map.keys addrs) $ \addr -> do
+        putStrLn $ "new addr: "++show addr
+        addPeer sv addr
+    atomically $ do
+        writeTVar (associatedPeers state) (addrs `Map.union` peers)
+        putTMVar (server state) sv
+    return jids
+
+rosterGetBuddies :: PresenceState -> ConnectionKey -> IO [Text]
 rosterGetBuddies = rosterGetStuff ConfigFiles.getBuddies
 rosterGetSolicited = rosterGetStuff ConfigFiles.getSolicited
 rosterGetOthers = rosterGetStuff ConfigFiles.getOthers
@@ -118,13 +170,14 @@ rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers
 
 
 main = runResourceT $ do
-    -- hostname <- liftIO textHostName
     state <- liftIO . atomically $ do
         clients <- newTVar Map.empty
         associatedPeers <- newTVar Map.empty
+        xmpp <- newEmptyTMVar
         return PresenceState
             { clients = clients
             , associatedPeers = associatedPeers
+            , server = xmpp
             }
     sv <- xmppServer
         XMPPServerParameters
@@ -151,14 +204,7 @@ main = runResourceT $ do
         , xmppInformClientPresence = \k stanza -> return ()
         }
     liftIO $ do
-    let testaddr0 = "fd97:ca88:fa7c:b94b:c8b8:fad4:1021:a54d"
-        -- testaddr0 = "fdef:9e0b:b502:52c3:c074:28d3:fcd7:bfb7"
-    testaddr<- fmap (addrAddress . head) $
-        getAddrInfo (Just $ defaultHints { addrFlags = [ AI_CANONNAME ]})
-                (Just testaddr0)
-                (Just "5269")
-    putStrLn $ "Connecting to "++show testaddr
-    addPeer sv testaddr
+    atomically $ putTMVar (server state) sv
 
     quitVar <- newEmptyTMVarIO
     installHandler sigTERM (CatchOnce (atomically $ putTMVar quitVar True)) Nothing
-- 
cgit v1.2.3