2 files changed, 50 insertions, 8 deletions

diff --git a/Presence/AdaptServer.hs b/Presence/AdaptServer.hs
index 2ef07038..3b57266c 100644
--- a/Presence/AdaptServer.hs
+++ b/Presence/AdaptServer.hs
@@ -3,7 +3,7 @@
 module AdaptServer where
 
 import Data.IORef
--- import Debug.Trace
+import Debug.Trace
 import Data.HList
 -- import Network.Socket (Socket)
 import qualified Data.ByteString.Lazy.Char8 as L
@@ -14,7 +14,7 @@ adaptStartCon start sock st = do
     st' <- start sock st
     return (HCons rsRef st')
 
-adaptDoCon (dropTill,lex,parse) g st bs cont = do
+adaptDoCon showlex (dropTill,lex,parse) g st bs cont = do
     putStrLn $ "packet: " ++ show bs
     let (HCons rsRef st') = st
     rs <- readIORef rsRef
@@ -27,15 +27,15 @@ adaptDoCon (dropTill,lex,parse) g st bs cont = do
           case e of
               Left err -> if null rs'
                             then contR "" ()
-                            else -- trace ("parse error "++show (err,bs,lexemes,rs')) $ do
+                            else trace ("parse error "++show (err,bs,showlex lexemes,showlex rs')) $ do
                                     contR rem ()
               Right e -> do
                 -- writeIORef rsRef rs'
-                g st' e (\() -> loop (dropTill rem rs') rs')
+                g st' e (\() -> do { putStrLn ("LOOP "++showlex rs'); loop (dropTill rem rs') rs' })
         loop rem [] = contR "" ()
     let buf = rs <++> bs
     when (L.length buf < 8192)
          (loop buf (lex buf))
 
 
-adaptServer (dropTill,lex,parse) (startCon,doCon) = (adaptStartCon startCon, adaptDoCon (dropTill,lex,parse) doCon)
+adaptServer showlex (dropTill,lex,parse) (startCon,doCon) = (adaptStartCon startCon, adaptDoCon showlex (dropTill,lex,parse) doCon)
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index aa3140e5..c9decd6c 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -6,6 +6,7 @@
 -- {-# LANGUAGE GADTs               #-}
 module XMPPServer where -- ( listenForXmppClients ) where
 
+import Data.Char (isSpace)
 import Todo
 import Data.HList.TypeEqGeneric1()
 import Data.HList.TypeCastGeneric1()
@@ -412,20 +413,61 @@ runTryParse (Try p) = p
 mapRight f (Right x,ls) = (Right (f x),ls)
 mapRight f (Left  y,ls) = (Left  y    ,ls)
 
+dropLeadingSpace toks = dropWhile space toks
+ where
+    space (_,TokFreeText cs) = all isSpace cs
+    space _                  = False
+
 xmppParse :: [(Posn, TokenT)] -> (Either String XmppObject, [(Posn, TokenT)])
 xmppParse ls = runTryParse $ do
     let xml :: (t -> b) -> XParser t -> (Either String b, [(Posn, TokenT)])
-        xml tag = mapRight tag . flip xmlParseWith ls
+        xml tag = mapRight tag . flip xmlParseWith (dropLeadingSpace ls)
     Try . xml Element               $ element
     Try . xml OpenTag               $ elemOpenTag
     Try . xml CloseTag              $ elemCloseTag streamName
     Try . xml ProcessingInstruction $ processinginstruction
+
+
+showTokenT TokCommentOpen       =     "<!--"
+showTokenT TokCommentClose      =     "-->"
+showTokenT TokPIOpen        =     "<?"
+showTokenT TokPIClose       =     "?>"
+showTokenT TokSectionOpen       =     "<!["
+showTokenT TokSectionClose      =     "]]>"
+showTokenT TokSpecialOpen       =     "<!"
+showTokenT TokEndOpen       =     "</"
+showTokenT TokEndClose      =     "/>"
+showTokenT TokAnyOpen       =     "<"
+showTokenT TokAnyClose      =     ">"
+showTokenT TokSqOpen        =     "["
+showTokenT TokSqClose       =     "]"
+showTokenT TokEqual         =     "="
+showTokenT TokQuery         =     "?"
+showTokenT TokStar          =     "*"
+showTokenT TokPlus          =     "+"
+showTokenT TokAmp           =     "&"
+showTokenT TokSemi          =     ";"
+showTokenT TokHash          =     "#"
+showTokenT TokBraOpen       =     "("
+showTokenT TokBraClose      =     ")"
+showTokenT TokPipe          =     "|"
+showTokenT TokPercent       =     "%"
+showTokenT TokComma         =     ","
+showTokenT TokQuote         =     "' or \""
+showTokenT TokNull          =     "(null)"
+showTokenT (TokError     s)     = "TokError "++ Prelude.show s
+showTokenT (TokSection s)       = "TokSection "++Prelude.show s
+showTokenT (TokSpecial s)       = "TokSpecial "++Prelude.show s
+showTokenT (TokName      s)     = "TokName "++Prelude.show s
+showTokenT (TokFreeText  s)     = "TokFreeText "++s
+
+showtoks ts = Prelude.show $ map (showTokenT . snd) ts
     
 
 listenForXmppClients session_factory port st = do
     -- standard port: 5222
     let (start,dopkt) = 
-            adaptServer ( dropTill
+            adaptServer showtoks ( dropTill
                         , xmlLexPartial "local-client" . unpack
                         , xmppParse)
                         (startCon session_factory,doCon)
@@ -481,7 +523,7 @@ xmlLexPartial name cs =
 listenForRemotePeers session_factory port st = do
     -- standard port: 5269
     let (start,dopkt) = 
-            adaptServer ( dropTill
+            adaptServer showtoks ( dropTill
                         , xmlLexPartial "remote-inbound" . unpack
                         , xmppParse)
                         (startPeer session_factory,doPeer)