Give field views access to raw multi-input values

jezen · jezen · commit 4d3fcc460fab · 2026-07-29T17:57:04.000+02:00
A field view receives the submitted input as Either Text a, which on
failure only carries the first raw value for the field's name. A field
that renders several inputs under one name -- a composite
amount-plus-currency field, for example -- therefore cannot restore
everything the user typed when the form fails to parse or validate,
whether re-rendered directly or replayed by runFormPRG.

mhelper now records the raw parameter values each field was run
against in a per-request cache, and the new lookupRawFieldInput
function exposes them to views by field name. The store is populated
for direct submissions and Post/Redirect/Get replays alike, and is
empty for generateFormPost runs and identifyForm-wrapped forms that
were not submitted, so views fall back to their defaults exactly as
before.

The addition is backwards compatible: no existing signature changes,
and the cache write is observable only through the new function.
diff --git a/yesod-form/ChangeLog.md b/yesod-form/ChangeLog.md
@@ -1,5 +1,15 @@
 # ChangeLog for yesod-form
 
+## 1.7.11
+
+* Add `lookupRawFieldInput`, giving field views access to all raw
+  parameter values the named field was run against — whether from a
+  direct submission or a `runFormPRG` replay. The `Either Text a`
+  argument a view receives only carries the first submitted value, so
+  fields rendering several inputs under one name (e.g. a composite
+  amount-plus-currency field) previously could not restore the user's
+  input after a failed submission.
+
 ## 1.7.10.1
 
 * Move the `runFormPRG` integration tests to yesod-test's test suite,
diff --git a/yesod-form/Yesod/Form/Functions.hs b/yesod-form/Yesod/Form/Functions.hs
@@ -60,6 +60,7 @@ module Yesod.Form.Functions
     , convertField
     , addClass
     , removeClass
+    , lookupRawFieldInput
     ) where
 
 import Yesod.Form.Types
@@ -70,6 +71,7 @@ import Control.Monad.Trans.Class
 import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST, local, mapRWST)
 import Control.Monad.Trans.Writer (runWriterT, writer)
 import Control.Monad (liftM, join, when)
+import Data.IORef (IORef, newIORef, modifyIORef', readIORef)
 import qualified Data.Aeson as A
 import Data.Byteable (constEqBytes)
 import qualified Data.ByteString.Lazy as BL
@@ -227,6 +229,34 @@ mopt :: (site ~ HandlerSite m, MonadHandler m)
      -> MForm m (FormResult (Maybe a), FieldView site)
 mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False
 
+-- | Per-request store of the raw parameter values each field was run
+-- against, keyed by field name; see 'lookupRawFieldInput'.
+newtype RawFieldInput = RawFieldInput (IORef (Map.Map Text [Text]))
+
+rawFieldInputRef :: MonadHandler m => m (IORef (Map.Map Text [Text]))
+rawFieldInputRef = do
+    RawFieldInput ref <- cachedBy "yesod-form-raw-field-input" $
+        fmap RawFieldInput $ liftIO $ newIORef Map.empty
+    return ref
+
+-- | The raw parameter values the named field was run against in this
+-- request, whether from a direct submission or a Post\/Redirect\/Get
+-- replay ('runFormPRG'). Empty if no form containing the field has run
+-- with a submission in this request (e.g. 'generateFormPost', or an
+-- 'identifyForm'-wrapped form that was not the one submitted).
+--
+-- This lets the view of a field rendering several inputs under one name
+-- restore all of the user's raw input after a failed submission: the
+-- @Either Text a@ argument a view receives can only carry the first
+-- submitted value. Only fields run through 'mreq'\/'mopt' (and the
+-- applicative\/widget helpers built on them) record their values here.
+--
+-- @since 1.7.11
+lookupRawFieldInput :: MonadHandler m => Text -> m [Text]
+lookupRawFieldInput name = do
+    ref <- rawFieldInputRef
+    Map.findWithDefault [] name `liftM` liftIO (readIORef ref)
+
 mhelper :: (site ~ HandlerSite m, MonadHandler m)
         => Field m a
         -> FieldSettings site
@@ -250,6 +280,9 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
                 mfs <- askFiles
                 let mvals = fromMaybe [] $ Map.lookup name p
                     files = fromMaybe [] $ mfs >>= Map.lookup name
+                lift $ do
+                    ref <- rawFieldInputRef
+                    liftIO $ modifyIORef' ref $ Map.insert name mvals
                 emx <- lift $ fieldParse mvals files
                 return $ case emx of
                     Left (SomeMessage e) -> (FormFailure [renderMessage site langs e], maybe (Left "") Left (listToMaybe mvals))
diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal
@@ -1,6 +1,6 @@
 cabal-version:   >= 1.10
 name:            yesod-form
-version:         1.7.10.1
+version:         1.7.11
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
diff --git a/yesod-test/test/PRGSpec.hs b/yesod-test/test/PRGSpec.hs
@@ -32,6 +32,8 @@ mkYesod "App" [parseRoutes|
 /two TwoR GET POST
 /corrupt CorruptR GET
 /stale StaleR GET
+/pair PairR GET POST
+/pair-rerender PairRerenderR GET POST
 |]
 
 instance Yesod App where
@@ -78,6 +80,73 @@ numForm name csrf = do
             |]
     return (res, widget)
 
