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

"); ta.scrollTop(10000); checkIn(); }); }

Share this: Twitter

Facebook

Like this: Like Loading... Related

This entry was posted on Thursday, July 22nd, 2010 at 22:17 and is filed under 1. You can follow any responses to this entry through the RSS 2.0 feed. You can leave a response, or trackback from your own site.