htmlField and fixed auth
This commit is contained in:
Michael Snoyman
parent
be3235a0b2
commit
f2e71a6c00
@ -8,18 +8,26 @@
|
||||
-- | Parse forms (and query strings).
|
||||
module Yesod.Form
|
||||
( -- * Data types
|
||||
Form (..)
|
||||
GForm (..)
|
||||
, Form
|
||||
, FormField
|
||||
, FormResult (..)
|
||||
-- * Unwrapping functions
|
||||
, runFormGet
|
||||
, runFormPost
|
||||
, runFormGet'
|
||||
, runFormPost'
|
||||
-- * Type classes
|
||||
, IsForm (..)
|
||||
, IsFormField (..)
|
||||
-- * Pre-built fields
|
||||
, requiredField
|
||||
, stringField
|
||||
, intField
|
||||
, dayField
|
||||
, boolField
|
||||
, htmlField
|
||||
, stringInput
|
||||
, fieldsToTable
|
||||
{- FIXME
|
||||
-- * Create your own formlets
|
||||
@ -60,7 +68,7 @@ import Data.Char (isAlphaNum, toUpper, isUpper)
|
||||
import Data.Maybe (isJust)
|
||||
import Web.Routes.Quasi (SinglePiece)
|
||||
import Data.Int (Int64)
|
||||
import qualified Data.ByteString.Lazy.UTF8
|
||||
import qualified Data.ByteString.Lazy.UTF8 as U
|
||||
import Yesod.Widget
|
||||
|
||||
data FormResult a = FormMissing
|
||||
@ -81,8 +89,8 @@ instance Applicative FormResult where
|
||||
|
||||
data Enctype = UrlEncoded | Multipart
|
||||
instance Show Enctype where
|
||||
show UrlEncoded = "urlencoded"
|
||||
show Multipart = "multipart/mimetype" -- FIXME
|
||||
show UrlEncoded = "application/x-www-form-urlencoded"
|
||||
show Multipart = "multipart/form-data"
|
||||
instance Monoid Enctype where
|
||||
mempty = UrlEncoded
|
||||
mappend UrlEncoded UrlEncoded = UrlEncoded
|
||||
@ -133,6 +141,11 @@ fieldsToTable = mapM_ go
|
||||
$fiErrors.fi$
|
||||
|]
|
||||
|
||||
class IsForm a where
|
||||
toForm :: Maybe a -> Form sub y a
|
||||
class IsFormField a where
|
||||
toFormField :: Html () -> Html () -> Maybe a -> FormField sub y a
|
||||
|
||||
requiredField :: FieldProfile sub y a
|
||||
-> Html () -> Html () -> Maybe a -> FormField sub y a
|
||||
requiredField (FieldProfile parse render mkXml w) label tooltip orig =
|
||||
@ -177,6 +190,8 @@ stringField = FieldProfile
|
||||
|]
|
||||
, fpWidget = \_name -> return ()
|
||||
}
|
||||
instance IsFormField String where
|
||||
toFormField = requiredField stringField
|
||||
|
||||
intField :: FieldProfile sub y Int
|
||||
intField = FieldProfile
|
||||
@ -187,6 +202,8 @@ intField = FieldProfile
|
||||
|]
|
||||
, fpWidget = \_name -> return ()
|
||||
}
|
||||
instance IsFormField Int where
|
||||
toFormField = requiredField intField
|
||||
|
||||
dayField :: FieldProfile sub y Day
|
||||
dayField = FieldProfile
|
||||
@ -202,6 +219,8 @@ dayField = FieldProfile
|
||||
addStylesheetRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css"
|
||||
addHead [$hamlet|%script $$(function(){$$("#$string.name$").datepicker({dateFormat:'yy-mm-dd'})})|]
|
||||
}
|
||||
instance IsFormField Day where
|
||||
toFormField = requiredField dayField
|
||||
|
||||
boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool
|
||||
boolField label tooltip orig = GForm $ \env _ -> do
|
||||
@ -224,6 +243,23 @@ boolField label tooltip orig = GForm $ \env _ -> do
|
||||
_ -> string ""
|
||||
}
|
||||
return (res, [fi], UrlEncoded)
|
||||
instance IsFormField Bool where
|
||||
toFormField = boolField
|
||||
|
||||
htmlField :: FieldProfile sub y (Html ())
|
||||
htmlField = FieldProfile
|
||||
{ fpParse = Right . preEscapedString
|
||||
, fpRender = U.toString . renderHtml
|
||||
, fpHamlet = \name val isReq -> [$hamlet|
|
||||
%textarea#$name$!name=$name$ $val$
|
||||
|]
|
||||
, fpWidget = \name -> do
|
||||
addScriptRemote "http://js.nicedit.com/nicEdit-latest.js"
|
||||
addHead [$hamlet|%script bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$string.name$")})|]
|
||||
addStyle [$hamlet|\#$string.name${min-width:400px;min-height:300px}|]
|
||||
}
|
||||
instance IsFormField (Html ()) where
|
||||
toFormField = requiredField htmlField
|
||||
|
||||
readMay :: Read a => String -> Maybe a
|
||||
readMay s = case reads s of
|
||||
@ -232,6 +268,17 @@ readMay s = case reads s of
|
||||
|
||||
--------------------- End prebuilt forms
|
||||
|
||||
--------------------- Begin prebuilt inputs
|
||||
|
||||
stringInput :: String -> Form sub master String
|
||||
stringInput n = GForm $ \env _ -> return
|
||||
(case lookup n env of
|
||||
Nothing -> FormMissing
|
||||
Just "" -> FormFailure [n ++ ": You must provide a non-empty string"]
|
||||
Just x -> FormSuccess x, mempty, UrlEncoded)
|
||||
|
||||
--------------------- End prebuilt inputs
|
||||
|
||||
incr :: Monad m => StateT Int m String
|
||||
incr = do
|
||||
i <- get
|
||||
@ -324,7 +371,7 @@ instance Formable (Maybe String) where
|
||||
instance Formable (Html ()) where
|
||||
formable = fmap preEscapedString
|
||||
. input go
|
||||
. fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml)
|
||||
. fmap (U.toString . renderHtml)
|
||||
where
|
||||
go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|]
|
||||
|
||||
|
||||
@ -182,7 +182,7 @@ $maybe message msg
|
||||
getOpenIdForward :: GHandler Auth master ()
|
||||
getOpenIdForward = do
|
||||
testOpenId
|
||||
oid <- runFormGet' $ requiredField "openid"
|
||||
oid <- runFormGet' $ stringInput "openid"
|
||||
render <- getUrlRender
|
||||
toMaster <- getRouteToMaster
|
||||
let complete = render $ toMaster OpenIdComplete
|
||||
@ -302,7 +302,7 @@ getEmailRegisterR = do
|
||||
postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml
|
||||
postEmailRegisterR = do
|
||||
ae <- getAuthEmailSettings
|
||||
email <- runFormPost' $ notEmptyField "email" -- FIXME checkEmail
|
||||
email <- runFormPost' $ stringInput "email" -- FIXME checkEmail
|
||||
y <- getYesod
|
||||
mecreds <- liftIO $ getEmailCreds ae email
|
||||
(lid, verKey) <-
|
||||
@ -367,8 +367,8 @@ postEmailLoginR :: YesodAuth master => GHandler Auth master ()
|
||||
postEmailLoginR = do
|
||||
ae <- getAuthEmailSettings
|
||||
(email, pass) <- runFormPost' $ (,)
|
||||
<$> notEmptyField "email" -- FIXME valid e-mail?
|
||||
<*> requiredField "password"
|
||||
<$> stringInput "email" -- FIXME valid e-mail?
|
||||
<*> stringInput "password"
|
||||
y <- getYesod
|
||||
mecreds <- liftIO $ getEmailCreds ae email
|
||||
let mlid =
|
||||
@ -420,8 +420,8 @@ postEmailPasswordR :: YesodAuth master => GHandler Auth master ()
|
||||
postEmailPasswordR = do
|
||||
ae <- getAuthEmailSettings
|
||||
(new, confirm) <- runFormPost' $ (,)
|
||||
<$> notEmptyField "new"
|
||||
<*> notEmptyField "confirm"
|
||||
<$> stringInput "new"
|
||||
<*> stringInput "confirm"
|
||||
toMaster <- getRouteToMaster
|
||||
when (new /= confirm) $ do
|
||||
setMessage $ string "Passwords did not match, please try again"
|
||||
@ -495,7 +495,7 @@ getFacebookR = do
|
||||
render <- getUrlRender
|
||||
tm <- getRouteToMaster
|
||||
let fb = Facebook.Facebook cid secret $ render $ tm FacebookR
|
||||
code <- runFormGet' $ requiredField "code"
|
||||
code <- runFormGet' $ stringInput "code"
|
||||
at <- liftIO $ Facebook.getAccessToken fb code
|
||||
so <- liftIO $ Facebook.getGraphData at "me"
|
||||
let c = fromMaybe (error "Invalid response from Facebook") $ do
|
||||
|
||||
@ -19,7 +19,7 @@ import Text.Hamlet
|
||||
import Yesod.Form
|
||||
import Data.Monoid (mempty)
|
||||
|
||||
class Formable a => Item a where
|
||||
class IsForm a => Item a where
|
||||
itemTitle :: a -> String
|
||||
|
||||
data Crud master item = Crud
|
||||
@ -133,7 +133,7 @@ crudHelper
|
||||
-> GHandler (Crud master a) master RepHtml
|
||||
crudHelper title me isPost = do
|
||||
crud <- getYesodSub
|
||||
(errs, form) <- runFormPost $ formable $ fmap snd me
|
||||
(errs, form, enctype) <- runFormPost $ toForm $ fmap snd me
|
||||
toMaster <- getRouteToMaster
|
||||
case (isPost, errs) of
|
||||
(True, FormSuccess a) -> do
|
||||
@ -146,21 +146,21 @@ crudHelper title me isPost = do
|
||||
$ toSinglePiece eid
|
||||
_ -> return ()
|
||||
applyLayoutW $ do
|
||||
wrapWidget (wrapForm toMaster) form
|
||||
wrapWidget (wrapForm toMaster enctype) form
|
||||
setTitle $ string title
|
||||
where
|
||||
wrapForm toMaster form = [$hamlet|
|
||||
wrapForm toMaster enctype form = [$hamlet|
|
||||
%p
|
||||
%a!href=@toMaster.CrudListR@ Return to list
|
||||
%h1 $string.title$
|
||||
%form!method=post
|
||||
%form!method=post!enctype=$string.show.enctype$
|
||||
%table
|
||||
^form^
|
||||
%tr
|
||||
%td!colspan=2
|
||||
%input!type=submit
|
||||
$maybe me e
|
||||
\
|
||||
\ $
|
||||
%a!href=@toMaster.CrudDeleteR.toSinglePiece.fst.e@ Delete
|
||||
|]
|
||||
|
||||
|
||||
@ -34,12 +34,17 @@ getRootR = applyLayoutW $ wrapWidget wrapper $ do
|
||||
addHead [$hamlet|%meta!keywords=haskell|]
|
||||
|
||||
handleFormR = do
|
||||
(res, form, enctype) <- runFormPost $ (,,,,)
|
||||
(res, form, enctype) <- runFormPost $ (,,,,,)
|
||||
<$> requiredField stringField (string "My Field") (string "Some tooltip info") Nothing
|
||||
<*> requiredField stringField (string "Another field") (string "") (Just "some default text")
|
||||
<*> requiredField intField (string "A number field") (string "some nums") (Just 5)
|
||||
<*> requiredField dayField (string "A day field") (string "") Nothing
|
||||
<*> boolField (string "A checkbox") (string "") (Just False)
|
||||
<*> requiredField htmlField (string "HTML") (string "")
|
||||
(Just $ string "You can put rich text here")
|
||||
let mhtml = case res of
|
||||
FormSuccess (_, _, _, _, _, x) -> Just x
|
||||
_ -> Nothing
|
||||
applyLayoutW $ do
|
||||
addStyle [$hamlet|\.tooltip{color:#666;font-style:italic}|]
|
||||
flip wrapWidget (fieldsToTable form) $ \h -> [$hamlet|
|
||||
@ -49,8 +54,8 @@ handleFormR = do
|
||||
%tr
|
||||
%td!colspan=2
|
||||
%input!type=submit
|
||||
%h3
|
||||
Result: $string.show.res$
|
||||
$maybe mhtml html
|
||||
$html$
|
||||
|]
|
||||
setTitle $ string "Form"
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user