bug fixes

2 files changed, 65 insertions, 32 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index a181b3e5..5a5cd9cc 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -795,8 +795,8 @@ makePresenceStanza namespace mjid pstat = do
       , EventContent (ContentText stat)
       , EventEndElement "{jabber:client}show" ]
     
-makeRosterUpdate tojid contact (suborask,relationship) = do
-    let attrs = [attr suborask relationship]
+makeRosterUpdate tojid contact as = do
+    let attrs = map (uncurry attr) as
     stanzaFromList Unrecognized
       [ EventBeginElement "{jabber:client}iq" 
             [ attr "to"   tojid
@@ -1343,13 +1343,12 @@ sendRoster query xmpp replyto = do
     hostname <- xmppTellMyNameToClient xmpp
     let getlist f = do
             bs <- f xmpp k
-            -- js <- mapM parseHostNameJID bs
             return (Set.fromList bs) -- js)
     buddies     <- getlist xmppRosterBuddies
     subscribers <- getlist xmppRosterSubscribers
     solicited   <- getlist xmppRosterSolicited
     subnone0    <- getlist xmppRosterOthers
-    let subnone = subnone0 \\ (Set.union buddies subscribers)
+    let subnone = Set.union solicited subnone0 \\ Set.union buddies subscribers
     let subto = buddies \\ subscribers
     let subfrom = subscribers \\ buddies
     let subboth = Set.intersection buddies subscribers
diff --git a/xmppServer.hs b/xmppServer.hs
index 74adc620..5771510a 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -15,7 +15,7 @@ import Network.Socket
     , SockAddr(..)
     )
 import System.Endian (fromBE32)
-import Data.List (nub, (\\) )
+import Data.List (nub, (\\), intersect )
 import Data.Monoid ( (<>) )
 import qualified Data.Text as Text
 import qualified Data.Text.IO as Text
@@ -86,14 +86,18 @@ data ClientState = ClientState
     , clientUser :: Text
     , clientPid :: Maybe ProcessID
     , clientStatus :: TVar (Maybe Stanza)
-    , clientFlags :: Int8
+    , clientFlags :: TVar Int8
     }
 
 -- | True if the client has sent an initial presence
-clientIsAvailable c  = clientFlags c .&. cf_available /= 0
+clientIsAvailable c  = do
+    flgs <- readTVar (clientFlags c)
+    return $ flgs .&. cf_available /= 0
 
 -- | True if the client has requested a roster
-clientIsInterested c = clientFlags c .&. cf_interested /= 0
+clientIsInterested c = do
+    flgs <- readTVar (clientFlags c)
+    return $ flgs .&. cf_interested /= 0
 
 data LocalPresence = LocalPresence
     { networkClients :: Map ConnectionKey ClientState
@@ -171,11 +175,12 @@ chooseResourceName state k addr desired = do
     (mtty,pid) <- getTTYandPID muid
     user <- getJabberUserForId muid
     status <- atomically $ newTVar Nothing
+    flgs <- atomically $ newTVar 0
     let client = ClientState { clientResource = maybe "fallback" id mtty
                              , clientUser = user
                              , clientPid = pid
                              , clientStatus = status
-                             , clientFlags = 0 }
+                             , clientFlags = flgs }
 
     atomically $ do
         modifyTVar' (clients state) $ Map.insert k client
@@ -310,12 +315,22 @@ newConn state k addr outchan = do
     when (isPeerKey k)
         $ sendProbesAndSolicitations state k addr outchan
 
+delclient k mlp = do
+    lp <- mlp
+    let nc = Map.delete k $ networkClients lp
+    guard $ not (Map.null nc)
+    return $ lp { networkClients = nc }
+
 eofConn state k = do
     atomically $ modifyTVar' (keyToChan state) $ Map.delete k
     case k of
         ClientKey {} -> do
+            forClient state k (return ()) $ \client -> do
             stanza <- makePresenceStanza "jabber:server" Nothing Offline
             informClientPresence state k stanza
+            atomically $ do
+                modifyTVar' (clientsByUser state)
+                    $ Map.alter (delclient k) (clientUser client)
         PeerKey {} -> do
             let h = peerKeyToText k
             jids <- atomically $ do
@@ -465,12 +480,13 @@ deliverMessage state fail msg =
 
 
 setClientFlag state k flag = 
