diff --git a/yesod-form/Yesod/Form/Functions.hs b/yesod-form/Yesod/Form/Functions.hs index 516ba22a..9a901108 100644 --- a/yesod-form/Yesod/Form/Functions.hs +++ b/yesod-form/Yesod/Form/Functions.hs @@ -20,6 +20,9 @@ module Yesod.Form.Functions , runFormPost , runFormPostNoNonce , runFormGet + -- * Generate a blank form + , generateFormPost + , generateFormGet -- * Rendering , FormRender , renderTable @@ -39,14 +42,14 @@ import Control.Monad (liftM, join) import Text.Blaze (Html, toHtml) import Yesod.Handler (GHandler, GGHandler, getRequest, runRequestBody, newIdent, getYesod) import Yesod.Core (RenderMessage, liftIOHandler) -import Yesod.Widget (GWidget, GGWidget, whamlet) +import Yesod.Widget (GWidget, whamlet) import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages) import Network.Wai (requestMethod) import Text.Hamlet (html) import Data.Monoid (mempty) import Data.Maybe (listToMaybe, fromMaybe) import Yesod.Message (RenderMessage (..)) -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.IO.Class (MonadIO) import qualified Data.Map as Map #if __GLASGOW_HASKELL__ >= 700 @@ -169,13 +172,20 @@ runFormPost :: RenderMessage master FormMessage => (Html -> Form sub master (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype) runFormPost form = do + env <- postEnv + postHelper form env + +postHelper :: RenderMessage master FormMessage + => (Html -> Form sub master (FormResult a, xml)) + -> Maybe (Env, FileEnv) + -> GHandler sub master ((FormResult a, xml), Enctype) +postHelper form env = do req <- getRequest let nonceKey = "_nonce" let nonce = case reqNonce req of Nothing -> mempty Just n -> [HTML||] - env <- postEnv m <- getYesod langs <- languages ((res, xml), enctype) <- runFormGeneric (form nonce) m langs env @@ -187,6 +197,17 @@ runFormPost form = do _ -> res return ((res', xml), enctype) +-- | Similar to 'runFormPost', except it always ignore the currently available +-- environment. This is necessary in cases like a wizard UI, where a single +-- page will both receive and incoming form and produce a new, blank form. For +-- general usage, you can stick with @runFormPost@. +generateFormPost + :: RenderMessage master FormMessage + => (Html -> Form sub master (FormResult a, xml)) + -> GHandler sub master ((FormResult a, xml), Enctype) +generateFormPost form = postHelper form Nothing + +postEnv :: GHandler sub master (Maybe (Env, FileEnv)) postEnv = do req <- getRequest if requestMethod (reqWaiRequest req) == "GET" @@ -205,13 +226,22 @@ runFormPostNoNonce form = do runFormGet :: (Html -> Form sub master a) -> GHandler sub master (a, Enctype) runFormGet form = do - let key = "_hasdata" - let fragment = [HTML||] gets <- liftM reqGetParams getRequest let env = - case lookup key gets of + case lookup getKey gets of Nothing -> Nothing Just _ -> Just (Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) gets, Map.empty) + getHelper form env + +generateFormGet :: (Html -> Form sub master a) -> GHandler sub master (a, Enctype) +generateFormGet form = getHelper form Nothing + +getKey :: Text +getKey = "_hasdata" + +getHelper :: (Html -> Form sub master a) -> Maybe (Env, FileEnv) -> GHandler sub master (a, Enctype) +getHelper form env = do + let fragment = [HTML||] langs <- languages m <- getYesod runFormGeneric (form fragment) m langs env