XMPPSession class

1 files changed, 22 insertions, 6 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index ace36f80..87745e96 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE ViewPatterns        #-}
 {-# LANGUAGE TupleSections       #-}
+{-# LANGUAGE TypeFamilies        #-}
 module XMPPServer where -- ( listenForXmppClients ) where
 
 import Data.HList.TypeEqGeneric1()
@@ -12,6 +13,7 @@ import Server
 import Data.ByteString.Lazy.Char8 as L 
     ( hPutStrLn
     , unlines
+    , ByteString
     , pack
     , unpack )
 import qualified Data.ByteString.Lazy.Char8 as L 
@@ -22,7 +24,7 @@ import System.IO
 import Data.HList
 import AdaptServer
 import Text.XML.HaXml.Lex (xmlLex)
-import Text.XML.HaXml.Parse  (xmlParseWith,element,{-doctypedecl,-}processinginstruction,elemOpenTag,elemCloseTag)
+import Text.XML.HaXml.Parse  (XParser,xmlParseWith,element,{-doctypedecl,-}processinginstruction,elemOpenTag,elemCloseTag)
 import Text.XML.HaXml.Types as Hax hiding (Element) -- (ElemTag,QName(..),Namespace(..),Element(..),Content(..),AttValue(..))
 import qualified Text.XML.HaXml.Types as Hax (Element(..))
 import Text.XML.HaXml.Posn (Posn)
@@ -37,6 +39,13 @@ import Network.Socket
 import Data.String
 
 
+class XMPPSession session where
+    data XMPPClass session
+    newSession   :: XMPPClass session -> Socket -> Handle -> IO session
+    setResource  :: session -> ByteString -> IO ()
+    getJID       :: session -> IO ByteString
+    closeSession :: session -> IO ()
+
 
 greet host = L.unlines 
     [ "<?xml version='1.0'?>"
@@ -56,13 +65,19 @@ greet host = L.unlines
     , "</stream:features>"
     ]
 
-startCon sock st  = do
+newtype TaggedXMPPSession s = TaggedXMPPSession s
+
+startCon session_factory sock st  = do
     let h = hOccursFst st :: Handle 
     cred <- getLocalPeerCred sock
     Prelude.putStrLn $ "PEER CRED: "++show cred
     pname <- getPeerName sock
+    session <- newSession session_factory sock h
     Prelude.putStrLn $ "PEER NAME: "++show pname
-    return (ConnectionFinalizer (return ()) .*. st)
+    
+    return ( ConnectionFinalizer (return ()) 
+           .*. TaggedXMPPSession session
+           .*. st)
 
 iq_query_unavailable host id mjid xmlns kind = L.unlines $
     [ "<iq type='error'"
@@ -228,7 +243,8 @@ mapRight f (Left  y,ls) = (Left  y    ,ls)
 
 xmppParse :: [(Posn, TokenT)] -> (Either String XmppObject, [(Posn, TokenT)])
 xmppParse ls = runTryParse $ do
-    let xml tag = mapRight tag . flip xmlParseWith ls
+    let xml :: (t -> b) -> XParser t -> (Either String b, [(Posn, TokenT)])
+        xml tag = mapRight tag . flip xmlParseWith ls
     Try . xml Element               $ element
     Try . xml OpenTag               $ elemOpenTag
     Try . xml CloseTag              $ elemCloseTag streamName
@@ -253,11 +269,11 @@ xmppParseOld ls =
     
 
 
-listenForXmppClients port st = do
+listenForXmppClients session_factory port st = do
     let (start,dopkt) = 
             adaptServer ( xmlLex "stream" . unpack
                         , xmppParse)
-                        (startCon,doCon)
+                        (startCon session_factory,doCon)
     doServer (port .*. st)
              dopkt
              start