From 6ae814b019a2b14848ee376d1f9ea521310ae0cd Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Sat, 8 Mar 2014 20:31:16 -0500
Subject: WIP: clientInformSubscription

---
 xmppServer.hs | 74 ++++++++++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 53 insertions(+), 21 deletions(-)

(limited to 'xmppServer.hs')

diff --git a/xmppServer.hs b/xmppServer.hs
index 99d5a197..13883c75 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -247,12 +247,15 @@ rosterGetStuff what state k = forClient state k (return [])
     return jids
 
 rosterGetBuddies :: PresenceState -> ConnectionKey -> IO [Text]
-rosterGetBuddies state k = do
-    buds <- rosterGetStuff ConfigFiles.getBuddies state k
-    return buds
+rosterGetBuddies state k = rosterGetStuff ConfigFiles.getBuddies state k
 
+rosterGetSolicited :: PresenceState -> ConnectionKey -> IO [Text]
 rosterGetSolicited = rosterGetStuff ConfigFiles.getSolicited
+
+rosterGetOthers :: PresenceState -> ConnectionKey -> IO [Text]
 rosterGetOthers = rosterGetStuff ConfigFiles.getOthers
+
+rosterGetSubscribers :: PresenceState -> ConnectionKey -> IO [Text]
 rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers
 
 data Conn = Conn { connChan :: TChan Stanza
@@ -616,7 +619,13 @@ sendCachedPresence state k = do
     -- send local buddies.
     return ()
 
-addToRosterFile doit whose to addrs = do
+addToRosterFile doit whose to addrs =
+    modifyRosterFile doit whose to addrs True
+
+removeFromRosterFile doit whose to addrs =
+    modifyRosterFile doit whose to addrs False
+
+modifyRosterFile doit whose to addrs bAdd = do
     let (mu,_,_) = splitJID to
         cmp jid = runTraversableT $ do
             let (mu,stored_h,mr) = splitJID (lazyByteStringToText jid)
@@ -629,7 +638,7 @@ addToRosterFile doit whose to addrs = do
             mzero
     doit (textToLazyByteString whose)
          cmp
-         (Just $ textToLazyByteString to)
+         (guard bAdd >> Just (textToLazyByteString to))
 
 clientSubscriptionRequest :: PresenceState -> IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO ()
 clientSubscriptionRequest state fail k stanza chan = do
@@ -660,6 +669,17 @@ clientSubscriptionRequest state fail k stanza chan = do
         sv <- atomically $ takeTMVar $ server state
         addPeer sv (head addrs)
 
+
+resolvedFromRoster
+  :: (L.ByteString -> IO [L.ByteString])
+     -> UserName -> IO [(Maybe UserName, ConnectionKey)]
+resolvedFromRoster doit u = do
+    subs <- configText doit u
+    runTraversableT $ do
+            (mu,h,_) <- liftT $ splitJID `fmap` subs
+            addr <- liftMT $ resolvePeer h
+            return (mu,PeerKey addr)
+
 peerSubscriptionRequest :: PresenceState -> IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO ()
 peerSubscriptionRequest state fail k stanza chan = do
     putStrLn $ "Handling pending subscription from remote"
@@ -677,12 +697,8 @@ peerSubscriptionRequest state fail k stanza chan = do
     (_,fromtup) <- rewriteJIDForClient laddr from
     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
+    resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u
+    let already_subscribed = 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
     --    see Appendix A. (pariticularly Appendex A.3.1)
@@ -722,17 +738,33 @@ peerSubscriptionRequest state fail k stanza chan = do
 
 
 clientInformSubscription state fail k stanza = do
-    putStrLn $ "TODO: clientInformSubscription"
-    -- approval:
-    --  add to subscribers
-    --  remove from pending
-    --  remove from others
-    -- rejection:
-    --  add to others
-    --  remove from pending
-    --  remove from subscribers
-    --
+    forClient state k fail $ \client -> do
+    flip (maybe fail) (stanzaTo stanza) $ \to -> do
+    putStrLn $ "clientInformSubscription"
+    let (mu,h,mr) = splitJID to
+    addrs <- resolvePeer h
+    -- remove from pending
+    buds <- resolvedFromRoster ConfigFiles.getBuddies (clientUser client)
+    let is_buddy = not . null $ map ((mu,) . PeerKey) addrs \\ buds
+    removeFromRosterFile ConfigFiles.modifyPending (clientUser client) to addrs
+    let (relationship,addf,remf) =
+         case stanzaType stanza of
+           PresenceInformSubscription True ->
+                ( if is_buddy then "both"
+                              else "from"
+                , ConfigFiles.modifySubscribers
+                , ConfigFiles.modifyOthers )
+           _ -> ( if is_buddy then "to"
+                              else "none"
+                , ConfigFiles.modifyOthers
+                , ConfigFiles.modifySubscribers )
+    addToRosterFile      addf (clientUser client) to addrs
+    removeFromRosterFile remf (clientUser client) to addrs
+    -- TODO
     -- send roster update to clients
+    --  approve: both ( ∈ buddies) else from
+    --  reject: to ( ∈ buddies ) else none 
+    
     -- notify peer
     return ()
 
-- 
cgit v1.2.3