2 files changed, 35 insertions, 9 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"
 
diff --git a/Presence/main.hs b/Presence/main.hs
index 78ca4363..44af40e3 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -82,18 +82,19 @@ instance XMPPSession UnixSession where
         L.putStrLn $ "SESSION: jid " <++> jid
         return jid
     closeSession _             = L.putStrLn "SESSION: close"
-    subscribeToPresence session Nothing = do
+    subscribe session Nothing = do
         let tmvar = greedySubscriber (presence_state session)
         chan <- atomically $
             (do (cnt,chan) <- takeTMVar tmvar
                 putTMVar tmvar (cnt+1,chan)
-                return chan )
+                chan' <- dupTChan chan
+                return chan' )
           `orElse`
             (do chan <- newTChan
                 putTMVar tmvar (1,chan)
                 return chan )
         return chan
-    subscribeToPresence session (Just jid) = do
+    subscribe session (Just jid) = do
         let tvar = subscriberMap (presence_state session)
         atomically $ do
             subs <- readTVar tvar
@@ -104,7 +105,8 @@ instance XMPPSession UnixSession where
                       newchan <- newTChan
                       return (newchan, Map.insert jid (1,newchan) subs)
                     Just (cnt,chan) -> do
-                      return (chan, Map.insert jid (cnt+1,chan) subs)
+                      chan' <- dupTChan chan
+                      return (chan', Map.insert jid (cnt+1,chan) subs)
             writeTVar tvar subs'
             return chan