xml presence notifications now sent to client.

1 files changed, 19 insertions, 2 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 192e9d47..660853b6 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -68,6 +68,18 @@ data JabberShow = Offline
 data Presence = Presence JID JabberShow
  deriving Show
 
+xmlifyPresence (Presence jid stat) = L.unlines 
+  [ "<presence from='" <++> bshow jid <++> "' " <++> typ stat <++> ">"
+  , "<show>" <++> shw stat <++> "</show>"
+  , "</presence>"
+  ]
+ where
+    typ Offline = " type='unavailable'"
+    typ _       = ""
+    shw Available = "chat"
+    shw Away      = "away"
+    shw Offline   = "away" -- Is this right?
+
 instance NFData Presence where
     rnf (Presence jid stat) = rnf jid `seq` stat `seq` ()
 
@@ -114,15 +126,20 @@ startCon session_factory sock st  = do
     pchan <- subscribe session Nothing
     cmdChan <- atomically newTChan
     reader <- forkIO $
-        handle (\(SomeException _) -> L.putStrLn "quit reader.") $
+        handle (\(SomeException _) -> L.putStrLn "quit reader via exception.") $
          fix $ \loop -> do
             event <- atomically $ 
                 (fmap Left $ readTChan pchan)
               `orElse`
                 (fmap Right $ readTChan cmdChan)
             case event of
-                Left presence ->
+                Left presence -> do
                     L.putStrLn $ "PRESENCE: " <++> bshow presence
+                    -- TODO: it violates spec to send presence information before
+                    --  a resource is bound.
+                    let r = xmlifyPresence presence
+                    hPutStrLn h r
+                    L.putStrLn $ "\nOUT:\n" <++> r
                 Right (Send r) ->
                     hPutStrLn h r
             loop