Wiki: markdown, chat subsite, event source

This example will tie 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 HTML 5 event source API to handle sending events from the server to the client.

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:

  1. -- @Chat/Data.hs
  2. {-# LANGUAGE FlexibleContexts #-}
  3. {-# LANGUAGE FlexibleInstances #-}
  4. {-# LANGUAGE OverloadedStrings #-}
  5. {-# LANGUAGE QuasiQuotes #-}
  6. {-# LANGUAGE RankNTypes #-}
  7. {-# LANGUAGE TemplateHaskell #-}
  8. {-# LANGUAGE TypeFamilies #-}
  9. module Chat.Data where
  10. import Blaze.ByteString.Builder.Char.Utf8 (fromText)
  11. import Control.Concurrent.Chan
  12. import Data.Monoid ((<>))
  13. import Data.Text (Text)
  14. import Network.Wai.EventSource
  15. import Network.Wai.EventSource.EventStream
  16. import Yesod
  17. import Yesod.Core.Types (SubHandlerFor)
  18. -- | Our subsite foundation. We keep a channel of events that all connections
  19. -- will share.
  20. data Chat = Chat (Chan ServerEvent)

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.

  1. -- @Chat/Data.hs
  2. mkYesodSubData "Chat" [parseRoutes|
  3. /send SendR POST
  4. /recv ReceiveR GET
  5. |]

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 to define a typeclass that encapsulates the necessary functionality. Let’s have a look at our YesodChat typeclass:

  1. -- @Chat/Data.hs
  2. class (Yesod master, RenderMessage master FormMessage)
  3. => YesodChat master where
  4. getUserName :: HandlerFor master Text
  5. isLoggedIn :: HandlerFor master Bool

Any master site which 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 around HandlerFor. Since this code is intended to work with many different applications, we use the full HandlerFor 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 use SubHandlerFor with both the subsite data type and the master site type. We’ll define a helper synonym for this which requires a YesodChat instance on the master site type, so we end up with:

  1. -- @Chat/Data.hs
  2. type ChatHandler a =
  3. forall master. YesodChat master =>
  4. SubHandlerFor Chat master 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 to know when to use lift. Let’s look at the implementation, and then discuss those lift usages:

  1. -- @Chat/Data.hs
  2. postSendR :: ChatHandler ()
  3. postSendR = do
  4. from <- liftHandler getUserName
  5. body <- runInputGet $ ireq textField "message"
  6. Chat chan <- getSubYesod
  7. liftIO $ writeChan chan $ ServerEvent Nothing Nothing $ return $
  8. 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 next call to getSubYesod 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. Since 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:

  1. -- @Chat/Data.hs
  2. getReceiveR :: ChatHandler ()
  3. getReceiveR = do
  4. Chat chan <- getSubYesod
  5. sendWaiApplication $ eventSourceAppChan chan

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. eventSourceAppChan duplicates the chan under the hood, which is a standard method in concurrent Haskel of creating broadcast channels.

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, since you’ll often want to place constraints on the master site. The formula we use is the following:

  1. -- @Chat.hs
  2. {-# LANGUAGE FlexibleContexts #-}
  3. {-# LANGUAGE FlexibleInstances #-}
  4. {-# LANGUAGE MultiParamTypeClasses #-}
  5. {-# LANGUAGE OverloadedStrings #-}
  6. {-# LANGUAGE QuasiQuotes #-}
  7. {-# LANGUAGE RankNTypes #-}
  8. {-# LANGUAGE TemplateHaskell #-}
  9. {-# LANGUAGE TypeFamilies #-}
  10. module Chat where
  11. import Chat.Data
  12. import Yesod
  13. instance YesodChat master => YesodSubDispatch Chat master where
  14. yesodSubDispatch = $(mkYesodSubDispatch resourcesChat)

We’re stating that our Chat subsite can live on top of any master site which is an instance of YesodChat. We then use the mkYesodSubDispatch Template Haskell function to generate all of our dispatching logic. While this is a bit more difficult to write than mkYesod, it provides 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 which 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 which will point at the correct URLs. Let’s start off our widget:

  1. -- @Chat.hs
  2. chatWidget :: YesodChat master
  3. => (Route Chat -> Route master)
  4. -> WidgetFor master ()
  5. 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.

  1. -- @Chat.hs
  2. chat <- newIdent -- the containing div
  3. output <- newIdent -- the box containing the messages
  4. 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. Since we’re in a Widget and that function lives in the Handler monad, we need to use handlerToWidget:

  1. -- @Chat.hs
  2. 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:

  1. -- @Chat.hs
  2. if ili
  3. then do
  4. -- Logged in: show the widget
  5. [whamlet|
  6. <div ##{chat}>
  7. <h2>Chat
  8. <div ##{output}>
  9. <input ##{input} type=text placeholder="Enter Message">
  10. |]
  11. -- Just some CSS
  12. toWidget [lucius|
  13. ##{chat} {
  14. position: absolute;
  15. top: 2em;
  16. right: 2em;
  17. }
  18. ##{output} {
  19. width: 200px;
  20. height: 300px;
  21. border: 1px solid #999;
  22. overflow: auto;
  23. }
  24. |]
  25. -- And now that Javascript
  26. toWidgetBody [julius|
  27. // Set up the receiving end
  28. var output = document.getElementById(#{toJSON output});
  29. var src = new EventSource("@{toMaster ReceiveR}");
  30. src.onmessage = function(msg) {
  31. // This function will be called for each new message.
  32. var p = document.createElement("p");
  33. p.appendChild(document.createTextNode(msg.data));
  34. output.appendChild(p);
  35. // And now scroll down within the output div so the most recent message
  36. // is displayed.
  37. output.scrollTop = output.scrollHeight;
  38. };
  39. // Set up the sending end: send a message via Ajax whenever the user hits
  40. // enter.
  41. var input = document.getElementById(#{toJSON input});
  42. input.onkeyup = function(event) {
  43. var keycode = (event.keyCode ? event.keyCode : event.which);
  44. if (keycode == '13') {
  45. var xhr = new XMLHttpRequest();
  46. var val = input.value;
  47. input.value = "";
  48. var params = "?message=" + encodeURI(val);
  49. xhr.open("POST", "@{toMaster SendR}" + params);
  50. xhr.send(null);
  51. }
  52. }
  53. |]

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

  1. -- @Chat.hs
  2. else do
  3. -- User isn't logged in, give a not-logged-in message.
  4. master <- getYesod
  5. [whamlet|
  6. <p>
  7. You must be #
  8. $maybe ar <- authRoute master
  9. <a href=@{ar}>logged in
  10. $nothing
  11. logged in
  12. \ to chat.
  13. |]

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 contents of each page is going to be a piece of Text. So our full foundation datatype is:

  1. -- @ChatMain.hs
  2. {-# LANGUAGE MultiParamTypeClasses #-}
  3. {-# LANGUAGE OverloadedStrings #-}
  4. {-# LANGUAGE QuasiQuotes #-}
  5. {-# LANGUAGE TemplateHaskell #-}
  6. {-# LANGUAGE TypeFamilies #-}
  7. {-# LANGUAGE ViewPatterns #-}
  8. module ChatMain where
  9. import Chat
  10. import Chat.Data
  11. import Control.Concurrent.Chan (newChan)
  12. import Data.IORef
  13. import Data.Map (Map)
  14. import qualified Data.Map as Map
  15. import Data.Text (Text)
  16. import qualified Data.Text.Lazy as TL
  17. import Text.Markdown
  18. import Yesod
  19. import Yesod.Auth
  20. import Yesod.Auth.Dummy
  21. import System.SetEnv
  22. data App = App
  23. { getChat :: Chat
  24. , wikiContent :: IORef (Map [Text] Text)
  25. }

Next we want to set up our routes:

  1. -- @ChatMain.hs
  2. mkYesod "App" [parseRoutes|
  3. / HomeR GET -- the homepage
  4. /wiki/*Texts WikiR GET POST -- note the multipiece for the wiki hierarchy
  5. /chat ChatR Chat getChat -- the chat subsite
  6. /auth AuthR Auth getAuth -- the auth subsite
  7. |]

Master site: instances

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

  1. -- @ChatMain.hs
  2. instance Yesod App where
  3. authRoute _ = Just $ AuthR LoginR -- get a working login link
  4. -- Our custom defaultLayout will add the chat widget to every page.
  5. -- We'll also add login and logout links to the top.
  6. defaultLayout widget = do
  7. pc <- widgetToPageContent $ do
  8. widget
  9. chatWidget ChatR
  10. mmsg <- getMessage
  11. withUrlRenderer
  12. [hamlet|
  13. $doctype 5
  14. <html>
  15. <head>
  16. <title>#{pageTitle pc}
  17. ^{pageHead pc}
  18. <body>
  19. $maybe msg <- mmsg
  20. <div .message>#{msg}
  21. <nav>
  22. <a href=@{AuthR LoginR}>Login
  23. \ | #
  24. <a href=@{AuthR LogoutR}>Logout
  25. ^{pageBody pc}
  26. |]

Since we’re using the chat subsite, we have to provide an instance of YesodChat.

  1. -- @ChatMain.hs
  2. instance YesodChat App where
  3. getUserName = do
  4. muid <- maybeAuthId
  5. case muid of
  6. Nothing -> do
  7. setMessage "Not logged in"
  8. redirect $ AuthR LoginR
  9. Just uid -> return uid
  10. isLoggedIn = do
  11. ma <- maybeAuthId
  12. return $ maybe False (const True) ma

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

  1. -- @ChatMain.hs
  2. -- Fairly standard YesodAuth instance. We'll use the dummy plugin so that you
  3. -- can create any name you want, and store the login name as the AuthId.
  4. instance YesodAuth App where
  5. type AuthId App = Text
  6. authPlugins _ = [authDummy]
  7. loginDest _ = HomeR
  8. logoutDest _ = HomeR
  9. getAuthId = return . Just . credsIdent
  10. maybeAuthId = lookupSession "_ID"
  11. instance RenderMessage App FormMessage where
  12. renderMessage _ _ = defaultFormMessage
  13. -- Nothing special here, just giving a link to the root of the wiki.
  14. getHomeR :: Handler Html
  15. getHomeR = defaultLayout
  16. [whamlet|
  17. <p>Welcome to the Wiki!
  18. <p>
  19. <a href=@{wikiRoot}>Wiki root
  20. |]
  21. where
  22. 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:

  1. -- @ChatMain.hs
  2. -- A form for getting wiki content
  3. wikiForm :: Maybe Textarea -> Html -> MForm Handler (FormResult Textarea, Widget)
  4. wikiForm mtext = renderDivs $ areq textareaField "Page body" mtext
  5. -- Show a wiki page and an edit form
  6. getWikiR :: [Text] -> Handler Html
  7. getWikiR page = do
  8. -- Get the reference to the contents map
  9. icontent <- fmap wikiContent getYesod
  10. -- And read the map from inside the reference
  11. content <- liftIO $ readIORef icontent
  12. -- Lookup the contents of the current page, if available
  13. let mtext = Map.lookup page content
  14. -- Generate a form with the current contents as the default value.
  15. -- Note that we use the Textarea wrapper to get a <textarea>.
  16. (form, _) <- generateFormPost $ wikiForm $ fmap Textarea mtext
  17. defaultLayout $ do
  18. case mtext of
  19. -- We're treating the input as markdown. The markdown package
  20. -- automatically handles XSS protection for us.
  21. Just text -> toWidget $ markdown def $ TL.fromStrict text
  22. Nothing -> [whamlet|<p>Page does not yet exist|]
  23. [whamlet|
  24. <h2>Edit page
  25. <form method=post>
  26. ^{form}
  27. <div>
  28. <input type=submit>
  29. |]
  30. -- Get a submitted wiki page and updated the contents.
  31. postWikiR :: [Text] -> Handler Html
  32. postWikiR page = do
  33. icontent <- fmap wikiContent getYesod
  34. content <- liftIO $ readIORef icontent
  35. let mtext = Map.lookup page content
  36. ((res, form), _) <- runFormPost $ wikiForm $ fmap Textarea mtext
  37. case res of
  38. FormSuccess (Textarea t) -> do
  39. liftIO $ atomicModifyIORef icontent $
  40. \m -> (Map.insert page t m, ())
  41. setMessage "Page updated"
  42. redirect $ WikiR page
  43. _ -> defaultLayout
  44. [whamlet|
  45. <form method=post>
  46. ^{form}
  47. <div>
  48. <input type=submit>
  49. |]

Master site: running

Finally, we’re ready to run our application. Unlike many of our 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.

  1. -- @ChatMain.hs
  2. main :: IO ()
  3. main = do
  4. -- Create our server event channel
  5. chan <- newChan
  6. -- Initially have a blank database of wiki pages
  7. icontent <- newIORef Map.empty
  8. -- Set web server's listening port required by warpEnv function
  9. -- This env var is set up automatically if 'yesod devel' is used
  10. setEnv "PORT" "3000"
  11. -- Run our app
  12. warpEnv App
  13. { getChat = Chat chan
  14. , wikiContent = icontent
  15. }

Conclusion

This example demonstrated creation of a non-trivial subsite. Some important points to notice were 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 lived in its own subsite.