From 9eeefca36aa66f3af8beab5599a98f41dda58fb4 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Fri, 7 Mar 2014 09:16:14 +0200
Subject: [PATCH] Added chat example

---
 yesod-websockets/chat.hs | 88 ++++++++++++++++++++++++++++++++++++++++
 1 file changed, 88 insertions(+)
 create mode 100644 yesod-websockets/chat.hs

diff --git a/yesod-websockets/chat.hs b/yesod-websockets/chat.hs
new file mode 100644
index 00000000..73f4df10
--- /dev/null
+++ b/yesod-websockets/chat.hs
@@ -0,0 +1,88 @@
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-}
+import Yesod.Core
+import Yesod.WebSockets
+import qualified Data.Text.Lazy as TL
+import Control.Monad (forever)
+import Control.Monad.Trans.Reader
+import Control.Concurrent (threadDelay)
+import Data.Time
+import Conduit
+import Data.Monoid ((<>))
+import Control.Concurrent.STM.Lifted
+import Data.Text (Text)
+
+data App = App (TChan Text)
+
+instance Yesod App
+
+mkYesod "App" [parseRoutes|
+/ HomeR GET
+|]
+
+chatApp :: WebSocketsT Handler ()
+chatApp = do
+    sendTextData ("Welcome to the chat server, please enter your name." :: Text)
+    name <- receiveData
+    sendTextData $ "Welcome, " <> name
+    App writeChan <- getYesod
+    readChan <- atomically $ do
+        writeTChan writeChan $ name <> " has joined the chat"
+        dupTChan writeChan
+    race_
+        (forever $ atomically (readTChan readChan) >>= sendTextData)
+        (sourceWS $$ mapM_C (\msg ->
+            atomically $ writeTChan writeChan $ name <> ": " <> msg))
+
+getHomeR :: Handler Html
+getHomeR = do
+    webSockets chatApp
+    defaultLayout $ do
+        [whamlet|
+            <div #output>
+            <form #form>
+                <input #input autofocus>
+        |]
+        toWidget [lucius|
+            \#output {
+                width: 600px;
+                height: 400px;
+                border: 1px solid black;
+                margin-bottom: 1em;
+                p {
+                    margin: 0 0 0.5em 0;
+                    padding: 0 0 0.5em 0;
+                    border-bottom: 1px dashed #99aa99;
+                }
+            }
+            \#input {
+                width: 600px;
+                display: block;
+            }
+        |]
+        toWidget [julius|
+            var url = document.URL,
+                output = document.getElementById("output"),
+                form = document.getElementById("form"),
+                input = document.getElementById("input"),
+                conn;
+
+            url = url.replace("http:", "ws:").replace("https:", "wss:");
+            conn = new WebSocket(url);
+
+            conn.onmessage = function(e) {
+                var p = document.createElement("p");
+                p.appendChild(document.createTextNode(e.data));
+                output.appendChild(p);
+            };
+
+            form.addEventListener("submit", function(e){
+                conn.send(input.value);
+                input.value = "";
+                e.preventDefault();
+            });
+        |]
+
+main :: IO ()
+main = do
+    chan <- atomically newBroadcastTChan
+    warp 3000 $ App chan