implemented xmlifyPresenceForClient in XMPP module

1 files changed, 69 insertions, 53 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 248d1ffb..7e513212 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -20,22 +20,83 @@ 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.Lazy.Char8 as L
     ( putStrLn
+    , fromChunks
     )
 import Control.Concurrent (forkIO,killThread)
+import Control.Concurrent.Async
 import Control.Exception (handle,SomeException(..),finally)
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Maybe
 import Todo
 import Control.Monad as Monad
 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.Lazy (toStrict)
+import GetHostByAddr
 
-data Commands x = Send [x] | QuitThread
+data Commands = Send [XML.Event] | QuitThread
  deriving Prelude.Show
 
-xmlifyPresenceForClient :: Presence -> IO [x]
-xmlifyPresenceForClient presence = todo
+getNamesForPeer :: Peer -> IO [ByteString]
+getNamesForPeer LocalHost = fmap ((:[]) . pack) getHostName
+getNamesForPeer peer@(RemotePeer addr) = do
+    ent <- getHostByAddr addr --  AF_UNSPEC addr
+    let names = hostName ent : hostAliases ent
+    return . map pack $ names
+
+
+xmlifyPresenceForClient :: Presence -> IO [XML.Event]
+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
+        jidstrs = fmap (toStrict . tostr) names
+    return (concatMap presenceEvents jidstrs)
+ where
+    presenceEvents jidstr =
+      [ EventBeginElement "presence" (("from",[ContentText jidstr]):typ stat)
+      , EventBeginElement "show" []
+      , EventContent (ContentText . shw $ stat)
+      , EventEndElement "show"
+      , EventEndElement "presence"
+      ]
+    typ Offline = [("type",[ContentText "unavailable"])]
+    typ _       = []
+    shw Available = "chat"
+    shw Away      = "away"
+    shw Offline   = "away" -- Is this right?
+
+
+
+fromClient :: MonadIO m => TChan Commands -> Sink XML.Event m ()
+fromClient cmdChan = fix $ \loop -> do
+    mb <- await
+    maybe (return ())
+          (\packet -> do
+                liftIO (L.putStrLn $ "client-in: " <++> bshow packet)
+                loop)
+          mb
+
+toClient :: MonadIO m => TChan Presence -> TChan Commands -> Source m XML.Event
+toClient pchan cmdChan = fix $ \loop -> do
+    event <- liftIO . atomically $ 
+              orElse (fmap Left $ readTChan pchan)
+                     (fmap Right $ readTChan cmdChan)
+    case event of
+      Right QuitThread -> 
+        return ()
+      Left  presence   -> do 
+        xs <- liftIO $ xmlifyPresenceForClient presence
+        Monad.mapM_ yield xs
+        loop
+    
 
 handleClient
   :: (SocketLike sock, HHead l (XMPPClass session),
@@ -50,58 +111,12 @@ handleClient st src snk = do
     pchan <- subscribe session Nothing
     cmdChan <- atomically newTChan
 
-
-    {-
-    reader <- forkIO $ do
-        flip ($$) snk $
-            handle (\(SomeException e) -> liftIO (L.putStrLn $ "quit reader via exception: "<++>bshow e) >> return ()) $
-             fix $ \loop -> do
-                event <- liftIO . atomically $ 
-                    (fmap Left $ readTChan pchan)
-                  `orElse`
-                    (fmap Right $ readTChan cmdChan)
-                case event of
-                    Left presence -> do
-                        liftIO (L.putStrLn $ "PRESENCE: " <++> bshow presence)
-                        -- TODO: it violates spec to send presence information before
-                        --  a resource is bound.
-                        -- r <- xmlifyPresenceForClient presence
-                        -- yield r
-                        -- -- hPutStrLn h r
-                        -- liftIO (L.putStrLn $ "\nOUT client:\n" <++> r)
-                    Right (Send r) ->
-                        mapM_ yield r
-                        -- yield r
-                        -- -- hPutStrLn h r
-                loop
-    -}
-    let outgoing = do
-            event <- liftIO . atomically $ 
-                (fmap Left $ readTChan pchan)
-              `orElse`
-                (fmap Right $ readTChan cmdChan)
-            case event of
-              Right QuitThread -> return ()
-              Left presence -> do 
-                xs <- liftIO $ xmlifyPresenceForClient presence
-                Monad.mapM_ yield xs
-                outgoing
-
-        incomming = do
-            mb <- await
-            maybe (return ())
-                  (\packet -> do
-                        liftIO (L.putStrLn $ "client-in: " <++> bshow packet)
-                        incomming)
-                  mb
-            
-    sendingThread <- forkIO (outgoing $$ snk)
-    let quit = do
+    writer <- async ( toClient pchan cmdChan $$ renderBytes def =$ snk )
+    finally         ( src $= parseBytes def $$ fromClient cmdChan )
+        $ do
             atomically $ writeTChan cmdChan QuitThread
+            wait writer
             closeSession session
-            -- killThread sendingThread
-    finally ( src $= parseBytes def $$ incomming )
-            quit
 
 listenForXmppClients ::
   (HList l, HHead l (XMPPClass session), HExtend e1 l2 l1,
@@ -122,4 +137,5 @@ seekRemotePeers :: XMPPConfig config =>
      config -> TChan Presence -> IO ()
 seekRemotePeers config chan = do
     putStrLn "unimplemented: seekRemotePeers"
+    -- TODO
     return ()