Bastian Holst: Multiple Button Forms in Yesod

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
                |]

Multiple Button Forms in Yesod

Edit

Comments

Add a Comment