From dda06169892a72b67f824ac8b24f7dd003b070ce Mon Sep 17 00:00:00 2001 From: Brandon Martin Date: Wed, 22 Jul 2015 15:50:03 -0600 Subject: [PATCH] quick chat example base on chat example from engine-io --- scripts/lib/common.sh | 2 +- scripts/test-all.sh | 2 +- servant-examples/servant-examples.cabal | 22 ++ servant-examples/socket-io-chat/Chat.hs | 109 +++++++ .../socket-io-chat/resources/index.html | 28 ++ .../socket-io-chat/resources/main.js | 274 ++++++++++++++++++ .../socket-io-chat/resources/style.css | 150 ++++++++++ .../socket-io-chat/socket-io-chat.hs | 54 ++++ 8 files changed, 639 insertions(+), 2 deletions(-) create mode 100644 servant-examples/socket-io-chat/Chat.hs create mode 100644 servant-examples/socket-io-chat/resources/index.html create mode 100644 servant-examples/socket-io-chat/resources/main.js create mode 100644 servant-examples/socket-io-chat/resources/style.css create mode 100644 servant-examples/socket-io-chat/socket-io-chat.hs diff --git a/scripts/lib/common.sh b/scripts/lib/common.sh index 6cdb8fbe..339fe863 100644 --- a/scripts/lib/common.sh +++ b/scripts/lib/common.sh @@ -19,7 +19,7 @@ CABAL=${CABAL:-cabal} TRAVIS=${TRAVIS:-false} declare -a SOURCES -readarray -t SOURCES < "$SOURCES_TXT" +SOURCES=$(awk -F= '{print $1}' "$SOURCES_TXT") join () { local IFS="$1"; shift; echo "$*"; } diff --git a/scripts/test-all.sh b/scripts/test-all.sh index 8f531b9d..04fd012b 100755 --- a/scripts/test-all.sh +++ b/scripts/test-all.sh @@ -27,7 +27,7 @@ prepare_sandbox () { if $TRAVIS ; then travis_retry $CABAL install --enable-tests ${SOURCES[@]} else - $CABAL install --enable-tests ${SOURCES[@]} + $CABAL install --max-backjumps -1 --reorder-goals --enable-tests ${SOURCES[@]} fi } diff --git a/servant-examples/servant-examples.cabal b/servant-examples/servant-examples.cabal index 12c797bd..a29ed7a2 100644 --- a/servant-examples/servant-examples.cabal +++ b/servant-examples/servant-examples.cabal @@ -97,3 +97,25 @@ executable auth-combinator , warp hs-source-dirs: auth-combinator default-language: Haskell2010 + +executable socket-io-chat + main-is: socket-io-chat.hs + build-depends: + aeson >= 0.8 + , base >= 4.7 && < 5 + , bytestring + , http-types + , servant == 0.5.* + , servant-server == 0.5.* + , socket-io + , engine-io + , engine-io-wai + , text + , wai + , warp + , transformers + , stm + , mtl + ghc-options: -Wall -O2 -threaded + hs-source-dirs: socket-io-chat + default-language: Haskell2010 diff --git a/servant-examples/socket-io-chat/Chat.hs b/servant-examples/socket-io-chat/Chat.hs new file mode 100644 index 00000000..9f2faa92 --- /dev/null +++ b/servant-examples/socket-io-chat/Chat.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} + +module Chat (eioServer, ServerState (..)) where + +import Prelude hiding (mapM_) + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), pure) +#endif +import Control.Monad.State.Class (MonadState) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson ((.=)) +import Data.Foldable (mapM_) + +import qualified Control.Concurrent.STM as STM +import qualified Data.Aeson as Aeson +import qualified Data.Text as Text +import qualified Network.SocketIO as SocketIO + + +data AddUser = AddUser Text.Text + +instance Aeson.FromJSON AddUser where + parseJSON = Aeson.withText "AddUser" $ pure . AddUser + + +data NumConnected = NumConnected !Int + +instance Aeson.ToJSON NumConnected where + toJSON (NumConnected n) = Aeson.object [ "numUsers" .= n] + + +data NewMessage = NewMessage Text.Text + +instance Aeson.FromJSON NewMessage where + parseJSON = Aeson.withText "NewMessage" $ pure . NewMessage + + +data Said = Said Text.Text Text.Text + +instance Aeson.ToJSON Said where + toJSON (Said username message) = Aeson.object + [ "username" .= username + , "message" .= message + ] + +data UserName = UserName Text.Text + +instance Aeson.ToJSON UserName where + toJSON (UserName un) = Aeson.object [ "username" .= un ] + + +data UserJoined = UserJoined Text.Text Int + +instance Aeson.ToJSON UserJoined where + toJSON (UserJoined un n) = Aeson.object + [ "username" .= un + , "numUsers" .= n + ] + + +-------------------------------------------------------------------------------- +data ServerState = ServerState { ssNConnected :: STM.TVar Int } + +--server :: ServerState -> StateT SocketIO.RoutingTable Snap.Snap () +eioServer :: forall (m :: * -> *). (MonadState SocketIO.RoutingTable m, MonadIO m) => ServerState -> m () +eioServer state = do + userNameMVar <- liftIO STM.newEmptyTMVarIO + let forUserName m = liftIO (STM.atomically (STM.tryReadTMVar userNameMVar)) >>= mapM_ m + + SocketIO.on "new message" $ \(NewMessage message) -> + forUserName $ \userName -> + SocketIO.broadcast "new message" (Said userName message) + + SocketIO.on "add user" $ \(AddUser userName) -> do + n <- liftIO $ STM.atomically $ do + n <- (+ 1) <$> STM.readTVar (ssNConnected state) + STM.putTMVar userNameMVar userName + STM.writeTVar (ssNConnected state) n + return n + + SocketIO.emit "login" (NumConnected n) + SocketIO.broadcast "user joined" (UserJoined userName n) + + SocketIO.appendDisconnectHandler $ do + (n, mUserName) <- liftIO $ STM.atomically $ do + n <- (+ (-1)) <$> STM.readTVar (ssNConnected state) + mUserName <- STM.tryReadTMVar userNameMVar + STM.writeTVar (ssNConnected state) n + return (n, mUserName) + + case mUserName of + Nothing -> return () + Just userName -> + SocketIO.broadcast "user left" (UserJoined userName n) + + SocketIO.on "typing" $ + forUserName $ \userName -> + SocketIO.broadcast "typing" (UserName userName) + + SocketIO.on "stop typing" $ + forUserName $ \userName -> + SocketIO.broadcast "stop typing" (UserName userName) + diff --git a/servant-examples/socket-io-chat/resources/index.html b/servant-examples/socket-io-chat/resources/index.html new file mode 100644 index 00000000..92b055ff --- /dev/null +++ b/servant-examples/socket-io-chat/resources/index.html @@ -0,0 +1,28 @@ + + + + + Socket.IO Chat Example + + + + + + + + + + diff --git a/servant-examples/socket-io-chat/resources/main.js b/servant-examples/socket-io-chat/resources/main.js new file mode 100644 index 00000000..08be0ad4 --- /dev/null +++ b/servant-examples/socket-io-chat/resources/main.js @@ -0,0 +1,274 @@ +$(function() { + var FADE_TIME = 150; // ms + var TYPING_TIMER_LENGTH = 400; // ms + var COLORS = [ + '#e21400', '#91580f', '#f8a700', '#f78b00', + '#58dc00', '#287b00', '#a8f07a', '#4ae8c4', + '#3b88eb', '#3824aa', '#a700ff', '#d300e7' + ]; + + // Initialize varibles + var $window = $(window); + var $usernameInput = $('.usernameInput'); // Input for username + var $messages = $('.messages'); // Messages area + var $inputMessage = $('.inputMessage'); // Input message input box + + var $loginPage = $('.login.page'); // The login page + var $chatPage = $('.chat.page'); // The chatroom page + + // Prompt for setting a username + var username; + var connected = false; + var typing = false; + var lastTypingTime; + var $currentInput = $usernameInput.focus(); + + var socket = io(); + + function addParticipantsMessage (data) { + var message = ''; + if (data.numUsers === 1) { + message += "there's 1 participant"; + } else { + message += "there're " + data.numUsers + " participants"; + } + log(message); + } + + // Sets the client's username + function setUsername () { + username = cleanInput($usernameInput.val().trim()); + + // If the username is valid + if (username) { + $loginPage.fadeOut(); + $chatPage.show(); + $loginPage.off('click'); + $currentInput = $inputMessage.focus(); + + // Tell the server your username + socket.emit('add user', username); + } + } + + // Sends a chat message + function sendMessage () { + var message = $inputMessage.val(); + // Prevent markup from being injected into the message + message = cleanInput(message); + // if there is a non-empty message and a socket connection + if (message && connected) { + $inputMessage.val(''); + addChatMessage({ + username: username, + message: message + }); + // tell server to execute 'new message' and send along one parameter + socket.emit('new message', message); + } + } + + // Log a message + function log (message, options) { + var $el = $('
  • ').addClass('log').text(message); + addMessageElement($el, options); + } + + // Adds the visual chat message to the message list + function addChatMessage (data, options) { + // Don't fade the message in if there is an 'X was typing' + var $typingMessages = getTypingMessages(data); + options = options || {}; + if ($typingMessages.length !== 0) { + options.fade = false; + $typingMessages.remove(); + } + + var $usernameDiv = $('') + .text(data.username) + .css('color', getUsernameColor(data.username)); + var $messageBodyDiv = $('') + .text(data.message); + + var typingClass = data.typing ? 'typing' : ''; + var $messageDiv = $('
  • ') + .data('username', data.username) + .addClass(typingClass) + .append($usernameDiv, $messageBodyDiv); + + addMessageElement($messageDiv, options); + } + + // Adds the visual chat typing message + function addChatTyping (data) { + data.typing = true; + data.message = 'is typing'; + addChatMessage(data); + } + + // Removes the visual chat typing message + function removeChatTyping (data) { + getTypingMessages(data).fadeOut(function () { + $(this).remove(); + }); + } + + // Adds a message element to the messages and scrolls to the bottom + // el - The element to add as a message + // options.fade - If the element should fade-in (default = true) + // options.prepend - If the element should prepend + // all other messages (default = false) + function addMessageElement (el, options) { + var $el = $(el); + + // Setup default options + if (!options) { + options = {}; + } + if (typeof options.fade === 'undefined') { + options.fade = true; + } + if (typeof options.prepend === 'undefined') { + options.prepend = false; + } + + // Apply options + if (options.fade) { + $el.hide().fadeIn(FADE_TIME); + } + if (options.prepend) { + $messages.prepend($el); + } else { + $messages.append($el); + } + $messages[0].scrollTop = $messages[0].scrollHeight; + } + + // Prevents input from having injected markup + function cleanInput (input) { + return $('
    ').text(input).text(); + } + + // Updates the typing event + function updateTyping () { + if (connected) { + if (!typing) { + typing = true; + socket.emit('typing'); + } + lastTypingTime = (new Date()).getTime(); + + setTimeout(function () { + var typingTimer = (new Date()).getTime(); + var timeDiff = typingTimer - lastTypingTime; + if (timeDiff >= TYPING_TIMER_LENGTH && typing) { + socket.emit('stop typing'); + typing = false; + } + }, TYPING_TIMER_LENGTH); + } + } + + // Gets the 'X is typing' messages of a user + function getTypingMessages (data) { + return $('.typing.message').filter(function (i) { + return $(this).data('username') === data.username; + }); + } + + // Gets the color of a username through our hash function + function getUsernameColor (username) { + // Compute hash code + var hash = 7; + for (var i = 0; i < username.length; i++) { + hash = username.charCodeAt(i) + (hash << 5) - hash; + } + // Calculate color + var index = Math.abs(hash % COLORS.length); + return COLORS[index]; + } + + // Keyboard events + + $window.keydown(function (event) { + // Auto-focus the current input when a key is typed + if (!(event.ctrlKey || event.metaKey || event.altKey)) { + $currentInput.focus(); + } + // When the client hits ENTER on their keyboard + if (event.which === 13) { + if (username) { + sendMessage(); + socket.emit('stop typing'); + typing = false; + } else { + setUsername(); + } + } + }); + + $inputMessage.on('input', function() { + updateTyping(); + }); + + // Click events + + // Focus input when clicking anywhere on login page + $loginPage.click(function () { + $currentInput.focus(); + }); + + // Focus input when clicking on the message input's border + $inputMessage.click(function () { + $inputMessage.focus(); + }); + + // Socket events + socket.on('connected', function (data) { + console.log('connected:', data); + }); + + // Socket events + socket.on('changes', function (data) { + console.log('changes:', data); + }); + + // Whenever the server emits 'login', log the login message + socket.on('login', function (data) { + connected = true; + // Display the welcome message + var message = "Welcome to Socket.IO Chat — "; + log(message, { + prepend: true + }); + addParticipantsMessage(data); + }); + + // Whenever the server emits 'new message', update the chat body + socket.on('new message', function (data) { + addChatMessage(data); + }); + + // Whenever the server emits 'user joined', log it in the chat body + socket.on('user joined', function (data) { + log(data.username + ' joined'); + addParticipantsMessage(data); + }); + + // Whenever the server emits 'user left', log it in the chat body + socket.on('user left', function (data) { + log(data.username + ' left'); + addParticipantsMessage(data); + removeChatTyping(data); + }); + + // Whenever the server emits 'typing', show the typing message + socket.on('typing', function (data) { + addChatTyping(data); + }); + + // Whenever the server emits 'stop typing', kill the typing message + socket.on('stop typing', function (data) { + removeChatTyping(data); + }); +}); diff --git a/servant-examples/socket-io-chat/resources/style.css b/servant-examples/socket-io-chat/resources/style.css new file mode 100644 index 00000000..62cbe093 --- /dev/null +++ b/servant-examples/socket-io-chat/resources/style.css @@ -0,0 +1,150 @@ +/* Fix user-agent */ + +* { + box-sizing: border-box; +} + +html { + font-weight: 300; + -webkit-font-smoothing: antialiased; +} + +html, input { + font-family: + "HelveticaNeue-Light", + "Helvetica Neue Light", + "Helvetica Neue", + Helvetica, + Arial, + "Lucida Grande", + sans-serif; +} + +html, body { + height: 100%; + margin: 0; + padding: 0; +} + +ul { + list-style: none; + word-wrap: break-word; +} + +/* Pages */ + +.pages { + height: 100%; + margin: 0; + padding: 0; + width: 100%; +} + +.page { + height: 100%; + position: absolute; + width: 100%; +} + +/* Login Page */ + +.login.page { + background-color: #000; +} + +.login.page .form { + height: 100px; + margin-top: -100px; + position: absolute; + + text-align: center; + top: 50%; + width: 100%; +} + +.login.page .form .usernameInput { + background-color: transparent; + border: none; + border-bottom: 2px solid #fff; + outline: none; + padding-bottom: 15px; + text-align: center; + width: 400px; +} + +.login.page .title { + font-size: 200%; +} + +.login.page .usernameInput { + font-size: 200%; + letter-spacing: 3px; +} + +.login.page .title, .login.page .usernameInput { + color: #fff; + font-weight: 100; +} + +/* Chat page */ + +.chat.page { + display: none; +} + +/* Font */ + +.messages { + font-size: 150%; +} + +.inputMessage { + font-size: 100%; +} + +.log { + color: gray; + font-size: 70%; + margin: 5px; + text-align: center; +} + +/* Messages */ + +.chatArea { + height: 100%; + padding-bottom: 60px; +} + +.messages { + height: 100%; + margin: 0; + overflow-y: scroll; + padding: 10px 20px 10px 20px; +} + +.message.typing .messageBody { + color: gray; +} + +.username { + float: left; + font-weight: 700; + overflow: hidden; + padding-right: 15px; + text-align: right; +} + +/* Input */ + +.inputMessage { + border: 10px solid #000; + bottom: 0; + height: 60px; + left: 0; + outline: none; + padding-left: 10px; + position: absolute; + right: 0; + width: 100%; +} diff --git a/servant-examples/socket-io-chat/socket-io-chat.hs b/servant-examples/socket-io-chat/socket-io-chat.hs new file mode 100644 index 00000000..63b33749 --- /dev/null +++ b/servant-examples/socket-io-chat/socket-io-chat.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + + +import Data.Monoid ((<>)) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative((<$>)) +#endif +import Network.Wai +import Servant +import Network.EngineIO.Wai +import Network.Wai.Handler.Warp (run) + + +import qualified Control.Concurrent.STM as STM +import qualified Network.SocketIO as SocketIO + + +import Chat (eioServer, ServerState (..)) + + +type API = "socket.io" :> Raw + :<|> Raw + + +api :: Proxy API +api = Proxy + + +server :: WaiMonad () -> Server API +server sHandler = socketIOHandler + :<|> serveDirectory "socket-io-chat/resources" + + where + socketIOHandler req respond = toWaiApplication sHandler req respond + + +app :: WaiMonad () -> Application +app sHandler = serve api $ server sHandler + +port :: Int +port = 3001 + + +main :: IO () +main = do + state <- ServerState <$> STM.newTVarIO 0 + sHandler <- SocketIO.initialize waiAPI (eioServer state) + putStrLn $ "Running on " <> show port + run port $ app sHandler + +