clientRequestsSubscription work in progress...

4 files changed, 65 insertions, 11 deletions

diff --git a/Presence/ControlMaybe.hs b/Presence/ControlMaybe.hs
index 37f6f93c..69a38f71 100644
--- a/Presence/ControlMaybe.hs
+++ b/Presence/ControlMaybe.hs
@@ -15,5 +15,9 @@ whenJust acn f = do
 catchIO_ :: IO a -> IO a -> IO a
 catchIO_ a h = Exception.catch a (\(_ :: IOException) -> h)
 
+catchIO :: IO a -> (IOException -> IO a)  -> IO a
+catchIO body handler = Exception.catch body handler
+
 handleIO_ = flip catchIO_
+handleIO = flip catchIO
 
diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 7b01711e..1520839e 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -62,6 +62,7 @@ import Control.Exception
     , finally
     , bracketOnError )
 import GHC.IO.Exception (IOException(..))
+import System.IO.Error (isDoesNotExistError)
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Maybe
@@ -93,7 +94,11 @@ import GHC.Conc
     , ThreadId
     )
 
-data Commands = Send [XML.Event] | QuitThread
+data Commands = 
+    Send [XML.Event] 
+    | BoundToResource
+    | InterestedInRoster
+    | QuitThread 
  deriving Prelude.Show
 
 getNamesForPeer :: Peer -> IO [ByteString]
@@ -260,7 +265,9 @@ handleIQSetBind session cmdChan stanza_id = do
         L.putStrLn $ "iq-set-bind-resource " <++> rsc
         setResource session rsc
         jid <- getJID session
-        atomically $ writeTChan cmdChan (Send $ iq_bind_reply stanza_id (toStrict $ L.decodeUtf8 $ L.show jid) )
+        atomically $ do
+            writeTChan cmdChan (Send $ iq_bind_reply stanza_id (toStrict $ L.decodeUtf8 $ L.show jid) )
+            writeTChan cmdChan BoundToResource
         forCachedPresence session $ \presence -> do
             xs <- xmlifyPresenceForClient presence
             atomically . writeTChan cmdChan . Send $ xs
@@ -410,7 +417,9 @@ handleIQGet session cmdChan tag = do
             -- ,(Name {nameLocalName = "type", nameNamespace = Nothing, namePrefix = Nothing},
             --  [ContentText "get"])]
             roster <- getRoster session stanza_id
-            atomically . writeTChan cmdChan . Send $ roster
+            atomically $ do
+                writeTChan cmdChan InterestedInRoster
+                writeTChan cmdChan . Send $ roster
         req -> unhandledGet req
     
 
@@ -436,15 +445,17 @@ fromClient session cmdChan = doNestingXML $ do
         whenJust nextElement $ \stanza -> do
             stanza_lvl <- nesting
 
+            liftIO . putStrLn $ "stanza: "++show stanza
+
             let unhandledStanza = do
                     xs <- gatherElement stanza Seq.empty
                     prettyPrint "unhandled-C: " (toList xs)
             case () of
              _ | stanza `isIQOf` iqTypeSet -> handleIQSet session cmdChan stanza
              _ | stanza `isIQOf` iqTypeGet -> handleIQGet session cmdChan stanza
-             _ | stanza `isPresenceOf` presenceTypeSubscribe 
-                                           -> clientRequestsSubscription session stanza
-             _ | stanza `isPresenceOf` presenceTypeSubscribed
+             _ | stanza `isClientPresenceOf` presenceTypeSubscribe 
+                                           -> clientRequestsSubscription session cmdChan stanza
+             _ | stanza `isClientPresenceOf` presenceTypeSubscribed
                                            -> clientApprovesSubscription session stanza
              _ | otherwise                 -> unhandledStanza
 
@@ -468,6 +479,7 @@ toClient pchan cmdChan = fix $ \loop -> do
     case event of
       Right QuitThread -> return ()
       Right (Send xs)  -> send xs >> loop
+      Right cmd        -> liftIO (putStrLn $ "unhandled event: "++show cmd) >> loop
       Left  presence   -> do 
         xs <- liftIO $ xmlifyPresenceForClient presence
         send xs
