2 files changed, 113 insertions, 0 deletions

diff --git a/Presence/EventUtil.hs b/Presence/EventUtil.hs
index e62f8afc..bdea9fa2 100644
--- a/Presence/EventUtil.hs
+++ b/Presence/EventUtil.hs
@@ -3,6 +3,7 @@ module EventUtil where
 
 import Control.Monad
 import Data.XML.Types as XML
+import qualified Data.List as List
 
 getStreamName (EventBeginElement name _) = name
 
@@ -21,3 +22,36 @@ elementAttrs _ _ = mzero
 streamP name = Name name (Just "http://etherx.jabber.org/streams") (Just "stream")
 
 attr   name value = (name,[ContentText value])
+
+isServerIQOf (EventBeginElement name attrs) testType 
+    | name=="{jabber:server}iq" 
+    && matchAttrib "type" testType attrs
+    = True
+isServerIQOf _ _ = False
+
+matchAttrib name value attrs = 
+    case List.find ( (==name) . fst) attrs of
+        Just (_,[ContentText x])   | x==value -> True
+        Just (_,[ContentEntity x]) | x==value -> True
+        _                                     -> False
+
+lookupAttrib name attrs =
+    case List.find ( (==name) . fst) attrs of
+        Just (_,[ContentText x])   -> Just x
+        Just (_,[ContentEntity x]) -> Just x
+        _                          -> Nothing
+
+tagAttrs (EventBeginElement _ xs) = xs
+tagAttrs _                        = []
+
+    
+{-
+iqTypeSet    = "set"
+iqTypeGet    = "get"
+iqTypeResult = "result"
+iqTypeError  = "error"
+-}
+
+
+tagName (EventBeginElement n _) = n
+tagName _                       = ""
diff --git a/Presence/Nesting.hs b/Presence/Nesting.hs
new file mode 100644
index 00000000..24f9baad
--- /dev/null
+++ b/Presence/Nesting.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Nesting where
+
+import Data.Conduit
+import Data.Conduit.Lift
+import Data.XML.Types
+import qualified Data.Text as S
+import Control.Monad.State
+import qualified Data.List as List
+
+type Lang = S.Text
+
+data StrictList a = a :! !(StrictList a) | StrictNil
+
+data XMLState = XMLState { 
+        nestingLevel :: Int,
+        langStack :: StrictList (Int,Lang)
+}
+
+type NestingXML o m a = ConduitM Event o (StateT XMLState m) a
+
+doNestingXML :: Monad m => NestingXML o m r -> ConduitM Event o m r
+doNestingXML m = 
+    evalStateC (XMLState 0 StrictNil) (trackNesting =$= m)
+
+nesting :: Monad m => NestingXML o m Int
+nesting = lift $ (return . nestingLevel) =<< get
+
+
+trackNesting :: Monad m => ConduitM Event Event (StateT XMLState m) ()
+trackNesting = awaitForever doit
+ where
+  doit xml = do
+    XMLState lvl langs <- lift get
+    lift . put $ case xml of
+              EventBeginElement _ attrs -> 
+                case lookupLang attrs of
+                  Nothing   -> XMLState (lvl+1) langs
+                  Just lang -> XMLState (lvl+1) ( (lvl+1,lang) :! langs)
+              EventEndElement _     -> 
+                case langs of 
+                  (llvl,_) :! ls | llvl==lvl -> XMLState (lvl-1) ls
+                  _              | otherwise -> XMLState (lvl-1) langs
+              _  -> XMLState lvl langs
+    yield xml
+
+
+lookupLang attrs =
+    case List.find ( (=="xml:lang") . fst) attrs of
+        Just (_,[ContentText x])   -> Just x
+        Just (_,[ContentEntity x]) -> Just x
+        _                          -> Nothing
+
+
+awaitCloser :: Monad m => Int -> NestingXML o m ()
+awaitCloser lvl = do
+    fix $ \loop -> do
+        lvl' <- nesting
+        when (lvl' >= lvl) $ do
+        xml <- await
+        maybe (return ()) (const loop) xml
+
+withXML f = await >>= maybe (return ()) f
+
+nextElement :: Monad m => NestingXML o m (Maybe Event)
+nextElement = do
+    lvl <- nesting
+    fix $ \loop  -> do
+        xml <- await
+        case xml of
+            Nothing                      -> return Nothing
+            Just (EventBeginElement _ _) -> do
+                return xml
+            Just _ -> do
+                lvl' <- nesting
+                if (lvl'>=lvl) then loop 
+                               else return Nothing
+