simple chat example program.

1 files changed, 64 insertions, 0 deletions

diff --git a/simplechat.hs b/simplechat.hs
new file mode 100644
index 00000000..a763a982
--- /dev/null
+++ b/simplechat.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+import Data.HList.TypeEqGeneric1()
+import Data.HList.TypeCastGeneric1()
+import ByteStringOperators
+
+import Server
+import Data.ByteString.Lazy.Char8 as L 
+    ( ByteString
+    , hPutStrLn
+    , init )
+import System.IO 
+    ( Handle
+    )
+import Control.Concurrent (forkIO)
+import Control.Concurrent.Chan
+import Data.HList
+
+
+startCon st  = do
+    let chan = hOccursFst st
+        nr = hOccursFst st :: ConnId
+        hdl = hOccursFst st :: Handle
+        quit = writeChan chan (nr,Nothing)
+        broadcast msg = writeChan chan (nr,Just msg)
+    chan' <- dupChan chan
+    reader <- forkIO $ fix $ \loop -> do
+        (nr', line) <- readChan chan'
+        case ( line, nr==nr') of
+          ( Nothing   , True  ) -> Prelude.putStrLn "quit-client."
+          ( Just msg  , False ) -> hPutStrLn hdl msg >> loop
+          _                     -> loop
+
+    hPutStrLn hdl "Hi, what's your name?"
+    line <- getPacket hdl
+    let name = L.init line
+    Prelude.putStrLn $ "readFst: " ++ show line
+    hPutStrLn hdl ("Welcome, " <++> name <++> "!")
+    broadcast ("--> " <++> name <++> " entered.")
+
+    return (name .*. ConnectionFinalizer quit .*. st)
+
+doCon st bs cont = do
+        let hdl = hOccursFst st :: Handle 
+            nr = hOccursFst st :: ConnId
+            chan = hOccursFst st
+            broadcast msg = writeChan chan (nr,Just msg)
+            name = hHead st
+        Prelude.putStrLn $ "read: " ++ show bs
+        case bs of
+         "quit\n" -> hPutStrLn hdl "Bye!"
+         _      -> do
+            broadcast (name <++> ": " <++> L.init bs)
+            cont ()
+
+
+main = do
+    (chan :: Chan (ConnId, Maybe ByteString)) <- newChan
+    doServer (5222 .*. chan .*. HNil)
+             doCon
+             startCon
+
+