@@ -610,6 +622,12 @@ isPresenceOf (EventBeginElement name attrs) testType
     = True
 isPresenceOf _ _ = False
 
+isClientPresenceOf (EventBeginElement name attrs) testType
+    | name=="{jabber:client}presence"
+    && matchAttribMaybe "type" testType attrs
+    = True
+isClientPresenceOf _ _ = False
+
 handlePresenceProbe session stanza = do
     withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to -> do
     -- withJust (lookupAttrib "from" (tagAttrs stanza)) $ \from -> do
@@ -638,7 +656,22 @@ subscribeToPresence subscribers peer_jid user = do
 
 bare (JID n host _) = JID n host Nothing
 
-clientRequestsSubscription session stanza = do
+presenceErrorRemoteNotFound iqid from to = return
+    [ EventBeginElement "{stream:client}presence" 
+        ( case iqid of { Nothing -> id; Just iqid -> ( attr "id" iqid :) }
+           $ [ attr "from" to
+             , attr "type" "error"
+             ] )
+    , EventBeginElement "{stream:client}error"
+        [ attr "type" "modify"]
+    , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-stanzas}remote-server-not-found"
+        []
+    , EventEndElement "{urn:ietf:params:xml:ns:xmpp-stanzas}remote-server-not-found"
+    , EventEndElement "{stream:client}error"
+    , EventEndElement "{stream:client}presence"
+    ]
+
+clientRequestsSubscription session cmdChan stanza = do
     -- make bare jid
     -- check local server and obey rules 3.1.3 of rfc 6121
     -- or forward to remote peer
@@ -646,10 +679,22 @@ clientRequestsSubscription session stanza = do
     -- if not bailed,
     --  add to solicited
     --  do roster push with subscription=none ask=subscribe
-    liftIO $ putStrLn $ "CLIENT PRESENCE SUBSCRIBE " ++ show stanza
-    -- add solicited
-    -- notify other clients
-    -- notify peer
+    liftIO $ do
+        putStrLn $ "CLIENT PRESENCE SUBSCRIBE " ++ show stanza
+        withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str -> do
+        let from = lookupAttrib "from" (tagAttrs stanza)
+            iqid = lookupAttrib "id" (tagAttrs stanza)
+        let handleError e | isDoesNotExistError e = do
+                putStrLn $ "remote-server-not-found"
+                r <- presenceErrorRemoteNotFound iqid from to_str
+                atomically $ writeTChan cmdChan (Send r)
+            handleError e = do
+                putStrLn $ "ERROR: "++ show e
+        handleIO handleError $ do
+            to_jid <- parseHostNameJID (L.fromChunks [S.encodeUtf8 to_str])
+            addSolicited session (L.fromChunks [S.encodeUtf8 to_str]) -- jid
+            putStrLn $ "added to solicited: " ++ show to_jid
+            -- TODO: create roster item and push to interested clients
     return ()
 
 peerRequestsSubsription session stanza = do
diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs
index 747ceb0e..301f19fd 100644
--- a/Presence/XMPPTypes.hs
+++ b/Presence/XMPPTypes.hs
@@ -44,6 +44,7 @@ class JabberClientSession session where
     getMyOthers        :: session -> IO [ByteString]
     getMyPending       :: session -> IO [ByteString]
     getMySolicited     :: session -> IO [ByteString]
+    addSolicited :: session -> ByteString ->  IO ()
 
 class JabberPeerSession session where
     data XMPPPeerClass session
diff --git a/Presence/main.hs b/Presence/main.hs
index 0eae8677..bf4809a8 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -168,6 +168,10 @@ instance JabberClientSession ClientSession where
             L.putStrLn $ "cached presence: " <++> bshow p
             action p
 
+    addSolicited s jid = do
+        user <- readIORef (unix_uid s) >>= getJabberUserForId
+        ConfigFiles.addSolicited user jid -- (L.show jid)
+
     getMyBuddies s = do
         user <- readIORef (unix_uid s) >>= getJabberUserForId
         ConfigFiles.getBuddies user