Started conduits-based XMPP module (will replace XMPPServer)

5 files changed, 133 insertions, 67 deletions

diff --git a/Presence/ServerC.hs b/Presence/ServerC.hs
index 3933c812..36e2d7bf 100644
--- a/Presence/ServerC.hs
+++ b/Presence/ServerC.hs
@@ -7,6 +7,7 @@ module ServerC
     , ConnId(..)
     , ServerHandle
     , quitListening
+    , dummyServerHandle
     ) where
 
 import Network.Socket as Socket
@@ -39,6 +40,7 @@ import Control.Monad.Trans.Class (lift)
 import Control.Monad.IO.Class (MonadIO (liftIO))
 import qualified Data.ByteString as S (ByteString)
 import System.IO (Handle)
+import Control.Concurrent.MVar (newMVar)
 
 import ByteStringOperators
 import SocketLike
@@ -50,6 +52,11 @@ newtype ConnId = ConnId Int
 
 newtype ServerHandle = ServerHandle Socket
 
+dummyServerHandle = do
+    mvar <- newMVar Closed
+    let sock = MkSocket 0 AF_UNSPEC NoSocketType 0 mvar
+    return (ServerHandle sock)
+
 quitListening :: ServerHandle -> IO ()
 quitListening (ServerHandle socket) = sClose socket
 
diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
new file mode 100644
index 00000000..f361641e
--- /dev/null
+++ b/Presence/XMPP.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE FlexibleContexts #-}
+module XMPP 
+    ( module XMPP
+    , module XMPPTypes
+    , quitListening
+    )  where
+
+import ServerC
+import XMPPTypes
+
+import Data.HList
+import Network.Socket (Family)
+import Network.BSD (PortNumber)
+import Control.Concurrent.STM
+
+listenForXmppClients
+  :: (HList t1, HExtend e l (HCons PortNumber t1), XMPPSession t) =>
+     Family -> XMPPClass t -> e -> l -> IO ServerHandle
+listenForXmppClients addr_family session_factory port st = do
+    putStrLn "unimplemented: listenForXmppClients"
+    dummyServerHandle
+    -- TODO
+
+listenForRemotePeers
+  :: (HList t1, HExtend e l (HCons PortNumber t1), XMPPSession t) =>
+     Family -> XMPPClass t -> e -> l -> IO ServerHandle
+listenForRemotePeers addrfamily session_factory port st = do
+    putStrLn "unimplemented: listenForRemotePeers"
+    dummyServerHandle
+    -- TODO
+
+seekRemotePeers :: XMPPConfig config =>
+     config -> TChan Presence -> IO ()
+seekRemotePeers config chan = do
+    putStrLn "unimplemented: seekRemotePeers"
+    return ()
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index e8ab5490..813c7c7b 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -6,6 +6,7 @@
 -- {-# LANGUAGE GADTs               #-}
 module XMPPServer 
     ( module XMPPServer
+    , module XMPPTypes
     , quitListening 
     )  where
 
@@ -58,39 +59,13 @@ import Control.Concurrent.STM
 import Control.Concurrent
 import Control.Exception as Exception
 import Text.Show.ByteString as L
-import Data.Binary.Builder as B
-import Data.Binary.Put
 import qualified Data.Map as Map
 import GHC.Conc
 import Network.BSD hiding (getHostByAddr)
 import Control.Concurrent.Async
 import qualified Data.Set as Set
 import GetHostByAddr
-
-data Peer = LocalHost | RemotePeer SockAddr
-  deriving (Eq,Prelude.Show)
-
-instance Ord Peer where
-    LocalHost <= _  
-      = True
-    RemotePeer (SockAddrUnix a) <= RemotePeer (SockAddrUnix b)
-      = a <= b
-    RemotePeer (SockAddrUnix _) <= _
-      = True
-    RemotePeer (SockAddrInet aport a) <= RemotePeer (SockAddrInet bport b)
-      = (a,aport) <= (b,bport)
-    RemotePeer (SockAddrInet aport a) <= _
-      = True
-    RemotePeer (SockAddrInet6 aport aflow a ascope) <= RemotePeer (SockAddrInet6 bport bflow b bscope)
-      = (a,aport,ascope,aflow) <= (b,bport,bscope,bflow)
-    a <= b = False
-
--- | Jabber ID (JID) datatype
-data JID = JID { name :: Maybe ByteString
-               , peer :: Peer
-               , resource :: Maybe ByteString
-               }
- deriving (Eq,Ord)
+import XMPPTypes
 
 is_remote (RemotePeer _) = True
 is_remote _              = False
@@ -110,37 +85,10 @@ getNamesForPeer peer@(RemotePeer addr) = do
     return . map pack $ names
 
 
-showPeer :: Peer -> ByteString
-showPeer LocalHost = "localhost"
-showPeer (RemotePeer addr@(SockAddrInet _ _)) = pack $ stripColon (Prelude.show addr)
- where stripColon s = pre where (pre,port) = break (==':') s
-showPeer (RemotePeer addr@(SockAddrInet6 _ _ _ _)) = pack $ stripColon (Prelude.show addr)
- where stripColon s = if null bracket then pre else pre ++ "]"
-          where
-            (pre,bracket) = break (==']') s
-
 peerAddr :: Peer -> SockAddr
 peerAddr (RemotePeer addr) = addr
 -- peerAddr LocalHost = throw exception
 
-instance L.Show JID where
-    showp (JID n s r ) = putBuilder . B.fromLazyByteString $ n <$++> "@" <?++> showPeer s <++?>  "/" <++$> r
-
-instance Prelude.Show JID where
-    show jid = L.unpack $ L.show jid
-
-instance NFData JID where
-    rnf v@(JID n s r) = n `seq` s `seq` r `seq` ()
-
-jid user host rsrc = JID (Just user) host (Just rsrc)
-
-data JabberShow = Offline
-                | Away
-                | Available
- deriving (Prelude.Show,Enum,Ord,Eq,Read)
-
-data Presence = Presence JID JabberShow
- deriving Prelude.Show
 
 xmlifyPresenceForPeer sock (Presence jid stat) = do
     -- TODO: accept socket argument and determine local ip address
@@ -184,19 +132,6 @@ instance NFData Presence where
     rnf (Presence jid stat) = rnf jid `seq` stat `seq` ()
 
 
-class XMPPSession session where
-    data XMPPClass session
-    newSession   :: XMPPClass session -> Socket -> Handle -> IO session
-    setResource  :: session -> ByteString -> IO ()
-    getJID       :: session -> IO JID
-    closeSession :: session -> IO ()
-    subscribe :: session -> Maybe JID -> IO (TChan Presence)
-    announcePresence :: session -> Presence -> IO ()
-
-class XMPPConfig config where
-    getBuddies :: config -> ByteString -> IO [ByteString]
-    getSubscribers :: config -> ByteString -> IO [ByteString]
-
 greet host = L.unlines 
     [ "<?xml version='1.0'?>"
     , "<stream:stream"
diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs
new file mode 100644
index 00000000..eb5d349e
--- /dev/null
+++ b/Presence/XMPPTypes.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE TypeFamilies        #-}
+module XMPPTypes where
+
+import Network.Socket (Socket,SockAddr(..))
+import System.IO (Handle)
+import Control.Concurrent.STM (TChan)
+import Data.ByteString.Lazy.Char8 as L  (ByteString,unpack,pack)
+import Text.Show.ByteString as L
+import Data.Binary.Builder as B
+import Data.Binary.Put
+import Control.DeepSeq
+import ByteStringOperators
+
+class XMPPSession session where
+    data XMPPClass session
+    newSession   :: XMPPClass session -> Socket -> Handle -> IO session
+    setResource  :: session -> ByteString -> IO ()
+    getJID       :: session -> IO JID
+    closeSession :: session -> IO ()
+    subscribe :: session -> Maybe JID -> IO (TChan Presence)
+    announcePresence :: session -> Presence -> IO ()
+
+class XMPPConfig config where
+    getBuddies :: config -> ByteString -> IO [ByteString]
+    getSubscribers :: config -> ByteString -> IO [ByteString]
+
+-- | Jabber ID (JID) datatype
+data JID = JID { name :: Maybe ByteString
+               , peer :: Peer
+               , resource :: Maybe ByteString
+               }
+ deriving (Eq,Ord)
+
+data JabberShow = Offline
+                | Away
+                | Available
+ deriving (Prelude.Show,Enum,Ord,Eq,Read)
+
+data Presence = Presence JID JabberShow
+ deriving Prelude.Show
+
+data Peer = LocalHost | RemotePeer SockAddr
+  deriving (Eq,Prelude.Show)
+
+
+
+instance Ord Peer where
+    LocalHost <= _  
+      = True
+    RemotePeer (SockAddrUnix a) <= RemotePeer (SockAddrUnix b)
+      = a <= b
+    RemotePeer (SockAddrUnix _) <= _
+      = True
+    RemotePeer (SockAddrInet aport a) <= RemotePeer (SockAddrInet bport b)
+      = (a,aport) <= (b,bport)
+    RemotePeer (SockAddrInet aport a) <= _
+      = True
+    RemotePeer (SockAddrInet6 aport aflow a ascope) <= RemotePeer (SockAddrInet6 bport bflow b bscope)
+      = (a,aport,ascope,aflow) <= (b,bport,bscope,bflow)
+    a <= b = False
+
+instance L.Show JID where
+    showp (JID n s r ) = putBuilder . B.fromLazyByteString $ n <$++> "@" <?++> showPeer s <++?>  "/" <++$> r
+
+instance Prelude.Show JID where
+    show jid = L.unpack $ L.show jid
+
+instance NFData JID where
+    rnf v@(JID n s r) = n `seq` s `seq` r `seq` ()
+
+jid user host rsrc = JID (Just user) host (Just rsrc)
+
+
+showPeer :: Peer -> ByteString
+showPeer LocalHost = "localhost"
+showPeer (RemotePeer addr@(SockAddrInet _ _)) = pack $ stripColon (Prelude.show addr)
+ where stripColon s = pre where (pre,port) = break (==':') s
+showPeer (RemotePeer addr@(SockAddrInet6 _ _ _ _)) = pack $ stripColon (Prelude.show addr)
+ where stripColon s = if null bracket then pre else pre ++ "]"
+          where
+            (pre,bracket) = break (==']') s
+
+
diff --git a/Presence/main.hs b/Presence/main.hs
index a0a80569..403a6ac7 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -25,7 +25,11 @@ import UTmp
 -- 
 #endif
 import FGConsole
+#ifdef HAXML
 import XMPPServer
+#else
+import XMPP
+#endif
 import Data.HList
 import Control.Exception
 import LocalPeerCred