From d163ee7393bcfcc2503698ea58db646546cfb55f Mon Sep 17 00:00:00 2001 From: joe Date: Mon, 8 Jul 2013 09:47:25 -0400 Subject: clientRequestsSubscription work in progress... --- Presence/ControlMaybe.hs | 4 +++ Presence/XMPP.hs | 67 ++++++++++++++++++++++++++++++++++++++++-------- Presence/XMPPTypes.hs | 1 + Presence/main.hs | 4 +++ 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 -- cgit v1.2.3