4 files changed, 63 insertions, 16 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index aae5e97a..f029810d 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -68,6 +68,7 @@ import qualified Data.Set as Set
 import qualified System.Random 
 import qualified Network.BSD as BSD
 import Data.Void (Void)
+import System.Endian (toBE32)
 
 import GetHostByAddr (getHostByAddr)
 import qualified Control.Concurrent.STM.UpdateStream as Slotted
@@ -254,10 +255,15 @@ peerKeyToResolvedNames :: ConnectionKey -> IO [Text]
 peerKeyToResolvedNames k@(ClientKey { localAddress=addr }) = return []
 peerKeyToResolvedNames k@(PeerKey { callBackAddress=addr }) = do
     handleIO_ (return []) $ do
-        ent <- getHostByAddr addr --  AF_UNSPEC addr
+        ent <- getHostByAddr (unmap6mapped4 addr) --  AF_UNSPEC addr
         let names = BSD.hostName ent : BSD.hostAliases ent
         return $ map Text.pack $ nub names
 
+unmap6mapped4 addr@(SockAddrInet6 port _ (0,0,0xFFFF,a) _) =
+    SockAddrInet port (toBE32 a)
+unmap6mapped4 addr = addr
+
+
 
 wlog :: String -> IO ()
 wlog s = putStrLn s >> hFlush stdout
diff --git a/presence.cabal b/presence.cabal
index 30081d17..aaa5603a 100644
--- a/presence.cabal
+++ b/presence.cabal
@@ -26,4 +26,5 @@ executable presence
     c-sources: Presence/monitortty.c
     hs-source-dirs: . Presence
     ghc-prof-options: -DNOUTMP
+    ghc-options: -O2 -fwarn-unused-binds -threaded
  
diff --git a/t b/t
index 6b7abba5..22b21361 100755
--- a/t
+++ b/t
@@ -1,5 +1,5 @@
 #!/bin/bash
