I am implementing a "contact me" form that will send an email when it is submitted. I needed this form to emit custom HTML, so I ended up using monadic forms. The problem is that I do not know how to use a monadic form.
the code is below. I have omitted the part that sends e-mail for brevity. the problem is that my form never validates correctly. the form result is never FormSuccess in my postContactR function.
It seems that I do not initialize the form correctly when I call runFormPost inside postContactR. I always pass Nothing instead of the actual ContactData to contactForm and I do not know how to construct my ContactData from the request. Is my understanding of the problem correct? I am trying to work with poorly documented features. :)
any help?
EDIT: what looks strange is that validation errors do show up in the form if I submit an invalid form, so the request data does get read at some point. what does not work is that when there are no errors I do not get redirected to RootR
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Handler.Contact where
import Control.Applicative ((<$>), (<*>))
import Data.Text (Text)
import Foundation
import Network.Mail.Mime
data ContactData = ContactData
{ contactName :: Text
, contactEmail :: Text
, contactMessage :: Textarea
}
deriving Show
contactForm d = \html -> do
(r1, v1) <- mreq textField "Your name:" (contactName <$> d)
(r2, v2) <- mreq emailField "Your e-mail:" (contactEmail <$> d)
(r3, v3) <- mreq textareaField "Message:" (contactMessage <$> d)
let views = [v1, v2, v3]
return (ContactData <$> r1 <*> r2 <*> r3, $(widgetFile "contact-form"))
getContactR :: Handler RepHtml
getContactR = do
((_, form), _) <- runFormPost (contactForm Nothing)
defaultLayout $ do
setTitle "contact"
addWidget $(widgetFile "contact")
postContactR :: Handler RepHtml
postContactR = do
((r, form), _) <- runFormPost (contactForm Nothing)
case r of
FormSuccess d -> do
sendEmail d
setMessage "Message sent"
redirect RedirectTemporary RootR
_ -> getContactR
Are you including the html value in contact-form.hamlet? It's a nonce value. You'd get better debug information if you printed the value of r (in postContactR).
I have on my writing TODO list to add a monadic form example, it should be up soon.
Related
The code below is from the Home.hs file created by the yesod-simple scaffold.
I like to do simple string manipulation on text input but don't know how to parse it into a Text value.
How, for example, can I use toUpper on fileDescription?
I've tried using lookupPostParam
but I'm struggling with it's type signature:
lookupPostParam :: MonadHandler m => Text -> m (Maybe Text)
Home.hs
module Handler.Home where
import Import
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
import Text.Julius (RawJS (..))
data FileForm = FileForm
{ fileInfo :: FileInfo
, fileDescription :: Text
}
getHomeR :: Handler Html
getHomeR = do
(formWidget, formEnctype) <- generateFormPost sampleForm
let submission = Nothing :: Maybe FileForm
handlerName = "getHomeR" :: Text
defaultLayout $ do
let (commentFormId, commentTextareaId, commentListId) = commentIds
aDomId <- newIdent
setTitle "Welcome To Yesod!"
$(widgetFile "homepage")
postHomeR :: Handler Html
postHomeR = do
((result, formWidget), formEnctype) <- runFormPost sampleForm
let handlerName = "postHomeR" :: Text
submission = case result of
FormSuccess res -> Just res
_ -> Nothing
defaultLayout $ do
let (commentFormId, commentTextareaId, commentListId) = commentIds
aDomId <- newIdent
setTitle "Welcome To Yesod!"
$(widgetFile "homepage")
sampleForm :: Form FileForm
sampleForm = renderBootstrap3 BootstrapBasicForm $ FileForm
<$> fileAFormReq "Choose a file"
<*> areq textField textSettings Nothing
where textSettings = FieldSettings
{ fsLabel = "What's on the file?"
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs =
[ ("class", "form-control")
, ("placeholder", "File description")
]
}
commentIds :: (Text, Text, Text)
commentIds = ("js-commentForm", "js-createCommentTextarea", "js-
commentList")
This is unfortunately a fault in documentation and communication.
Given
lookupPostParam :: (MonadResource m, MonadHandler m) => Text -> m (Maybe Text)
the reader is meant to infer that m is not only a MonadResouce and a MonadHandler but also Monad. This tiny little line of code packs up a lot of intent into a very small sentence; it's a wart that so much of Haskell library usage is left implicit and subtextual. For example, to call toUpper on the Text inside this type you are meant to do this:
{-# language OverloadedStrings #-}
foo :: (MonadResource m, MonadHandler m) => m (Maybe Text)
foo = do
valueMaybe <- lookupPostParam "key"
case valueMaybe of
Just value ->
pure (toUpper value)
Nothing ->
Nothing
Note that the monad stack (MonadHandler, MonadResource) has "infected" your code. This is meant to be intentional, so as to constrain you via the type checker to only run this function in the intended Yesod environment/state machine/context/whatever.
However
You are using yesod-forms and it would be nice to do the same thing within that framework. As with lookupPostParam, we can take advantage of the monad-applicative-functor typeclasses.
We can adapt this to the Form FileForm value that you have.
sampleForm :: AForm Handler FileForm
sampleForm =
FileForm <$> fileAFormReq "Choose a file"
<*> (toUpper <$> areq textField textSettings Nothing)
I think the types of yesod-forms changed between releases. I'm copying my types off the latest version as of writing, 1.4.11.
Here we take advantage of the Monad m => Functor (AForm m) instance. Knowing that we are indeed in a monad (the Handler monad) means we can use fmap and its infixed sibling <$> on the value returned by areq textField textSettings Nothing. This allows us to lift arbitrary functions acting on Text into the AForm m stack. For example, here we went from Text -> Text to AForm Handler Text -> AForm Handler Text.
Hope that helps.
I have a program where the user can upload a file, some validation of this file takes place, and if the validation fails, I would like to provide feedback to the user via a javascript alert message, rather than via a message embedded in the html itself.
Ideally, once the user has acknowledged the alert message (clicking the alert button), the program can redirect to another route.
Unfortunately the redirection seems to happen right away, without pausing until the user clicks the alert button, so the alert is missed altogether.
Here is a simple snippet which illustrates the problem : the user is asked to pick a file. If it is a text file its name is displayed, otherwise an alert is produced.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
import Yesod
import Control.Concurrent.STM (TVar, newTVarIO, readTVarIO, atomically, writeTVar)
import Data.Text (Text)
data App = App (TVar Text)
mkYesod "App" [parseRoutes|
/ HomeR GET POST
/alert AlertR GET
|]
instance Yesod App
instance RenderMessage App FormMessage where
renderMessage _ _ = defaultFormMessage
getHomeR :: Handler Html
getHomeR = do
(formWidget, formEncType) <- generateFormPost uploadForm
App ttxt <- getYesod
txt <- liftIO $ readTVarIO ttxt
liftIO $ print txt
defaultLayout $ do
[whamlet|
<h1>Text file name: #{txt}
<p>
<form method=post action=#{HomeR} enctype=#{formEncType}>
^{formWidget} #
<input type="submit" value="Upload File Name">
|]
postHomeR :: Handler Html
postHomeR = do
((result, _), _) <- runFormPost uploadForm
case result of
FormSuccess fi -> do
app <- getYesod
case fileContentType fi of
"text/plain" -> updateFileName app $ fileName fi
_ -> redirect AlertR
_ -> return ()
redirect HomeR
updateFileName :: App -> Text -> Handler ()
updateFileName app#(App ttxt) txtnew =
liftIO . atomically $ writeTVar ttxt txtnew
getAlertR :: Handler Html
getAlertR = do
defaultLayout $ do
setTitle "ALERT!"
toWidgetBody [julius|
alert("Only text files are accepted");
|]
redirect HomeR
uploadForm = renderDivs $ fileAFormReq "file"
main :: IO ()
main = do
ttxt <- newTVarIO "nil"
warp 3000 $ App ttxt
So this does not work and, in getAlertR, the redirect HomeR code does not "wait" until the user clicks the alert button (in fact the alert is not even displayed).
To get around the issue I have changed getAlertR like that :
getAlertR :: Handler Html
getAlertR = do
defaultLayout $ do
setTitle "ALERT!"
toWidgetBody [julius|
alert("Only text files are accepted");
location.assign("#{HomeR}");
|]
-- redirect HomeR
... which works ok.
But here is my question : is there a more "Yesod-like" way to do this without having the routing inside the julius script?
This is basically an "outside the scope of Yesod" issue: if you want the behavior to occur based on a user responding to an alert box, it has to be handled in Javascript, in which can your approach works quite well. Once within the Javascript world, there are dozens/hundreds of different ways of doing this (automatically using a timer? use a notification message on the page instead of a separate dialog? etc), but there's nothing you can do server side to check that the user has clicked a button without Javascript support.
Let's say we have something like this:
myForm :: Form (Text, Text)
myForm = renderBootstrap3 BootstrapBasicForm $ (,)
<$> areq passwordField (bfs ("Password" :: Text)) Nothing
<*> areq passwordField (bfs ("Repeat password" :: Text)) Nothing
Is it possible to check whether the both field are the same? Validation is
described here,
check
seems to be not powerful enough to perform this sort of check. Maybe
checkM
may be of some use?
If it's not possible to do with built-in Yesod facilities, what would be the
best work-around? I can think of:
postSomethingR :: Handler Html
postSomethingR = do
((result, form), enctype) <- runFormPost myForm
case result of
FormSuccess (password0, password1) -> do
if password0 == password1
then
-- do your thing
else
-- serve the form again and perhaps set message telling that
-- passwords don't match?
This is a working example of a custom password field that checks if the input from both boxes were the same. This comparison is created in the record fieldParse.
To run this example from cmd: stack runghc <filename.hs>
{-# 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
|]
instance Yesod App
instance RenderMessage App FormMessage where
renderMessage _ _ = defaultFormMessage
passwordConfirmField :: Field Handler Text
passwordConfirmField = Field
{ fieldParse = \rawVals _fileVals ->
case rawVals of
[a, b]
| a == b -> return $ Right $ Just a
| otherwise -> return $ Left "Passwords don't match"
[] -> return $ Right Nothing
_ -> return $ Left "You must enter two values"
, fieldView = \idAttr nameAttr otherAttrs eResult isReq ->
[whamlet|
<input id=#{idAttr} name=#{nameAttr} *{otherAttrs} type=password>
<div>Confirm:
<input id=#{idAttr}-confirm name=#{nameAttr} *{otherAttrs} type=password>
|]
, fieldEnctype = UrlEncoded
}
getHomeR :: Handler Html
getHomeR = do
((res, widget), enctype) <- runFormGet $ renderDivs $
areq passwordConfirmField "Password" Nothing
defaultLayout
[whamlet|
<p>Result: #{show res}
<form enctype=#{enctype}>
^{widget}
<input type=submit value="Change password">
|]
main :: IO ()
main = warp 3000 App
This is a follow-up to my question here: Extracting database field values inside a Handler
I would like to extract some information from the database and pass it in as a label value for a form. However, I get a type error.
A simple demonstration below (shell code from the Yesod Book):
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
import Control.Applicative ((<$>), (<*>))
import Data.Text (Text)
import Data.Time (Day)
import Yesod
import Yesod.Form.Jquery
data App = App
mkYesod "App" [parseRoutes|
/ HomeR GET
|]
instance Yesod App
instance RenderMessage App FormMessage where
renderMessage _ _ = defaultFormMessage
instance YesodJquery App
data Person = Person
{ personName :: Text
}
deriving Show
personForm :: Text -> Html -> MForm Handler (FormResult Person, Widget)
personForm n1 = renderDivs $ Person
<$> areq textField n1 Nothing -- Changing n1 to "Name" works just fine.
getHomeR :: Handler Html
getHomeR = do
(widget, enctype) <- generateFormPost $ personForm "test"
defaultLayout
[whamlet|
<p>
The widget generated contains only the contents
of the form, not the form tag itself. So...
|]
main :: IO ()
main = warp 3000 App
When I run the program with runhaskell, I get the following error:
Couldn't match expected type `FieldSettings site0'
with actual type `Text'
In the second argument of `areq', namely `n1'
In the second argument of `(<$>)', namely
`areq textField n1 Nothing'
In the second argument of `($)', namely
`Person <$> areq textField n1 Nothing'
I also tried (FieldSettings n1 Nothing Nothing Nothing []) but no luck. Any thoughts on how to pass in label values to areq?
Let us look at the type of areq
areq :: (RenderMessage master msg, RenderMessage master FormMessage) => Field sub master a -> FieldSettings msg -> Maybe a -> AForm sub master a
So the areq function doesn't expect a Text value as its second parameter, it expects a FieldSettings msg. So what is the reason that it works when you write "Name" in your source code?
Looking up the documentation for FieldSettings in the documentation for yesod-forms we see that it is a datatype that has an IsString instance. Looking at the specific instance in the source code
we see that:
instance (a ~ Text) => IsString (FieldSettings a) where
fromString s = FieldSettings (fromString s) Nothing Nothing Nothing []
So everytime you write a String in your source code (if the OverloadedStrings extension is enabled), the compiler will insert the contents of the fromString instance.
However, you don't want to enter a String, but instead you want to create a FieldSettings from a Text value. Looking further we see that the first part of a FieldSettings is a SomeMessage, checking the documentation yet again and the source we see that a SomeMessage can be created by using the SomeMessage constructor.
personForm :: Text -> Html -> MForm Handler (FormResult Person, Widget)
personForm n1 = renderDivs $ Person
<$> areq textField (FieldSettings (SomeMessage n1) Nothing Nothing Nothing []) Nothing
I have a doubt of why is this happening. I have been following the "Yesod Web" ebook but with a scaffolded site. When I arrived to a position that I wanted to apply the function of "plural" inside a "messages" file, the compiler returns this error:
Foundation.hs:52:1: Not in scope: `plural'
Where plural is declared in the same hs file as the one that I am calling the "hamlet" one. However, if I move the function declaration before the line #52 in the "Foundation.hs" file, then the error vanishes and it let me compile it effectively. Why does this happen??
module Handler.UserProfile where
import Import
import Data.Maybe (fromMaybe)
import Data.Text (pack, unpack)
viewCountName :: Text
viewCountName = "UserProfileViews"
readInt :: String -> Int
readInt = read
plural :: Int -> String -> String -> String
plural 1 x _ = x
plural _ _ y = y
getUserProfileR :: Handler RepHtml
getUserProfileR = do
viewCount <- lookupSession viewCountName
>>= return . (1 +) . readInt . unpack . fromMaybe "0"
setSession viewCountName (pack $ show viewCount)
maid <- maybeAuth
--msg <- getMessageRender
let user = case maid of
Nothing -> "(Unknown User ID)" --show MsgHello --
Just (Entity _ u) -> userEmail u
defaultLayout $ do
setTitleI MsgUserProfile
$(widgetFile "nhUserProfile")
Take a look at the GHC users manual: http://www.haskell.org/ghc/docs/7.4.2/html/users_guide/template-haskell.html#id684916
The staging restriction in play is described in the second bullet point:
You can only run a function at compile time if it is imported from
another module. That is, you can't define a function in a module, and
call it from within a splice in the same module. (It would make sense
to do so, but it's hard to implement.)