View source on Github

This is 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 templates.

While in general we recommend placing templates, Persist entity definitions, and routing in separate files, we'll keep it all in one file here for convenience. The one exception you'll see below 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.

1 2 3 {-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes, TemplateHaskell, GADTs, FlexibleContexts, MultiParamTypeClasses #-}

Now our imports.

4 5 6 7 8 9 10 11 12 13 14 15 import Yesod import Yesod.Auth import Yesod.Form.Nic ( YesodNic , nicHtmlField) import Yesod.Auth.BrowserId (authBrowserId) import Data.Text ( Text ) import Network.HTTP.Conduit ( Manager , newManager, def) import Database.Persist.Sqlite ( ConnectionPool , SqlPersist , runSqlPool, runMigration , createSqlitePool ) import Data.Time ( UTCTime , getCurrentTime) import Control.Applicative ((<$>), (<*>), pure)

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

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

Keeps track of users. In a more robust application, we would also keep account creation date, display name, etc.

17 18 19 User email Text UniqueUser email

An individual blog entry (I've avoided using the word "post" due to the confusion with the request method POST).

20 21 22 23 Entry title Text posted UTCTime content Html

We need to tack on this "deriving" line since Html doesn't specify instances for Read, Show or Eq. If you get an error message about "cannot derive" in your own code, try adding the deriving statement.

24 deriving

And a comment on the blog post.

25 26 27 28 29 30 31 Comment entry EntryId posted UTCTime user UserId name Text text Textarea |]

Every site has a foundation datatype. 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 this file for how those are initialized.

32 33 34 35 data Blog = 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.

36 mkMessage "Blog" "../messages-blog" "en"

Our en.msg message file contains the following content:

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.

37 38 39 40 41 42 mkYesod "Blog" [parseRoutes| / RootR GET /blog BlogR GET POST /blog/# EntryId EntryR GET POST /auth AuthR Auth getAuth |]

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

43 instance Yesod Blog where

The base of our application. Note that in order to make BrowserID work properly, this must be a valid URL.

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

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 or not a request is a write request, given by the True in the second field.

First, we'll authorize requests to add a new entry.

45 46 47 48 49 50 51 isAuthorized BlogR True = 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.

52 53 54 55 56 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.

57 isAuthorized _ _ = return Authorized

Where a user should be redirected to if they get an AuthenticationRequired.

58 authRoute _ = Just ( AuthR LoginR )

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

59 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.

60 mmsg <- getMessage

We use widgets to compose together HTML, CSS and Javascript. 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 for all pages. We'll use the Lucius template language to create the latter.

61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 pc <- widgetToPageContent $ do toWidget [lucius| body { width: 760 px; margin: 1 em auto; font-family: sans-serif; } textarea { width: 400 px; height: 200 px; } #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.

77 78 79 80 81 82 83 84 85 86 87 hamletToRepHtml [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 hard-coded my own email address.

88 89 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.

90 91 92 93 94 95 instance YesodPersist Blog where type YesodPersistBackend Blog = SqlPersist 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.

96 type Form x = Html -> MForm Blog Blog ( 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.

97 98 instance RenderMessage Blog FormMessage where 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.

99 instance YesodNic Blog

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

100 101 102 103 104 instance YesodAuth Blog where type AuthId Blog = UserId loginDest _ = RootR logoutDest _ = RootR authHttpManager = httpManager

We'll use BrowserID, which is a third-party system using email addresses as your identifier. This makes it easy to switch to other systems in the future, locally authenticated email addresses (also included with yesod-auth).

105 authPlugins _ = [authBrowserId]

This function takes someone's login credentials (i.e., his/her email address) and gives back a UserId.

106 107 108 109 110 getAuthId creds = do let email = credsIdent creds user = User email res <- runDB $ insertBy user return $ Just $ either entityKey id res

Homepage handler. The one important detail here 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.

111 112 113 114 115 116 117 118 getRootR :: Handler RepHtml getRootR = defaultLayout $ do setTitleI MsgHomepageTitle [whamlet| <p>_{ MsgWelcomeHomepage } <p> <a href=@{ BlogR }>_{ MsgSeeArchive } |]

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

119 120 121 122 123 entryForm :: Form Entry entryForm = renderDivs $ Entry <$> areq textField (fieldSettingsLabel MsgNewEntryTitle ) Nothing <*> aformM (liftIO getCurrentTime) <*> areq nicHtmlField (fieldSettingsLabel MsgNewEntryContent ) Nothing

Get the list of all blog entries, and present an admin with a form to create a new entry.

124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 getBlogR :: Handler RepHtml getBlogR = do muser <- maybeAuth entries <- runDB $ selectList [] [ Desc EntryPosted ] ((_, 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.

139 140 141 142 143 144 145 146 147 148 $maybe Entity _ user <- muser $ if isAdmin user <form method=post enctype=#{enctype}> ^{entryWidget} <div> <input type =submit value=_{ MsgNewEntry }> $nothing <p> <a href=@{ AuthR LoginR }>_{ MsgLoginToPost } |]

Process an incoming entry addition. We don't do any permissions checking, since 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.

149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 postBlogR :: Handler RepHtml 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| <form method=post enctype=#{enctype}> ^{entryWidget} <div> <input type =submit value=_{ MsgNewEntry }> |]

A form for comments, very similar to our entryForm above.

165 166 167 168 169 170 171 commentForm :: EntryId -> Form Comment commentForm entryId = renderDivs $ Comment <$> pure entryId <*> aformM (liftIO getCurrentTime) <*> aformM requireAuthId <*> areq textField (fieldSettingsLabel MsgCommentName ) Nothing <*> areq textareaField (fieldSettingsLabel MsgCommentText ) Nothing

Show an individual entry, comments, and an add comment form if the user is logged in.

172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 getEntryR :: EntryId -> Handler RepHtml getEntryR entryId = do (entry, comments) <- runDB $ do entry <- get404 entryId comments <- selectList [CommentEntry ==. entryId] [ Asc CommentPosted ] 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} <section .comments> <h1>_{ MsgCommentsHeading } $ if null comments <p>_{ MsgNoComments } $ else $forall Comment _entry posted _user name text <- comments <div .comment> <span .by>#{name} <span .at>#{show posted} <div .content>#{text} <section> <h1>_{ MsgAddCommentHeading } $maybe _ <- muser <form method=post enctype=#{enctype}> ^{commentWidget} <div> <input type =submit value=_{ MsgAddCommentButton }> $nothing <p> <a href=@{ AuthR LoginR }>_{ MsgLoginToComment } |]

Receive an incoming comment submission.

207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 postEntryR :: EntryId -> Handler RepHtml 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| <form method=post enctype=#{enctype}> ^{commentWidget} <div> <input type =submit value=_{ MsgAddCommentButton }> |]

Finally our main function.