As I am a big fan of type-safe programming in Haskell, I want to run my blog on a Haskell Software as well. I decided to use Yesod to write a dynamic web site and here it is. However, at the beginning of the development, I was relatively new to both, web development and Yesod, so I had a few obstacles to overcome.
This blog post is about a relatively easy task, for which I could not find working examples: writing forms with multiple buttons. Michael Snoyman, a creator of Yesod, recommends a similar technique in this stack overflow question. I started with a simple page to add a new entry.
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
import Control.Applicative
import Data.Text (Text)
import Yesod
data App = App
mkYesod "App" [parseRoutes|
/ HomeR GET POST
|]
instance Yesod App
instance RenderMessage App FormMessage where
renderMessage _ _ = defaultFormMessage
data Entry = Entry
{ entryTitle :: Text
, entryContent :: Textarea
}
deriving Show
entryForm :: Html -> MForm Handler (FormResult Entry, Widget)
entryForm = renderDivs $ Entry
<$> areq textField "Title" Nothing
<*> areq textareaField "Content" Nothing
getHomeR :: Handler Html
getHomeR = do
(widget, enctype) <- generateFormPost entryForm
defaultLayout $ do
setTitle "Add Blog Entry"
[whamlet|
<div .container>
<h1>Add Blog Entry
<form method=post enctype=#{enctype}>
^{widget}
<button type=submit>Save
|]
postHomeR :: Handler Html
postHomeR = do
((res, widget), enctype) <- runFormPost entryForm
case res of
FormSuccess entry ->
defaultLayout $ do
setTitle "Entry saved"
[whamlet|
<div .container>
<h1>Entry Saved
|]
_ -> do
defaultLayout $ do
setTitle "Failed Form"
[whamlet|
<div .container>
<h1>Error
|]
main :: IO ()
main = warpEnv App
The program defines the form and two handlers. One handler is for GET
requests and the other is for POST
requests on the root path of the server. Yesod encourages the programmer to use the same path for the form action as for the form itself. This is achieved by omitting the action
attribute of the <form>
-tag.
On a GET
request, the server shows a simple page using the form created by entryForm
. Furthermore, it adds a submit button with the text “Save”.
On a POST
request, the form results are evaluated with runFormPost
. If the form has been filled correctly, the “Entry Saved” page is returned. If it has not, the user sees an error page.
For now, our form has only one button, but adding a second button is simple: The Hamlet code is modified to contain a second preview button. Additionally, to distinguish a click on the submit button from a click on the preview button, the button gets the name “preview” and the value “yes”. This adds the attribute preview=yes
to the content of the POST
request when the user clicks on this button.
getHomeR :: Handler Html
getHomeR = do
(widget, enctype) <- generateFormPost entryForm
defaultLayout $ do
setTitle "Add Blog Entry"
[whamlet|
<div .container>
<h1>Add Blog Entry
<form method=post enctype=#{enctype}>
^{widget}
<button type=submit name=preview value=yes>Preview
<button type=submit>Save
|]
Now, we have to evaluate the Information of the additional field to determine if we have to display a preview or if we have to save the blog entry. Therefore, we run an additional boolField
with the name “preview” corresponding the name of the preview button.
postHomeR :: Handler Html
postHomeR = do
((res, widget), enctype) <- runFormPost entryForm
isPreview <- runInputPost $ iopt boolField "preview"
case res of
FormSuccess entry -> case isPreview of
Just True ->
defaultLayout $ do
setTitle "Preview Entry"
[whamlet|
<div .container>
<h1>#{entryTitle entry}
<article>#{entryContent entry}
|]
_ -> do
defaultLayout $ do
setTitle "Entry saved"
[whamlet|
<div .container>
<h1>Entry Saved
|]
_ -> do
defaultLayout $ do
setTitle "Failed Form"
[whamlet|
<div .container>
<h1>Error
|]
If the post request sets the value of preview
to yes
, on
, or true
, the action returns
Just True
. If it sets preview to no
, off
, or false
, it returns Just False
. If the field preview
is not set at all, the action returns Nothing
. In our case, as we only set the field “preview” when the user clicked the preview button,
we can show the preview if isPreview
equals Just True
. Otherwise, we can expect that the user wants to save the entry. This code example shows only two buttons, but we can add even more buttons in the same way.
I hope this blog post helps the one or other Yesod newbie. If you find any mistakes, please inform me in a comment or e-mail.
Edit
Let's say we want to add a third button to the form to publish the entry. Using the above technique, it would require to add another boolField
to the PUSH
handler. On reddit, Michael Snoyman indicated that there is a function lookupPostParam to lookup arbitrary post parameters. To adapt my form, I decided to add a field action
, which indicates which button has been pushed. Furthermore, we now require the action
parameter.
getHomeR :: Handler Html
getHomeR = do
(widget, enctype) <- generateFormPost entryForm
defaultLayout $ do
setTitle "Add Blog Entry"
[whamlet|
<div .container>
<h1>Add Blog Entry
<form method=post enctype=#{enctype}>
^{widget}
<button type=submit name=action value=preview>Preview
<button type=submit name=action value=save>Save
<button type=submit name=action value=publish>Publish
|]
postHomeR :: Handler Html
postHomeR = do
((res, widget), enctype) <- runFormPost entryForm
action <- lookupPostParam "action"
case (res, action) of
(FormSuccess entry, Just "preview") ->
defaultLayout $ do
setTitle "Preview Entry"
[whamlet|
<div .container>
<h1>#{entryTitle entry}
<article>#{entryContent entry}
|]
(FormSuccess entry, Just "save") ->
defaultLayout $ do
setTitle "Entry saved"
[whamlet|
<div .container>
<h1>Entry Saved
|]
(FormSuccess entry, Just "publish") ->
defaultLayout $ do
setTitle "Entry published"
[whamlet|
<div .container>
<h1>Entry Published
|]
_ -> do
defaultLayout $ do
setTitle "Failed Form"
[whamlet|
<div .container>
<h1>Error
|]