Ajax Chat App using Yesod

I’ve finally recovered from fourth year enough that I feel like coding a serious personal project again. That project is a turn-based tabletop game I’m adapting to code, I’ll go into more detail about it later. For the interface, I want to do an Ajax-powered web app, and I’m using Michael Snoyman’s excellent Haskell web framework, Yesod, to make that happen.

There’s Ajax support built into Yesod, but nothing for push updates sent to clients. In order to prove that Yesod (and I) were up to the job, I wrote a basic many-user chat room app. It uses the fairly standard hack for Ajax push: clients send a dummy request and the server just leaves the connection open, and uses the response as a form of push.

The code, both the Haskell and the Javascript (uses jQuery), follows. I’m not going to bother explaining how Yesod works, Michael Snoyman has already done an excellent job of that at docs.yesodweb.com. This is basically a combination of the Ajax and “Chat” (really a message board) tutorials from there. The only tricky part is that the site argument, a read-only parameter passed to request handlers by Yesod, contains a couple of TVars that hold one duplicate of a single TChan for each client (dupTChan is awesome for this kind of independent-read/broadcast-write application).

Clients send an Ajax request to post a message, of course, but they also make a check-in request. That handler (getCheckR) finds that client’s TChan and blocks until data is available on it, which it then sends to the client. The clients displays it and makes another check-in request.

That leads me to my question to my readers: The Javascript function checkIn makes an Ajax request whose callback calls checkIn again. Is that a safe thing to do? Does it leak stack frames? It depends, I suppose, on the internals of jQuery’s implementation, and possibly on the Javascript engine. If anyone could enlighten me, I would be very grateful.

Edit: You may have noticed that WordPress mangled the code below. It’s also out of date with the modern versions of Yesod. A cleaned up and modernized version of my code can be found in the yesod-examples package.

{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies #-}

module Main where

import Yesod
import Yesod.Helpers.Static

import Control.Concurrent.STM
import Control.Concurrent.STM.TChan
import Control.Concurrent.STM.TVar

import Control.Arrow ((***))

-- speaker and content
data Message = Message String String

-- all those TChans are dupes, so writing to any one writes to them all, but reading is separate
data Chat = Chat
  { chatClients    :: TVar [(Int, TChan Message)]
  , nextClient     :: TVar Int
  , chatStatic     :: Static

staticFiles "static"

mkYesod "Chat" [$parseRoutes|
/          HomeR   GET
/check     CheckR  GET
/post      PostR   GET
/static    StaticR Static chatStatic

instance Yesod Chat where
  approot _ = ""
  defaultLayout content = hamletToContent [$hamlet|
            %title $pageTitle.content$

getHomeR :: Handler Chat RepHtml
getHomeR = do
  Chat clients next _ <- getYesod
  client <- liftIO . atomically $ do
    c <- readTVar next
    writeTVar next (c+1)
    cs <- readTVar clients
    chan  newTChan
              (_,x):_ -> dupTChan x
    writeTVar clients ((c,chan) : cs)
    return c
  applyLayout "Chat Page" mempty [$hamlet|
    %h1 Chat Example
     var clientNumber = $show client$ 


getCheckR :: Handler Chat RepJson
getCheckR = do
  liftIO $ putStrLn "Check"
  Chat clients _ _ <- getYesod
  client <- do
    c  invalidArgs ["No client value in Check request"]
      Just c' -> return $ read c'
  cs <- liftIO . atomically $ readTVar clients
  chan  invalidArgs ["Bad client value"]
            Just ch -> return ch
  -- block until there's something there
  first <- liftIO . atomically $ readTChan chan
  let Message s c = first
  jsonToRepJson $ zipJson ["sender", "content"] [s,c]

zipJson x y = jsonMap $ map (id *** (jsonScalar.string)) $ zip x y

getPostR :: Handler Chat RepJson
getPostR = do
  liftIO $ putStrLn "Post"
  Chat clients _ _ <- getYesod
  (sender,content) <- do
    s <- lookupGetParam "name"
    c  return (s', c')
      _                  -> invalidArgs ["Either name or send not provided."]
  liftIO . atomically $ do
    cs <- readTVar clients
    let chan = snd . head $ cs -- doesn't matter which one we use, they're all duplicates
    writeTChan chan (Message sender content)
  jsonToRepJson $ jsonScalar (string "success")

main :: IO ()
main = do
  clients <- newTVarIO []
  next <- newTVarIO 0
  let static = fileLookupDir "static" typeByExt
  basicHandler 3000 $ Chat clients next static

And the JS, which must be called static/chat.js to be loaded properly.

$(document).ready(function () {
    $("form").submit(function (e) {
        $.getJSON("/post", { name: $("#name").attr("value"), send: $("#send").attr("value") }, function(o) { });
        $("#send").attr("value", "");



function checkIn () {
    $.getJSON("/check", { client: clientNumber }, function(o) {
        //alert("response: " + o);
        var ta = $("textarea");
        ta.html(ta.html() + o.sender + ": " + o.content + "\n");



5 Responses to Ajax Chat App using Yesod

  1. Wow, I can’t believe you put this article together so quickly. Mind if I link to it from the Yesod website?

    • bradenshep says:

      Please, go ahead and link it.

      I have nothing but praise for Yesod, that was the most pleasant web programming experience I’ve had.

  2. Greg says:

    Very cool!

    This would be great to turn into a chat subsite for your game app that could be re-usable in different Yesod apps. Any plans to persist the chats?

    • bradenshep says:

      I still need to investigate Widgets, but it seems like such a chat system might be an excellent Widget to drop into pages.

      I have no plans to persist them, though of course it could be done. This code I posted was just a proof-of-concept, but the chat in the real game is not going to be logged either.

  3. svdberg says:

    Hi, great tutorial! However your code seems garbled! getHomeR seems to be missing a case or something, near line 50. I think the patternmatch bit is missing some code due to the blog-engine formatting?

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s

%d bloggers like this: