From 4322ba246f8276e82fb0538c40e0c41d584fa6b2 Mon Sep 17 00:00:00 2001 From: joe Date: Wed, 19 Jun 2013 01:55:04 -0400 Subject: xml presence notifications now sent to client. --- Presence/XMPPServer.hs | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) (limited to 'Presence/XMPPServer.hs') 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 + [ " typ stat <++> ">" + , "" <++> shw stat <++> "" + , "" + ] + 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 -- cgit v1.2.3