Developing Web Apps with Haskell and Yesod, Second Edition (2015)

Part III. Examples

Chapter 23. Wiki: Markdown, Chat Subsite, Event Source

This chapter ties together a few different ideas. We’ll start with a chat subsite, which allows us to embed a chat widget on any page. We’ll use the HTML5 event source API to handle sending events from the server to the client. You can view the entire project on FP Haskell Center.

Subsite: Data

In order to define a subsite, we first need to create a foundation type for the subsite, the same as we would do for a normal Yesod application. In our case, we want to keep a channel of all the events to be sent to the individual participants of a chat. This ends up looking like:

-- @Chat/Data.hs

{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE FlexibleInstances #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE QuasiQuotes #-}

{-# LANGUAGE RankNTypes #-}

{-# LANGUAGE TemplateHaskell #-}

{-# LANGUAGE TypeFamilies #-}

moduleChat.Datawhere

import Blaze.ByteString.Builder.Char.Utf8 (fromText)

import Control.Concurrent.Chan

import Data.Monoid ((<>))

import Data.Text (Text)

import Network.Wai.EventSource

import Network.Wai.EventSource.EventStream

import Yesod

-- | Our subsite foundation. We keep a channel of events that all connections

-- will share.

dataChat=Chat (ChanServerEvent)

We also need to define our subsite routes in the same module. We need to have two commands—one to send a new message to all users, and another to receive the stream of messages:

-- @Chat/Data.hs

mkYesodSubData "Chat" [parseRoutes|

/send SendRPOST

/recv ReceiveRGET

Subsite: Handlers

Now that we’ve defined our foundation and routes, we need to create a separate module for providing the subsite dispatch functionality. We’ll call this module Chat, and it’s where we’ll start to see how a subsite functions.

A subsite always sits as a layer on top of some master site, which will be provided by the user. In many cases, a subsite will require specific functionality to be present in the master site. In the case of our chat subsite, we want user authentication to be provided by the master site. The subsite needs to be able to query whether the current user is logged into the site, and to get the user’s name.

The way we represent this concept is by defining a typeclass that encapsulates the necessary functionality. Let’s have a look at our YesodChat typeclass:

-- @Chat/Data.hs

class (Yesod master, RenderMessage master FormMessage)

=>YesodChat master where

getUserName ::HandlerT master IOText

isLoggedIn ::HandlerT master IOBool

Any master site that wants to use the chat subsite will need to provide a YesodChat instance. (We’ll see in a bit how this requirement is enforced.)

There are a few interesting things to note:

§ We can put further constraints on the master site, such as providing a Yesod instance and allowing rendering of form messages. The former allows us to use defaultLayout, while the latter allows us to use standard form widgets.

§ Previously in the book, we’ve used the Handler monad quite a bit. Remember that Handler is just an application-specific type synonym for HandlerT. This code is intended to work with many different applications, so we use the full HandlerT form of the transformer.

Speaking of the Handler type synonym, we’re going to want to have something similar for our subsite. The question is: what does this monad look like? In a subsite situation, we end up with two layers of HandlerT transformers: one for the subsite, and one for the master site. We want to have a synonym that works for any master site that is an instance of YesodChat, so we end up with:

-- @Chat/Data.hs

typeChatHandler a =

forall master. YesodChat master =>

HandlerTChat (HandlerT master IO) a

Now that we have our machinery out of the way, it’s time to write our subsite handler functions. We had two routes: one for sending messages, and one for receiving messages. Let’s start with sending. We need to:

1. Get the username for the person sending the message.

2. Parse the message from the incoming parameters. (Note that we’re going to use GET parameters for simplicity of the client-side Ajax code.)

3. Write the message to the Chan.

The trickiest bit of all this code is knowing when to use lift. Let’s look at the implementation, and then discuss those lift usages:

-- @Chat/Data.hs

postSendR ::ChatHandler ()

postSendR =do

from <-lift getUserName

body <-lift $ runInputGet $ ireq textField "message"

Chat chan <-getYesod

liftIO $ writeChan chan $ ServerEventNothingNothing $ return $

fromText from <> fromText ": " <> fromText body

getUserName is the function we defined in our YesodChat typeclass earlier. If we look at that type signature, we see that it lives in the master site’s Handler monad. Therefore, we need to lift that call out of the subsite.

The call to runInputGet is a little more subtle. Theoretically, we could run this in either the subsite or the master site. However, we use lift here as well, for one specific reason: message translations. By using the master site, we can take advantage of whatever RenderMessage instance the master site defines. This also explains why we have a RenderMessage constraint on the YesodChat typeclass.

The next call to getYesod is not lifted. The reasoning here is simple: we want to get the subsite’s foundation type in order to access the message channel. If we instead lifted that call, we’d get the master site’s foundation type instead, which is not what we want in this case.

The final line puts the new message into the channel. Because this is an IO action, we use liftIO. ServerEvent is part of the wai-eventsource package and is the means by which we’re providing server-sent events in this example.

The receiving side is similarly simple:

-- @Chat/Data.hs

getReceiveR ::ChatHandler ()

getReceiveR =do

Chat chan0 <-getYesod

chan <-liftIO $ dupChan chan0

sendWaiApplication $ eventSourceAppChan chan

We use dupChan so that each new connection receives its own copy of newly generated messages. This is a standard method in concurrent Haskell of creating broadcast channels. The last line in our function exposes the underlying wai-eventsource application as a Yesod handler, using the sendWaiApplication function to promote a WAI application to a Yesod handler.

Now that we’ve defined our handler functions, we can set up our dispatch. In a normal application, dispatching is handled by calling mkYesod, which creates the appropriate YesodDispatch instance. In subsites, things are a little bit more complicated, because you’ll often want to place constraints on the master site. The formula we use is the following:

-- @Chat.hs

{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE FlexibleInstances #-}

{-# LANGUAGE MultiParamTypeClasses #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE QuasiQuotes #-}

{-# LANGUAGE RankNTypes #-}

{-# LANGUAGE TemplateHaskell #-}

{-# LANGUAGE TypeFamilies #-}

moduleChatwhere

import Chat.Data

import Yesod

instanceYesodChat master =>YesodSubDispatchChat (HandlerT master IO) where

yesodSubDispatch =$(mkYesodSubDispatch resourcesChat)

We’re stating that our chat subsite can live on top of any master site that is an instance of YesodChat. We then use the mkYesodSubDispatch Template Haskell function to generate all of our dispatching logic. This is a bit more difficult to write than mkYesod, but it provides the necessary flexibility and is mostly identical for any subsite you’ll write.

Subsite: Widget

We now have a fully working subsite. The final component we want as part of our chat library is a widget to be embedded inside a page that will provide chat functionality. By creating this as a widget, we can include all of our HTML, CSS, and Javascript as a reusable component.

Our widget will need to take in one argument: a function to convert a chat subsite URL into a master site URL. The reasoning here is that an application developer could place the chat subsite anywhere in the URL structure, and this widget needs to be able to generate Javascript that will point at the correct URLs. Let’s start off our widget:

-- @Chat.hs

chatWidget ::YesodChat master

=> (RouteChat->Route master)

->WidgetT master IO ()

chatWidget toMaster =do

Next, we’re going to generate some identifiers to be used by our widget. It’s always good practice to let Yesod generate unique identifiers for you instead of creating them manually, to avoid name collisions:

-- @Chat.hs

chat <-newIdent -- the containing div

output <-newIdent -- the box containing the messages

input <-newIdent -- input field from the user

And next, we need to check if the user is logged in, using the isLoggedIn function in our YesodChat typeclass. We’re in a Widget and that function lives in the Handler monad, so we need to use handlerToWidget:

-- @Chat.hs

ili <-handlerToWidget isLoggedIn -- check if we're already logged in

If the user is logged in, we want to display the chat box, style it with some CSS, and then make it interactive using some Javascript. This is mostly client-side code wrapped in a Widget:

-- @Chat.hs

if ili

thendo

-- Logged in: show the widget

[whamlet|

<h2>Chat

-- Just some CSS

toWidget [lucius|

##{chat} {

position: absolute;

top: 2em;

right: 2em;

}

##{output} {

width: 200px;

height: 300px;

border: 1px solid #999;

overflow: auto;

}

-- And now that Javascript

toWidgetBody [julius|

// Set up the receiving end

var output =document.getElementById(#{toJSON output});

var src =new EventSource("@{toMaster ReceiveR}");

src.onmessage =function(msg) {

// This function will be called for each new message.

var p =document.createElement("p");

p.appendChild(document.createTextNode(msg.data));

output.appendChild(p);

// And now scroll down within the output div

so the most recent message

// is displayed.

output.scrollTop =output.scrollHeight;

};

// Set up the sending end: send a message via Ajax

whenever the user hits Enter.

var input =document.getElementById(#{toJSON input});

input.onkeyup =function(event) {

var keycode = (event.keyCode ? event.keyCode : event.which);

if (keycode == '13') {

var xhr =new XMLHttpRequest();

var val =input.value;

input.value ="";

var params ="?message=" + encodeURI(val);

xhr.open("POST", "@{toMaster SendR}" + params);

xhr.send(null);

}

And finally, if the user isn’t logged in, we’ll ask her to log in to use the chat app:

-- @Chat.hs

elsedo

-- User isn't logged in, give a not-logged-in message.

master <-getYesod

[whamlet|

<p>

You must be #

$maybe ar <-authRoute master

<a href=@{ar}>logged in

$nothing

logged in

\ to chat.

Master Site: Data

Now we can proceed with writing our main application. This application will include the chat subsite and a wiki. The first thing we need to consider is how to store the wiki contents. Normally, we’d want to put this in some kind of a Persistent database. For simplicity, we’ll just use an in-memory representation. Each wiki page is indicated by a list of names, and the content of each page is going to be a piece of Text. So, our full foundation data type is:

-- @ChatMain.hs

{-# LANGUAGE MultiParamTypeClasses #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE QuasiQuotes #-}

{-# LANGUAGE TemplateHaskell #-}

{-# LANGUAGE TypeFamilies #-}

{-# LANGUAGE ViewPatterns #-}

moduleChatMainwhere

import Chat

import Chat.Data

import Control.Concurrent.Chan (newChan)

import Data.IORef

import Data.Map (Map)

importqualifiedData.Map as Map

import Data.Text (Text)

importqualifiedData.Text.Lazy as TL

import Text.Markdown

import Yesod

import Yesod.Auth

import Yesod.Auth.Dummy

dataApp=App

{ getChat ::Chat

, wikiContent ::IORef (Map [Text] Text)

}

Next, we want to set up our routes:

-- @ChatMain.hs

mkYesod "App" [parseRoutes|

/ HomeRGET -- the homepage

/wiki/*TextsWikiRGETPOST -- note the multipiece for the wiki hierarchy

/chat ChatRChat getChat -- the chat subsite

/auth AuthRAuth getAuth -- the auth subsite

Master Site: Instances

We need to make two modifications to the default Yesod instance. First, we want to provide an implementation of authRoute, so that our chat subsite widget can provide a proper link to a login page. Second, we’ll provide an override to the defaultLayout. Besides providing login/logout links, this function will add in the chat widget on every page:

-- @ChatMain.hs

instanceYesodAppwhere

authRoute _=Just $ AuthRLoginR -- get a working login link

-- Our custom defaultLayout will add the chat widget to every page.

-- We'll also add login and logout links to the top.

defaultLayout widget =do

pc <-widgetToPageContent $ do

widget

chatWidget ChatR

mmsg <-getMessage

withUrlRenderer

[hamlet|

$doctype 5

<html>

<head>

<title>#{pageTitle pc}

^{pageHead pc}

<body>

$maybe msg <-mmsg

<div .message>#{msg}

<nav>

<a href=@{AuthRLoginR}>Login

\ | #

<a href=@{AuthRLogoutR}>Logout

^{pageBody pc}

Because we’re using the chat subsite, we have to provide an instance of YesodChat:

-- @ChatMain.hs

instanceYesodChatAppwhere

getUserName =do

muid <-maybeAuthId

case muid of

Nothing->do

setMessage "Not logged in"

redirect $ AuthRLoginR

Just uid ->return uid

isLoggedIn =do

ma <-maybeAuthId

return $ maybe False (const True) ma

Our YesodAuth and RenderMessage instances, as well as the homepage handler, are rather bland:

-- @ChatMain.hs

-- Fairly standard YesodAuth instance. We'll use the dummy plug-in so that you

-- can create any name you want, and store the login name as the AuthId.

instanceYesodAuthAppwhere

typeAuthIdApp=Text

authPlugins _= [authDummy]

loginDest _=HomeR

logoutDest _=HomeR

getAuthId =return . Just . credsIdent

authHttpManager =error "authHttpManager" -- not used by authDummy

maybeAuthId =lookupSession "_ID"

instanceRenderMessageAppFormMessagewhere

renderMessage __=defaultFormMessage

-- Nothing special here, just giving a link to the root of the wiki.

getHomeR ::HandlerHtml

getHomeR =defaultLayout

[whamlet|

<p>Welcome to the Wiki!

<p>

<a href=@{wikiRoot}>Wiki root

where

wikiRoot =WikiR[]

Master Site: Wiki Handlers

Now it’s time to write our wiki handlers: a GET for displaying a page, and a POST for updating a page. We’ll also define a wikiForm function to be used on both handlers:

-- @ChatMain.hs

-- A form for getting wiki content

wikiForm ::MaybeTextarea->Html->MFormHandler (FormResultTextarea, Widget)

wikiForm mtext =renderDivs $ areq textareaField "Page body" mtext

-- Show a wiki page and an edit form

getWikiR :: [Text] ->HandlerHtml

getWikiR page =do

-- Get the reference to the contents map

icontent <-fmap wikiContent getYesod

-- And read the map from inside the reference

content <-liftIO $ readIORef icontent

-- Look up the contents of the current page, if available

let mtext =Map.lookup page content

-- Generate a form with the current contents as the default value.

-- Note that we use the Textarea wrapper to get a <textarea>.

(form, _) <-generateFormPost $ wikiForm $ fmap Textarea mtext

defaultLayout $ do

case mtext of

-- We're treating the input as markdown. The markdown package

-- automatically handles XSS protection for us.

Just text ->toWidget $ markdown def $ TL.fromStrict text

Nothing-> [whamlet|<p>Page does not yet exist|]

[whamlet|

<h2>Edit page

^{form}

<div>

-- Get a submitted wiki page and update the contents.

postWikiR :: [Text] ->HandlerHtml

postWikiR page =do

icontent <-fmap wikiContent getYesod

content <-liftIO $ readIORef icontent

let mtext =Map.lookup page content

((res, form), _) <-runFormPost $ wikiForm $ fmap Textarea mtext

case res of

FormSuccess (Textarea t) ->do

liftIO $ atomicModifyIORef icontent $

\m -> (Map.insert page t m, ())

setMessage "Page updated"

redirect $ WikiR page

_->defaultLayout

[whamlet|

^{form}

<div>

Master Site: Running

Finally, we’re ready to run our application. Unlike many of the previous examples in this book, we need to perform some real initialization in the main function. The chat subsite requires an empty Chan to be created, and we need to create a mutable variable to hold the wiki contents. Once we have those values, we can create an App value and pass it to the warp function:

-- @ChatMain.hs

main ::IO ()

main =do

-- Create our server event channel

chan <-newChan

-- Initially have a blank database of wiki pages

icontent <-newIORef Map.empty

-- Run our app

warpEnv App

{ getChat =Chat chan

, wikiContent =icontent

}

Summary

This chapter demonstrated the creation of a nontrivial subsite. Some important points to notice include the usage of typeclasses to express constraints on the master site, how data initialization was performed in the main function, and how lifting allowed us to operate in either the subsite or master site context.

If you’re looking for a way to test out your subsite skills, I’d recommend modifying this example so that the wiki code also lives in its own subsite.