xml-conduit parsing for packets inbound from clients

1 files changed, 94 insertions, 7 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index e158eea2..248d1ffb 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE FlexibleContexts    #-}
 module XMPP 
     ( module XMPPTypes
     , listenForXmppClients
@@ -9,19 +10,105 @@ module XMPP
 
 import ServerC
 import XMPPTypes
+import SocketLike
+import ByteStringOperators
 
 import Data.HList
 import Network.Socket (Family)
 import Network.BSD (PortNumber)
 import Control.Concurrent.STM
+import Data.Conduit
+import qualified Data.Conduit.List as CL
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as L
+    ( putStrLn
+    )
+import Control.Concurrent (forkIO,killThread)
+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
 
-listenForXmppClients
-  :: (HList t1, HExtend e l (HCons PortNumber t1), XMPPSession t) =>
-     Family -> XMPPClass t -> e -> l -> IO ServerHandle
+data Commands x = Send [x] | QuitThread
+ deriving Prelude.Show
+
+xmlifyPresenceForClient :: Presence -> IO [x]
+xmlifyPresenceForClient presence = todo
+
+handleClient
+  :: (SocketLike sock, HHead l (XMPPClass session),
+      XMPPSession session) =>
+     HCons sock (HCons t l) -> Source IO ByteString -> Sink ByteString IO () -> IO ()
+handleClient st src snk = do
+    let HCons sock (HCons _ st') = st
+        session_factory = hHead st'
+    pname <- getPeerName sock
+    session <- newSession session_factory sock
+    Prelude.putStrLn $ "PEER NAME: "++Prelude.show pname
+    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
+            atomically $ writeTChan cmdChan QuitThread
+            closeSession session
+            -- killThread sendingThread
+    finally ( src $= parseBytes def $$ incomming )
+            quit
+
+listenForXmppClients ::
+  (HList l, HHead l (XMPPClass session), HExtend e1 l2 l1,
+   HExtend e l1 (HCons PortNumber l), XMPPSession session) =>
+  Family -> e1 -> e -> l2 -> IO ServerHandle
 listenForXmppClients addr_family session_factory port st = do
-    putStrLn "unimplemented: listenForXmppClients"
-    dummyServerHandle
-    -- TODO
+    doServer (addr_family .*. port .*. session_factory .*. st) handleClient
 
 listenForRemotePeers
   :: (HList t1, HExtend e l (HCons PortNumber t1), XMPPSession t) =>