-        atomically $ modifyTVar' (clients state)
-            $ Map.adjust  
-                (\c -> c { clientFlags = clientFlags c .|. flag })
-                k
+        atomically $ do
+            cmap <- readTVar (clients state)
+            flip (maybe $ return ()) (Map.lookup k cmap) $ \client -> do
+            modifyTVar' (clientFlags client) (\flgs -> flgs .|. flag)
 
-informSentRoster state k = setClientFlag state k cf_interested
+informSentRoster state k = do
+    setClientFlag state k cf_interested
 
 
 subscribedPeers user = do
@@ -493,7 +509,8 @@ informClientPresence state k stanza = do
         flip (maybe $ return ()) mb $ \cstate -> do
         writeTVar (clientStatus cstate) $ Just dup
     forClient state k (return ()) $ \client -> do
-    when (not $ clientIsAvailable client) $ do
+    is_avail <- atomically $ clientIsAvailable client
+    when (not is_avail) $ do
         setClientFlag state k cf_available
         sendCachedPresence state k
     addrs <- subscribedPeers (clientUser client)
@@ -546,7 +563,8 @@ informPeerPresence state k stanza = do
     forM_ clients $ \(ck,con,client) -> do
         -- (TODO: appropriately authorized clients only.)
         -- For now, all "available" clients (available = sent initial presence)
-        when (clientIsAvailable client) $ do
+        is_avail <- atomically $ clientIsAvailable client
+        when is_avail $ do
         froms <- do
             let ClientKey laddr = ck
             (_,trip) <- multiplyJIDForClient laddr from
