new Server code, xmppServer demo

1 files changed, 60 insertions, 0 deletions

diff --git a/xmppServer.hs b/xmppServer.hs
new file mode 100644
index 00000000..50818dd6
--- /dev/null
+++ b/xmppServer.hs
@@ -0,0 +1,60 @@
+import Control.Monad.Trans.Resource (runResourceT)
+import Control.Monad.Trans (lift)
+import Control.Monad.Fix (fix)
+import Control.Concurrent (forkIO)
+import Control.Concurrent.STM
+-- import Control.Concurrent.STM.TChan
+import Network.Socket
+import XMPPTypes (withPort)
+import Text.Printf
+
+import Server
+
+wlog s = putStrLn s
+
+control sv = atomically . putTMVar (serverCommand sv)
+
+monitor sv params = do
+    chan <- return $ serverEvent sv
+    fix $ \loop -> do
+    (k,e) <- atomically $ readTChan chan
+    case e of
+        Connection -> wlog $ tomsg k "Connection"
+        EOF        -> wlog $ tomsg k "EOF"
+        HalfConnection In -> do
+            wlog $ tomsg k "ReadOnly"
+            control sv (Connect (callBackAddress k) params)
+        HalfConnection Out -> wlog $ tomsg k "WriteOnly"
+        RequiresPing -> wlog $ tomsg k "RequiresPing"
+        _ -> return ()
+    loop
+ where
+    tomsg k str =  printf "%12s %s" str (show k)
+
+data ConnectionKey
+       = PeerKey { callBackAddress :: SockAddr }
+       | ClientKey { localAddress :: SockAddr }
+ deriving (Show, Ord, Eq)
+
+peerKey (sock,addr) = do
+    peer <- getPeerName sock
+    return $ PeerKey (peer `withPort` fromIntegral peerport)
+
+clientKey (sock,addr) = return $ ClientKey addr
+
+peerport = 5269
+clientport = 5222
+
+main = runResourceT $ do
+    sv <- server
+    lift $ do
+    peer_params <- return (connectionDefaults peerKey)
+                          { duplex = False }
+    client_params <- return $ connectionDefaults clientKey
+    forkIO $ monitor sv peer_params
+    control sv (Listen peerport peer_params)
+    control sv (Listen clientport client_params)
+
+    atomically $ newEmptyTMVar >>= readTMVar -- Wait for control-c
+
+    return ()