1 files changed, 125 insertions, 17 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index bfa5827e..656ed170 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE CPP                 #-}
+{-# LANGUAGE ViewPatterns        #-}
 module XMPP 
     ( module XMPPTypes
     , listenForXmppClients
@@ -38,8 +39,8 @@ import Text.XML.Stream.Parse
 import Text.XML.Stream.Render
 import Data.XML.Types as XML
 import Network.BSD (getHostName,hostName,hostAliases)
-import Data.Text.Encoding      as S (decodeUtf8)
-import Data.Text.Lazy.Encoding as L (decodeUtf8)
+import Data.Text.Encoding      as S (decodeUtf8,encodeUtf8)
+import Data.Text.Lazy.Encoding as L (decodeUtf8,encodeUtf8)
 import Data.Text.Lazy (toStrict)
 import GetHostByAddr
 import Data.Monoid
@@ -48,6 +49,8 @@ import Data.Foldable (toList)
 #ifdef RENDERFLUSH
 import Data.Conduit.Blaze
 #endif
+import Data.List (find)
+import qualified Text.Show.ByteString as L
 
 data Commands = Send [XML.Event] | QuitThread
  deriving Prelude.Show
@@ -126,24 +129,131 @@ eventIsBeginElement _                       = False
 eventIsEndElement (EventEndElement _) = True
 eventIsEndElement _                   = False
 
+filterMapElement::
+  (Monad m, MonadPlus mp) =>
+  (Event -> mp a) -> Event -> mp a -> MaybeT (ConduitM Event o m) (mp a)
+filterMapElement ret opentag empty = loop (empty `mplus` ret opentag) 1 
+ where
+    loop ts 0 = return ts
+    loop ts cnt = do
+        tag <- mawait
+        let ts' = mplus ts (ret tag)
+        case () of
+         _ | eventIsEndElement tag   -> loop ts' (cnt-1)
+         _ | eventIsBeginElement tag -> loop ts' (cnt+1)
+         _                           -> loop ts' cnt
+
 gatherElement ::
   (Monad m, MonadPlus mp) =>
   Event -> mp Event -> MaybeT (ConduitM Event o m) (mp Event)
-gatherElement opentag empty = gatherElement' (empty `mplus` return opentag) 1 
+gatherElement opentag empty = loop (empty `mplus` return opentag) 1 
  where
-    gatherElement' ts cnt = do
+    loop ts 0 = return ts
+    loop ts cnt = do
         tag <- mawait
-        let ts' = ts `mplus` return tag
-            cnt' = case () of
-                     _ | eventIsEndElement tag -> cnt-1
-                     _ | eventIsBeginElement tag -> cnt+1
-                     _ -> cnt
-        if (cnt'>0) then gatherElement' ts' cnt'
-                   else return ts' 
+        let ts' = mplus ts (return tag)
+        case () of
+         _ | eventIsEndElement tag   -> loop ts' (cnt-1)
+         _ | eventIsBeginElement tag -> loop ts' (cnt+1)
+         _                           -> loop ts' cnt
+
+{-
+sourceStanza :: Monad m => Event -> ConduitM Event Event m ()
+sourceStanza opentag = yield opentag >> loop 1
+ where
+    loop 0 = return ()
+    loop cnt = do
+        e <- await
+        let go tag cnt = yield tag >> loop cnt
+        case e of
+            Just tag | eventIsEndElement tag   -> go tag (cnt-1)
+            Just tag | eventIsBeginElement tag -> go tag (cnt+1)
+            Just tag                           -> go tag cnt
+            Nothing                            -> return ()
+-}
 
 voidMaybeT body = (>> return ()) . runMaybeT $ body
 fixMaybeT f = (>> return ()) . runMaybeT . fix $ f
 
+iq_bind_reply id jid =
+    [ EventBeginElement "{jabber:client}iq" [("type",[ContentText "result"]),("id",[ContentText id])]
+
+    , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
+        [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])]
+    , EventBeginElement "jid" []
+    , EventContent (ContentText jid)
+    , EventEndElement "jid"
+    , EventEndElement  "{urn:ietf:params:xml:ns:xmpp-bind}bind"
+    , EventEndElement "{jabber:client}iq"
+    ]
+
+uncontent cs = head $ map getText cs
+ where
+    getText (ContentText x) = x
+    getText (ContentEntity x ) = x
+
+-- doIQ :: MonadIO m => Event -> MaybeT (ConduitM Event o m) ()
+doIQ session cmdChan tag@(EventBeginElement name attrs) = do
+    (_,uncontent->iq_id) <- MaybeT . return $ find (\(n,v)->isId n) attrs 
+        -- The 'id' attribute is REQUIRED for IQ stanzas. 
+        -- todo: handle it's absence more gracefully
+    case (find (\(n,v)->isType n) attrs) of
+      Just (_,[ContentText "get"]) -> discard
+      Just (_,[ContentText "set"]) -> do
+        fix $ \iqsetloop -> do
+            setwhat <- mawait
+            liftIO (putStrLn $ "IQ-set " ++ show setwhat)
+            case setwhat of
+                bind@(EventBeginElement name attrs) | isBind name -> do
+                  fix $ \again -> do
+                    rscElem <- mawait
+                    liftIO (putStrLn $ "IQ-set-bind " ++ show rscElem)
+                    case rscElem of
+                        bindchild@(EventBeginElement name _) | isResource name -> do
+                            let isContent (EventContent (ContentText v)) = return v
+                                isContent _                              = mzero
+                            xs <- filterMapElement isContent bindchild Nothing
+                            case xs of
+                                Just rsrc -> 
+                                    liftIO $ do
+                                     setResource session (L.fromChunks [S.encodeUtf8 rsrc])
+                                     jid <- getJID session
+                                     atomically $ writeTChan cmdChan (Send $ iq_bind_reply iq_id (toStrict $ L.decodeUtf8 $ L.show jid) )
+                                Nothing -> return () -- TODO: empty resource tag?
+                            void $ gatherElement bind Nothing
+                        bindchild@(EventBeginElement _ _) -> do
+                            liftIO (putStrLn "unknown bind child")
+                            gatherElement bindchild Nothing 
+                            void $ gatherElement bind Nothing
+                        EventEndElement _ -> do
+                            liftIO (putStrLn "empty bind")
+                            -- TODO
+                            -- A server that supports resource binding MUST be able to 
+                            -- generate a resource identifier on behalf of a client. A 
+                            -- resource identifier generated by the server MUST be unique 
+                            -- for that <node@domain>. 
+                        _ -> again
+                  discard
+                req@(EventBeginElement name attrs) -> do
+                    liftIO (putStrLn $ "IQ-set-unknown " ++ show req)
+                    gatherElement req Nothing
+                    discard
+                endtag@(EventEndElement _) -> do
+                    liftIO (putStrLn $ "IQ-set-empty" ++ show endtag)
+                _ -> iqsetloop
+      Just (_,[ContentText "result"]) -> discard
+      Just (_,[ContentText "error"]) -> discard
+      Just _ -> discard -- error: type must be one of {get,set,result,error}
+      Nothing -> discard -- error: The 'type' attribute is REQUIRED for IQ stanzas.
+  where
+      isId n       = n=="id"
+      isType n     = n=="type"
+      isResource n = n=="{urn:ietf:params:xml:ns:xmpp-bind}resource"
+      isBind n     = n=="{urn:ietf:params:xml:ns:xmpp-bind}bind"
+      discard = do
+            xs <- gatherElement tag Seq.empty 
+            prettyPrint "client-in: ignoring iq:" (toList xs)
+
 fromClient :: (MonadIO m, XMPPSession session) => 
     session -> TChan Commands -> Sink XML.Event m ()
 fromClient session cmdChan = voidMaybeT $ do
@@ -163,16 +273,14 @@ fromClient session cmdChan = voidMaybeT $ do
     fix $ \loop -> do
       xml <- mawait
       log $ bshow xml
+      let isIQ n       = n=="{jabber:client}iq"
       case xml of
         _ | eventIsEndElement xml -> return ()
+        tag@(EventBeginElement name attrs) | isIQ name -> doIQ session cmdChan tag >> loop
+
         tag@(EventBeginElement _ _) -> do
              xs <- gatherElement tag Seq.empty
              prettyPrint "client-in: ignoring..." (toList xs)
-             {-
-             liftIO (putStrLn "client-in: ignoring\n{")
-             liftIO (mapM_ print xs)
-             liftIO (putStrLn "}")
-             -}
              loop
         _ -> loop
 
@@ -192,7 +300,7 @@ toClient pchan cmdChan = fix $ \loop -> do
                      (fmap Right $ readTChan cmdChan)
     case event of
       Right QuitThread -> return ()
-      Right (Send xs)  -> yield xs >> loop -- prettyPrint "client-out: " xs >> loop
+      Right (Send xs)  -> yield xs >> prettyPrint "client-out: " xs >> loop
       Left  presence   -> do 
         xs <- liftIO $ xmlifyPresenceForClient presence
         yield xs