NestingXML experiment

1 files changed, 76 insertions, 7 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index c2ff6739..5c5cbaef 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -35,7 +35,7 @@ import Control.Monad.Trans.Class
 import Control.Monad.Trans.Maybe
 import Todo
 import Control.Monad as Monad
-import Text.XML.Stream.Parse
+import Text.XML.Stream.Parse (parseBytes,content)
 import Text.XML.Stream.Render
 import Data.XML.Types as XML
 import Network.BSD (getHostName,hostName,hostAliases)
@@ -51,6 +51,7 @@ import Data.Conduit.Blaze
 #endif
 import Data.List (find)
 import qualified Text.Show.ByteString as L
+import NestingXML
 
 data Commands = Send [XML.Event] | QuitThread
  deriving Prelude.Show
@@ -254,15 +255,72 @@ doIQ session cmdChan tag@(EventBeginElement name attrs) = do
             xs <- gatherElement tag Seq.empty 
             prettyPrint "client-in: ignoring iq:" (toList xs)
 
-fromClient :: (MonadIO m, XMPPSession session) => 
+withJust (Just x) f = f x
+withJust Nothing  f = return ()
+
+whenJust acn f = do
+    x <- acn
+    withJust x f
+
+tagAttrs (EventBeginElement _ xs) = xs
+tagAttrs _                        = []
+
+tagName (EventBeginElement n _) = n
+tagName _                       = ""
+
+handleIQSetBind session cmdChan stanza_id = do
+    whenJust nextElement $ \child -> do
+    let unhandledBind = liftIO $ putStrLn $ "unhandled-bind: "++show child
+    case tagName child of
+        "{urn:ietf:params:xml:ns:xmpp-bind}resource"
+          -> do
+            rsc <- lift content
+            liftIO $ do
+                putStrLn $ "iq-set-bind-resource " ++ show rsc
+                setResource session (L.fromChunks [S.encodeUtf8 rsc])
+                jid <- getJID session
+                atomically $ writeTChan cmdChan (Send $ iq_bind_reply stanza_id (toStrict $ L.decodeUtf8 $ L.show jid) )
+        _ -> unhandledBind
+
+handleIQSet session cmdChan tag = do
+    withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do
+    whenJust nextElement $ \child -> do
+    let unhandledSet = liftIO $ putStrLn ("iq-set: "++show (stanza_id,child))
+    case tagName child of
+      "{urn:ietf:params:xml:ns:xmpp-bind}bind" 
+        -> handleIQSetBind session cmdChan stanza_id
+      _ -> unhandledSet
+
+matchAttrib name value attrs = 
+    case find ( (==name) . fst) attrs of
+        Just (_,[ContentText x])   | x==value -> True
+        Just (_,[ContentEntity x]) | x==value -> True
+        _                                     -> False
+
+lookupAttrib name attrs =
+    case find ( (==name) . fst) attrs of
+        Just (_,[ContentText x])   -> Just x
+        Just (_,[ContentEntity x]) -> Just x
+        _                          -> Nothing
+    
+iqTypeSet = "set"
+
+isIQOf (EventBeginElement name attrs) testType 
+    | name=="{jabber:client}iq" 
+    && matchAttrib "type" testType attrs
+    = True
+isIQOf _ _ = False
+
+fromClient :: (MonadThrow m,MonadIO m, XMPPSession session) => 
     session -> TChan Commands -> Sink XML.Event m ()
-fromClient session cmdChan = voidMaybeT $ do
+fromClient session cmdChan = doNestingXML $ do
     let log  = liftIO . L.putStrLn . ("client-in: " <++>)
         send = liftIO . atomically . writeTChan cmdChan . Send
-    mawait >>= guard . (==EventBeginDocument)
+    withXML $ \begindoc -> do
+    when (begindoc==EventBeginDocument) $ do
     log "begin-doc"
-    xml <- mawait
-    stream_attrs <- elementAttrs "stream" xml
+    withXML $ \xml -> do
+    withJust (elementAttrs "stream" xml) $ \stream_attrs -> do
     log $ "stream " <++> bshow stream_attrs
     host <- liftIO $ do
         jid <- getJID session
@@ -270,6 +328,7 @@ fromClient session cmdChan = voidMaybeT $ do
         return (S.decodeUtf8 . head $ names)
     send $ greet host
     
+{-
     fix $ \loop -> do
       xml <- mawait
       log $ bshow xml
@@ -283,9 +342,19 @@ fromClient session cmdChan = voidMaybeT $ do
              prettyPrint "client-in: ignoring..." (toList xs)
              loop
         _ -> loop
+-}
+    fix $ \loop -> do
+        whenJust nextElement $ \stanza -> do
+            stanza_lvl <- nesting
+            let unhandledStanza = liftIO $ putStrLn ("ignoring stanza: "++show stanza)
+            case () of
+             _ | stanza `isIQOf` iqTypeSet -> handleIQSet session cmdChan stanza
+             _ | otherwise                 -> unhandledStanza
+            awaitCloser stanza_lvl
+            loop
 
     log $ "end of stream"
-    xml <- mawait
+    withXML $ \xml -> do
     log $ "end-of-document: " <++> bshow xml
 
 prettyPrint prefix xs =