4 files changed, 99 insertions, 11 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) =>
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 813c7c7b..f607989d 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -160,7 +160,7 @@ startCon session_factory sock st  = do
     -- cred <- getLocalPeerCred sock
     -- Prelude.putStrLn $ "PEER CRED: "++Prelude.show cred
     pname <- getPeerName sock
-    session <- newSession session_factory sock h
+    session <- newSession session_factory sock
     Prelude.putStrLn $ "PEER NAME: "++Prelude.show pname
     pchan <- subscribe session Nothing
     cmdChan <- atomically newTChan
@@ -418,7 +418,7 @@ startPeer session_factory sock st = do
     name <- fmap bshow $ getPeerName sock
     L.putStrLn $ "IN peer: connected " <++> name
     jids <- newTVarIO Set.empty
-    session <- newSession session_factory sock h
+    session <- newSession session_factory sock
     let quit = do
             L.putStrLn $ "IN peer: disconnected " <++> name
             js <- fmap Set.toList (readTVarIO jids)
diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs
index eb5d349e..e3bbfd16 100644
--- a/Presence/XMPPTypes.hs
+++ b/Presence/XMPPTypes.hs
@@ -11,10 +11,11 @@ import Data.Binary.Builder as B
 import Data.Binary.Put
 import Control.DeepSeq
 import ByteStringOperators
+import SocketLike
 
 class XMPPSession session where
     data XMPPClass session
-    newSession   :: XMPPClass session -> Socket -> Handle -> IO session
+    newSession   :: SocketLike sock => XMPPClass session -> sock -> IO session
     setResource  :: session -> ByteString -> IO ()
     getJID       :: session -> IO JID
     closeSession :: session -> IO ()
diff --git a/Presence/main.hs b/Presence/main.hs
index 403a6ac7..9a09b855 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -63,7 +63,7 @@ data UnixSession = UnixSession {
 
 instance XMPPSession UnixSession where
     data XMPPClass UnixSession = UnixSessions PresenceState
-    newSession (UnixSessions state) sock handle = do
+    newSession (UnixSessions state) sock = do
         muid <- getLocalPeerCred sock
         L.putStrLn $ "SESSION: open " <++> bshow muid
         uid_ref <- newIORef muid