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

Part III. Examples

Chapter 22. Blog: i18n, Authentication, Authorization, and Database

This chapter presents a simple blog app. It allows an admin to add blog posts via a rich text editor (nicedit), allows logged-in users to comment, and has full i18n support. It is also a good example of using a Persistent database, leveraging Yesod’s authorization system, and using templates.

It is generally recommended to place templates, Persist entity definitions, and routing in separate files, but we’ll keep it all in one file here for convenience. The one exception you’ll see will be i18n messages.

We’ll start off with our language extensions. In scaffolded code, the language extensions are specified in the cabal file, so you won’t need to put this in your individual Haskell files:

{-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes,

TemplateHaskell, GADTs, FlexibleContexts,

MultiParamTypeClasses, DeriveDataTypeable,

GeneralizedNewtypeDeriving, ViewPatterns #-}

Now our imports:

importYesod

importYesod.Auth

importYesod.Form.Nic (YesodNic, nicHtmlField)

importYesod.Auth.BrowserId (authBrowserId, def)

importData.Text (Text)

importNetwork.HTTP.Client.TLS (tlsManagerSettings)

importNetwork.HTTP.Conduit (Manager, newManager)

importDatabase.Persist.Sqlite

( ConnectionPool, SqlBackend, runSqlPool, runMigration

, createSqlitePool, runSqlPersistMPool

)

importData.Time (UTCTime, getCurrentTime)

importControl.Applicative ((<$>), (<*>), pure)

importData.Typeable (Typeable)

importControl.Monad.Logger (runStdoutLoggingT)

First, we’ll set up our Persistent entities. We’re going to create our data types (via mkPersist) and a migration function, which will automatically create and update our SQL schema (if we were using the MongoDB backend, migration would not be needed):

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|

The following keeps track of users (in a more robust application, we would also keep the account creation date, display name, etc.):

User

email Text

UniqueUser email

In order to work with yesod-auth’s caching, our User type must be an instance of Typeable:

derivingTypeable

An individual blog entry has this format (I’ve avoided using the word “post” due to the confusion with the request method POST):

Entry

title Text

posted UTCTime

content Html

And a comment on the blog post looks like this:

Comment

entry EntryId

posted UTCTime

user UserId

name Text

text Textarea

Every site has a foundation data type. This value is initialized before launching your application, and is available throughout. We’ll store a database connection pool and HTTP connection manager in ours. See the very end of the file for how those are initialized:

dataBlog=Blog

{ connPool ::ConnectionPool

, httpManager ::Manager

}

To make i18n easy and translator-friendly, we have a special file format for translated messages. There is a single file for each language, and each file is named based on the language code (e.g., en, es, de-DE) and placed in that folder. We also specify the main language file (here, "en“) as a default language:

mkMessage "Blog" "blog-messages" "en"

Our blog-messages/en.msg file contains the following content:

-- @blog-messages/en.msg

NotAnAdmin: You must be an administrator to access this page.

WelcomeHomepage: Welcome to the homepage

SeeArchive: See the archive

NoEntries: There are no entries in the blog

LoginToPost: Admins can login to post

NewEntry: Post to blog

NewEntryTitle: Title

NewEntryContent: Content

PleaseCorrectEntry: Your submitted entry had some errors,

please correct and try again.

EntryCreated title@Text: Your new blog post, #{title}, has been created

EntryTitle title@Text: Blog post: #{title}

CommentsHeading: Comments

NoComments: There are no comments

AddCommentHeading: Add a Comment

LoginToComment: You must be logged in to comment

AddCommentButton: Add comment

CommentName: Your display name

CommentText: Comment

CommentAdded: Your comment has been added

PleaseCorrectComment: Your submitted comment had some errors,

please correct and try again.

HomepageTitle: Yesod Blog Demo

BlogArchiveTitle: Blog Archive

Now we’re going to set up our routing table. We have four entries: a homepage, an entry list page (BlogR), an individual entry page (EntryR), and our authentication subsite. Note that BlogR and EntryR both accept GET and POST methods. The POST methods are for adding a new blog post and adding a new comment, respectively:

mkYesod "Blog" [parseRoutes|

/ HomeR GET

/blog BlogR GETPOST

/blog/#EntryIdEntryRGETPOST

/auth AuthR Auth getAuth

Every foundation needs to be an instance of the Yesod typeclass. This is where we configure various settings:

instanceYesodBlogwhere

This is the base of our application (note that in order to make BrowserID work properly, a valid URL must be used):

approot =ApprootStatic "http://localhost:3000"

For our authorization scheme, we want to have the following rules:

§ Only admins can add a new entry.

§ Only logged-in users can add a new comment.

§ All other pages can be accessed by anyone.

We set up our routes in a RESTful way, where the actions that could make changes are always using a POST method. As a result, we can simply check for whether a request is a write request, given by the True in the second field.

First, we’ll authorize requests to add a new entry:

isAuthorized BlogRTrue=do

mauth <-maybeAuth

case mauth of

Nothing->return AuthenticationRequired

Just (Entity_ user)

| isAdmin user ->return Authorized

| otherwise -> unauthorizedI MsgNotAnAdmin

Now we’ll authorize requests to add a new comment:

isAuthorized (EntryR_) True=do

mauth <-maybeAuth

case mauth of

Nothing->return AuthenticationRequired

Just_ ->return Authorized

And for all other requests, the result is always authorized:

isAuthorized __=return Authorized

We’ll also specify where users should be redirected to if they get an AuthenticationRequired:

authRoute _=Just (AuthRLoginR)

Next is where we define our site’s look and feel. The function is given the content for the individual page, and wraps it up with a standard template:

defaultLayout inside =do

Yesod encourages the get-following-post pattern, where after a POST, the user is redirected to another page. In order to allow the POST page to give the user some kind of feedback, we have the getMessage and setMessage functions. It’s a good idea to always check for pending messages in your defaultLayout function:

mmsg <-getMessage

We use widgets to compose HTML, CSS, and JavaScript resources. At the end of the day, we need to unwrap all of that into simple HTML. That’s what the widgetToPageContent function is for. We’re going to give it a widget consisting of the content we received from the individual page (inside), plus a standard CSS stylesheet for all pages. We’ll use the Lucius template language to create the latter:

pc <-widgetToPageContent $ do

toWidget [lucius|

body {

width: 760px;

margin: 1em auto;

font-family: sans-serif;

}

textarea {

width: 400px;

height: 200px;

}

#message {

color: #900;

}

inside

And finally, we’ll use a new Hamlet template to wrap up the individual components (title, head data, and body data) into the final output:

withUrlRenderer [hamlet|

$doctype 5

<html>

<head>

<title>#{pageTitle pc}

^{pageHead pc}

<body>

$maybe msg <-mmsg

<div #message>#{msg}

^{pageBody pc}

This is a simple function to check if a user is the admin. In a real application, we would likely store the admin bit in the database itself, or check with some external system. For now, I’ve just hardcoded my own email address:

isAdmin ::User->Bool

isAdmin user =userEmail user == "michael@snoyman.com"

In order to access the database we need to create a YesodPersist instance, which says which backend we’re using and how to run an action:

instanceYesodPersistBlogwhere

typeYesodPersistBackendBlog=SqlBackend

runDB f =do

master <-getYesod

let pool =connPool master

runSqlPool f pool

This is a convenience synonym. It is defined automatically for you in the scaffolding:

typeForm x =Html->MFormHandler (FormResult x, Widget)

In order to use yesod-form and yesod-auth, we need an instance of RenderMessage for FormMessage. This allows us to control the i18n of individual form messages:

instanceRenderMessageBlogFormMessagewhere

renderMessage __=defaultFormMessage

In order to use the built-in Nic HTML editor, we need this instance. We just take the default values, which use a CDN-hosted version of Nic:

instanceYesodNicBlog

In order to use yesod-auth, we need a YesodAuth instance:

instanceYesodAuthBlogwhere

typeAuthIdBlog=UserId

loginDest _=HomeR

logoutDest _=HomeR

authHttpManager =httpManager

We’ll use BrowserID (a.k.a., Mozilla Persona), which is a third-party system using email addresses as identifiers. This makes it easy to switch to other systems in the future, such as locally authenticated email addresses (also included with yesod-auth):

authPlugins _= [authBrowserId def]

This function takes someone’s login credentials (i.e., email address) and gives back a UserId:

getAuthId creds =do

let email =credsIdent creds

user =User email

res <-runDB $ insertBy user

return $ Just $ either entityKey id res

We also need to provide a YesodAuthPersist instance to work with Persistent:

instanceYesodAuthPersistBlog

The one important detail in the homepage handler is our usage of setTitleI, which allows us to use i18n messages for the title. We also use this message with a _{Msg…} interpolation in Hamlet:

getHomeR ::HandlerHtml

getHomeR =defaultLayout $ do

setTitleI MsgHomepageTitle

[whamlet|

<p>_{MsgWelcomeHomepage}

<p>

<a href=@{BlogR}>_{MsgSeeArchive}

Next, we define a form for adding new entries. We want the user to provide the title and content, and then we fill in the post date automatically via getCurrentTime.

Note that slightly strange lift (liftIO getCurrentTime) manner of running an IO action. The reason is that applicative forms are not monads, and therefore cannot be instances of MonadIO. Instead, we use lift to run the action in the underlying Handler monad, and liftIO to convert the IO action into a Handler action:

entryForm ::FormEntry

entryForm =renderDivs $ Entry

<$> areq textField (fieldSettingsLabel MsgNewEntryTitle) Nothing

<*> lift (liftIO getCurrentTime)

<*> areq nicHtmlField (fieldSettingsLabel MsgNewEntryContent) Nothing

Here we get the list of all blog entries, and present an admin with a form to create a new entry:

getBlogR ::HandlerHtml

getBlogR =do

muser <-maybeAuth

entries <-runDB $ selectList [] [DescEntryPosted]

(entryWidget, enctype) <-generateFormPost entryForm

defaultLayout $ do

setTitleI MsgBlogArchiveTitle

[whamlet|

$if null entries

<p>_{MsgNoEntries}

$else

<ul>

$forall Entity entryId entry <-entries

<li>

<a href=@{EntryR entryId}>#{entryTitle entry}

We have three possibilities: the user is logged in as an admin, the user is logged in and is not an admin, and the user is not logged in. In the first case, we should display the entry form. In the second, we’ll do nothing. In the third, we’ll provide a login link:

$maybe Entity_ user <-muser

$if isAdmin user

^{entryWidget}

<div>

$nothing

<p>

<a href=@{AuthRLoginR}>_{MsgLoginToPost}

Next, we need to process an incoming entry addition. We don’t do any permissions checking, because isAuthorized handles it for us. If the form submission was valid, we add the entry to the database and redirect to the new entry. Otherwise, we ask the user to try again:

postBlogR ::HandlerHtml

postBlogR =do

((res, entryWidget), enctype) <-runFormPost entryForm

case res of

FormSuccess entry ->do

entryId <-runDB $ insert entry

setMessageI $ MsgEntryCreated $ entryTitle entry

redirect $ EntryR entryId

_->defaultLayout $ do

setTitleI MsgPleaseCorrectEntry

[whamlet|

^{entryWidget}

<div>

Next up is a form for comments, very similar to our entryForm. It takes the EntryId of the entry the comment is attached to. By using pure, we embed this value in the resulting Comment output, without having it appear in the generated HTML:

commentForm ::EntryId->FormComment

commentForm entryId =renderDivs $ Comment

<$> pure entryId

<*> lift (liftIO getCurrentTime)

<*> lift requireAuthId

<*> areq textField (fieldSettingsLabel MsgCommentName) Nothing

<*> areq textareaField (fieldSettingsLabel MsgCommentText) Nothing

We show an individual entry, comments, and an add comment form if the user is logged in:

getEntryR ::EntryId->HandlerHtml

getEntryR entryId =do

(entry, comments) <-runDB $ do

entry <-get404 entryId

comments <-selectList [CommentEntry ==. entryId] [AscCommentPosted]

return (entry, map entityVal comments)

muser <-maybeAuth

(commentWidget, enctype) <-

generateFormPost (commentForm entryId)

defaultLayout $ do

setTitleI $ MsgEntryTitle $ entryTitle entry

[whamlet|

<h1>#{entryTitle entry}

<article>#{entryContent entry}

<h1>_{MsgCommentsHeading}

$if null comments

<p>_{MsgNoComments}

$else

$forall Comment _entry posted _user name text <-comments

<span .by>#{name}

<span .at>#{show posted}

<div .content>#{text}

<h1>_{MsgAddCommentHeading}

$maybe _<-muser

^{commentWidget}

<div>

$nothing

<p>

<a href=@{AuthRLoginR}>_{MsgLoginToComment}

Here’s how we receive an incoming comment submission:

postEntryR ::EntryId->HandlerHtml

postEntryR entryId =do

((res, commentWidget), enctype) <-

runFormPost (commentForm entryId)

case res of

FormSuccess comment ->do

_<-runDB $ insert comment

setMessageI MsgCommentAdded

redirect $ EntryR entryId

_->defaultLayout $ do

setTitleI MsgPleaseCorrectComment

[whamlet|

^{commentWidget}

<div>

Finally, our main function:

main ::IO ()

main =do

pool <-runStdoutLoggingT $ createSqlitePool "blog.db3" 10

-- create a new pool

-- perform any necessary migration

runSqlPersistMPool (runMigration migrateAll) pool

manager <-newManager tlsManagerSettings -- create a new HTTP manager

warp 3000 $ Blog pool manager -- start our server