/
chat.hs
88 lines (79 loc) · 2.51 KB
/
chat.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
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