git.iko.soy/servant
on master help sign in
quick chat example base on chat example from engine-io
dda0616Brandon Martin
scripts/lib/common.sh+1−1
compare with master
unifiedsplit
@@ -19,7 +19,7 @@ CABAL=${CABAL:-cabal}
19TRAVIS=${TRAVIS:-false}
19TRAVIS=${TRAVIS:-false}
20
20
21declare -a SOURCES
21declare -a SOURCES
22−readarray -t SOURCES < "$SOURCES_TXT"
22+SOURCES=$(awk -F= '{print $1}' "$SOURCES_TXT")
23
23
24join () { local IFS="$1"; shift; echo "$*"; }
24join () { local IFS="$1"; shift; echo "$*"; }
25
25
scripts/test-all.sh+1−1
@@ -27,7 +27,7 @@ prepare_sandbox () {
27 if $TRAVIS ; then
27 if $TRAVIS ; then
28 travis_retry $CABAL install --enable-tests ${SOURCES[@]}
28 travis_retry $CABAL install --enable-tests ${SOURCES[@]}
29 else
29 else
30− $CABAL install --enable-tests ${SOURCES[@]}
30+ $CABAL install --max-backjumps -1 --reorder-goals --enable-tests ${SOURCES[@]}
31 fi
31 fi
32}
32}
33
33
servant-examples/servant-examples.cabal+22
@@ -97,3 +97,25 @@ executable auth-combinator
97 , warp
97 , warp
98 hs-source-dirs: auth-combinator
98 hs-source-dirs: auth-combinator
99 default-language: Haskell2010
99 default-language: Haskell2010
100+
101+executable socket-io-chat
102+ main-is: socket-io-chat.hs
103+ build-depends:
104+ aeson >= 0.8
105+ , base >= 4.7 && < 5
106+ , bytestring
107+ , http-types
108+ , servant == 0.5.*
109+ , servant-server == 0.5.*
110+ , socket-io
111+ , engine-io
112+ , engine-io-wai
113+ , text
114+ , wai
115+ , warp
116+ , transformers
117+ , stm
118+ , mtl
119+ ghc-options: -Wall -O2 -threaded
120+ hs-source-dirs: socket-io-chat
121+ default-language: Haskell2010
servant-examples/socket-io-chat/Chat.hsnew file+109
@@ -0,0 +1,109 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE RankNTypes #-}
6+
7+module Chat (eioServer, ServerState (..)) where
8+
9+import Prelude hiding (mapM_)
10+
11+#if !MIN_VERSION_base(4,8,0)
12+import Control.Applicative ((<$>), pure)
13+#endif
14+import Control.Monad.State.Class (MonadState)
15+import Control.Monad.IO.Class (MonadIO)
16+import Control.Monad.IO.Class (liftIO)
17+import Data.Aeson ((.=))
18+import Data.Foldable (mapM_)
19+
20+import qualified Control.Concurrent.STM as STM
21+import qualified Data.Aeson as Aeson
22+import qualified Data.Text as Text
23+import qualified Network.SocketIO as SocketIO
24+
25+
26+data AddUser = AddUser Text.Text
27+
28+instance Aeson.FromJSON AddUser where
29+ parseJSON = Aeson.withText "AddUser" $ pure . AddUser
30+
31+
32+data NumConnected = NumConnected !Int
33+
34+instance Aeson.ToJSON NumConnected where
35+ toJSON (NumConnected n) = Aeson.object [ "numUsers" .= n]
36+
37+
38+data NewMessage = NewMessage Text.Text
39+
40+instance Aeson.FromJSON NewMessage where
41+ parseJSON = Aeson.withText "NewMessage" $ pure . NewMessage
42+
43+
44+data Said = Said Text.Text Text.Text
45+
46+instance Aeson.ToJSON Said where
47+ toJSON (Said username message) = Aeson.object
48+ [ "username" .= username
49+ , "message" .= message
50+ ]
51+
52+data UserName = UserName Text.Text
53+
54+instance Aeson.ToJSON UserName where
55+ toJSON (UserName un) = Aeson.object [ "username" .= un ]
56+
57+
58+data UserJoined = UserJoined Text.Text Int
59+
60+instance Aeson.ToJSON UserJoined where
61+ toJSON (UserJoined un n) = Aeson.object
62+ [ "username" .= un
63+ , "numUsers" .= n
64+ ]
65+
66+
67+--------------------------------------------------------------------------------
68+data ServerState = ServerState { ssNConnected :: STM.TVar Int }
69+
70+--server :: ServerState -> StateT SocketIO.RoutingTable Snap.Snap ()
71+eioServer :: forall (m :: * -> *). (MonadState SocketIO.RoutingTable m, MonadIO m) => ServerState -> m ()
72+eioServer state = do
73+ userNameMVar <- liftIO STM.newEmptyTMVarIO
74+ let forUserName m = liftIO (STM.atomically (STM.tryReadTMVar userNameMVar)) >>= mapM_ m
75+
76+ SocketIO.on "new message" $ \(NewMessage message) ->
77+ forUserName $ \userName ->
78+ SocketIO.broadcast "new message" (Said userName message)
79+
80+ SocketIO.on "add user" $ \(AddUser userName) -> do
81+ n <- liftIO $ STM.atomically $ do
82+ n <- (+ 1) <$> STM.readTVar (ssNConnected state)
83+ STM.putTMVar userNameMVar userName
84+ STM.writeTVar (ssNConnected state) n
85+ return n
86+
87+ SocketIO.emit "login" (NumConnected n)
88+ SocketIO.broadcast "user joined" (UserJoined userName n)
89+
90+ SocketIO.appendDisconnectHandler $ do
91+ (n, mUserName) <- liftIO $ STM.atomically $ do
92+ n <- (+ (-1)) <$> STM.readTVar (ssNConnected state)
93+ mUserName <- STM.tryReadTMVar userNameMVar
94+ STM.writeTVar (ssNConnected state) n
95+ return (n, mUserName)
96+
97+ case mUserName of
98+ Nothing -> return ()
99+ Just userName ->
100+ SocketIO.broadcast "user left" (UserJoined userName n)
101+
102+ SocketIO.on "typing" $
103+ forUserName $ \userName ->
104+ SocketIO.broadcast "typing" (UserName userName)
105+
106+ SocketIO.on "stop typing" $
107+ forUserName $ \userName ->
108+ SocketIO.broadcast "stop typing" (UserName userName)
109+
servant-examples/socket-io-chat/resources/index.htmlnew file+28
@@ -0,0 +1,28 @@
1+<!doctype html>
2+<html lang="en">
3+<head>
4+ <meta charset="UTF-8">
5+ <title>Socket.IO Chat Example</title>
6+ <link rel="stylesheet" href="style.css">
7+</head>
8+<body>
9+ <ul class="pages">
10+ <li class="chat page">
11+ <div class="chatArea">
12+ <ul class="messages"></ul>
13+ </div>
14+ <input class="inputMessage" placeholder="Type here..."/>
15+ </li>
16+ <li class="login page">
17+ <div class="form">
18+ <h3 class="title">What's your nickname?</h3>
19+ <input class="usernameInput" type="text" maxlength="14" />
20+ </div>
21+ </li>
22+ </ul>
23+
24+ <script src="https://cdn.socket.io/socket.io-1.2.1.js"></script>
25+ <script src="https://code.jquery.com/jquery-1.10.2.min.js"></script>
26+ <script src="/main.js"></script>
27+</body>
28+</html>
servant-examples/socket-io-chat/resources/main.jsnew file+274
@@ -0,0 +1,274 @@
1+$(function() {
2+ var FADE_TIME = 150; // ms
3+ var TYPING_TIMER_LENGTH = 400; // ms
4+ var COLORS = [
5+ '#e21400', '#91580f', '#f8a700', '#f78b00',
6+ '#58dc00', '#287b00', '#a8f07a', '#4ae8c4',
7+ '#3b88eb', '#3824aa', '#a700ff', '#d300e7'
8+ ];
9+
10+ // Initialize varibles
11+ var $window = $(window);
12+ var $usernameInput = $('.usernameInput'); // Input for username
13+ var $messages = $('.messages'); // Messages area
14+ var $inputMessage = $('.inputMessage'); // Input message input box
15+
16+ var $loginPage = $('.login.page'); // The login page
17+ var $chatPage = $('.chat.page'); // The chatroom page
18+
19+ // Prompt for setting a username
20+ var username;
21+ var connected = false;
22+ var typing = false;
23+ var lastTypingTime;
24+ var $currentInput = $usernameInput.focus();
25+
26+ var socket = io();
27+
28+ function addParticipantsMessage (data) {
29+ var message = '';
30+ if (data.numUsers === 1) {
31+ message += "there's 1 participant";
32+ } else {
33+ message += "there're " + data.numUsers + " participants";
34+ }
35+ log(message);
36+ }
37+
38+ // Sets the client's username
39+ function setUsername () {
40+ username = cleanInput($usernameInput.val().trim());
41+
42+ // If the username is valid
43+ if (username) {
44+ $loginPage.fadeOut();
45+ $chatPage.show();
46+ $loginPage.off('click');
47+ $currentInput = $inputMessage.focus();
48+
49+ // Tell the server your username
50+ socket.emit('add user', username);
51+ }
52+ }
53+
54+ // Sends a chat message
55+ function sendMessage () {
56+ var message = $inputMessage.val();
57+ // Prevent markup from being injected into the message
58+ message = cleanInput(message);
59+ // if there is a non-empty message and a socket connection
60+ if (message && connected) {
61+ $inputMessage.val('');
62+ addChatMessage({
63+ username: username,
64+ message: message
65+ });
66+ // tell server to execute 'new message' and send along one parameter
67+ socket.emit('new message', message);
68+ }
69+ }
70+
71+ // Log a message
72+ function log (message, options) {
73+ var $el = $('<li>').addClass('log').text(message);
74+ addMessageElement($el, options);
75+ }
76+
77+ // Adds the visual chat message to the message list
78+ function addChatMessage (data, options) {
79+ // Don't fade the message in if there is an 'X was typing'
80+ var $typingMessages = getTypingMessages(data);
81+ options = options || {};
82+ if ($typingMessages.length !== 0) {
83+ options.fade = false;
84+ $typingMessages.remove();
85+ }
86+
87+ var $usernameDiv = $('<span class="username"/>')
88+ .text(data.username)
89+ .css('color', getUsernameColor(data.username));
90+ var $messageBodyDiv = $('<span class="messageBody">')
91+ .text(data.message);
92+
93+ var typingClass = data.typing ? 'typing' : '';
94+ var $messageDiv = $('<li class="message"/>')
95+ .data('username', data.username)
96+ .addClass(typingClass)
97+ .append($usernameDiv, $messageBodyDiv);
98+
99+ addMessageElement($messageDiv, options);
100+ }
101+
102+ // Adds the visual chat typing message
103+ function addChatTyping (data) {
104+ data.typing = true;
105+ data.message = 'is typing';
106+ addChatMessage(data);
107+ }
108+
109+ // Removes the visual chat typing message
110+ function removeChatTyping (data) {
111+ getTypingMessages(data).fadeOut(function () {
112+ $(this).remove();
113+ });
114+ }
115+
116+ // Adds a message element to the messages and scrolls to the bottom
117+ // el - The element to add as a message
118+ // options.fade - If the element should fade-in (default = true)
119+ // options.prepend - If the element should prepend
120+ // all other messages (default = false)
121+ function addMessageElement (el, options) {
122+ var $el = $(el);
123+
124+ // Setup default options
125+ if (!options) {
126+ options = {};
127+ }
128+ if (typeof options.fade === 'undefined') {
129+ options.fade = true;
130+ }
131+ if (typeof options.prepend === 'undefined') {
132+ options.prepend = false;
133+ }
134+
135+ // Apply options
136+ if (options.fade) {
137+ $el.hide().fadeIn(FADE_TIME);
138+ }
139+ if (options.prepend) {
140+ $messages.prepend($el);
141+ } else {
142+ $messages.append($el);
143+ }
144+ $messages[0].scrollTop = $messages[0].scrollHeight;
145+ }
146+
147+ // Prevents input from having injected markup
148+ function cleanInput (input) {
149+ return $('<div/>').text(input).text();
150+ }
151+
152+ // Updates the typing event
153+ function updateTyping () {
154+ if (connected) {
155+ if (!typing) {
156+ typing = true;
157+ socket.emit('typing');
158+ }
159+ lastTypingTime = (new Date()).getTime();
160+
161+ setTimeout(function () {
162+ var typingTimer = (new Date()).getTime();
163+ var timeDiff = typingTimer - lastTypingTime;
164+ if (timeDiff >= TYPING_TIMER_LENGTH && typing) {
165+ socket.emit('stop typing');
166+ typing = false;
167+ }
168+ }, TYPING_TIMER_LENGTH);
169+ }
170+ }
171+
172+ // Gets the 'X is typing' messages of a user
173+ function getTypingMessages (data) {
174+ return $('.typing.message').filter(function (i) {
175+ return $(this).data('username') === data.username;
176+ });
177+ }
178+
179+ // Gets the color of a username through our hash function
180+ function getUsernameColor (username) {
181+ // Compute hash code
182+ var hash = 7;
183+ for (var i = 0; i < username.length; i++) {
184+ hash = username.charCodeAt(i) + (hash << 5) - hash;
185+ }
186+ // Calculate color
187+ var index = Math.abs(hash % COLORS.length);
188+ return COLORS[index];
189+ }
190+
191+ // Keyboard events
192+
193+ $window.keydown(function (event) {
194+ // Auto-focus the current input when a key is typed
195+ if (!(event.ctrlKey || event.metaKey || event.altKey)) {
196+ $currentInput.focus();
197+ }
198+ // When the client hits ENTER on their keyboard
199+ if (event.which === 13) {
200+ if (username) {
201+ sendMessage();
202+ socket.emit('stop typing');
203+ typing = false;
204+ } else {
205+ setUsername();
206+ }
207+ }
208+ });
209+
210+ $inputMessage.on('input', function() {
211+ updateTyping();
212+ });
213+
214+ // Click events
215+
216+ // Focus input when clicking anywhere on login page
217+ $loginPage.click(function () {
218+ $currentInput.focus();
219+ });
220+
221+ // Focus input when clicking on the message input's border
222+ $inputMessage.click(function () {
223+ $inputMessage.focus();
224+ });
225+
226+ // Socket events
227+ socket.on('connected', function (data) {
228+ console.log('connected:', data);
229+ });
230+
231+ // Socket events
232+ socket.on('changes', function (data) {
233+ console.log('changes:', data);
234+ });
235+
236+ // Whenever the server emits 'login', log the login message
237+ socket.on('login', function (data) {
238+ connected = true;
239+ // Display the welcome message
240+ var message = "Welcome to Socket.IO Chat &mdash; ";
241+ log(message, {
242+ prepend: true
243+ });
244+ addParticipantsMessage(data);
245+ });
246+
247+ // Whenever the server emits 'new message', update the chat body
248+ socket.on('new message', function (data) {
249+ addChatMessage(data);
250+ });
251+
252+ // Whenever the server emits 'user joined', log it in the chat body
253+ socket.on('user joined', function (data) {
254+ log(data.username + ' joined');
255+ addParticipantsMessage(data);
256+ });
257+
258+ // Whenever the server emits 'user left', log it in the chat body
259+ socket.on('user left', function (data) {
260+ log(data.username + ' left');
261+ addParticipantsMessage(data);
262+ removeChatTyping(data);
263+ });
264+
265+ // Whenever the server emits 'typing', show the typing message
266+ socket.on('typing', function (data) {
267+ addChatTyping(data);
268+ });
269+
270+ // Whenever the server emits 'stop typing', kill the typing message
271+ socket.on('stop typing', function (data) {
272+ removeChatTyping(data);
273+ });
274+});
servant-examples/socket-io-chat/resources/style.cssnew file+150
@@ -0,0 +1,150 @@
1+/* Fix user-agent */
2+
3+* {
4+ box-sizing: border-box;
5+}
6+
7+html {
8+ font-weight: 300;
9+ -webkit-font-smoothing: antialiased;
10+}
11+
12+html, input {
13+ font-family:
14+ "HelveticaNeue-Light",
15+ "Helvetica Neue Light",
16+ "Helvetica Neue",
17+ Helvetica,
18+ Arial,
19+ "Lucida Grande",
20+ sans-serif;
21+}
22+
23+html, body {
24+ height: 100%;
25+ margin: 0;
26+ padding: 0;
27+}
28+
29+ul {
30+ list-style: none;
31+ word-wrap: break-word;
32+}
33+
34+/* Pages */
35+
36+.pages {
37+ height: 100%;
38+ margin: 0;
39+ padding: 0;
40+ width: 100%;
41+}
42+
43+.page {
44+ height: 100%;
45+ position: absolute;
46+ width: 100%;
47+}
48+
49+/* Login Page */
50+
51+.login.page {
52+ background-color: #000;
53+}
54+
55+.login.page .form {
56+ height: 100px;
57+ margin-top: -100px;
58+ position: absolute;
59+
60+ text-align: center;
61+ top: 50%;
62+ width: 100%;
63+}
64+
65+.login.page .form .usernameInput {
66+ background-color: transparent;
67+ border: none;
68+ border-bottom: 2px solid #fff;
69+ outline: none;
70+ padding-bottom: 15px;
71+ text-align: center;
72+ width: 400px;
73+}
74+
75+.login.page .title {
76+ font-size: 200%;
77+}
78+
79+.login.page .usernameInput {
80+ font-size: 200%;
81+ letter-spacing: 3px;
82+}
83+
84+.login.page .title, .login.page .usernameInput {
85+ color: #fff;
86+ font-weight: 100;
87+}
88+
89+/* Chat page */
90+
91+.chat.page {
92+ display: none;
93+}
94+
95+/* Font */
96+
97+.messages {
98+ font-size: 150%;
99+}
100+
101+.inputMessage {
102+ font-size: 100%;
103+}
104+
105+.log {
106+ color: gray;
107+ font-size: 70%;
108+ margin: 5px;
109+ text-align: center;
110+}
111+
112+/* Messages */
113+
114+.chatArea {
115+ height: 100%;
116+ padding-bottom: 60px;
117+}
118+
119+.messages {
120+ height: 100%;
121+ margin: 0;
122+ overflow-y: scroll;
123+ padding: 10px 20px 10px 20px;
124+}
125+
126+.message.typing .messageBody {
127+ color: gray;
128+}
129+
130+.username {
131+ float: left;
132+ font-weight: 700;
133+ overflow: hidden;
134+ padding-right: 15px;
135+ text-align: right;
136+}
137+
138+/* Input */
139+
140+.inputMessage {
141+ border: 10px solid #000;
142+ bottom: 0;
143+ height: 60px;
144+ left: 0;
145+ outline: none;
146+ padding-left: 10px;
147+ position: absolute;
148+ right: 0;
149+ width: 100%;
150+}
servant-examples/socket-io-chat/socket-io-chat.hsnew file+54
@@ -0,0 +1,54 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE TypeOperators #-}
5+
6+
7+import Data.Monoid ((<>))
8+#if !MIN_VERSION_base(4,8,0)
9+import Control.Applicative((<$>))
10+#endif
11+import Network.Wai
12+import Servant
13+import Network.EngineIO.Wai
14+import Network.Wai.Handler.Warp (run)
15+
16+
17+import qualified Control.Concurrent.STM as STM
18+import qualified Network.SocketIO as SocketIO
19+
20+
21+import Chat (eioServer, ServerState (..))
22+
23+
24+type API = "socket.io" :> Raw
25+ :<|> Raw
26+
27+
28+api :: Proxy API
29+api = Proxy
30+
31+
32+server :: WaiMonad () -> Server API
33+server sHandler = socketIOHandler
34+ :<|> serveDirectory "socket-io-chat/resources"
35+
36+ where
37+ socketIOHandler req respond = toWaiApplication sHandler req respond
38+
39+
40+app :: WaiMonad () -> Application
41+app sHandler = serve api $ server sHandler
42+
43+port :: Int
44+port = 3001
45+
46+
47+main :: IO ()
48+main = do
49+ state <- ServerState <$> STM.newTVarIO 0
50+ sHandler <- SocketIO.initialize waiAPI (eioServer state)
51+ putStrLn $ "Running on " <> show port
52+ run port $ app sHandler
53+
54+