identifyForm bug when there are 2 form and one of them have no field (already fixed https://github.com/yesodweb/yesod/pull/1340)

README

to write this later

identifyForm-bug.cabal

name: identifyForm-bug
version: 0.0.0
cabal-version: >= 1.8
build-type: Simple

executable identifyForm-bug
    main-is: main.hs
    hs-source-dirs: .
    build-depends: base,
                   yesod,
                   text
    ghc-options: -Wall

main.hs

{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings #-}

import Yesod
import Data.Monoid
import Data.Text

data App = App

instance Yesod App where
  shouldLog _ _ = (LevelDebug <=)

instance RenderMessage App FormMessage where
  renderMessage _ _ = defaultFormMessage

mkYesod "App" [parseRoutes|
  / HomeR GET POST
|]

getHomeR :: Handler Html
getHomeR = homeR

postHomeR :: Handler Html
postHomeR = homeR

homeR :: Handler Html
homeR = do
  ((result0, widget0), enctype0) <- runFormPost form0
  ((result1, widget1), enctype1) <- runFormPost form1
  logFormResult "form 0" result0
  logFormResult "form 1" result1
  defaultLayout [whamlet|
    <form method=post action=@{HomeR} enctype=#{enctype0}>
      ^{widget0}
      <button>form 0 button
    <form method=post action=@{HomeR} enctype=#{enctype1}>
      ^{widget1}
      <button>form 1 button
  |]

form0 :: Html -> MForm Handler (FormResult (Maybe Text), Widget)
form0 = identifyForm "form 0" $ renderDivs $ aopt textField "form 0 text" Nothing

form1 :: Html -> MForm Handler (FormResult (), Widget)
form1 = identifyForm "form 1" $ renderDivs $ pure ()

logFormResult :: MonadLogger m => Text -> FormResult t -> m ()
logFormResult tag result = $(logDebug) $ (tag <>) $ case result of
                                                        FormSuccess _ -> " success"
                                                        FormFailure _ -> " failure"
                                                        FormMissing   -> " missing"

main :: IO ()
main = warp 4000 App

stack.yaml

resolver: lts-8.11
packages:
- '.'
extra-deps: []
flags: {}
extra-package-dbs: []