haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Clean build

Browse Source
This commit is contained in:
Michael Snoyman 2011-05-09 18:59:36 +03:00
parent c593ded7e5
commit 122f7f85a6
5 changed files with 33 additions and 654 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

318
Yesod/Form.hs
View File

@ -7,319 +7,13 @@
{-# LANGUAGE OverloadedStrings #-}
-- | Parse forms (and query strings).
module Yesod.Form
( -- * Data types
GForm
, FormResult (..)
, Enctype (..)
, FormFieldSettings (..)
, Textarea (..)
, FieldInfo (..)
-- ** Utilities
, formFailures
{-
-- * Type synonyms
, Form
, Formlet
, FormField
, FormletField
, FormInput
-}
-- * Unwrapping functions
, generateForm
, runFormGet
--, runFormMonadGet
, runFormPost
, runFormPostNoNonce
{-
, runFormMonadPost
, runFormGet'
, runFormPost'
-}
-- ** High-level form post unwrappers
{-
, runFormTable
, runFormDivs
-}
-- * Field/form helpers
, fieldsToTable
, fieldsToDivs
, fieldsToPlain
{-
, checkForm
-}
-- * Type classes
, module Yesod.Form.Class
-- * Template Haskell
--, mkToForm
( module Yesod.Form.Types
, module Yesod.Form.Functions
, module Yesod.Form.Fields
-- FIXME , module Yesod.Form.Class
) where
import Yesod.Form.Core
import Yesod.Form.Types
import Yesod.Form.Functions
import Yesod.Form.Fields
import Yesod.Form.Class
import Yesod.Form.Profiles (Textarea (..))
import Yesod.Widget (GWidget, GGWidget)
import Text.Hamlet
import Yesod.Request
import Yesod.Handler
import Control.Applicative hiding (optional)
import Data.Maybe (fromMaybe, mapMaybe)
import Control.Monad ((<=<), liftM)
import Language.Haskell.TH.Syntax hiding (lift)
import Database.Persist.Base (EntityDef (..), PersistEntity (entityDef))
import Data.Char (toUpper, isUpper)
import Control.Arrow ((&&&))
import Data.List (group, sort)
import Data.Monoid (mempty)
import Data.Text (Text)
import Control.Monad.Trans.RWS (runRWST)
#if __GLASGOW_HASKELL__ >= 700
#define HAMLET hamlet
#else
#define HAMLET $hamlet
#endif
-- | Display only the actual input widget code, without any decoration.
fieldsToPlain :: (Monad mo, Monad mo') => GForm [FieldInfo (GGWidget master mo' ())] mo a -> GForm (GGWidget master mo' ()) mo a
fieldsToPlain = mapFormXml $ mapM_ fiInput
-- | Display the label, tooltip, input code and errors in a single row of a
-- table.
fieldsToTable :: (Monad mo, Monad mo') => GForm [FieldInfo (GGWidget master mo' ())] mo a -> GForm (GGWidget master mo' ()) mo a
fieldsToTable = mapFormXml $ mapM_ go
where
go fi = [HAMLET|
<tr .#{clazz fi}>
<td>
<label for="#{fiIdent fi}">#{fiLabel fi}
<div .tooltip>#{fiTooltip fi}
<td>
\^{fiInput fi}
$maybe err <- fiErrors fi
<td .errors>#{err}
|]
clazz fi = if fiRequired fi then "required" else "optional" :: Text
-- | Display the label, tooltip, input code and errors in a single div.
fieldsToDivs :: (Monad mo, Monad mo') => GForm [FieldInfo (GGWidget master mo' ())] mo a -> GForm (GGWidget master mo' ()) mo a
fieldsToDivs = mapFormXml $ mapM_ go
where
go fi = [HAMLET|
<div .#{clazz fi}>
<label for="#{fiIdent fi}">#{fiLabel fi}
<div .tooltip>#{fiTooltip fi}
\^{fiInput fi}
$maybe err <- fiErrors fi
<div .errors>#{err}
|]
clazz fi = if fiRequired fi then "required" else "optional" :: Text
-- | Run a form against POST parameters, without CSRF protection.
runFormPostNoNonce :: GForm xml (GHandler s m) a -> GHandler s m (a, xml, Enctype)
runFormPostNoNonce f = do
(pp, files) <- runRequestBody
runFormGeneric pp files f
-- | Run a form against POST parameters.
--
-- This function includes CSRF protection by checking a nonce value. You must
-- therefore embed this nonce in the form as a hidden field; that is the
-- meaning of the fourth element in the tuple.
runFormPost :: GForm xml (GHandler s m) (FormResult a) -> GHandler s m (FormResult a, xml, Enctype, Html)
runFormPost f = do
(pp, files) <- runRequestBody
nonce <- liftM reqNonce getRequest
(res, xml, enctype) <- runFormGeneric pp files f
let res' =
case res of
FormSuccess x ->
if lookup nonceName pp == nonce
then FormSuccess x
else FormFailure ["As a protection against cross-site request forgery attacks, please confirm your form submission."] -- TRANS
_ -> res
return (res', xml, enctype, maybe mempty hidden nonce)
where
hidden nonce = [HAMLET|
<input type="hidden" name="#{nonceName}" value="#{nonce}">
|]
nonceName :: Text
nonceName = "_nonce"
{- FIXME
-- | Run a form against POST parameters, disregarding the resulting HTML and
-- returning an error response on invalid input. Note: this does /not/ perform
-- CSRF protection.
runFormPost' :: GForm sub y xml a -> GHandler sub y a
runFormPost' f = do
(pp, files) <- runRequestBody
x <- runFormGeneric pp files f
helper x
-}
{- FIXME
-- | Create a table-styled form.
--
-- This function wraps around 'runFormPost' and 'fieldsToTable', taking care of
-- some of the boiler-plate in creating forms. In particular, is automatically
-- creates the form element, sets the method, action and enctype attributes,
-- adds the CSRF-protection nonce hidden field and inserts a submit button.
runFormTable :: Route m -> String -> FormField s m a
-> GHandler s m (FormResult a, GWidget s m ())
runFormTable dest inputLabel form = do
(res, widget, enctype, nonce) <- runFormPost $ fieldsToTable form
return (res, [HAMLET|
<form method="post" action="@{dest}" enctype="#{enctype}">
<table>
\^{widget}
<tr>
<td colspan="2">
\#{nonce}
<input type="submit" value="#{inputLabel}">
|])
-}
{- FIXME
-- | Same as 'runFormPostTable', but uses 'fieldsToDivs' for styling.
runFormDivs :: Route m -> String -> FormField s m a
-> GHandler s m (FormResult a, GWidget s m ())
runFormDivs dest inputLabel form = do
(res, widget, enctype, nonce) <- runFormPost $ fieldsToDivs form
return (res, [HAMLET|
<form method="post" action="@{dest}" enctype="#{enctype}">
\^{widget}
<div>
\#{nonce}
<input type="submit" value="#{inputLabel}">
|])
-}
{- FIXME
-- | Run a form against GET parameters, disregarding the resulting HTML and
-- returning an error response on invalid input.
runFormGet' :: GForm xml mo a -> GHandler sub y a
runFormGet' = helper <=< runFormGet
-}
helper :: (FormResult a, b, c) -> GHandler sub y a
helper (FormSuccess a, _, _) = return a
helper (FormFailure e, _, _) = invalidArgs e
helper (FormMissing, _, _) = invalidArgs ["No input found"]
-- | Generate a form, feeding it no data. The third element in the result tuple
-- is a nonce hidden field.
generateForm :: Monad mo => GForm xml (GGHandler s m mo) a -> GGHandler s m mo (xml, Enctype, Html)
generateForm f = do
(_, b, c) <- runFormGeneric [] [] f
nonce <- liftM reqNonce getRequest
return (b, c, [HAMLET|\
$maybe n <- nonce
<input type="hidden" name="#{nonceName}" value="#{n}">
|])
-- | Run a form against GET parameters.
runFormGet :: Monad mo => GForm xml (GGHandler s m mo) a -> GGHandler s m mo (a, xml, Enctype)
runFormGet f = do
gs <- reqGetParams `liftM` getRequest
runFormGeneric gs [] f
runFormGeneric :: Monad mo => Env -> FileEnv -> GForm xml mo a -> mo (a, xml, Enctype)
runFormGeneric e fe f = do
(a, _s, (enc, xml)) <- runRWST f (e, fe) (IntSingle 1)
return (a, xml, enc)
{- FIXME
-- | Create 'ToForm' instances for the given entity. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=.
mkToForm :: PersistEntity v => v -> Q [Dec]
mkToForm =
fmap return . derive . entityDef
where
afterPeriod s =
case dropWhile (/= '.') s of
('.':t) -> t
_ -> s
beforePeriod s =
case break (== '.') s of
(t, '.':_) -> Just t
_ -> Nothing
getSuperclass (_, _, z) = getTFF' z >>= beforePeriod
getTFF (_, _, z) = maybe "toFormField" afterPeriod $ getTFF' z
getTFF' [] = Nothing
getTFF' (('t':'o':'F':'o':'r':'m':'F':'i':'e':'l':'d':'=':x):_) = Just x
getTFF' (_:x) = getTFF' x
getLabel (x, _, z) = fromMaybe (toLabel x) $ getLabel' z
getLabel' [] = Nothing
getLabel' (('l':'a':'b':'e':'l':'=':x):_) = Just x
getLabel' (_:x) = getLabel' x
getTooltip (_, _, z) = fromMaybe "" $ getTooltip' z
getTooltip' (('t':'o':'o':'l':'t':'i':'p':'=':x):_) = Just x
getTooltip' (_:x) = getTooltip' x
getTooltip' [] = Nothing
getId (_, _, z) = fromMaybe "" $ getId' z
getId' (('i':'d':'=':x):_) = Just x
getId' (_:x) = getId' x
getId' [] = Nothing
getName (_, _, z) = fromMaybe "" $ getName' z
getName' (('n':'a':'m':'e':'=':x):_) = Just x
getName' (_:x) = getName' x
getName' [] = Nothing
derive :: EntityDef -> Q Dec
derive t = do
let cols = map ((getId &&& getName) &&& ((getLabel &&& getTooltip) &&& getTFF)) $ entityColumns t
ap <- [|(<*>)|]
just <- [|pure|]
nothing <- [|Nothing|]
let just' = just `AppE` ConE (mkName $ entityName t)
string' <- [|toHtml|]
ftt <- [|fieldsToTable|]
ffs' <- [|FormFieldSettings|]
let stm "" = nothing
stm x = just `AppE` LitE (StringL x)
let go_ = go ap just' ffs' stm string' ftt
let c1 = Clause [ ConP (mkName "Nothing") []
]
(NormalB $ go_ $ zip cols $ map (const nothing) cols)
[]
xs <- mapM (const $ newName "x") cols
let xs' = map (AppE just . VarE) xs
let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ entityName t)
$ map VarP xs]]
(NormalB $ go_ $ zip cols xs')
[]
let y = mkName "y"
let ctx = map (\x -> ClassP (mkName x) [VarT y])
$ map head $ group $ sort
$ mapMaybe getSuperclass
$ entityColumns t
return $ InstanceD ctx ( ConT ''ToForm
`AppT` ConT (mkName $ entityName t)
`AppT` VarT y)
[FunD (mkName "toForm") [c1, c2]]
go ap just' ffs' stm string' ftt a =
let x = foldl (ap' ap) just' $ map (go' ffs' stm string') a
in ftt `AppE` x
go' ffs' stm string' (((theId, name), ((label, tooltip), tff)), ex) =
let label' = LitE $ StringL label
tooltip' = string' `AppE` LitE (StringL tooltip)
ffs = ffs' `AppE`
label' `AppE`
tooltip' `AppE`
(stm theId) `AppE`
(stm name)
in VarE (mkName tff) `AppE` ffs `AppE` ex
ap' ap x y = InfixE (Just x) ap (Just y)
-}
toLabel :: String -> String
toLabel "" = ""
toLabel (x:rest) = toUpper x : go rest
where
go "" = ""
go (c:cs)
| isUpper c = ' ' : c : go cs
| otherwise = c : go cs
formFailures :: FormResult a -> Maybe [Text]
formFailures (FormFailure x) = Just x
formFailures _ = Nothing
-- FIXME import Yesod.Form.Class

298
Yesod/Form/Core.hs
View File

@ -1,298 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- | Users of the forms library should not need to use this module in general.
-- It is intended only for writing custom forms and form fields.
module Yesod.Form.Core
( FormResult (..)
, GForm (..)
, newFormIdent
{- FIXME
, deeperFormIdent
, shallowerFormIdent
-}
, Env
, FileEnv
, Enctype (..)
, Ints (..)
, requiredFieldHelper
, optionalFieldHelper
, mapFormXml
{- FIXME
, checkForm
, checkField
-}
, askParams
, askFiles
-- * Data types
, FieldInfo (..)
, FormFieldSettings (..)
, FieldProfile (..)
-- * Type synonyms
{- FIXME
, Form
, Formlet
, FormField
, FormletField
, FormInput
-}
) where
import Control.Monad.Trans.RWS
import Control.Monad.Trans.Class (lift)
import Yesod.Handler
import Yesod.Widget
import Data.Monoid (Monoid (..))
import Control.Applicative
import Yesod.Request
import Control.Monad (liftM)
import Text.Hamlet
import Text.Blaze (ToHtml (..))
import Data.String
import Control.Monad (join)
import Data.Text (Text, pack)
import qualified Data.Text as T
import Prelude hiding ((++))
(++) :: Monoid a => a -> a -> a
(++) = mappend
-- | A form can produce three different results: there was no data available,
-- the data was invalid, or there was a successful parse.
--
-- The 'Applicative' instance will concatenate the failure messages in two
-- 'FormResult's.
data FormResult a = FormMissing
| FormFailure [Text]
| FormSuccess a
deriving Show
instance Functor FormResult where
fmap _ FormMissing = FormMissing
fmap _ (FormFailure errs) = FormFailure errs
fmap f (FormSuccess a) = FormSuccess $ f a
instance Applicative FormResult where
pure = FormSuccess
(FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g
(FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y
(FormFailure x) <*> _ = FormFailure x
_ <*> (FormFailure y) = FormFailure y
_ <*> _ = FormMissing
instance Monoid m => Monoid (FormResult m) where
mempty = pure mempty
mappend x y = mappend <$> x <*> y
-- | The encoding type required by a form. The 'ToHtml' instance produces values
-- that can be inserted directly into HTML.
data Enctype = UrlEncoded | Multipart
deriving (Eq, Enum, Bounded)
instance ToHtml Enctype where
toHtml UrlEncoded = unsafeByteString "application/x-www-form-urlencoded"
toHtml Multipart = unsafeByteString "multipart/form-data"
instance Monoid Enctype where
mempty = UrlEncoded
mappend UrlEncoded UrlEncoded = UrlEncoded
mappend _ _ = Multipart
data Ints = IntCons Int Ints | IntSingle Int
instance Show Ints where
show (IntSingle i) = show i
show (IntCons i is) = show i ++ ('-' : show is)
incrInts :: Ints -> Ints
incrInts (IntSingle i) = IntSingle $ i + 1
incrInts (IntCons i is) = (i + 1) `IntCons` is
type GForm xml m a = RWST (Env, FileEnv) (Enctype, xml) Ints m a -- FIXME rename to Form
type Env = [(Text, Text)]
type FileEnv = [(Text, FileInfo)]
-- | Get a unique identifier.
newFormIdent :: (Monoid xml, Monad m) => GForm xml m Text
newFormIdent = do
i <- get
let i' = incrInts i
put i'
return $ pack $ 'f' : show i'
{- FIXME
deeperFormIdent :: Monad m => StateT Ints m ()
deeperFormIdent = do
i <- get
let i' = 1 `IntCons` incrInts i
put i'
shallowerFormIdent :: Monad m => StateT Ints m ()
shallowerFormIdent = do
IntCons _ i <- get
put i
-}
-- | Create a required field (ie, one that cannot be blank) from a
-- 'FieldProfile'.
requiredFieldHelper
:: (Monoid xml', Monad m)
=> FieldProfile xml a
-> FormFieldSettings
-> Maybe a
-> GForm xml' m (FormResult a, FieldInfo xml)
requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = do
env <- askParams
let (FormFieldSettings label tooltip theId' name') = ffs
name <- maybe newFormIdent return name'
theId <- maybe newFormIdent return theId'
let (res, val) =
if null env
then (FormMissing, maybe "" render orig)
else case lookup name env of
Nothing -> (FormMissing, "")
Just "" -> (FormFailure ["Value is required"], "") -- TRANS
Just x ->
case parse x of
Left e -> (FormFailure [e], x)
Right y -> (FormSuccess y, x)
let fi = FieldInfo
{ fiLabel = toHtml label
, fiTooltip = tooltip
, fiIdent = theId
, fiInput = mkWidget theId name val True
, fiErrors = case res of
FormFailure [x] -> Just $ toHtml x
_ -> Nothing
, fiRequired = True
}
let res' = case res of
FormFailure [e] -> FormFailure [label ++ ": " ++ e]
_ -> res
return (res', fi)
-- | Create an optional field (ie, one that can be blank) from a
-- 'FieldProfile'.
optionalFieldHelper
:: (Monad m, Monoid xml')
=> FieldProfile xml b
-> FormFieldSettings
-> Maybe (Maybe b)
-> GForm xml' m (FormResult (Maybe b), FieldInfo xml)
optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = do
env <- askParams
let (FormFieldSettings label tooltip theId' name') = ffs
let orig = join orig'
name <- maybe newFormIdent return name'
theId <- maybe newFormIdent return theId'
let (res, val) =
if null env
then (FormSuccess Nothing, maybe "" render orig)
else case lookup name env of
Nothing -> (FormSuccess Nothing, "")
Just "" -> (FormSuccess Nothing, "")
Just x ->
case parse x of
Left e -> (FormFailure [e], x)
Right y -> (FormSuccess $ Just y, x)
let fi = FieldInfo
{ fiLabel = toHtml label
, fiTooltip = tooltip
, fiIdent = theId
, fiInput = mkWidget theId name val False
, fiErrors = case res of
FormFailure x -> Just $ toHtml $ T.unlines x
_ -> Nothing
, fiRequired = False
}
let res' = case res of
FormFailure [e] -> FormFailure [label ++ ": " ++ e]
_ -> res
return (res', fi)
-- | Convert the XML in a 'GForm'.
mapFormXml :: Monad m => (xml1 -> xml2) -> GForm xml1 m a -> GForm xml2 m a
mapFormXml f = mapRWST $ \x -> do
(a, b, (c, d)) <- x
return (a, b, (c, f d))
-- | Using this as the intermediate XML representation for fields allows us to
-- write generic field functions and then different functions for producing
-- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'.
data FieldInfo xml = FieldInfo
{ fiLabel :: Html
, fiTooltip :: Html
, fiIdent :: Text
, fiInput :: xml
, fiErrors :: Maybe Html
, fiRequired :: Bool
}
data FormFieldSettings = FormFieldSettings
{ ffsLabel :: Text
, ffsTooltip :: Html
, ffsId :: Maybe Text
, ffsName :: Maybe Text
}
instance IsString FormFieldSettings where
fromString s = FormFieldSettings (pack s) mempty Nothing Nothing
-- | A generic definition of a form field that can be used for generating both
-- required and optional fields. See 'requiredFieldHelper and
-- 'optionalFieldHelper'.
data FieldProfile xml a = FieldProfile
{ fpParse :: Text -> Either Text a
, fpRender :: a -> Text
-- | ID, name, value, required
, fpWidget :: Text -> Text -> Text -> Bool -> xml
}
{- FIXME
type Form sub y = GForm sub y (GWidget sub y ())
type Formlet sub y a = Maybe a -> Form sub y a
type FormInput sub y = GForm sub y [GWidget sub y ()]
type FormField xml m = GForm xml m [FieldInfo xml]
type FormletField xml m a = Maybe a -> FormField xml a
-}
{- FIXME
-- | Add a validation check to a form.
--
-- Note that if there is a validation error, this message will /not/
-- automatically appear on the form; for that, you need to use 'checkField'.
checkForm :: (a -> FormResult b) -> GForm s m x a -> GForm s m x b
checkForm f (GForm form) = GForm $ do
(res, xml, enc) <- form
let res' = case res of
FormSuccess a -> f a
FormFailure e -> FormFailure e
FormMissing -> FormMissing
return (res', xml, enc)
-- | Add a validation check to a 'FormField'.
--
-- Unlike 'checkForm', the validation error will appear in the generated HTML
-- of the form.
checkField :: (a -> Either Text b) -> FormField s m a -> FormField s m b
checkField f form = do
(res, xml, enc) <- form
let (res', merr) =
case res of
FormSuccess a ->
case f a of
Left e -> (FormFailure [e], Just e)
Right x -> (FormSuccess x, Nothing)
FormFailure e -> (FormFailure e, Nothing)
FormMissing -> (FormMissing, Nothing)
let xml' =
case merr of
Nothing -> xml
Just err -> flip map xml $ \fi -> fi
{ fiErrors = Just $
case fiErrors fi of
Nothing -> toHtml err
Just x -> x
}
return (res', xml', enc)
-}
askParams :: (Monoid xml, Monad m) => GForm xml m Env
askParams = liftM fst ask
askFiles :: (Monoid xml, Monad m) => GForm xml m FileEnv
askFiles = liftM snd ask

47
Yesod/Form/Jquery.hs
View File

@ -8,20 +8,15 @@
module Yesod.Form.Jquery
( YesodJquery (..)
, jqueryDayField
, maybeJqueryDayField
, jqueryDayTimeField
, jqueryDayTimeFieldProfile
, jqueryAutocompleteField
, maybeJqueryAutocompleteField
, jqueryDayFieldProfile
, googleHostedJqueryUiCss
, JqueryDaySettings (..)
, Default (..)
) where
import Yesod.Handler
import Yesod.Form.Core
import Yesod.Form.Profiles
import Yesod.Form
import Yesod.Widget
import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime,
timeToTimeOfDay)
@ -68,18 +63,15 @@ class YesodJquery a where
urlJqueryUiDateTimePicker :: a -> Either (Route a) Text
urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js"
jqueryDayField = requiredFieldHelper . jqueryDayFieldProfile
maybeJqueryDayField = optionalFieldHelper . jqueryDayFieldProfile
jqueryDayFieldProfile jds = FieldProfile
{ fpParse = maybe
jqueryDayField :: (YesodJquery master) => JqueryDaySettings -> Field (GWidget sub master ()) Day
jqueryDayField jds = Field
{ fieldParse = maybe
(Left "Invalid day, must be in YYYY-MM-DD format")
Right
. readMay
. unpack
, fpRender = pack . show
, fpWidget = \theId name val isReq -> do
, fieldRender = pack . show
, fieldView = \theId name val isReq -> do
addHtml [HAMLET|\
<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}">
|]
@ -116,8 +108,6 @@ ifRight e f = case e of
showLeadingZero :: (Show a) => a -> String
showLeadingZero time = let t = show time in if length t == 1 then "0" ++ t else t
jqueryDayTimeField = requiredFieldHelper jqueryDayTimeFieldProfile
-- use A.M/P.M and drop seconds and "UTC" (as opposed to normal UTCTime show)
jqueryDayTimeUTCTime :: UTCTime -> String
jqueryDayTimeUTCTime (UTCTime day utcTime) =
@ -128,10 +118,11 @@ jqueryDayTimeUTCTime (UTCTime day utcTime) =
let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM")
in (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm
jqueryDayTimeFieldProfile = FieldProfile
{ fpParse = parseUTCTime . unpack
, fpRender = pack . jqueryDayTimeUTCTime
, fpWidget = \theId name val isReq -> do
jqueryDayTimeField :: YesodJquery master => Field (GWidget sub master ()) UTCTime
jqueryDayTimeField = Field
{ fieldParse = parseUTCTime . unpack
, fieldRender = pack . jqueryDayTimeUTCTime
, fieldView = \theId name val isReq -> do
addHtml [HAMLET|\
<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}">
|]
@ -154,16 +145,11 @@ parseUTCTime s =
ifRight (parseTime timeS)
(UTCTime date . timeOfDayToTime)
jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile
maybeJqueryAutocompleteField src =
optionalFieldHelper $ jqueryAutocompleteFieldProfile src
jqueryAutocompleteFieldProfile :: YesodJquery master => Route master -> FieldProfile (GWidget sub master ()) Text
jqueryAutocompleteFieldProfile src = FieldProfile
{ fpParse = Right
, fpRender = id
, fpWidget = \theId name val isReq -> do
jqueryAutocompleteField :: YesodJquery master => Route master -> Field (GWidget sub master ()) Text
jqueryAutocompleteField src = Field
{ fieldParse = Right
, fieldRender = id
, fieldView = \theId name val isReq -> do
addHtml [HAMLET|\
<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}" .autocomplete>
|]
@ -175,6 +161,7 @@ $(function(){$("##{theId}").autocomplete({source:"@{src}",minLength:2})});
|]
}
addScript' :: Monad m => (t -> Either (Route master) Text) -> GGWidget master (GGHandler sub t m) ()
addScript' f = do
y <- lift getYesod
addScriptEither $ f y

17
Yesod/Form/Nic.hs
View File

@ -8,11 +8,10 @@
module Yesod.Form.Nic
( YesodNic (..)
, nicHtmlField
, maybeNicHtmlField
) where
import Yesod.Handler
import Yesod.Form.Core
import Yesod.Form
import Yesod.Widget
import Text.HTML.SanitizeXSS (sanitizeBalance)
import Text.Hamlet (Html, hamlet)
@ -27,15 +26,11 @@ class YesodNic a where
urlNicEdit :: a -> Either (Route a) Text
urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"
nicHtmlField = requiredFieldHelper nicHtmlFieldProfile
maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile
--nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html
nicHtmlFieldProfile = FieldProfile
{ fpParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME
, fpRender = pack . renderHtml
, fpWidget = \theId name val _isReq -> do
nicHtmlField :: YesodNic master => Field (GWidget sub master ()) Html
nicHtmlField = Field
{ fieldParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME
, fieldRender = pack . renderHtml
, fieldView = \theId name val _isReq -> do
addHtml
#if __GLASGOW_HASKELL__ >= 700
[hamlet|

7
yesod-form.cabal
View File

@ -29,15 +29,16 @@ library
, bytestring >= 0.9 && < 0.10
, text >= 0.7 && < 1.0
, web-routes-quasi >= 0.7 && < 0.8
, wai >= 0.4 && < 0.5
exposed-modules: Yesod.Form
Yesod.Form.Class
Yesod.Form.Core
Yesod.Form.Types
Yesod.Form.Functions
Yesod.Form.Fields
Yesod.Form.Jquery
Yesod.Form.Nic
Yesod.Form.Profiles
-- FIXME Yesod.Helpers.Crud
ghc-options: -Wall
ghc-options: -Wall -Werror
source-repository head
type: git