From f2e71a6c001aff092f6883d02dedfa49c07004b2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 2 Jul 2010 07:18:39 +0300 Subject: [PATCH] htmlField and fixed auth --- Yesod/Form.hs | 57 +++++++++++++++++++++++++++++++++++++++---- Yesod/Helpers/Auth.hs | 14 +++++------ Yesod/Helpers/Crud.hs | 12 ++++----- hellowidget.hs | 11 ++++++--- 4 files changed, 73 insertions(+), 21 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index f365e842..1bd1916e 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -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$|] diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 3de63fd4..366639c5 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -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 diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index d777494d..f469a07a 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -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 |] diff --git a/hellowidget.hs b/hellowidget.hs index fb8983d5..c06264f4 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -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"