1 files changed, 45 insertions, 12 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 6d187132..ce1ea7c5 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -20,6 +20,7 @@ import SocketLike
 import ByteStringOperators
 import ControlMaybe
 
+import Data.Maybe (catMaybes)
 import Data.HList
 import Network.Socket 
     ( Family
@@ -95,6 +96,9 @@ import GHC.Conc
     , ThreadId
     )
 
+textToByteString x = L.fromChunks [S.encodeUtf8 x]
+
+
 data Commands = 
     Send [XML.Event] 
     | BoundToResource
@@ -257,7 +261,7 @@ handleIQSetBind session cmdChan stanza_id = do
                     "{urn:ietf:params:xml:ns:xmpp-bind}resource"
                       -> do
                         rsc <- lift content
-                        return $ L.fromChunks [S.encodeUtf8 rsc]
+                        return . textToByteString $ rsc
                     _ -> unhandledBind
              Nothing -> do
                 liftIO $ putStrLn $ "empty bind request!"
@@ -616,13 +620,13 @@ handlePeer st src snk = do
 handlePeerPresence session stanza False = do
     -- Offline
     withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do
-    peer_jid <- liftIO $ parseAddressJID (L.fromChunks [S.encodeUtf8 jid])
+    peer_jid <- liftIO $ parseAddressJID (textToByteString jid)
     liftIO $ announcePresence session (Presence peer_jid Offline)
 handlePeerPresence session stanza True = do
     -- online (Available or Away)
     let log  = liftIO . L.putStrLn . ("(P) " <++>)
     withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do
-    pjid <- liftIO $ parseAddressJID (L.fromChunks [S.encodeUtf8 jid])
+    pjid <- liftIO $ parseAddressJID (textToByteString jid)
     -- stat <- show element content
     let parseChildren stat = do
             child <- nextElement
@@ -673,7 +677,7 @@ isClientPresenceOf _ _ = False
 handlePresenceProbe session stanza = do
     withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to -> do
     -- withJust (lookupAttrib "from" (tagAttrs stanza)) $ \from -> do
-    jid <- liftIO $ parseAddressJID $ L.fromChunks [S.encodeUtf8 to]
+    jid <- liftIO $ parseAddressJID $ textToByteString to
     withJust (name jid) $ \user -> do
     liftIO $ L.putStrLn $ "RECEIVED PROBE "<++>bshow (peerAddress session,to)
     liftIO $ do
@@ -735,7 +739,7 @@ clientRequestsSubscription session cmdChan stanza = do
             handleError e = do
                 putStrLn $ "ERROR: "++ show e
         handleIO handleError $ do
-            let to_str' = (L.fromChunks [S.encodeUtf8 to_str])
+            let to_str' = textToByteString to_str
             to_jid <- fmap bare $ parseHostNameJID to_str'
             if (is_remote . peer) to_jid 
              then do
@@ -751,13 +755,36 @@ clientRequestsSubscription session cmdChan stanza = do
 
 peerRequestsSubsription session stanza = do
     liftIO $ putStrLn $ "PEER PRESENCE SUBSCRIBE " ++ show stanza
-    -- TODO
-    -- if already subscribed
-    --   reply
-    -- else if no client:
-    --   add pending
-    -- else:
-    --   notify client(s)
+    withJust (lookupAttrib "from" (tagAttrs stanza)) $ \from0-> do
+    withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to0 -> do
+    let to = textToByteString to0
+        from = textToByteString from0
+        factory = peerSessionFactory session
+    mjid <- liftIO $  handleIO_ (return Nothing) (fmap Just $ parseAddressJID to)
+    mfrom <- liftIO $  handleIO_ (return Nothing) (fmap Just $ parseAddressJID from)
+    withJust (mfrom >>= name) $ \from -> do
+    withJust mjid $ \tojid -> do
+    withJust (name tojid) $ \user -> do
+    subs <- liftIO $ do
+             subs <- getSubscribers factory user
+             msubs <- flip mapM subs $ \str -> do
+                        handleIO_ (return Nothing) 
+                                  (fmap Just $ parseHostNameJID str)
+             return (catMaybes msubs)
+    let peer = peerAddress session
+        fromjid = JID (Just from) peer Nothing
+    if elem fromjid subs
+      then do
+        liftIO . L.putStrLn $ bshow fromjid <++> " already subscribed to " <++> user
+        -- if already subscribed
+        --   reply
+        return ()
+      else
+        -- if no client:
+        --   add pending
+        -- else:
+        --   notify client(s)
+        return ()
     return ()
 
 clientApprovesSubscription session stanza = do
@@ -822,6 +849,7 @@ fromPeer session = doNestingXML $ do
 data OutBoundMessage = OutBoundPresence Presence 
                         | PresenceProbe JID JID
                         | Solicitation  JID JID
+                        | Approval JID JID
  deriving Prelude.Show
 
 newServerConnections = newTVar Map.empty
@@ -851,6 +879,7 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do
                     cache <- readIORef cached
                     let probes' = Map.adjust (Set.insert (False,from)) to $ probes cache
                     writeIORef cached (cache { probes=probes' })
+        cacheCmd (Approval from to) cached = return () -- Subscription approvals are not cached.
 
     fix $ \sendmsgs -> do
         connected <- liftIO . async $ connect' (peerAddr peer) port
@@ -979,6 +1008,10 @@ toPeer sock cache chan fail = do
           Solicitation from to -> do
             liftIO $ L.putStrLn "sending live solicitation..."
             sendSolicitation from to
+          Approval from to -> do
+            liftIO . L.putStrLn $ "sending approval "<++>bshow (from,to)
+            r <- liftIO $ presenceProbe sock from to "subscribed"
+            send r
         loop
     send goodbyePeer