Simple web chat using Haskell's Wai/Warp
Tue Apr 16, 2013Here'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 case
s.