yesod-form (empty) → 0.0.0
raw patch · 10 files changed
+1910/−0 lines, 10 filesdep +basedep +blaze-builderdep +blaze-htmlsetup-changed
Dependencies added: base, blaze-builder, blaze-html, bytestring, data-default, email-validate, hamlet, network, persistent, template-haskell, time, transformers, xss-sanitize, yesod-core
Files
- LICENSE +25/−0
- Setup.lhs +7/−0
- Yesod/Form.hs +338/−0
- Yesod/Form/Class.hs +61/−0
- Yesod/Form/Core.hs +370/−0
- Yesod/Form/Fields.hs +520/−0
- Yesod/Form/Jquery.hs +237/−0
- Yesod/Form/Nic.hs +63/−0
- Yesod/Form/Profiles.hs +249/−0
- yesod-form.cabal +40/−0
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2010, Michael Snoyman. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ Yesod/Form.hs view
@@ -0,0 +1,338 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+-- | 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.Fields+ ) where++import Yesod.Form.Core+import Yesod.Form.Fields+import Yesod.Form.Class+import Yesod.Form.Profiles (Textarea (..))+import Yesod.Widget (GWidget)++import Text.Hamlet+import Yesod.Request+import Yesod.Handler+import Control.Applicative hiding (optional)+import Data.Maybe (fromMaybe, mapMaybe)+import Control.Monad ((<=<))+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)++-- | Display only the actual input widget code, without any decoration.+fieldsToPlain :: FormField sub y a -> Form sub y a+fieldsToPlain = mapFormXml $ mapM_ fiInput++-- | Display the label, tooltip, input code and errors in a single row of a+-- table.+fieldsToTable :: FormField sub y a -> Form sub y a+fieldsToTable = mapFormXml $ mapM_ go+ where+ go fi =+#if __GLASGOW_HASKELL__ >= 700+ [hamlet|+#else+ [$hamlet|+#endif+<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"++-- | Display the label, tooltip, input code and errors in a single div.+fieldsToDivs :: FormField sub y a -> Form sub y a+fieldsToDivs = mapFormXml $ mapM_ go+ where+ go fi =+#if __GLASGOW_HASKELL__ >= 700+ [hamlet|+#else+ [$hamlet|+#endif+<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"++-- | Run a form against POST parameters, without CSRF protection.+runFormPostNoNonce :: GForm s m xml a -> GHandler s m (FormResult 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 s m xml a -> GHandler s m (FormResult a, xml, Enctype, Html)+runFormPost f = do+ (pp, files) <- runRequestBody+ nonce <- fmap 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."]+ _ -> res+ return (res', xml, enctype, maybe mempty hidden nonce)+ where+ hidden nonce =+#if __GLASGOW_HASKELL__ >= 700+ [hamlet|+#else+ [$hamlet|+#endif+ <input type="hidden" name="#{nonceName}" value="#{nonce}">+|]++nonceName :: String+nonceName = "_nonce"++-- | Run a form against POST parameters. Please note that this does not provide+-- CSRF protection.+runFormMonadPost :: GFormMonad s m a -> GHandler s m (a, Enctype)+runFormMonadPost f = do+ (pp, files) <- runRequestBody+ runFormGeneric pp files f++-- | 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++-- | 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+ let widget' =+#if __GLASGOW_HASKELL__ >= 700+ [hamlet|+#else+ [$hamlet|+#endif+<form method="post" action="@{dest}" enctype="#{enctype}">+ <table>+ \^{widget}+ <tr>+ <td colspan="2">+ \#{nonce}+ <input type="submit" value="#{inputLabel}">+|]+ return (res, widget')++-- | 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+ let widget' =+#if __GLASGOW_HASKELL__ >= 700+ [hamlet|+#else+ [$hamlet|+#endif+<form method="post" action="@{dest}" enctype="#{enctype}">+ \^{widget}+ <div>+ \#{nonce}+ <input type="submit" value="#{inputLabel}">+|]+ return (res, widget')++-- | Run a form against GET parameters, disregarding the resulting HTML and+-- returning an error response on invalid input.+runFormGet' :: GForm sub y xml 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 :: GForm s m xml a -> GHandler s m (xml, Enctype, Html)+generateForm f = do+ (_, b, c) <- runFormGeneric [] [] f+ nonce <- fmap reqNonce getRequest+ return (b, c,+#if __GLASGOW_HASKELL__ >= 700+ [hamlet|+#else+ [$hamlet|+#endif+$maybe n <- nonce+ <input type="hidden" name="#{nonceName}" value="#{n}">+|])++-- | Run a form against GET parameters.+runFormGet :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype)+runFormGet f = do+ gs <- reqGetParams `fmap` getRequest+ runFormGeneric gs [] f++runFormMonadGet :: GFormMonad s m a -> GHandler s m (a, Enctype)+runFormMonadGet f = do+ gs <- reqGetParams `fmap` getRequest+ runFormGeneric gs [] f++-- | 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' <- [|string|]+ 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 [String]+formFailures (FormFailure x) = Just x+formFailures _ = Nothing
+ Yesod/Form/Class.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Yesod.Form.Class+ ( ToForm (..)+ , ToFormField (..)+ ) where++import Text.Hamlet+import Yesod.Form.Fields+import Yesod.Form.Core+import Yesod.Form.Profiles (Textarea)+import Data.Int (Int64)+import Data.Time (Day, TimeOfDay)++class ToForm a y where+ toForm :: Formlet sub y a+class ToFormField a y where+ toFormField :: FormFieldSettings -> FormletField sub y a++instance ToFormField String y where+ toFormField = stringField+instance ToFormField (Maybe String) y where+ toFormField = maybeStringField++instance ToFormField Int y where+ toFormField = intField+instance ToFormField (Maybe Int) y where+ toFormField = maybeIntField+instance ToFormField Int64 y where+ toFormField = intField+instance ToFormField (Maybe Int64) y where+ toFormField = maybeIntField++instance ToFormField Double y where+ toFormField = doubleField+instance ToFormField (Maybe Double) y where+ toFormField = maybeDoubleField++instance ToFormField Day y where+ toFormField = dayField+instance ToFormField (Maybe Day) y where+ toFormField = maybeDayField++instance ToFormField TimeOfDay y where+ toFormField = timeField+instance ToFormField (Maybe TimeOfDay) y where+ toFormField = maybeTimeField++instance ToFormField Bool y where+ toFormField = boolField++instance ToFormField Html y where+ toFormField = htmlField+instance ToFormField (Maybe Html) y where+ toFormField = maybeHtmlField++instance ToFormField Textarea y where+ toFormField = textareaField+instance ToFormField (Maybe Textarea) y where+ toFormField = maybeTextareaField
+ Yesod/Form/Core.hs view
@@ -0,0 +1,370 @@+{-# 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+ , deeperFormIdent+ , shallowerFormIdent+ , Env+ , FileEnv+ , Enctype (..)+ , Ints (..)+ , requiredFieldHelper+ , optionalFieldHelper+ , fieldsToInput+ , mapFormXml+ , checkForm+ , checkField+ , askParams+ , askFiles+ , liftForm+ , IsForm (..)+ , RunForm (..)+ , GFormMonad+ -- * Data types+ , FieldInfo (..)+ , FormFieldSettings (..)+ , FieldProfile (..)+ -- * Type synonyms+ , Form+ , Formlet+ , FormField+ , FormletField+ , FormInput+ ) where++import Control.Monad.Trans.State+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Writer+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)++-- | 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 [String]+ | 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 'Show' 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++-- | A generic form, allowing you to specifying the subsite datatype, master+-- site datatype, a datatype for the form XML and the return type.+newtype GForm s m xml a = GForm+ { deform :: FormInner s m (FormResult a, xml, Enctype)+ }++type GFormMonad s m a = WriterT Enctype (FormInner s m) a++type FormInner s m =+ StateT Ints (+ ReaderT Env (+ ReaderT FileEnv (+ GHandler s m+ )))++type Env = [(String, String)]+type FileEnv = [(String, FileInfo)]++-- | Get a unique identifier.+newFormIdent :: Monad m => StateT Ints m String+newFormIdent = do+ i <- get+ let i' = incrInts i+ put i'+ return $ 'f' : show i'++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++instance Monoid xml => Functor (GForm sub url xml) where+ fmap f (GForm g) =+ GForm $ liftM (first3 $ fmap f) g+ where+ first3 f' (x, y, z) = (f' x, y, z)++instance Monoid xml => Applicative (GForm sub url xml) where+ pure a = GForm $ return (pure a, mempty, mempty)+ (GForm f) <*> (GForm g) = GForm $ do+ (f1, f2, f3) <- f+ (g1, g2, g3) <- g+ return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3)++-- | Create a required field (ie, one that cannot be blank) from a+-- 'FieldProfile'.+requiredFieldHelper+ :: IsForm f+ => FieldProfile (FormSub f) (FormMaster f) (FormType f)+ -> FormFieldSettings+ -> Maybe (FormType f)+ -> f+requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = toForm $ do+ env <- lift ask+ 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"], "")+ Just x ->+ case parse x of+ Left e -> (FormFailure [e], x)+ Right y -> (FormSuccess y, x)+ let fi = FieldInfo+ { fiLabel = string label+ , fiTooltip = tooltip+ , fiIdent = theId+ , fiInput = mkWidget theId name val True+ , fiErrors = case res of+ FormFailure [x] -> Just $ string x+ _ -> Nothing+ , fiRequired = True+ }+ let res' = case res of+ FormFailure [e] -> FormFailure [label ++ ": " ++ e]+ _ -> res+ return (res', fi, UrlEncoded)++class IsForm f where+ type FormSub f+ type FormMaster f+ type FormType f+ toForm :: FormInner+ (FormSub f)+ (FormMaster f)+ (FormResult (FormType f),+ FieldInfo (FormSub f) (FormMaster f),+ Enctype) -> f+instance IsForm (FormField s m a) where+ type FormSub (FormField s m a) = s+ type FormMaster (FormField s m a) = m+ type FormType (FormField s m a) = a+ toForm x = GForm $ do+ (a, b, c) <- x+ return (a, [b], c)+instance (FormResult ~ formResult) => IsForm (GFormMonad s m (formResult a, FieldInfo s m)) where+ type FormSub (GFormMonad s m (formResult a, FieldInfo s m)) = s+ type FormMaster (GFormMonad s m (formResult a, FieldInfo s m)) = m+ type FormType (GFormMonad s m (formResult a, FieldInfo s m)) = a+ toForm x = do+ (res, fi, enctype) <- lift x+ tell enctype+ return (res, fi)++class RunForm f where+ type RunFormSub f+ type RunFormMaster f+ type RunFormType f+ runFormGeneric :: Env -> FileEnv -> f+ -> GHandler (RunFormSub f)+ (RunFormMaster f)+ (RunFormType f)++instance RunForm (GForm s m xml a) where+ type RunFormSub (GForm s m xml a) = s+ type RunFormMaster (GForm s m xml a) = m+ type RunFormType (GForm s m xml a) =+ (FormResult a, xml, Enctype)+ runFormGeneric env fe (GForm f) =+ runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe++instance RunForm (GFormMonad s m a) where+ type RunFormSub (GFormMonad s m a) = s+ type RunFormMaster (GFormMonad s m a) = m+ type RunFormType (GFormMonad s m a) = (a, Enctype)+ runFormGeneric e fe f =+ runReaderT (runReaderT (evalStateT (runWriterT f) $ IntSingle 1) e) fe++-- | Create an optional field (ie, one that can be blank) from a+-- 'FieldProfile'.+optionalFieldHelper+ :: (IsForm f, Maybe b ~ FormType f)+ => FieldProfile (FormSub f) (FormMaster f) b+ -> FormFieldSettings+ -> Maybe (Maybe b)+ -> f+optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = toForm $ do+ env <- lift ask+ 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 = string label+ , fiTooltip = tooltip+ , fiIdent = theId+ , fiInput = mkWidget theId name val False+ , fiErrors = case res of+ FormFailure x -> Just $ string $ unlines x+ _ -> Nothing+ , fiRequired = False+ }+ let res' = case res of+ FormFailure [e] -> FormFailure [label ++ ": " ++ e]+ _ -> res+ return (res', fi, UrlEncoded)++fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()]+fieldsToInput = map fiInput++-- | Convert the XML in a 'GForm'.+mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a+mapFormXml f (GForm g) = GForm $ do+ (res, xml, enc) <- g+ return (res, f xml, enc)++-- | 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 sub y = FieldInfo+ { fiLabel :: Html+ , fiTooltip :: Html+ , fiIdent :: String+ , fiInput :: GWidget sub y ()+ , fiErrors :: Maybe Html+ , fiRequired :: Bool+ }++data FormFieldSettings = FormFieldSettings+ { ffsLabel :: String+ , ffsTooltip :: Html+ , ffsId :: Maybe String+ , ffsName :: Maybe String+ }+instance IsString FormFieldSettings where+ fromString s = FormFieldSettings 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 sub y a = FieldProfile+ { fpParse :: String -> Either String a+ , fpRender :: a -> String+ -- | ID, name, value, required+ , fpWidget :: String -> String -> String -> Bool -> GWidget sub y ()+ }++type Form sub y = GForm sub y (GWidget sub y ())+type Formlet sub y a = Maybe a -> Form sub y a+type FormField sub y = GForm sub y [FieldInfo sub y]+type FormletField sub y a = Maybe a -> FormField sub y a+type FormInput sub y = GForm sub y [GWidget sub y ()]++-- | 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 String b) -> FormField s m a -> FormField s m b+checkField f (GForm form) = GForm $ 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 -> string err+ Just x -> x+ }+ return (res', xml', enc)++askParams :: Monad m => StateT Ints (ReaderT Env m) Env+askParams = lift ask++askFiles :: Monad m => StateT Ints (ReaderT Env (ReaderT FileEnv m)) FileEnv+askFiles = lift $ lift ask++liftForm :: Monad m => m a -> StateT Ints (ReaderT Env (ReaderT FileEnv m)) a+liftForm = lift . lift . lift
+ Yesod/Form/Fields.hs view
@@ -0,0 +1,520 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+module Yesod.Form.Fields+ ( -- * Fields+ -- ** Required+ stringField+ , passwordField+ , textareaField+ , hiddenField+ , intField+ , doubleField+ , dayField+ , timeField+ , htmlField+ , selectField+ , radioField+ , boolField+ , emailField+ , searchField+ , urlField+ , fileField+ -- ** Optional+ , maybeStringField+ , maybePasswordField+ , maybeTextareaField+ , maybeHiddenField+ , maybeIntField+ , maybeDoubleField+ , maybeDayField+ , maybeTimeField+ , maybeHtmlField+ , maybeSelectField+ , maybeRadioField+ , maybeEmailField+ , maybeSearchField+ , maybeUrlField+ , maybeFileField+ -- * Inputs+ -- ** Required+ , stringInput+ , intInput+ , boolInput+ , dayInput+ , emailInput+ , urlInput+ -- ** Optional+ , maybeStringInput+ , maybeDayInput+ , maybeIntInput+ ) where++import Yesod.Form.Core+import Yesod.Form.Profiles+import Yesod.Request (FileInfo)+import Yesod.Widget (GWidget)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ask)+import Data.Time (Day, TimeOfDay)+import Text.Hamlet+import Data.Monoid+import Control.Monad (join)+import Data.Maybe (fromMaybe, isNothing)++stringField :: (IsForm f, FormType f ~ String)+ => FormFieldSettings -> Maybe String -> f+stringField = requiredFieldHelper stringFieldProfile++maybeStringField :: (IsForm f, FormType f ~ Maybe String)+ => FormFieldSettings -> Maybe (Maybe String) -> f+maybeStringField = optionalFieldHelper stringFieldProfile++passwordField :: (IsForm f, FormType f ~ String)+ => FormFieldSettings -> Maybe String -> f+passwordField = requiredFieldHelper passwordFieldProfile++maybePasswordField :: (IsForm f, FormType f ~ Maybe String)+ => FormFieldSettings -> Maybe (Maybe String) -> f+maybePasswordField = optionalFieldHelper passwordFieldProfile++intInput :: Integral i => String -> FormInput sub master i+intInput n =+ mapFormXml fieldsToInput $+ requiredFieldHelper intFieldProfile (nameSettings n) Nothing++maybeIntInput :: Integral i => String -> FormInput sub master (Maybe i)+maybeIntInput n =+ mapFormXml fieldsToInput $+ optionalFieldHelper intFieldProfile (nameSettings n) Nothing++intField :: (Integral (FormType f), IsForm f)+ => FormFieldSettings -> Maybe (FormType f) -> f+intField = requiredFieldHelper intFieldProfile++maybeIntField :: (Integral i, FormType f ~ Maybe i, IsForm f)+ => FormFieldSettings -> Maybe (FormType f) -> f+maybeIntField = optionalFieldHelper intFieldProfile++doubleField :: (IsForm f, FormType f ~ Double)+ => FormFieldSettings -> Maybe Double -> f+doubleField = requiredFieldHelper doubleFieldProfile++maybeDoubleField :: (IsForm f, FormType f ~ Maybe Double)+ => FormFieldSettings -> Maybe (Maybe Double) -> f+maybeDoubleField = optionalFieldHelper doubleFieldProfile++dayField :: (IsForm f, FormType f ~ Day)+ => FormFieldSettings -> Maybe Day -> f+dayField = requiredFieldHelper dayFieldProfile++maybeDayField :: (IsForm f, FormType f ~ Maybe Day)+ => FormFieldSettings -> Maybe (Maybe Day) -> f+maybeDayField = optionalFieldHelper dayFieldProfile++timeField :: (IsForm f, FormType f ~ TimeOfDay)+ => FormFieldSettings -> Maybe TimeOfDay -> f+timeField = requiredFieldHelper timeFieldProfile++maybeTimeField :: (IsForm f, FormType f ~ Maybe TimeOfDay)+ => FormFieldSettings -> Maybe (Maybe TimeOfDay) -> f+maybeTimeField = optionalFieldHelper timeFieldProfile++boolField :: (IsForm f, FormType f ~ Bool)+ => FormFieldSettings -> Maybe Bool -> f+boolField ffs orig = toForm $ do+ env <- askParams+ let label = ffsLabel ffs+ tooltip = ffsTooltip ffs+ name <- maybe newFormIdent return $ ffsName ffs+ theId <- maybe newFormIdent return $ ffsId ffs+ let (res, val) =+ if null env+ then (FormMissing, fromMaybe False orig)+ else case lookup name env of+ Nothing -> (FormSuccess False, False)+ Just "" -> (FormSuccess False, False)+ Just "false" -> (FormSuccess False, False)+ Just _ -> (FormSuccess True, True)+ let fi = FieldInfo+ { fiLabel = string label+ , fiTooltip = tooltip+ , fiIdent = theId+ , fiInput =+#if __GLASGOW_HASKELL__ >= 700+ [hamlet|+#else+ [$hamlet|+#endif+<input id="#{theId}" type="checkbox" name="#{name}" :val:checked="">+|]+ , fiErrors = case res of+ FormFailure [x] -> Just $ string x+ _ -> Nothing+ , fiRequired = True+ }+ return (res, fi, UrlEncoded)++htmlField :: (IsForm f, FormType f ~ Html)+ => FormFieldSettings -> Maybe Html -> f+htmlField = requiredFieldHelper htmlFieldProfile++maybeHtmlField :: (IsForm f, FormType f ~ Maybe Html)+ => FormFieldSettings -> Maybe (Maybe Html) -> f+maybeHtmlField = optionalFieldHelper htmlFieldProfile++selectField :: (Eq x, IsForm f, FormType f ~ x)+ => [(x, String)]+ -> FormFieldSettings+ -> Maybe x+ -> f+selectField pairs ffs initial = toForm $ do+ env <- askParams+ let label = ffsLabel ffs+ tooltip = ffsTooltip ffs+ theId <- maybe newFormIdent return $ ffsId ffs+ name <- maybe newFormIdent return $ ffsName ffs+ let pairs' = zip [1 :: Int ..] pairs+ let res = case lookup name env of+ Nothing -> FormMissing+ Just "none" -> FormFailure ["Field is required"]+ Just x ->+ case reads x of+ (x', _):_ ->+ case lookup x' pairs' of+ Nothing -> FormFailure ["Invalid entry"]+ Just (y, _) -> FormSuccess y+ [] -> FormFailure ["Invalid entry"]+ let isSelected x =+ case res of+ FormSuccess y -> x == y+ _ -> Just x == initial+ let input =+#if __GLASGOW_HASKELL__ >= 700+ [hamlet|+#else+ [$hamlet|+#endif+<select id="#{theId}" name="#{name}">+ <option value="none">+ $forall pair <- pairs'+ <option value="#{show (fst pair)}" :isSelected (fst (snd pair)):selected="">#{snd (snd pair)}+|]+ let fi = FieldInfo+ { fiLabel = string label+ , fiTooltip = tooltip+ , fiIdent = theId+ , fiInput = input+ , fiErrors = case res of+ FormFailure [x] -> Just $ string x+ _ -> Nothing+ , fiRequired = True+ }+ return (res, fi, UrlEncoded)++maybeSelectField :: (Eq x, IsForm f, Maybe x ~ FormType f)+ => [(x, String)]+ -> FormFieldSettings+ -> Maybe (FormType f)+ -> f+maybeSelectField pairs ffs initial' = toForm $ do+ env <- askParams+ let initial = join initial'+ label = ffsLabel ffs+ tooltip = ffsTooltip ffs+ theId <- maybe newFormIdent return $ ffsId ffs+ name <- maybe newFormIdent return $ ffsName ffs+ let pairs' = zip [1 :: Int ..] pairs+ let res = case lookup name env of+ Nothing -> FormMissing+ Just "none" -> FormSuccess Nothing+ Just x ->+ case reads x of+ (x', _):_ ->+ case lookup x' pairs' of+ Nothing -> FormFailure ["Invalid entry"]+ Just (y, _) -> FormSuccess $ Just y+ [] -> FormFailure ["Invalid entry"]+ let isSelected x =+ case res of+ FormSuccess y -> Just x == y+ _ -> Just x == initial+ let input =+#if __GLASGOW_HASKELL__ >= 700+ [hamlet|+#else+ [$hamlet|+#endif+<select id="#{theId}" name="#{name}">+ <option value="none">+ $forall pair <- pairs'+ <option value="#{show (fst pair)}" :isSelected (fst (snd pair)):selected="">#{snd (snd pair)}+|]+ let fi = FieldInfo+ { fiLabel = string label+ , fiTooltip = tooltip+ , fiIdent = theId+ , fiInput = input+ , fiErrors = case res of+ FormFailure [x] -> Just $ string x+ _ -> Nothing+ , fiRequired = False+ }+ return (res, fi, UrlEncoded)++stringInput :: String -> FormInput sub master String+stringInput n =+ mapFormXml fieldsToInput $+ requiredFieldHelper stringFieldProfile (nameSettings n) Nothing++maybeStringInput :: String -> FormInput sub master (Maybe String)+maybeStringInput n =+ mapFormXml fieldsToInput $+ optionalFieldHelper stringFieldProfile (nameSettings n) Nothing++boolInput :: String -> FormInput sub master Bool+boolInput n = GForm $ do+ env <- askParams+ let res = case lookup n env of+ Nothing -> FormSuccess False+ Just "" -> FormSuccess False+ Just "false" -> FormSuccess False+ Just _ -> FormSuccess True+ let xml =+#if __GLASGOW_HASKELL__ >= 700+ [hamlet|+#else+ [$hamlet|+#endif+ <input id="#{n}" type="checkbox" name="#{n}">+|]+ return (res, [xml], UrlEncoded)++dayInput :: String -> FormInput sub master Day+dayInput n =+ mapFormXml fieldsToInput $+ requiredFieldHelper dayFieldProfile (nameSettings n) Nothing++maybeDayInput :: String -> FormInput sub master (Maybe Day)+maybeDayInput n =+ mapFormXml fieldsToInput $+ optionalFieldHelper dayFieldProfile (nameSettings n) Nothing++nameSettings :: String -> FormFieldSettings+nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n)++urlField :: (IsForm f, FormType f ~ String)+ => FormFieldSettings -> Maybe String -> f+urlField = requiredFieldHelper urlFieldProfile++maybeUrlField :: (IsForm f, FormType f ~ Maybe String)+ => FormFieldSettings -> Maybe (Maybe String) -> f+maybeUrlField = optionalFieldHelper urlFieldProfile++urlInput :: String -> FormInput sub master String+urlInput n =+ mapFormXml fieldsToInput $+ requiredFieldHelper urlFieldProfile (nameSettings n) Nothing++emailField :: (IsForm f, FormType f ~ String)+ => FormFieldSettings -> Maybe String -> f+emailField = requiredFieldHelper emailFieldProfile++maybeEmailField :: (IsForm f, FormType f ~ Maybe String)+ => FormFieldSettings -> Maybe (Maybe String) -> f+maybeEmailField = optionalFieldHelper emailFieldProfile++emailInput :: String -> FormInput sub master String+emailInput n =+ mapFormXml fieldsToInput $+ requiredFieldHelper emailFieldProfile (nameSettings n) Nothing++searchField :: (IsForm f, FormType f ~ String)+ => AutoFocus -> FormFieldSettings -> Maybe String -> f+searchField = requiredFieldHelper . searchFieldProfile++maybeSearchField :: (IsForm f, FormType f ~ Maybe String)+ => AutoFocus -> FormFieldSettings -> Maybe (Maybe String) -> f+maybeSearchField = optionalFieldHelper . searchFieldProfile++textareaField :: (IsForm f, FormType f ~ Textarea)+ => FormFieldSettings -> Maybe Textarea -> f+textareaField = requiredFieldHelper textareaFieldProfile++maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe Textarea)+maybeTextareaField = optionalFieldHelper textareaFieldProfile++hiddenField :: (IsForm f, FormType f ~ String)+ => FormFieldSettings -> Maybe String -> f+hiddenField = requiredFieldHelper hiddenFieldProfile++maybeHiddenField :: (IsForm f, FormType f ~ Maybe String)+ => FormFieldSettings -> Maybe (Maybe String) -> f+maybeHiddenField = optionalFieldHelper hiddenFieldProfile++fileField :: (IsForm f, FormType f ~ FileInfo)+ => FormFieldSettings -> f+fileField ffs = toForm $ do+ env <- lift ask+ fenv <- lift $ lift ask+ let (FormFieldSettings label tooltip theId' name') = ffs+ name <- maybe newFormIdent return name'+ theId <- maybe newFormIdent return theId'+ let res =+ if null env && null fenv+ then FormMissing+ else case lookup name fenv of+ Nothing -> FormFailure ["File is required"]+ Just x -> FormSuccess x+ let fi = FieldInfo+ { fiLabel = string label+ , fiTooltip = tooltip+ , fiIdent = theId+ , fiInput = fileWidget theId name True+ , fiErrors = case res of+ FormFailure [x] -> Just $ string x+ _ -> Nothing+ , fiRequired = True+ }+ let res' = case res of+ FormFailure [e] -> FormFailure [label ++ ": " ++ e]+ _ -> res+ return (res', fi, Multipart)++maybeFileField :: (IsForm f, FormType f ~ Maybe FileInfo)+ => FormFieldSettings -> f+maybeFileField ffs = toForm $ do+ fenv <- lift $ lift ask+ let (FormFieldSettings label tooltip theId' name') = ffs+ name <- maybe newFormIdent return name'+ theId <- maybe newFormIdent return theId'+ let res = FormSuccess $ lookup name fenv+ let fi = FieldInfo+ { fiLabel = string label+ , fiTooltip = tooltip+ , fiIdent = theId+ , fiInput = fileWidget theId name False+ , fiErrors = Nothing+ , fiRequired = True+ }+ return (res, fi, Multipart)++fileWidget :: String -> String -> Bool -> GWidget s m ()+fileWidget theId name isReq =+#if __GLASGOW_HASKELL__ >= 700+ [hamlet|+#else+ [$hamlet|+#endif+<input id="#{theId}" type="file" name="#{name}" :isReq:required="">+|]++radioField :: (Eq x, IsForm f, FormType f ~ x)+ => [(x, String)]+ -> FormFieldSettings+ -> Maybe x+ -> f+radioField pairs ffs initial = toForm $ do+ env <- askParams+ let label = ffsLabel ffs+ tooltip = ffsTooltip ffs+ theId <- maybe newFormIdent return $ ffsId ffs+ name <- maybe newFormIdent return $ ffsName ffs+ let pairs' = zip [1 :: Int ..] pairs+ let res = case lookup name env of+ Nothing -> FormMissing+ Just "none" -> FormFailure ["Field is required"]+ Just x ->+ case reads x of+ (x', _):_ ->+ case lookup x' pairs' of+ Nothing -> FormFailure ["Invalid entry"]+ Just (y, _) -> FormSuccess y+ [] -> FormFailure ["Invalid entry"]+ let isSelected x =+ case res of+ FormSuccess y -> x == y+ _ -> Just x == initial+ let input =+#if __GLASGOW_HASKELL__ >= 700+ [hamlet|+#else+ [$hamlet|+#endif+<div id="#{theId}">+ $forall pair <- pairs'+ <div>+ <input id="#{theId}-#{show (fst pair)}" type="radio" name="#{name}" value="#{show (fst pair)}" :isSelected (fst (snd pair)):checked="">+ <label for="#{name}-#{show (fst pair)}">#{snd (snd pair)}+|]+ let fi = FieldInfo+ { fiLabel = string label+ , fiTooltip = tooltip+ , fiIdent = theId+ , fiInput = input+ , fiErrors = case res of+ FormFailure [x] -> Just $ string x+ _ -> Nothing+ , fiRequired = True+ }+ return (res, fi, UrlEncoded)++maybeRadioField+ :: (Eq x, IsForm f, FormType f ~ Maybe x)+ => [(x, String)]+ -> FormFieldSettings+ -> Maybe (FormType f)+ -> f+maybeRadioField pairs ffs initial' = toForm $ do+ env <- askParams+ let initial = join initial'+ label = ffsLabel ffs+ tooltip = ffsTooltip ffs+ theId <- maybe newFormIdent return $ ffsId ffs+ name <- maybe newFormIdent return $ ffsName ffs+ let pairs' = zip [1 :: Int ..] pairs+ let res = case lookup name env of+ Nothing -> FormMissing+ Just "none" -> FormSuccess Nothing+ Just x ->+ case reads x of+ (x', _):_ ->+ case lookup x' pairs' of+ Nothing -> FormFailure ["Invalid entry"]+ Just (y, _) -> FormSuccess $ Just y+ [] -> FormFailure ["Invalid entry"]+ let isSelected x =+ case res of+ FormSuccess y -> Just x == y+ _ -> Just x == initial+ let isNone =+ case res of+ FormSuccess Nothing -> True+ FormSuccess Just{} -> False+ _ -> isNothing initial+ let input =+#if __GLASGOW_HASKELL__ >= 700+ [hamlet|+#else+ [$hamlet|+#endif+<div id="#{theId}">+ $forall pair <- pairs'+ <div>+ <input id="#{theId}-none" type="radio" name="#{name}" value="none" :isNone:checked="">None+ <div>+ <input id="#{theId}-#{show (fst pair)}" type="radio" name="#{name}" value="#{show (fst pair)}" :isSelected (fst (snd pair)):checked="">+ <label for="#{name}-#{show (fst pair)}">#{snd (snd pair)}+|]+ let fi = FieldInfo+ { fiLabel = string label+ , fiTooltip = tooltip+ , fiIdent = theId+ , fiInput = input+ , fiErrors = case res of+ FormFailure [x] -> Just $ string x+ _ -> Nothing+ , fiRequired = False+ }+ return (res, fi, UrlEncoded)
+ Yesod/Form/Jquery.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+-- | Some fields spiced up with jQuery UI.+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.Widget+import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime,+ timeToTimeOfDay)+import Data.Char (isSpace)+import Data.Default+import Text.Hamlet (hamlet)+import Text.Julius (julius)+import Control.Monad.Trans.Class (lift)++#if __GLASGOW_HASKELL__ >= 700+#define HAMLET hamlet+#define CASSIUS cassius+#define JULIUS julius+#else+#define HAMLET $hamlet+#define CASSIUS $cassius+#define JULIUS $julius+#endif++-- | Gets the Google hosted jQuery UI 1.8 CSS file with the given theme.+googleHostedJqueryUiCss :: String -> String+googleHostedJqueryUiCss theme = concat+ [ "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/themes/"+ , theme+ , "/jquery-ui.css"+ ]++class YesodJquery a where+ -- | The jQuery 1.4 Javascript file.+ urlJqueryJs :: a -> Either (Route a) String+ urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.4/jquery.min.js"++ -- | The jQuery UI 1.8 Javascript file.+ urlJqueryUiJs :: a -> Either (Route a) String+ urlJqueryUiJs _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/jquery-ui.min.js"++ -- | The jQuery UI 1.8 CSS file; defaults to cupertino theme.+ urlJqueryUiCss :: a -> Either (Route a) String+ urlJqueryUiCss _ = Right $ googleHostedJqueryUiCss "cupertino"++ -- | jQuery UI time picker add-on.+ urlJqueryUiDateTimePicker :: a -> Either (Route a) String+ urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js"++jqueryDayField :: (IsForm f, FormType f ~ Day, YesodJquery (FormMaster f))+ => JqueryDaySettings+ -> FormFieldSettings+ -> Maybe (FormType f)+ -> f+jqueryDayField = requiredFieldHelper . jqueryDayFieldProfile++maybeJqueryDayField+ :: (IsForm f, FormType f ~ Maybe Day, YesodJquery (FormMaster f))+ => JqueryDaySettings+ -> FormFieldSettings+ -> Maybe (FormType f)+ -> f+maybeJqueryDayField = optionalFieldHelper . jqueryDayFieldProfile++jqueryDayFieldProfile :: YesodJquery y+ => JqueryDaySettings -> FieldProfile sub y Day+jqueryDayFieldProfile jds = FieldProfile+ { fpParse = maybe+ (Left "Invalid day, must be in YYYY-MM-DD format")+ Right+ . readMay+ , fpRender = show+ , fpWidget = \theId name val isReq -> do+ addHtml [HAMLET|\+<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}">+|]+ addScript' urlJqueryJs+ addScript' urlJqueryUiJs+ addStylesheet' urlJqueryUiCss+ addJulius [JULIUS|+$(function(){$("##{theId}").datepicker({+ dateFormat:'yy-mm-dd',+ changeMonth:#{jsBool $ jdsChangeMonth jds},+ changeYear:#{jsBool $ jdsChangeYear jds},+ numberOfMonths:#{mos $ jdsNumberOfMonths jds},+ yearRange:"#{jdsYearRange jds}"+})});+|]+ }+ where+ jsBool True = "true"+ jsBool False = "false"+ mos (Left i) = show i+ mos (Right (x, y)) = concat+ [ "["+ , show x+ , ","+ , show y+ , "]"+ ]++ifRight :: Either a b -> (b -> c) -> Either a c+ifRight e f = case e of+ Left l -> Left l+ Right r -> Right $ f r++showLeadingZero :: (Show a) => a -> String+showLeadingZero time = let t = show time in if length t == 1 then "0" ++ t else t++jqueryDayTimeField+ :: (IsForm f, FormType f ~ UTCTime, YesodJquery (FormMaster f))+ => FormFieldSettings+ -> Maybe (FormType f)+ -> f+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) =+ let timeOfDay = timeToTimeOfDay utcTime+ in (replace '-' '/' (show day)) ++ " " ++ showTimeOfDay timeOfDay+ where+ showTimeOfDay (TimeOfDay hour minute _) =+ let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM")+ in (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm++jqueryDayTimeFieldProfile :: YesodJquery y => FieldProfile sub y UTCTime+jqueryDayTimeFieldProfile = FieldProfile+ { fpParse = parseUTCTime+ , fpRender = jqueryDayTimeUTCTime+ , fpWidget = \theId name val isReq -> do+ addHtml [HAMLET|\+<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}">+|]+ addScript' urlJqueryJs+ addScript' urlJqueryUiJs+ addScript' urlJqueryUiDateTimePicker+ addStylesheet' urlJqueryUiCss+ addJulius [JULIUS|+$(function(){$("##{theId}").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})});+|]+ }++parseUTCTime :: String -> Either String UTCTime+parseUTCTime s =+ let (dateS, timeS) = break isSpace (dropWhile isSpace s)+ dateE = parseDate dateS+ in case dateE of+ Left l -> Left l+ Right date ->+ ifRight (parseTime timeS)+ (UTCTime date . timeOfDayToTime)++jqueryAutocompleteField+ :: (IsForm f, FormType f ~ String, YesodJquery (FormMaster f))+ => Route (FormMaster f)+ -> FormFieldSettings+ -> Maybe (FormType f)+ -> f+jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile++maybeJqueryAutocompleteField+ :: (IsForm f, FormType f ~ Maybe String, YesodJquery (FormMaster f))+ => Route (FormMaster f)+ -> FormFieldSettings+ -> Maybe (FormType f)+ -> f+maybeJqueryAutocompleteField src =+ optionalFieldHelper $ jqueryAutocompleteFieldProfile src++jqueryAutocompleteFieldProfile :: YesodJquery y => Route y -> FieldProfile sub y String+jqueryAutocompleteFieldProfile src = FieldProfile+ { fpParse = Right+ , fpRender = id+ , fpWidget = \theId name val isReq -> do+ addHtml [HAMLET|\+<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}" .autocomplete>+|]+ addScript' urlJqueryJs+ addScript' urlJqueryUiJs+ addStylesheet' urlJqueryUiCss+ addJulius [JULIUS|+$(function(){$("##{theId}").autocomplete({source:"@{src}",minLength:2})});+|]+ }++addScript' :: (y -> Either (Route y) String) -> GWidget sub y ()+addScript' f = do+ y <- lift getYesod+ addScriptEither $ f y++addStylesheet' :: (y -> Either (Route y) String) -> GWidget sub y ()+addStylesheet' f = do+ y <- lift getYesod+ addStylesheetEither $ f y++readMay :: Read a => String -> Maybe a+readMay s = case reads s of+ (x, _):_ -> Just x+ [] -> Nothing++-- | Replaces all instances of a value in a list by another value.+-- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace+replace :: Eq a => a -> a -> [a] -> [a]+replace x y = map (\z -> if z == x then y else z)++data JqueryDaySettings = JqueryDaySettings+ { jdsChangeMonth :: Bool+ , jdsChangeYear :: Bool+ , jdsYearRange :: String+ , jdsNumberOfMonths :: Either Int (Int, Int)+ }++instance Default JqueryDaySettings where+ def = JqueryDaySettings+ { jdsChangeMonth = False+ , jdsChangeYear = False+ , jdsYearRange = "c-10:c+10"+ , jdsNumberOfMonths = Left 1+ }
+ Yesod/Form/Nic.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+-- | Provide the user with a rich text editor.+module Yesod.Form.Nic+ ( YesodNic (..)+ , nicHtmlField+ , maybeNicHtmlField+ ) where++import Yesod.Handler+import Yesod.Form.Core+import Yesod.Widget+import Text.HTML.SanitizeXSS (sanitizeBalance)+import Text.Hamlet (Html, hamlet)+import Text.Julius (julius)+import Text.Blaze.Renderer.String (renderHtml)+import Text.Blaze (preEscapedString)+import Control.Monad.Trans.Class (lift)++class YesodNic a where+ -- | NIC Editor Javascript file.+ urlNicEdit :: a -> Either (Route a) String+ urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"++nicHtmlField :: (IsForm f, FormType f ~ Html, YesodNic (FormMaster f))+ => FormFieldSettings -> Maybe Html -> f+nicHtmlField = requiredFieldHelper nicHtmlFieldProfile++maybeNicHtmlField+ :: (IsForm f, FormType f ~ Maybe Html, YesodNic (FormMaster f))+ => FormFieldSettings -> Maybe (FormType f) -> f+maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile++nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html+nicHtmlFieldProfile = FieldProfile+ { fpParse = Right . preEscapedString . sanitizeBalance+ , fpRender = renderHtml+ , fpWidget = \theId name val _isReq -> do+ addHtml+#if __GLASGOW_HASKELL__ >= 700+ [hamlet|+#else+ [$hamlet|+#endif+ <textarea id="#{theId}" name="#{name}" .html>#{val}+|]+ addScript' urlNicEdit+ addJulius+#if __GLASGOW_HASKELL__ >= 700+ [julius|+#else+ [$julius|+#endif+bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{theId}")});+|]+ }++addScript' :: (y -> Either (Route y) String) -> GWidget sub y ()+addScript' f = do+ y <- lift getYesod+ addScriptEither $ f y
+ Yesod/Form/Profiles.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+module Yesod.Form.Profiles+ ( stringFieldProfile+ , passwordFieldProfile+ , textareaFieldProfile+ , hiddenFieldProfile+ , intFieldProfile+ , dayFieldProfile+ , timeFieldProfile+ , htmlFieldProfile+ , emailFieldProfile+ , searchFieldProfile+ , AutoFocus+ , urlFieldProfile+ , doubleFieldProfile+ , parseDate+ , parseTime+ , Textarea (..)+ ) where++import Yesod.Form.Core+import Yesod.Widget+import Text.Hamlet hiding (renderHtml)+import Text.Blaze (ToHtml (..))+import Text.Cassius+import Data.Time (Day, TimeOfDay(..))+import qualified Text.Email.Validate as Email+import Network.URI (parseURI)+import Database.Persist (PersistField)+import Text.HTML.SanitizeXSS (sanitizeBalance)+import Control.Monad (when)++import qualified Blaze.ByteString.Builder.Html.Utf8 as B+import Blaze.ByteString.Builder (writeByteString, toLazyByteString)+import Blaze.ByteString.Builder.Internal.Write (fromWriteList)++import Text.Blaze.Renderer.String (renderHtml)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L++#if __GLASGOW_HASKELL__ >= 700+#define HAMLET hamlet+#define CASSIUS cassius+#define JULIUS julius+#else+#define HAMLET $hamlet+#define CASSIUS $cassius+#define JULIUS $julius+#endif++intFieldProfile :: Integral i => FieldProfile sub y i+intFieldProfile = FieldProfile+ { fpParse = maybe (Left "Invalid integer") Right . readMayI+ , fpRender = showI+ , fpWidget = \theId name val isReq -> addHamlet+ [HAMLET|\+<input id="#{theId}" name="#{name}" type="number" :isReq:required="" value="#{val}">+|]+ }+ where+ showI x = show (fromIntegral x :: Integer)+ readMayI s = case reads s of+ (x, _):_ -> Just $ fromInteger x+ [] -> Nothing++doubleFieldProfile :: FieldProfile sub y Double+doubleFieldProfile = FieldProfile+ { fpParse = maybe (Left "Invalid number") Right . readMay+ , fpRender = show+ , fpWidget = \theId name val isReq -> addHamlet+ [HAMLET|\+<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}">+|]+ }++dayFieldProfile :: FieldProfile sub y Day+dayFieldProfile = FieldProfile+ { fpParse = parseDate+ , fpRender = show+ , fpWidget = \theId name val isReq -> addHamlet+ [HAMLET|\+<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}">+|]+ }++timeFieldProfile :: FieldProfile sub y TimeOfDay+timeFieldProfile = FieldProfile+ { fpParse = parseTime+ , fpRender = show . roundFullSeconds+ , fpWidget = \theId name val isReq -> addHamlet+ [HAMLET|\+<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}">+|]+ }+ where+ roundFullSeconds tod =+ TimeOfDay (todHour tod) (todMin tod) fullSec+ where+ fullSec = fromInteger $ floor $ todSec tod++htmlFieldProfile :: FieldProfile sub y Html+htmlFieldProfile = FieldProfile+ { fpParse = Right . preEscapedString . sanitizeBalance+ , fpRender = renderHtml+ , fpWidget = \theId name val _isReq -> addHamlet+ [HAMLET|\+<textarea id="#{theId}" name="#{name}" .html>#{val}+|]+ }++-- | A newtype wrapper around a 'String' that converts newlines to HTML+-- br-tags.+newtype Textarea = Textarea { unTextarea :: String }+ deriving (Show, Read, Eq, PersistField)+instance ToHtml Textarea where+ toHtml =+ unsafeByteString+ . S.concat+ . L.toChunks+ . toLazyByteString+ . fromWriteList writeHtmlEscapedChar+ . unTextarea+ where+ -- Taken from blaze-builder and modified with newline handling.+ writeHtmlEscapedChar '\n' = writeByteString "<br>"+ writeHtmlEscapedChar c = B.writeHtmlEscapedChar c++textareaFieldProfile :: FieldProfile sub y Textarea+textareaFieldProfile = FieldProfile+ { fpParse = Right . Textarea+ , fpRender = unTextarea+ , fpWidget = \theId name val _isReq -> addHamlet+ [HAMLET|\+<textarea id="#{theId}" name="#{name}">#{val}+|]+ }++hiddenFieldProfile :: FieldProfile sub y String+hiddenFieldProfile = FieldProfile+ { fpParse = Right+ , fpRender = id+ , fpWidget = \theId name val _isReq -> addHamlet+ [HAMLET|\+<input type="hidden" id="#{theId}" name="#{name}" value="#{val}">+|]+ }++stringFieldProfile :: FieldProfile sub y String+stringFieldProfile = FieldProfile+ { fpParse = Right+ , fpRender = id+ , fpWidget = \theId name val isReq -> addHamlet+ [HAMLET|\+<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}">+|]+ }++passwordFieldProfile :: FieldProfile s m String+passwordFieldProfile = FieldProfile+ { fpParse = Right+ , fpRender = id+ , fpWidget = \theId name val isReq -> addHamlet+ [HAMLET|\+<input id="#{theId}" name="#{name}" type="password" :isReq:required="" value="#{val}">+|]+ }++readMay :: Read a => String -> Maybe a+readMay s = case reads s of+ (x, _):_ -> Just x+ [] -> Nothing++parseDate :: String -> Either String Day+parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right+ . readMay . replace '/' '-'++-- | Replaces all instances of a value in a list by another value.+-- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace+replace :: Eq a => a -> a -> [a] -> [a]+replace x y = map (\z -> if z == x then y else z)++parseTime :: String -> Either String TimeOfDay+parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0')+parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0')+parseTime (h1:h2:':':m1:m2:' ':'A':'M':[]) =+ parseTimeHelper (h1, h2, m1, m2, '0', '0')+parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) =+ let [h1', h2'] = show $ (read [h1, h2] :: Int) + 12+ in parseTimeHelper (h1', h2', m1, m2, '0', '0')+parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) =+ parseTimeHelper (h1, h2, m1, m2, s1, s2)+parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format"++parseTimeHelper :: (Char, Char, Char, Char, Char, Char)+ -> Either [Char] TimeOfDay+parseTimeHelper (h1, h2, m1, m2, s1, s2)+ | h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h+ | m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m+ | s < 0 || s > 59 = Left $ "Invalid second: " ++ show s+ | otherwise = Right $ TimeOfDay h m s+ where+ h = read [h1, h2]+ m = read [m1, m2]+ s = fromInteger $ read [s1, s2]++emailFieldProfile :: FieldProfile s y String+emailFieldProfile = FieldProfile+ { fpParse = \s -> if Email.isValid s+ then Right s+ else Left "Invalid e-mail address"+ , fpRender = id+ , fpWidget = \theId name val isReq -> addHamlet+ [HAMLET|\+<input id="#{theId}" name="#{name}" type="email" :isReq:required="" value="#{val}">+|]+ }++type AutoFocus = Bool+searchFieldProfile :: AutoFocus -> FieldProfile s y String+searchFieldProfile autoFocus = FieldProfile+ { fpParse = Right+ , fpRender = id+ , fpWidget = \theId name val isReq -> do+ addHtml [HAMLET|\+<input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{val}">+|]+ when autoFocus $ do+ addHtml $ [HAMLET|\<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}</script> +|]+ addCassius [CASSIUS|+ #$theId$+ -webkit-appearance: textfield+ |]+ }++urlFieldProfile :: FieldProfile s y String+urlFieldProfile = FieldProfile+ { fpParse = \s -> case parseURI s of+ Nothing -> Left "Invalid URL"+ Just _ -> Right s+ , fpRender = id+ , fpWidget = \theId name val isReq -> addHamlet+ [HAMLET|\+<input id="#{theId}" name="#{name}" type="url" :isReq:required="" value="#{val}">+|]+ }
+ yesod-form.cabal view
@@ -0,0 +1,40 @@+name: yesod-form+version: 0.0.0+license: BSD3+license-file: LICENSE+author: Michael Snoyman <michael@snoyman.com>+maintainer: Michael Snoyman <michael@snoyman.com>+synopsis: Form handling support for Yesod Web Framework+category: Web, Yesod+stability: Stable+cabal-version: >= 1.6+build-type: Simple+homepage: http://docs.yesodweb.com/++library+ build-depends: base >= 4 && < 5+ , yesod-core >= 0.7 && < 0.8+ , time >= 1.1.4 && < 1.3+ , hamlet >= 0.7 && < 0.8+ , persistent >= 0.4 && < 0.5+ , template-haskell+ , transformers >= 0.2.2 && < 0.3+ , data-default >= 0.2 && < 0.3+ , xss-sanitize >= 0.2.4 && < 0.3+ , blaze-builder >= 0.2.1 && < 0.3+ , network >= 2.2 && < 2.4+ , email-validate >= 0.2.6 && < 0.3+ , blaze-html >= 0.4 && < 0.5+ , bytestring >= 0.9 && < 0.10+ exposed-modules: Yesod.Form+ Yesod.Form.Class+ Yesod.Form.Core+ Yesod.Form.Fields+ Yesod.Form.Jquery+ Yesod.Form.Nic+ Yesod.Form.Profiles+ ghc-options: -Wall++source-repository head+ type: git+ location: git://github.com/snoyberg/yesod-form.git