+-- | A composite field rendering two inputs under one name. Its view
+-- restores both raw values via 'lookupRawFieldInput'; the @Either@
+-- argument alone could only restore the first.
+pairField :: Field Handler (Text, Text)
+pairField = Field
+    { fieldParse = \vals _files -> return $ case vals of
+        [a, b]
+            | T.null a && T.null b -> Right Nothing
+            | any ("!" `T.isPrefixOf`) [a, b] ->
+                Left $ SomeMessage ("no exclamations" :: Text)
+            | otherwise -> Right $ Just (a, b)
+        _ -> Right Nothing
+    , fieldView = \theId name _attrs eval isReq -> do
+        raws <- lookupRawFieldInput name
+        let (v1, v2) = case eval of
+                Right (a, b) -> (a, b)
+                Left _ -> case raws of
+                    [a, b] -> (a, b)
+                    _ -> ("", "")
+        [whamlet|
+            <input id=#{theId} name=#{name} value=#{v1} :isReq:required>
+            <input name=#{name} value=#{v2} :isReq:required>
+        |]
+    , fieldEnctype = UrlEncoded
+    }
+
+pairForm :: Html -> MForm Handler (FormResult (Text, Text), Widget)
+pairForm csrf = do
+    (res, view) <- mreq pairField (fs "pair") Nothing
+    let widget = [whamlet|
+            #{csrf}
+            ^{fvInput view}
+            $maybe err <- fvErrors view
+                <p .error>#{err}
+            |]
+    return (res, widget)
+
+getPairR :: Handler Html
+getPairR = do
+    ((_res, widget), enctype) <- runFormPRG pairForm
+    defaultLayout [whamlet|
+        <form method=post action=@{PairR} enctype=#{enctype}>
+            ^{widget}
+            <button>go
+    |]
+
+postPairR :: Handler Html
+postPairR = do
+    ((res, _widget), _enctype) <- runFormPRG pairForm
+    case res of
+        FormSuccess _ -> setMessage "paired" >> redirect PairR
+        _ -> redirect PairR
+
+-- | The non-redirecting counterpart: on failure the POST response
+-- itself re-renders the form, values restored from the live request.
+getPairRerenderR :: Handler Html
+getPairRerenderR = do
+    ((_res, widget), enctype) <- runFormPost pairForm
+    defaultLayout [whamlet|
+        <form method=post action=@{PairRerenderR} enctype=#{enctype}>
+            ^{widget}
+            <button>go
+    |]
+
+postPairRerenderR :: Handler Html
+postPairRerenderR = getPairRerenderR
+
 getFormR :: Handler Html
 getFormR = do
     mmsg <- getMessage
@@ -235,6 +304,31 @@ spec = yesodSpec App $
             statusIs 200
             bodyContains "name=\"name\""
 
+        yit "restores multi-input raw values after a replay (lookupRawFieldInput)" $ do
+            get PairR
+            token <- extractToken
+            postParams PairR token [("pair", "hello"), ("pair", "!bad")]
+            statusIs 303
+            get PairR
+            statusIs 200
+            bodyContains "value=\"hello\""
+            bodyContains "value=\"!bad\""
+            bodyContains "no exclamations"
+
+        yit "restores multi-input raw values on a plain re-render (lookupRawFieldInput)" $ do
+            get PairRerenderR
+            token <- extractToken
+            postParams PairRerenderR token [("pair", "hello"), ("pair", "!bad")]
+            statusIs 200
+            bodyContains "value=\"hello\""
+            bodyContains "value=\"!bad\""
+
+        yit "records nothing for a fresh GET (lookupRawFieldInput)" $ do
+            get PairR
+            statusIs 200
+            bodyContains "value=\"\""
+            bodyNotContains "hello"
+
         yit "keys the stash by path" $ do
             get FormR
             token <- extractToken
