Carlo Hamalainen


Monadic Yesod form with ReCAPTCHA

2016-05-08

Applicative forms in Yesod are nifty but they don't let you customise layout, CSS, and so on. I had this form for comments on my blog:

commentFormOLD :: EntryId -> Form Comment
commentFormOLD entryId = renderDivs $ Comment
    <$> pure entryId
    <*> lift (liftIO getCurrentTime)
    <*> areq textField (fieldSettingsLabel MsgCommentName) Nothing
    <*> aopt emailField (fieldSettingsLabel MsgCommentEmail) Nothing
    <*> aopt urlField (fieldSettingsLabel MsgCommentUrl) Nothing
    <*> areq htmlField (fieldSettingsLabel MsgCommentText) Nothing
    <*> pure False <* recaptchaAForm

I wanted to tweak the layout so I had to convert it to a monadic form. The only quirk was that the second part of the return value of recaptchaMForm is of type [FieldView site], not FieldView site. It looks like the first element of the list does the job for rendering the Yesod-ReCAPTCHA widget. So we set

    let recapView0 = recapView DL.!! 0

and then write

                <p>
                    ^{fvInput recapView0}

in the whamlet.

Here's the full function. Note the fvId bits where we can specify the width and height. Also, to the form as a parameter to generateFormPost, we must have a parameter of type Html. So we put the EntryId at the front so that we can use Currying.

commentForm :: EntryId -> Html -> MForm Handler (FormResult Comment, Widget)
commentForm entryId extra = do
    (nameRes, nameView)     <- mreq textField  (fieldSettingsLabel MsgCommentName)  Nothing
    (emailRes, emailView)   <- mopt emailField (fieldSettingsLabel MsgCommentEmail) Nothing
    (urlRes, urlView)       <- mopt urlField   (fieldSettingsLabel MsgCommentUrl)   Nothing
    (textRes, textView)     <- mreq htmlField  (fieldSettingsLabel MsgCommentText)  Nothing

    (recapRes, recapView)   <- recaptchaMForm

    let recapView0 = recapView DL.!! 0

    now <- liftIO getCurrentTime

    let c = Comment
              <$> pure entryId
              <*> pure now
              <*> nameRes
              <*> emailRes
              <*> urlRes
              <*> textRes
              <*> pure False <* recapRes

    let widget = do
            toWidget
                [lucius|
                    ##{fvId nameView} {
                        width: 70ch;
                    }
                    ##{fvId emailView} {
                        width: 70ch;
                    }
                    ##{fvId urlView} {
                        width: 70ch;
                    }
                    ##{fvId textView} {
                        width: 120ch;
                        height: 120ch;
                    }
                |]
            [whamlet|
                #{extra}
                <p>
                    Name                 #
                <p>
                    ^{fvInput nameView}
                <p>
                    \ Email (not shown)  #
                <p>
                    ^{fvInput emailView}
                <p>
                    \ URL (optional)     #
                <p>
                    ^{fvInput urlView}
                <p>
                    \ Comment            #
                <p>
                    ^{fvInput textView}
                <p>
                    ^{fvInput recapView0}
            |]

    return (c, widget)


The diff starting from line 71 shows the change in Handler/Home.hs: ce76215f72cbcf748bef89bfa3b09a077ceb9ab9#diff-1d7a37a0e3408faaa1abf31093eb8a50L71.