Simple web chat using Haskell's Wai/Warp

Here's a quick and dirty chat application written in Wai[1].

{-# LANGUAGE OverloadedStrings #-}
module Main where

import Control.Concurrent.Chan

import Control.Monad.Trans (liftIO)

import Network.Wai
import Network.Wai.EventSource
import Network.Wai.Handler.Warp (run)
import Network.Wai.Middleware.Gzip (gzip, def)
import Network.Wai.Parse (parseRequestBody, lbsBackEnd)
import Network.HTTP.Types (status200, ok200)

import Blaze.ByteString.Builder.Char.Utf8 (fromString)
import Data.ByteString.Char8 (ByteString, unpack)

app :: Chan ServerEvent -> Application
app chan req = do
  (params, _) <- parseRequestBody lbsBackEnd req
  case pathInfo req of
    [] -> return $ ResponseFile status200 [("Content-Type", "text/html")] "static/index.html" Nothing
    ["post"] -> liftIO $ postMessage chan $ lookPost "message" params
    ["source"] -> eventSourceAppChan chan req
    path -> error $ "unexpected pathInfo " ++ show (queryString req)

lookPost :: ByteString -> [(ByteString, ByteString)] -> String
lookPost paramName params = case lookup paramName params of
  Just val -> unpack val
  _ ->  ""

postMessage :: Chan ServerEvent -> String -> IO Response
postMessage chan msg = do
  writeChan chan $ ServerEvent (Just $ fromString "message") Nothing $ [fromString msg]
  return $ responseLBS ok200 [] "Posted"

main :: IO ()
main = do  
  chan <- newChan
  run 8000 $ gzip def $ app chan

That's the most basic example I could find/cobble together of using SSEs in Wai. That's the library called Network.Wai.EventSource up there, and you can see the channel represented in the expressions involving newChan, eventSourceAppChan and writeChan. Basically, we set up a Chan[2] at server startup, we hand out an endpoint whenever someone requests /source, and we write to all endpoints whenever someone requests /post.

The file index.html is exactly what you think it is; about 10 lines each of HTML and JavaScript that set up the front-end EventSource hooks and make sure the chat list gets updated with each new message. You could write it yourself without very much trouble.

This isn't particularly interesting. Firstly because, as you can see, it's ridiculously simple, and secondly because it doesn't scale. I mean it scales with users, sure. According to the Warp benchmarks, we can expect this to support somewhere between 20k and 50k people chatting depending on their loquaciousness, but since they'll all be chatting anonymously in the same room, the experience will stop being useful well before that. The next step confounded me for a little while because I had the assumption that using state in Haskell meant using the State monad[3]. It turns out that's probably not what you'd want here.

What we're after is a system where you can start up arbitrary new rooms, and post to a specific one. In other words, something like

{-# LANGUAGE OverloadedStrings #-}
module Main where

import Control.Concurrent.Chan
import Control.Concurrent (forkIO, threadDelay)

import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Resource (ResourceT)

import Network.Wai
import Network.Wai.EventSource
import Network.Wai.Handler.Warp (run)
import Network.Wai.Middleware.Gzip (gzip, def)
import Network.Wai.Parse (parseRequestBody, lbsBackEnd)

import Network.HTTP.Types (status200, ok200)
import Blaze.ByteString.Builder.Char.Utf8 (fromString)
import qualified Data.ByteString.Char8 as C

import Data.IORef
import Data.Text (unpack, pack)

app :: IORef [(String, Chan ServerEvent)] -> Application
app channels req = do
  (params, _) <- parseRequestBody lbsBackEnd req
  case pathInfo req of
    [] -> serveFile "text/html" "static/index.html"
    ["jquery.js"] -> serveFile "text/javascript" "static/jquery.min.js"
    ["chat.js"] -> serveFile "text/javascript" "static/chat.js"
    [channelName, action] -> do
      chan <- liftIO $ getOrCreateChannel channels $ unpack channelName
      case action of
        "post" -> 
          liftIO $ postMessage chan $ lookPost "message" params
        "source" -> 
          eventSourceAppChan chan req
        _ -> serveFile "text/html" "static/index.html"
    _ -> serveFile "text/html" "static/index.html"

serveFile :: C.ByteString -> FilePath -> ResourceT IO Response
serveFile mime filePath = return $ ResponseFile status200 [("Content-Type", mime)] filePath Nothing

lookPost :: C.ByteString -> [(C.ByteString, C.ByteString)] -> String
lookPost paramName params = case lookup paramName params of
  Just val -> C.unpack val
  _ ->  ""

getOrCreateChannel :: IORef [(String, Chan ServerEvent)] -> String -> IO (Chan ServerEvent)
getOrCreateChannel channels name = do
  res <- readIORef channels
  case lookup name res of
    Just chan -> 
      return chan
    _ -> do
      new <- newChan
      atomicModifyIORef channels (\cs -> ((name, new):cs, new))
      return new

postMessage :: Chan ServerEvent -> String -> IO Response
postMessage chan msg = do
  writeChan chan $ ServerEvent (Just $ fromString "message") Nothing $ [fromString msg]
  return $ responseLBS ok200 [] "Posted"

main :: IO ()
main = do
  channels <- newIORef []
  run 8000 $ gzip def $ app channels

That's a bit chunkier, but not by very much.

The significant operations there all involve something called an IORef, which is Haskell-talk for "a pointer". You can think of it an IO-based global variable that you can store stuff in[4], in this case, a map of channel names to channel streams.

That index.html file has a bunch of front-end changes too, mostly to do with acquiring and displaying multiple SSE sources, but we're not interested in that today. In the back-end, you'll notice that we've got a new function, getOrCreateChannel, which takes a "pointer" to our channel map and a name, and either returns the result of looking up that name, or inserts and returns a corresponding entry. readIORef "dereferences" that "pointer" to our map, and atomicModifyIORef mutates it. The rest of it should be self-explanatory.

Because we need to do a channel lookup before calling postMessage or eventSourceAppChan, our routes get a bit more complicated. We need to call getOrCreateChannel on the passed in channelName, then pass that to the appropriate function and return the response[5].

Finally, instead of passing a single channel to our app, we need to pass it a "pointer" to our lookup table. That happens in main at the bottom there.

The result of this exercise, as long as we put the front-end together appropriately, is a multi-room, anonymous, HTML chat system. More importantly though, this is a demonstration of how to handle simple global states in Haskell without tearing all your hair out.

I really wish someone else had written this before I started thinking about it...

---

Footnotes

1 - [back] - No, still not Yesod. Feel perfectly free to use it if that's your thing, but I'd still recommend Happstack if you absolutely, positively need a framework..

2 - [back] - Which I assume is reasonably efficient, since it's one of Haskell's basic concurrency constructs.

3 - [back] - Also, because I'm still not quite awesome enough at this that I can manipulate type expressions in my head. As a result, successful signature changes rarely happen first try, and I often find myself commenting them out then resorting to :t in GHCi and following the compilers' lead. I assume that's mechanical rather than a conceptual problem though, and talking about how I need more practice won't really help you out in any way.

4 - [back] - The IORef docs warn that using more than one of these in a program makes them unreliable in a multi-threaded setting. The thing is:

• This chat program is extremely simple, needing only one global map to store open channels
• If it ever got to the point of needing a more complex model, I'd hook it up to AcidState rather than trying to fiddle with MVars myself.

5 - [back] - You can see that happening in the branch labeled [channelName, action] ->, though we easily could have separated it into an external function rather than nesting cases.