1 files changed, 195 insertions, 3 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 1a4b0e7b..417b3ce7 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)
@@ -54,6 +76,11 @@ import Data.List (find)
 import qualified Text.Show.ByteString as L
 import NestingXML
 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
@@ -534,9 +561,174 @@ 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
+        L.hPutStrLn h "<stream>"
+        L.putStrLn $ "OUT peer: <stream>"
+        cache <- fmap Map.assocs . readIORef $ cached
+        writeIORef cached Map.empty -- hint garbage collector: we're done with this
+        forM_ cache $ \(jid,st) -> do
+            r <- xmlifyPresenceForPeer sock (Presence jid st)
+            L.hPutStrLn h r
+            L.putStrLn $ "OUT peer: (cache)\n" <++> r <++> "\n"
+        fix $ \loop -> do
+            event <- atomically $ readTChan chan
+            case event of
+              OutBoundPresence p -> do
+                r <- xmlifyPresenceForPeer sock p
+                L.hPutStrLn h r
+                L.putStrLn $ "OUT peer:\n" <++> r <++> "\n"
+            loop
+        L.hPutStrLn h "</stream>"
+        L.putStrLn $ "OUT peer: </stream>"
+
+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
+        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?