finished clientSubscriptionRequest, WIP: peerSuscriptionRequest

1 files changed, 77 insertions, 22 deletions

diff --git a/xmppServer.hs b/xmppServer.hs
index d553d1e7..81cbf212 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, (\\) )
 import Data.Monoid ( (<>) )
 import qualified Data.Text as Text
 import qualified Data.Text.IO as Text
@@ -27,6 +27,7 @@ import Data.Text (Text)
 import qualified Data.Map as Map
 import Data.Map (Map)
 import Control.Exception ({-evaluate,-}handle,SomeException(..),bracketOnError,ErrorCall(..))
+import System.IO.Error (isDoesNotExistError)
 import System.Posix.User (getUserEntryForID,userName)
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified ConfigFiles
@@ -471,6 +472,9 @@ subscribedPeers user = do
     let hosts = map ((\(_,h,_)->h) . splitJID) jids
     fmap Map.keys $ resolveAllPeers hosts 
 
+clientJID con client = unsplitJID ( Just $ clientUser client
+                                  , addrToText $ auxAddr con
+                                  , Just $ clientResource client)
 
 -- | Send presence notification to subscribed peers.
 -- Note that a full JID from address will be added to the
@@ -489,9 +493,7 @@ informClientPresence state k stanza = do
     ktc <- atomically $ readTVar (keyToChan state)
     let connected = mapMaybe (flip Map.lookup ktc . PeerKey) addrs
     forM_ connected $ \con -> do
-    let from' = unsplitJID ( Just $ clientUser client
-                           , addrToText $ auxAddr con
-                           , Just $ clientResource client)
+    let from' = clientJID con client
     mto <- runTraversableT $ do
             to <- liftT $ stanzaTo stanza
             (to',_) <- liftMT $ rewriteJIDForPeer to
@@ -612,33 +614,86 @@ sendCachedPresence state k = do
     -- send local buddies.
     return ()
 
+addToRosterFile doit whose to addrs = do
+    let (mu,_,_) = splitJID to
+        cmp jid = runTraversableT $ do
+            let (mu,stored_h,mr) = splitJID (lazyByteStringToText jid)
+            flip (maybe mzero) mr . const $ do
+            flip (maybe mzero) mu $ \stored_u -> do
+            flip (maybe $ return jid) mu $ \u -> do
+            if stored_u /= u then return jid else do
+            stored_addrs <- lift $ nub `fmap` resolvePeer stored_h
+            if null (stored_addrs \\ addrs) then return jid else do
+            mzero
+    doit (textToLazyByteString whose)
+         cmp
+         (Just $ textToLazyByteString to)
+
 clientSubscriptionRequest :: PresenceState -> IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO ()
 clientSubscriptionRequest state fail k stanza chan = do
+    forClient state k fail $ \client -> do
     flip (maybe fail) (stanzaTo stanza) $ \to -> do
-    putStrLn $ "TODO: clientSubscriptionRequest"
-    -- TODO: resolve hostname
-    -- TODO: add to solicited
-    -- TODO; if already connected, send solicitation 
-    -- TODO: addPeer
-    return ()
+    putStrLn $ "Forwarding solictation to peer"
+    let (mu,h,_) = splitJID to
+    to <- return $ unsplitJID (mu,h,Nothing) -- delete resource
+    flip (maybe fail) mu $ \u -> do
+    addrs <- nub `fmap` resolvePeer h
+    if null addrs then fail else do
+    -- add to-address to from's solicited
+    addToRosterFile ConfigFiles.modifySolicited (clientUser client) to addrs
+    (ktc,ap) <- atomically $ 
+        liftM2 (,) (readTVar $ keyToChan state)
+                   (readTVar $ associatedPeers state)
+    let dsts = Map.fromList $ map ((,()) . PeerKey) addrs
+        cdsts = ktc Map.\\ dsts
+    forM_ (Map.toList cdsts) $ \(pk,con) -> do
+        -- if already connected, send solicitation ...
+        let from = clientJID con client
+        sendModifiedStanzaToPeer (stanza { stanzaTo = Just to
+                                         , stanzaFrom = Just from })
+                                 (connChan con)
+    let addrm = Map.fromList (map (,()) addrs)
+    when (not . Map.null $ addrm Map.\\ ap) $ do
+        -- Add peer if we are not already associated ...
+        sv <- atomically $ takeTMVar $ server state
+        addPeer sv (head addrs)
 
 peerSubscriptionRequest :: PresenceState -> IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO ()
 peerSubscriptionRequest state fail k stanza chan = do
     putStrLn $ "TODO: peerSubscriptionRequest"
-    -- TODO: if already subscribed, reply and quit
-
-    -- TODO: add to pending
-
-    -- TODO: send to clients
-    --    "all available resources in accordence with section 8"
+    flip (maybe fail) (stanzaFrom stanza) $ \from -> do
+    flip (maybe fail) (stanzaTo stanza) $ \to -> do
+    let (mto_u,h,_) = splitJID to
+        (mfrom_u,from_h,_) = splitJID from
+    to <- return $ unsplitJID (mto_u,h,Nothing) -- delete resource
+    from <- return $ unsplitJID (mfrom_u,from_h,Nothing) -- delete resource
+    flip (maybe fail) mto_u $ \u -> do
+    flip (maybe fail) mfrom_u $ \from_u -> do
+    subs <- configText ConfigFiles.getSubscribers u
+    let resolved_subs = runTraversableT $ do
+            (mu,h,_) <- liftT $ splitJID `fmap` subs
+            addr <- liftMT $ resolvePeer h
+            return (mu,PeerKey addr)
+    already_subscribed <-  fmap (elem (mfrom_u,k)) resolved_subs
     --    Section 8 says (for presence of type "subscribe", the server MUST
     --    adhere to the rules defined under Section 3 and summarized under
-    --    Appendix A. 
-    --    Appendex A.3.1 says
-    --      contact ∈ subscribers --> SHOULD NOT, already handled
-    --      contact ∉ subscribers & contact ∈ pending --> SHOULD NOT
-    --      contact ∉ subscribers & contact ∉ pending --> MUST
-
+    --    see Appendix A. (pariticularly Appendex A.3.1)
+    if already_subscribed
+     then do
+        -- contact ∈ subscribers --> SHOULD NOT, already handled
+        -- TODO: already subscribed, reply and quit
+        return ()
+     else do
+    -- 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
+    already_pending <- addToRosterFile ConfigFiles.modifyPending u from addrs
+
+    -- contact ∉ subscribers & contact ∈ pending --> SHOULD NOT
+    when (not already_pending) $ do
+    -- contact ∉ subscribers & contact ∉ pending --> MUST
+    -- TODO: send to clients
     return ()
 
 clientInformSubscription state fail k stanza = do