1 files changed, 29 insertions, 5 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 4a859bc9..192e9d47 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -42,6 +42,8 @@ import Control.Monad.Trans.Maybe
 import Control.Monad.IO.Class
 import Control.DeepSeq
 import Control.Concurrent.STM
+import Control.Concurrent
+import Control.Exception
 
 -- | Jabber ID (JID) datatype
 data JID = JID { name :: Maybe ByteString
@@ -64,6 +66,7 @@ data JabberShow = Offline
  deriving (Show,Enum,Ord,Eq,Read)
 
 data Presence = Presence JID JabberShow
+ deriving Show
 
 instance NFData Presence where
     rnf (Presence jid stat) = rnf jid `seq` stat `seq` ()
@@ -75,7 +78,7 @@ class XMPPSession session where
     setResource  :: session -> ByteString -> IO ()
     getJID       :: session -> IO ByteString
     closeSession :: session -> IO ()
-    subscribeToPresence :: session -> Maybe JID -> IO (TChan Presence)
+    subscribe :: session -> Maybe JID -> IO (TChan Presence)
 
 
 greet host = L.unlines 
@@ -98,6 +101,9 @@ greet host = L.unlines
 
 -- data TaggedXMPPSession s = TaggedXMPPSession s
 
+data Commands = Send ByteString
+ deriving Show
+
 startCon session_factory sock st  = do
     let h = hOccursFst st :: Handle 
     cred <- getLocalPeerCred sock
@@ -105,8 +111,25 @@ startCon session_factory sock st  = do
     pname <- getPeerName sock
     session <- newSession session_factory sock h
     Prelude.putStrLn $ "PEER NAME: "++show pname
-    
-    return ( session .*. ConnectionFinalizer (closeSession session) .*. st)
+    pchan <- subscribe session Nothing
+    cmdChan <- atomically newTChan
+    reader <- forkIO $
+        handle (\(SomeException _) -> L.putStrLn "quit reader.") $
+         fix $ \loop -> do
+            event <- atomically $ 
+                (fmap Left $ readTChan pchan)
+              `orElse`
+                (fmap Right $ readTChan cmdChan)
+            case event of
+                Left presence ->
+                    L.putStrLn $ "PRESENCE: " <++> bshow presence
+                Right (Send r) ->
+                    hPutStrLn h r
+            loop
+    let quit = do
+            killThread reader
+            closeSession session
+    return ( (session,cmdChan) .*. ConnectionFinalizer quit .*. st)
 
 iq_query_unavailable host id mjid xmlns kind = L.unlines $
     [ "<iq type='error'"
@@ -217,10 +240,11 @@ presence_response host (Elem _ attrs content) = do
 doCon st elem cont = do
         let h = hOccursFst st :: Handle 
             host = "localhost"
+            (session,cmdChan) = hHead st
             hsend r = do
-                hPutStrLn h r
+                atomically $ writeTChan cmdChan (Send r)
+                -- hPutStrLn h r
                 L.putStrLn $ "\nOUT:\n" <++> r
-            session = hHead st
 
         putStrLn $ (show $ hang (text "\nIN:") 2 $ pp elem) ++ "\n"