@@ -557,11 +575,11 @@ informPeerPresence state k stanza = do
         sendModifiedStanzaToClient (dup { stanzaFrom=Just from' })
                                    (connChan con)
 
-answerProbe state k stanza chan = do
+answerProbe state mto k chan = do
     -- putStrLn $ "answerProbe! " ++ show (stanzaType stanza)
     ktc <- atomically $ readTVar (keyToChan state)
     muser <- runTraversableT $ do
-        to <- liftT $ stanzaTo stanza
+        to <- liftT $ mto
         conn <- liftT $ Map.lookup k ktc
         let (mu,h,_) = splitJID to -- TODO: currently resource-id is ignored on presence
                                    --  probes.  Is this correct? Check the spec.
@@ -665,6 +683,11 @@ clientSubscriptionRequest state fail k stanza chan = do
     if null addrs then fail else do
     -- add to-address to from's solicited
     addToRosterFile ConfigFiles.modifySolicited (clientUser client) to addrs
+    removeFromRosterFile ConfigFiles.modifyBuddies (clientUser client) to addrs
+    resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers (clientUser client)
+    let is_subscribed = not . null $ intersect (map ((mu,).PeerKey) addrs) resolved_subs
+    -- subscribers: "from"
+    -- buddies: "to"
 
     (ktc,ap) <- atomically $ 
         liftM2 (,) (readTVar $ keyToChan state)
@@ -677,7 +700,11 @@ clientSubscriptionRequest state fail k stanza chan = do
         chans <- clientCons state ktc (clientUser client)
         forM_ chans $ \( Conn { connChan=chan }, client ) -> do
             -- roster update ask="subscribe"
-            update <- makeRosterUpdate cjid to ("ask","subscribe")
+            update <- makeRosterUpdate cjid to
+                [ ("ask","subscribe")
+                , if is_subscribed then ("subscription","from")
+                                   else ("subscription","none")
+                ]
             sendModifiedStanzaToClient update chan
      _ -> return ()
 
@@ -700,6 +727,7 @@ clientSubscriptionRequest state fail k stanza chan = do
         -- Add peer if we are not already associated ...
         sv <- atomically $ takeTMVar $ server state
         addPeer sv (head addrs)
+        atomically $ putTMVar (server state) sv
 
 
 resolvedFromRoster
@@ -755,6 +783,7 @@ peerSubscriptionRequest state fail k stanza chan = do
         -- (note: swapping to and from for reply)
         reply <- makeInformSubscription "jabber:server" to from is_wanted
         sendModifiedStanzaToPeer reply chan
+        answerProbe state (Just to) k chan
      else do
 
     -- TODO: if peer-connection is to self, then auto-approve local user.
@@ -797,7 +826,7 @@ clientInformSubscription state fail k stanza = do
     addrs <- resolvePeer h
     -- remove from pending
     buds <- resolvedFromRoster ConfigFiles.getBuddies (clientUser client)
-    let is_buddy = not . null $ map ((mu,) . PeerKey) addrs \\ buds
+    let is_buddy = not . null $ map ((mu,) . PeerKey) addrs `intersect` buds
     removeFromRosterFile ConfigFiles.modifyPending (clientUser client) to addrs
     let (relationship,addf,remf) =
          case stanzaType stanza of
@@ -813,20 +842,27 @@ clientInformSubscription state fail k stanza = do
     addToRosterFile      addf (clientUser client) to addrs
     removeFromRosterFile remf (clientUser client) to addrs
 
+    do
+        cbu <- atomically $ readTVar (clientsByUser state)
+        putStrLn $ "cbu = " ++ show (fmap (fmap clientPid . networkClients) cbu)
+
     -- send roster update to clients
     (clients,ktc) <- atomically $ do
         cbu <- readTVar (clientsByUser state)
-        let mlp = mu >>= flip Map.lookup cbu
+        let mlp = Map.lookup (clientUser client) cbu
         let cs = maybe [] (Map.toList . networkClients) mlp
         ktc <- readTVar (keyToChan state)
         return (cs,ktc)
     forM_ clients $ \(ck, client) -> do
-        when (clientIsInterested client) $ do
+        is_intereseted <- atomically $ clientIsInterested client
+        putStrLn $ "clientIsInterested: "++show is_intereseted
+        is_intereseted <- atomically $ clientIsInterested client
+        when is_intereseted $ do
         flip (maybe $ return ()) (Map.lookup ck ktc) $ \con -> do
         hostname <- textHostName
         -- TODO: Should cjid include the resource?
         let cjid = unsplitJID (mu, hostname, Nothing)
-        update <- makeRosterUpdate cjid to relationship
+        update <- makeRosterUpdate cjid to [relationship]
         sendModifiedStanzaToClient update (connChan con)
 
     -- notify peer
@@ -839,6 +875,7 @@ clientInformSubscription state fail k stanza = do
         sendModifiedStanzaToPeer (dup { stanzaTo = Just $ to'
                                       , stanzaFrom = Just from })
                                  (connChan con)
+        answerProbe state (Just from) pk (connChan con)
     
 peerInformSubscription state fail k stanza = do
     putStrLn $ "TODO: peerInformSubscription"
@@ -858,7 +895,7 @@ peerInformSubscription state fail k stanza = do
     addrs <- resolvePeer from_h
     was_solicited <- removeFromRosterFile ConfigFiles.modifySolicited user from'' addrs
     subs <- resolvedFromRoster ConfigFiles.getSubscribers user
-    let is_sub = not . null $ map ((from_u,) . PeerKey) addrs \\ subs
+    let is_sub = not . null $ map ((from_u,) . PeerKey) addrs `intersect` subs
     let (relationship,addf,remf) =
          case stanzaType stanza of
            PresenceInformSubscription True ->
@@ -873,20 +910,17 @@ peerInformSubscription state fail k stanza = do
     addToRosterFile      addf user from'' addrs
     removeFromRosterFile remf user from'' addrs
 
-    ktc <- atomically $ readTVar (keyToChan state)
-    flip (maybe fail) (Map.lookup k ktc)
-         $ \Conn { auxAddr=laddr } -> do
     hostname <- textHostName
     let to' = unsplitJID (Just user, hostname, Nothing)
-    (_,fromtup) <- rewriteJIDForClient laddr from
     chans <- clientCons state ktc user
     forM_ chans $ \(Conn { connChan=chan }, client) -> do
-    update <- makeRosterUpdate to' from relationship
-    when (clientIsInterested client) $ do
+    update <- makeRosterUpdate to' from'' [relationship]
+    is_intereseted <- atomically $ clientIsInterested client
+    when is_intereseted $ do
         sendModifiedStanzaToClient update chan
     -- TODO: interested/availabe clients only?
     dup <- cloneStanza stanza
-    sendModifiedStanzaToClient dup { stanzaFrom = Just $ unsplitJID fromtup
+    sendModifiedStanzaToClient dup { stanzaFrom = Just $ from''
                                    , stanzaTo = Just to' }
                                chan
 
@@ -924,7 +958,7 @@ main = runResourceT $ do
         , xmppDeliverMessage = deliverMessage state
         , xmppInformClientPresence = informClientPresence state
         , xmppInformPeerPresence = informPeerPresence state
-        , xmppAnswerProbe = answerProbe state
+        , xmppAnswerProbe = \k stanza chan -> answerProbe state (stanzaTo stanza) k chan
         , xmppClientSubscriptionRequest = clientSubscriptionRequest state
         , xmppPeerSubscriptionRequest = peerSubscriptionRequest state
         , xmppClientInformSubscription = clientInformSubscription state