1 files changed, 89 insertions, 15 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index d0333f4a..8508c3b4 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -20,7 +20,7 @@ import Control.Concurrent.STM
 import Data.Conduit
 import qualified Data.Conduit.List as CL
 import Data.ByteString (ByteString)
-import Data.ByteString.Char8 (pack)
+import qualified Data.ByteString.Char8 as S (pack,putStr,putStrLn)
 import qualified Data.ByteString.Lazy.Char8 as L
     ( putStrLn
     , fromChunks
@@ -36,19 +36,23 @@ 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.Lazy.Encoding (decodeUtf8)
+import Data.Text.Encoding      as S (decodeUtf8)
+import Data.Text.Lazy.Encoding as L (decodeUtf8)
 import Data.Text.Lazy (toStrict)
 import GetHostByAddr
+import Data.Monoid
+import qualified Data.Sequence as Seq
+import Data.Foldable (toList)
 
 data Commands = Send [XML.Event] | QuitThread
  deriving Prelude.Show
 
 getNamesForPeer :: Peer -> IO [ByteString]
-getNamesForPeer LocalHost = fmap ((:[]) . pack) getHostName
+getNamesForPeer LocalHost = fmap ((:[]) . S.pack) getHostName
 getNamesForPeer peer@(RemotePeer addr) = do
     ent <- getHostByAddr addr --  AF_UNSPEC addr
     let names = hostName ent : hostAliases ent
-    return . map pack $ names
+    return . map S.pack $ names
 
 
 xmlifyPresenceForClient :: Presence -> IO [XML.Event]
@@ -56,7 +60,7 @@ xmlifyPresenceForClient (Presence jid stat) = do
     let n   = name jid
         rsc = resource jid
     names <- getNamesForPeer (peer jid)
-    let tostr p = decodeUtf8 $ n <$++> "@" <?++> L.fromChunks [p] <++?>  "/" <++$> rsc
+    let tostr p = L.decodeUtf8 $ n <$++> "@" <?++> L.fromChunks [p] <++?>  "/" <++$> rsc
         jidstrs = fmap (toStrict . tostr) names
     return (concatMap presenceEvents jidstrs)
  where
@@ -73,6 +77,34 @@ xmlifyPresenceForClient (Presence jid stat) = do
     shw Away      = "away"
     shw Offline   = "away" -- Is this right?
 
+prefix ## name = Name name Nothing (Just prefix)
+
+streamP name = Name name (Just "http://etherx.jabber.org/streams") (Just "stream")
+    
+greet host =
+    [ EventBeginDocument
+    , EventBeginElement (streamP "stream")
+        [("from",[ContentText host])
+        ,("id",[ContentText "someid"])
+        ,("xmlns",[ContentText "jabber:client"])
+        ,("xmlns:stream",[ContentText "http://etherx.jabber.org/streams"])
+        ,("version",[ContentText "1.0"])
+        ]
+    , EventBeginElement (streamP "features") []
+    , EventBeginElement "bind" [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])]
+    , EventEndElement   "bind"
+
+    {-
+    -- , "  <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>"
+    , " <mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>"
+    -- , " <mechanism>DIGEST-MD5</mechanism>"
+    , " <mechanism>PLAIN</mechanism>"
+    , " </mechanisms> "
+    -}
+
+    , EventEndElement (streamP "features")
+    ]
+
 
 -- type Consumer i m r = forall o. ConduitM i o m r
 mawait :: Monad m => MaybeT (ConduitM i o m) i
@@ -83,19 +115,62 @@ elementAttrs expected (EventBeginElement name attrs)
     = return attrs
 elementAttrs _ _ = mzero
      
+eventIsBeginElement (EventBeginElement _ _) = True
+eventIsBeginElement _                       = False
+
+eventIsEndElement (EventEndElement _) = True
+eventIsEndElement _                   = False
 
-fromClient :: MonadIO m => TChan Commands -> Sink XML.Event m ()
-fromClient cmdChan = (>>return ()) . runMaybeT $ do
+gatherElement ::
+  (Monad m, MonadPlus mp) =>
+  Event -> mp Event -> MaybeT (ConduitM Event o m) (mp Event)
+gatherElement opentag empty = gatherElement' (empty `mplus` return opentag) 1 
+ where
+    gatherElement' 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' 
+
+fromClient :: (MonadIO m, XMPPSession session) => 
+    session -> TChan Commands -> Sink XML.Event m ()
+fromClient session cmdChan = (>>return ()) . runMaybeT $ do
+    let log  = liftIO . L.putStrLn . ("client-in: " <++>)
+        send = liftIO . atomically . writeTChan cmdChan . Send
     mawait >>= guard . (==EventBeginDocument)
-    liftIO . L.putStrLn $ "client-in: begin-doc "
+    log "begin-doc"
     xml <- mawait
     stream_attrs <- elementAttrs "stream" xml
-    liftIO . L.putStrLn $ "client-in: stream " <++> bshow stream_attrs
+    log $ "stream " <++> bshow stream_attrs
+    host <- liftIO $ do
+        jid <- getJID session
+        names <- getNamesForPeer (peer jid)
+        return (S.decodeUtf8 . head $ names)
+    send $ greet host
+    
     fix $ \loop -> do
       xml <- mawait
-      liftIO (L.putStrLn $ "client-in: " <++> bshow xml)
-      loop
+      log $ bshow xml
+      case xml of
+        _ | eventIsEndElement xml -> return ()
+        tag@(EventBeginElement _ _) -> do
+             xs <- gatherElement tag Seq.empty
+             prettyPrint "client-in: ignoring..." (toList xs)
+             loop
+        _ -> loop
+
+    log $ "end of stream"
+    xml <- mawait
+    log $ "end-of-document: " <++> bshow xml
 
+prettyPrint prefix xs = 
+    liftIO $ do
+        S.putStrLn prefix
+        CL.sourceList xs $= renderBytes (def { rsPretty=True }) $$ CL.mapM_ S.putStr
 
 toClient :: MonadIO m => TChan Presence -> TChan Commands -> Source m XML.Event
 toClient pchan cmdChan = fix $ \loop -> do
@@ -103,13 +178,12 @@ toClient pchan cmdChan = fix $ \loop -> do
               orElse (fmap Left $ readTChan pchan)
                      (fmap Right $ readTChan cmdChan)
     case event of
-      Right QuitThread -> 
-        return ()
+      Right QuitThread -> return ()
+      Right (Send xs)  -> mapM_ yield xs >> prettyPrint "client-out: " xs >> loop
       Left  presence   -> do 
         xs <- liftIO $ xmlifyPresenceForClient presence
         Monad.mapM_ yield xs
         loop
-    
 
 handleClient
   :: (SocketLike sock, HHead l (XMPPClass session),
@@ -125,7 +199,7 @@ handleClient st src snk = do
     cmdChan <- atomically newTChan
 
     writer <- async ( toClient pchan cmdChan $$ renderBytes def =$ snk )
-    finally         ( src $= parseBytes def $$ fromClient cmdChan )
+    finally         ( src $= parseBytes def $$ fromClient session cmdChan )
         $ do
             atomically $ writeTChan cmdChan QuitThread
             wait writer