Send remote presence to clients.

Implmented -4 switch to select ipv4, otherwise ipv6

4 files changed, 36 insertions, 46 deletions

diff --git a/Presence/AdaptServer.hs b/Presence/AdaptServer.hs
index eca4cb1e..dd453ba9 100644
--- a/Presence/AdaptServer.hs
+++ b/Presence/AdaptServer.hs
@@ -15,7 +15,7 @@ adaptStartCon start sock st = do
     return (HCons rsRef st')
 
 adaptDoCon showlex (dropTill,lex,parse) g st bs cont = do
-    -- putStrLn $ "packet: " ++ show bs
+    putStrLn $ "packet: " ++ show bs
     let (HCons rsRef st') = st
     rs <- readIORef rsRef
 
diff --git a/Presence/Server.hs b/Presence/Server.hs
index b611fae8..55a8b57b 100644
--- a/Presence/Server.hs
+++ b/Presence/Server.hs
@@ -35,33 +35,8 @@ newtype ConnectionFinalizer = ConnectionFinalizer (IO ())
 
 getPacket h = do { hWaitForInput h (-1) ; fmap (fromChunks . (:[])) $ hGetNonBlocking h 1024 }
 
-{-
-doServer ::
-  HList st 
-  => PortNumber :*: st
-      -> ( Handle :*: ConnId :*: PortNumber :*: st
-            -> S.ByteString 
-            -> (() -> IO ()) 
-            -> IO () )
-      -> IO b
--}
-{-
-doServer
-  :: (HOccursFst ConnectionFinalizer l, HList t) =>
-     HCons PortNumber t
-     -> (l
-         -> ByteString
-         -> (() -> IO ())
-         -> IO ())
-     -> (Socket
-         -> HCons
-              Handle (HCons ConnId (HCons PortNumber t))
-         -> IO l)
-     -> IO Socket
--}
-doServer port g startCon = do
-    doServer' AF_INET6 port g startCon
-    -- doServer' AF_INET port g startCon
+doServer addrfamily port g startCon = do
+    doServer' addrfamily port g startCon
 
 doServer' family port g startCon = runServer2 port (runConn2 g)
  where
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 58dcf430..be59ac02 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -229,7 +229,7 @@ startCon session_factory sock st  = do
     pchan <- subscribe session Nothing
     cmdChan <- atomically newTChan
     reader <- forkIO $
-        handle (\(SomeException _) -> L.putStrLn "quit reader via exception.") $
+        handle (\(SomeException e) -> L.putStrLn $ "quit reader via exception: "<++>bshow e) $
          fix $ \loop -> do
             event <- atomically $ 
                 (fmap Left $ readTChan pchan)
@@ -464,14 +464,15 @@ showTokenT (TokFreeText  s)     = "TokFreeText "++s
 showtoks ts = Prelude.show $ map (showTokenT . snd) ts
     
 
-listenForXmppClients session_factory port st = do
+listenForXmppClients addr_family session_factory port st = do
     -- standard port: 5222
     let (start,dopkt) = 
             adaptServer showtoks ( dropTill
                         , xmlLexPartial "local-client" . unpack
                         , xmppParse)
                         (startCon session_factory,doCon)
-    doServer (port .*. st)
+    doServer addr_family
+             (port .*. st)
              dopkt
              start
 
@@ -503,10 +504,19 @@ doPeer st elem cont = do
           (Just jid,Nothing) -> do
             let string (CString _ s _) = [s]
                 stat = listToMaybe . Prelude.concatMap string . tagcontent "show" $ content
+                stat' = case stat of
+                         Nothing -> Available
+                         Just "away" -> Away
+                         Just "xa"   -> Away -- TODO: xa
+                         Just "dnd"  -> Away -- TODO: dnd
+                         Just "chat" -> Available
+                         _       -> Available
             -- Available or Away.
-            names <- parseAddressJID jid >>= getNamesForPeer  . peer
-            L.putStrLn $ "IN peer: PRESENCE! "<++>bshow (stat,names)<++>" avail/away jid=" <++> jid
-            -- todo: announcePresence
+            pjid <- parseAddressJID jid
+            names <- getNamesForPeer  (peer pjid)
+            -- L.putStrLn $ "IN peer: PRESENCE! "<++>bshow (stat,names)<++>" avail/away jid=" <++> jid
+            announcePresence session (Presence pjid stat')
+            L.putStrLn $ "IN peer: " <++> bshow (Presence pjid stat')
       _ -> return () -- putStrLn $ "inbound unhandled: "++show v
     cont ()
 
@@ -520,14 +530,15 @@ xmlLexPartial name cs =
         else gs
         
 
-listenForRemotePeers session_factory port st = do
+listenForRemotePeers addrfamily session_factory port st = do
     -- standard port: 5269
     let (start,dopkt) = 
             adaptServer showtoks ( dropTill
                         , xmlLexPartial "remote-inbound" . unpack
                         , xmppParse)
                         (startPeer session_factory,doPeer)
-    doServer (port .*. st)
+    doServer addrfamily
+             (port .*. st)
              dopkt
              start
 
@@ -736,7 +747,7 @@ seekRemotePeers config chan = do
     fix $ \loop -> do
         event <- atomically $ readTChan chan
         case event of
-            p@(Presence jid stat) -> do
+            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
@@ -748,4 +759,5 @@ seekRemotePeers config chan = do
                   forM_ (Set.toList peers) $ \peer -> do
                     when (is_remote peer) $
                         liftIO $ sendMessage server_connections (OutBoundPresence p) peer
+            _ -> return (Just ())
         loop 
diff --git a/Presence/main.hs b/Presence/main.hs
index 24d240cd..5897d79e 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -49,6 +49,7 @@ import qualified Prelude
 import           Prelude hiding (putStrLn)
 import System.Environment
 import qualified Text.Show.ByteString as L
+import Network.Socket (Family(AF_INET,AF_INET6))
 
 
 data UnixSession = UnixSession {
@@ -93,8 +94,11 @@ instance XMPPSession UnixSession where
         let tvar = subscriberMap (presence_state session)
         atomically $ subscribeToMap tvar jid
     announcePresence session (Presence jid status) = do
-        subs <- readTVarIO $ subscriberMap (presence_state session)
-        update_presence Nothing (fmap snd subs) (Set.singleton jid) (const status)
+        (greedy,subs) <- atomically $ do
+            subs <- readTVar $ subscriberMap (presence_state session)
+            greedy <- fmap snd $ readTMVar $ localSubscriber (presence_state session)
+            return (greedy,subs)
+        update_presence (Just greedy) (fmap snd subs) (Set.singleton jid) (const status)
 
 
 subscribeToChan tmvar =
@@ -198,8 +202,8 @@ instance XMPPConfig UnixConfig where
     getBuddies     _ user = ConfigFiles.getBuddies user
     getSubscribers _ user = ConfigFiles.getSubscribers user
 
-start :: ByteString -> IO ()
-start host = do
+start :: Network.Socket.Family -> IO ()
+start ip4or6 = do
     let host = LocalHost
     tracked <- newPresenceState host
     let dologin e = track_login host tracked e
@@ -219,8 +223,8 @@ start host = do
             utmp_file
             dologin
 #endif
-    sockLocals <- listenForXmppClients (UnixSessions tracked) 5222 HNil
-    sockRemotes <- listenForRemotePeers (UnixSessions tracked) 5269 HNil
+    sockLocals <- listenForXmppClients ip4or6 (UnixSessions tracked) 5222 HNil
+    sockRemotes <- listenForRemotePeers ip4or6 (UnixSessions tracked) 5269 HNil
 
     threadDelay 1000 -- wait a moment to obtain current tty
     dologin ()
@@ -278,8 +282,7 @@ getOptions (x0:xs) = getOptions xs
 
 main = do
     opts <- fmap getOptions getArgs
-    let hostname = maybe "localhost" id (Map.lookup "n" opts)
-    L.putStrLn $ "hostname = " <++> hostname
-    runOnce ["/var/run/presence.pid","/tmp/presence.pid"] (start hostname) sendUSR1
+    let use_ip4 = if isJust (Map.lookup "4" opts) then AF_INET else AF_INET6
+    runOnce ["/var/run/presence.pid","/tmp/presence.pid"] (start use_ip4) sendUSR1