Merge pull request #162 from codedmart/socketIOExample

add a chat example based on chat example from engine-io, to demonstrate how to integrate engine-io/websockets in a servant app

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 "$*"; }
 

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
 }
 

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

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)
+

servant-examples/socket-io-chat/resources/index.html

@@ -0,0 +1,28 @@
+<!doctype html>
+<html lang="en">
+<head>
+  <meta charset="UTF-8">
+  <title>Socket.IO Chat Example</title>
+  <link rel="stylesheet" href="style.css">
+</head>
+<body>
+  <ul class="pages">
+    <li class="chat page">
+      <div class="chatArea">
+        <ul class="messages"></ul>
+      </div>
+      <input class="inputMessage" placeholder="Type here..."/>
+    </li>
+    <li class="login page">
+      <div class="form">
+        <h3 class="title">What's your nickname?</h3>
+        <input class="usernameInput" type="text" maxlength="14" />
+      </div>
+    </li>
+  </ul>
+
+  <script src="https://cdn.socket.io/socket.io-1.2.1.js"></script>
+  <script src="https://code.jquery.com/jquery-1.10.2.min.js"></script>
+  <script src="/main.js"></script>
+</body>
+</html>

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 = $('<li>').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 = $('<span class="username"/>')
+      .text(data.username)
+      .css('color', getUsernameColor(data.username));
+    var $messageBodyDiv = $('<span class="messageBody">')
+      .text(data.message);
+
+    var typingClass = data.typing ? 'typing' : '';
+    var $messageDiv = $('<li class="message"/>')
+      .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 $('<div/>').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 &mdash; ";
+    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);
+  });
+});

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%;
+}

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
+
+