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 #-}
import
Yesod
import
Yesod.Auth
import
Yesod.Form.Nic
(
YesodNic
,
nicHtmlField
)
import
Yesod.Auth.BrowserId
(
authBrowserId
,
def
)
import
Data.Text
(
Text
)
import
Network.HTTP.Client.TLS
(
tlsManagerSettings
)
import
Network.HTTP.Conduit
(
Manager
,
newManager
)
import
Database.Persist.Sqlite
(
ConnectionPool
,
SqlBackend
,
runSqlPool
,
runMigration
,
createSqlitePool
,
runSqlPersistMPool
)
import
Data.Time
(
UTCTime
,
getCurrentTime
)
import
Control.Applicative
((
<$>
),
(
<*>
),
pure
)
import
Data.Typeable
(
Typeable
)
import
Control.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
Text
UniqueUser
In order to work with yesod-auth
’s caching, our User
type must be an instance of Typeable
:
deriving
Typeable
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:
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:
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
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:
instance
Yesod
Blog
where
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
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:
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
(
AuthR
LoginR
)
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
:
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:
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
==
"[email protected]"
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:
instance
YesodPersist
Blog
where
type
YesodPersistBackend
Blog
=
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:
type
Form
x
=
Html
->
MForm
Handler
(
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:
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:
instance
YesodNic
Blog
In order to use yesod-auth
, we need a YesodAuth
instance:
instance
YesodAuth
Blog
where
type
AuthId
Blog
=
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
=
credsIdent
creds
user
=
User
res
<-
runDB
$
insertBy
user
return
$
Just
$
either
entityKey
id
res
We also need to provide a YesodAuthPersist
instance to work with Persistent:
instance
YesodAuthPersist
Blog
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
::
Handler
Html
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
::
Form
Entry
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
::
Handler
Html
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:
$
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
}
|
]
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
::
Handler
Html
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
}
>
|
]
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
->
Form
Comment
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
->
Handler
Html
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
}
|
]
Here’s how we receive an incoming comment submission:
postEntryR
::
EntryId
->
Handler
Html
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:
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