-args="-fwarn-unused-imports -rtsopts -DRENDERFLUSH -optP-include -optPdist/build/autogen/cabal_macros.h"
+args="-threaded -fwarn-unused-imports -rtsopts -DRENDERFLUSH -optP-include -optPdist/build/autogen/cabal_macros.h"
 
 root=${0%/*}
 cd "$root"
diff --git a/xmppServer.hs b/xmppServer.hs
index 598ffe72..3752218a 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections #-}
 import System.Posix.Signals
+import Control.Concurrent (threadDelay,forkIO,forkOS,killThread,throwTo)
 import Control.Concurrent.STM
 import Control.Concurrent.STM.TMVar
 import Control.Monad.Trans.Resource (runResourceT)
@@ -146,10 +147,31 @@ make6mapped4 addr@(SockAddrInet port a) = SockAddrInet6 port 0 (0,0,0xFFFF,fromB
 
 resolvePeer :: Text -> IO [SockAddr]
 resolvePeer addrtext = do
-        fmap (map $ make6mapped4 . addrAddress) $ 
-            getAddrInfo (Just $ defaultHints { addrFlags = [ AI_CANONNAME, AI_V4MAPPED ]})
+    r <- atomically newEmptyTMVar
+    mvar <- atomically newEmptyTMVar
+    rt <- forkOS $ resolver r mvar
+    tt <- forkIO $ timer r rt
+    atomically $ putTMVar mvar tt
+    atomically $ readTMVar r
+ where
+    resolver r mvar = do
+      xs <- handle (\e -> let _ = isDoesNotExistError e in return [])
+            $ do fmap (map $ make6mapped4 . addrAddress) $ 
+                  getAddrInfo (Just $ defaultHints { addrFlags = [ AI_CANONNAME, AI_V4MAPPED ]})
                     (Just $ Text.unpack $ strip_brackets addrtext)
                     (Just "5269")
+      did <- atomically $ tryPutTMVar r xs
+      when did $ do
+      tt <- atomically $ readTMVar mvar
+      throwTo tt (ErrorCall "Interrupted delay")
+      return ()
+    timer r rt = do
+      handle (\(ErrorCall _)-> return ()) $ do
+      threadDelay 1000000
+      did <- atomically $ tryPutTMVar r []
+      when did $ do
+      putStrLn $ "timeout resolving: "++show addrtext
+      killThread rt
 
 strip_brackets s = 
     case Text.uncons s of
@@ -388,12 +410,14 @@ rewriteJIDForClient laddr jid = do
                   else peerKeyToResolvedName (PeerKey addr)
     return (mine,(n,h',r))
 
+sameAddress laddr addr = laddr `withPort` 0  == addr `withPort` 0
+
 multiplyJIDForClient :: SockAddr -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)])
 multiplyJIDForClient laddr jid = do
     let (n,h,r) = splitJID jid
     maddr <- parseAddress (strip_brackets h)
     flip (maybe $ return (False,[(n,ip6literal h,r)])) maddr $ \addr -> do
-    let mine =  laddr `withPort` 0  == addr `withPort` 0
+    let mine =  sameAddress laddr addr
     names <- if mine then fmap (:[]) textHostName
                      else peerKeyToResolvedNames (PeerKey addr)
     return (mine,map (\h' -> (n,h',r)) names)
@@ -529,10 +553,11 @@ informClientPresence state k stanza = do
 
 informPeerPresence state k stanza = do
     -- Presence must indicate full JID with resource...
-    putStrLn $ "xmppInformPeerPresence checking from address..."
+    putStrLn $ "xmppInformPeerPresence checking from address..." 
     flip (maybe $ return ()) (stanzaFrom stanza) $ \from -> do
     let (muser,h,mresource) = splitJID from
-    flip (maybe $ return ()) mresource       $ \resource -> do
+    putStrLn $ "xmppInformPeerPresence from  = " ++ show from
+    -- flip (maybe $ return ()) mresource       $ \resource -> do
     flip (maybe $ return ()) muser           $ \user -> do
     
     clients <- atomically $ do
@@ -542,13 +567,25 @@ informPeerPresence state k stanza = do
         let umap = maybe Map.empty id $ Map.lookup k rbp
             rp = case (presenceShow $ stanzaType stanza) of
                     Offline ->
-                         maybe (Map.empty)
-                               (Map.delete resource . resources)
-                             $ Map.lookup user umap
-                    _ -> maybe (Map.singleton resource stanza) 
-                               (Map.insert resource stanza . resources )
-                             $ Map.lookup user umap
+                        maybe Map.empty
+                              (\resource -> 
+                                  maybe (Map.empty)
+                                     (Map.delete resource . resources)
+                                   $ Map.lookup user umap)
+                              mresource
+                    
+                    _ ->maybe Map.empty
+                              (\resource ->
+                                  maybe (Map.singleton resource stanza) 
+                                     (Map.insert resource stanza . resources )
+                                    $ Map.lookup user umap)
+                              mresource
             umap' = Map.insert user (RemotePresence rp) umap
+        
+        flip (maybe $ return []) (case presenceShow $ stanzaType stanza of
+                                     Offline -> Just ()
+                                     _ -> mresource >> Just ())
+            $ \_ -> do
         writeTVar (remotesByPeer state) $ Map.insert k umap' rbp
         -- TODO: Store or delete the stanza (remotesByPeer)
         
@@ -565,11 +602,13 @@ informPeerPresence state k stanza = do
         -- For now, all "available" clients (available = sent initial presence)
         is_avail <- atomically $ clientIsAvailable client
         when is_avail $ do
+        putStrLn $ "reversing for client: " ++ show from
         froms <- do
             let ClientKey laddr = ck
             (_,trip) <- multiplyJIDForClient laddr from
             return (map unsplitJID trip)
-        putStrLn $ "sending to client: " ++ show (stanzaType stanza)
+                    
+        putStrLn $ "sending to client: " ++ show (stanzaType stanza,froms)
         forM_ froms $ \from' -> do
         dup <- cloneStanza stanza
         sendModifiedStanzaToClient (dup { stanzaFrom=Just from' })
@@ -802,11 +841,12 @@ peerSubscriptionRequest state fail k stanza chan = do
 
     -- TODO: if peer-connection is to self, then auto-approve local user.
     
-    -- Catch exception in case the user does not exist
-    handle (\e -> let _ = isDoesNotExistError e in fail) $ do
     -- add from-address to to's pending
     addrs <- resolvePeer from_h
 
+    -- Catch exception in case the user does not exist
+    if null addrs then fail else do
+
     let from' = unsplitJID fromtup
 
     already_pending <-