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|
    !!!
    %html
        %head
            %title $pageTitle.content$
            %script!src="http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js"
            %script!src=@StaticR.chat_js@
            ^pageHead.content^
        %body
            ^pageBody.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
    %form
        %textarea!cols=80!rows=20!name=chat
        %p
            %input!type=text!size=15!name=name#name
            %input!type=text!size=60!name=send#send
            %input!type=submit!value=Send
     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) {
        e.preventDefault();
        $.getJSON("/post", { name: $("#name").attr("value"), send: $("#send").attr("value") }, function(o) { });
        $("#send").attr("value", "");
    });

    checkIn();

});


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

        checkIn();
    });
}