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

Removed Yesod.Form hierarchy

Browse Source 
All of this code will be included in a separate yesod-form package to
allow for more flexibility in API changes, plus to make it more natural
to swap in other packages such as digestive-functors.
This commit is contained in:
Michael Snoyman 2010-12-16 22:05:54 +02:00
parent b2e95911d8
commit 522203f812
12 changed files with 2 additions and 2094 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Yesod.hs
View File

@ -6,7 +6,6 @@ module Yesod
, module Yesod.Yesod
, module Yesod.Handler
, module Yesod.Dispatch
, module Yesod.Form
, module Yesod.Hamlet
, module Yesod.Json
, module Yesod.Widget
@ -34,7 +33,6 @@ import Yesod.Handler hiding (runHandler)
#endif
import Yesod.Request
import Yesod.Form
import Yesod.Widget
import Network.Wai (Application)
import Yesod.Hamlet

341
Yesod/Form.hs
View File

@ -1,341 +0,0 @@
{-# 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 "transformers" Control.Monad.IO.Class
import Control.Monad ((<=<))
import Language.Haskell.TH.Syntax
import Database.Persist.Base (EntityDef (..), PersistEntity (entityDef))
import Data.Char (toUpper, isUpper)
import Control.Arrow ((&&&))
import Data.List (group, sort)
-- | 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 GHC7
[hamlet|
#else
[$hamlet|
#endif
%tr.$clazz.fi$
%td
%label!for=$fiIdent.fi$ $fiLabel.fi$
.tooltip $fiTooltip.fi$
%td
^fiInput.fi^
$maybe fiErrors.fi err
%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 GHC7
[hamlet|
#else
[$hamlet|
#endif
.$clazz.fi$
%label!for=$fiIdent.fi$ $fiLabel.fi$
.tooltip $fiTooltip.fi$
^fiInput.fi^
$maybe fiErrors.fi err
%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
rr <- getRequest
(pp, files) <- liftIO $ reqRequestBody rr
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
rr <- getRequest
(pp, files) <- liftIO $ reqRequestBody rr
nonce <- fmap reqNonce getRequest
(res, xml, enctype) <- runFormGeneric pp files f
let res' =
case res of
FormSuccess x ->
if lookup nonceName pp == Just 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, hidden nonce)
where
hidden nonce =
#if GHC7
[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
rr <- getRequest
(pp, files) <- liftIO $ reqRequestBody rr
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
rr <- getRequest
(pp, files) <- liftIO $ reqRequestBody rr
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 GHC7
[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 GHC7
[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 GHC7
[hamlet|
#else
[$hamlet|
#endif
%input!type=hidden!name=$nonceName$!value=$nonce$
|])
-- | 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

61
Yesod/Form/Class.hs
View File

@ -1,61 +0,0 @@
{-# 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

369
Yesod/Form/Core.hs
View File

@ -1,369 +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
, 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 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 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

409
Yesod/Form/Fields.hs
View File

@ -1,409 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}
module Yesod.Form.Fields
( -- * Fields
-- ** Required
stringField
, passwordField
, textareaField
, hiddenField
, intField
, doubleField
, dayField
, timeField
, htmlField
, selectField
, boolField
, emailField
, searchField
, urlField
, fileField
-- ** Optional
, maybeStringField
, maybePasswordField
, maybeTextareaField
, maybeHiddenField
, maybeIntField
, maybeDoubleField
, maybeDayField
, maybeTimeField
, maybeHtmlField
, maybeSelectField
, 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)
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 GHC7
[hamlet|
#else
[$hamlet|
#endif
%input#$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 GHC7
[hamlet|
#else
[$hamlet|
#endif
%select#$theId$!name=$name$
%option!value=none
$forall pairs' pair
%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 GHC7
[hamlet|
#else
[$hamlet|
#endif
%select#$theId$!name=$name$
%option!value=none
$forall pairs' pair
%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 GHC7
[hamlet|
#else
[$hamlet|
#endif
%input#$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 GHC7
[hamlet|
#else
[$hamlet|
#endif
%input#$theId$!type=file!name=$name$!:isReq:required
|]

235
Yesod/Form/Jquery.hs
View File

@ -1,235 +0,0 @@
{-# 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 Yesod.Hamlet
import Data.Char (isSpace)
import Data.Default
#if GHC7
#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#$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#$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.autocomplete#$theId$!name=$name$!type=text!:isReq:required!value=$val$
|]
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 <- liftHandler getYesod
addScriptEither $ f y
addStylesheet' :: (y -> Either (Route y) String) -> GWidget sub y ()
addStylesheet' f = do
y <- liftHandler 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
}

61
Yesod/Form/Nic.hs
View File

@ -1,61 +0,0 @@
{-# 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.Hamlet
import Yesod.Widget
import Text.HTML.SanitizeXSS (sanitizeBalance)
import Yesod.Internal (lbsToChars)
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 = lbsToChars . renderHtml
, fpWidget = \theId name val _isReq -> do
addHtml
#if GHC7
[hamlet|
#else
[$hamlet|
#endif
%textarea.html#$theId$!name=$name$ $val$
|]
addScript' urlNicEdit
addJulius
#if GHC7
[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 <- liftHandler getYesod
addScriptEither $ f y

235
Yesod/Form/Profiles.hs
View File

@ -1,235 +0,0 @@
{-# 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
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)
import Blaze.ByteString.Builder.Internal.Write (fromWriteList)
import Yesod.Internal (lbsToChars)
#if GHC7
#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#$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#$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#$theId$!name=$name$!type=date!:isReq:required!value=$val$
|]
}
timeFieldProfile :: FieldProfile sub y TimeOfDay
timeFieldProfile = FieldProfile
{ fpParse = parseTime
, fpRender = show
, fpWidget = \theId name val isReq -> addHamlet
[HAMLET|
%input#$theId$!name=$name$!:isReq:required!value=$val$
|]
}
htmlFieldProfile :: FieldProfile sub y Html
htmlFieldProfile = FieldProfile
{ fpParse = Right . preEscapedString . sanitizeBalance
, fpRender = lbsToChars . renderHtml
, fpWidget = \theId name val _isReq -> addHamlet
[HAMLET|
%textarea.html#$theId$!name=$name$ $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 =
Html . 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#$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#$theId$!name=$name$!value=$val$
|]
}
stringFieldProfile :: FieldProfile sub y String
stringFieldProfile = FieldProfile
{ fpParse = Right
, fpRender = id
, fpWidget = \theId name val isReq -> addHamlet
[HAMLET|
%input#$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#$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#$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#$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#$theId$!name=$name$!type=url!:isReq:required!value=$val$
|]
}

208
Yesod/Helpers/Crud.hs
View File

@ -1,208 +0,0 @@
{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Yesod.Helpers.Crud
( Item (..)
, Crud (..)
, CrudRoute (..)
, defaultCrud
) where
import Yesod.Yesod
import Yesod.Widget
import Yesod.Dispatch
import Yesod.Content
import Yesod.Handler
import Text.Hamlet
import Yesod.Form
import Language.Haskell.TH.Syntax
-- | An entity which can be displayed by the Crud subsite.
class Item a where
-- | The title of an entity, to be displayed in the list of all entities.
itemTitle :: a -> String
-- | Defines all of the CRUD operations (Create, Read, Update, Delete)
-- necessary to implement this subsite. When using the "Yesod.Form" module and
-- 'ToForm' typeclass, you can probably just use 'defaultCrud'.
data Crud master item = Crud
{ crudSelect :: GHandler (Crud master item) master [(Key item, item)]
, crudReplace :: Key item -> item -> GHandler (Crud master item) master ()
, crudInsert :: item -> GHandler (Crud master item) master (Key item)
, crudGet :: Key item -> GHandler (Crud master item) master (Maybe item)
, crudDelete :: Key item -> GHandler (Crud master item) master ()
}
mkYesodSub "Crud master item"
[ ClassP ''Yesod [VarT $ mkName "master"]
, ClassP ''Item [VarT $ mkName "item"]
, ClassP ''SinglePiece [ConT ''Key `AppT` VarT (mkName "item")]
, ClassP ''ToForm [VarT $ mkName "item", VarT $ mkName "master"]
]
#if GHC7
[parseRoutes|
#else
[$parseRoutes|
#endif
/ CrudListR GET
/add CrudAddR GET POST
/edit/#String CrudEditR GET POST
/delete/#String CrudDeleteR GET POST
|]
getCrudListR :: (Yesod master, Item item, SinglePiece (Key item))
=> GHandler (Crud master item) master RepHtml
getCrudListR = do
items <- getYesodSub >>= crudSelect
toMaster <- getRouteToMaster
defaultLayout $ do
setTitle "Items"
addWidget
#if GHC7
[hamlet|
#else
[$hamlet|
#endif
%h1 Items
%ul
$forall items item
%li
%a!href=@toMaster.CrudEditR.toSinglePiece.fst.item@
$itemTitle.snd.item$
%p
%a!href=@toMaster.CrudAddR@ Add new item
|]
getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item),
ToForm item master)
=> GHandler (Crud master item) master RepHtml
getCrudAddR = crudHelper
"Add new"
(Nothing :: Maybe (Key item, item))
False
postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item),
ToForm item master)
=> GHandler (Crud master item) master RepHtml
postCrudAddR = crudHelper
"Add new"
(Nothing :: Maybe (Key item, item))
True
getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item),
ToForm item master)
=> String -> GHandler (Crud master item) master RepHtml
getCrudEditR s = do
itemId <- maybe notFound return $ itemReadId s
crud <- getYesodSub
item <- crudGet crud itemId >>= maybe notFound return
crudHelper
"Edit item"
(Just (itemId, item))
False
postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item),
ToForm item master)
=> String -> GHandler (Crud master item) master RepHtml
postCrudEditR s = do
itemId <- maybe notFound return $ itemReadId s
crud <- getYesodSub
item <- crudGet crud itemId >>= maybe notFound return
crudHelper
"Edit item"
(Just (itemId, item))
True
getCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item))
=> String -> GHandler (Crud master item) master RepHtml
getCrudDeleteR s = do
itemId <- maybe notFound return $ itemReadId s
crud <- getYesodSub
item <- crudGet crud itemId >>= maybe notFound return -- Just ensure it exists
toMaster <- getRouteToMaster
defaultLayout $ do
setTitle "Confirm delete"
addWidget
#if GHC7
[hamlet|
#else
[$hamlet|
#endif
%form!method=post!action=@toMaster.CrudDeleteR.s@
%h1 Really delete?
%p Do you really want to delete $itemTitle.item$?
%p
%input!type=submit!value=Yes
\ $
%a!href=@toMaster.CrudListR@ No
|]
postCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item))
=> String -> GHandler (Crud master item) master RepHtml
postCrudDeleteR s = do
itemId <- maybe notFound return $ itemReadId s
crud <- getYesodSub
toMaster <- getRouteToMaster
crudDelete crud itemId
redirect RedirectTemporary $ toMaster CrudListR
itemReadId :: SinglePiece x => String -> Maybe x
itemReadId = either (const Nothing) Just . fromSinglePiece
crudHelper
:: (Item a, Yesod master, SinglePiece (Key a), ToForm a master)
=> String -> Maybe (Key a, a) -> Bool
-> GHandler (Crud master a) master RepHtml
crudHelper title me isPost = do
crud <- getYesodSub
(errs, form, enctype, hidden) <- runFormPost $ toForm $ fmap snd me
toMaster <- getRouteToMaster
case (isPost, errs) of
(True, FormSuccess a) -> do
eid <- case me of
Just (eid, _) -> do
crudReplace crud eid a
return eid
Nothing -> crudInsert crud a
redirect RedirectTemporary $ toMaster $ CrudEditR
$ toSinglePiece eid
_ -> return ()
defaultLayout $ do
setTitle $ string title
addWidget
#if GHC7
[hamlet|
#else
[$hamlet|
#endif
%p
%a!href=@toMaster.CrudListR@ Return to list
%h1 $title$
%form!method=post!enctype=$enctype$
%table
^form^
%tr
%td!colspan=2
$hidden$
%input!type=submit
$maybe me e
\ $
%a!href=@toMaster.CrudDeleteR.toSinglePiece.fst.e@ Delete
|]
-- | A default 'Crud' value which relies about persistent and "Yesod.Form".
defaultCrud
:: (PersistEntity i, PersistBackend (YesodDB a (GHandler (Crud a i) a)),
YesodPersist a)
=> a -> Crud a i
defaultCrud = const Crud
{ crudSelect = runDB $ selectList [] [] 0 0
, crudReplace = \a -> runDB . replace a
, crudInsert = runDB . insert
, crudGet = runDB . get
, crudDelete = runDB . delete
}

4
Yesod/Widget.hs
View File

@ -40,15 +40,13 @@ import Control.Monad.Trans.State
import Text.Hamlet
import Text.Cassius
import Text.Julius
import Yesod.Handler (Route, GHandler, HandlerData, YesodSubRoute(..), toMasterHandlerMaybe, getYesod)
import Yesod.Handler (Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod)
import Control.Applicative (Applicative)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Class (lift)
import Yesod.Internal
import Control.Monad.IO.Peel (MonadPeelIO)
import Control.Monad (liftM)
import qualified Data.Map as Map
-- | A generic widget, allowing specification of both the subsite and master
-- site datatypes. This is basically a large 'WriterT' stack keeping track of

161
hellowidget.hs
View File

@ -1,161 +0,0 @@
{-# LANGUAGE TypeFamilies, QuasiQuotes, OverloadedStrings #-}
import Yesod
import Yesod.Widget
import Yesod.Helpers.Static
import Yesod.Form.Jquery
import Yesod.Form.Core
import Data.Monoid
import Yesod.Form.Nic
import Control.Applicative
import qualified Data.ByteString.Lazy as L
import System.Directory
import Control.Monad.Trans.Class
import Data.Default
data HW = HW { hwStatic :: Static }
mkYesod "HW" [$parseRoutes|
/ RootR GET
/form FormR
/static StaticR Static hwStatic
/autocomplete AutoCompleteR GET
/customform CustomFormR GET
|]
instance Yesod HW where
approot _ = ""
addStaticContent ext _ content = do
let fn = (base64md5 content) ++ '.' : ext
liftIO $ createDirectoryIfMissing True "static/tmp"
liftIO $ L.writeFile ("static/tmp/" ++ fn) content
return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], [])
type Handler = GHandler HW HW
instance YesodNic HW
instance YesodJquery HW where
urlJqueryUiCss _ = Right $ googleHostedJqueryUiCss "ui-darkness"
wrapper h = [$hamlet|
#wrapper ^h^
%footer Brought to you by Yesod Widgets&trade;
|]
getRootR = defaultLayout $ wrapper $ do
i <- newIdent
setTitle $ string "Hello Widgets"
addCassius [$cassius|
#$i$
color: red
|]
addStylesheet $ StaticR $ StaticRoute ["style.css"] []
addStylesheetRemote "http://localhost:3000/static/style2.css"
addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js"
addScript $ StaticR $ StaticRoute ["script.js"] []
addHamlet [$hamlet|
%h1#$i$ Welcome to my first widget!!!
%p
%a!href=@RootR@ Recursive link.
%p
%a!href=@FormR@ Check out the form.
%p
%a!href=@CustomFormR@ Custom form arrangement.
%p.noscript Your script did not load. :(
|]
addHtmlHead [$hamlet|%meta!keywords=haskell|]
handleFormR = do
(res, form, enctype, hidden) <- runFormPost $ fieldsToTable $ (,,,,,,,,,,,)
<$> stringField (FormFieldSettings "My Field" "Some tooltip info" Nothing Nothing) Nothing
<*> stringField ("Another field") (Just "some default text")
<*> intField (FormFieldSettings "A number field" "some nums" Nothing Nothing) (Just 5)
<*> jqueryDayField def
{ jdsChangeMonth = True
, jdsChangeYear = True
, jdsYearRange = "1900:c+10"
, jdsNumberOfMonths = Right (2, 3)
} ("A day field") Nothing
<*> timeField ("A time field") Nothing
<*> boolField FormFieldSettings
{ ffsLabel = "A checkbox"
, ffsTooltip = ""
, ffsId = Nothing
, ffsName = Nothing
} (Just False)
<*> jqueryAutocompleteField AutoCompleteR
(FormFieldSettings "Autocomplete" "Try it!" Nothing Nothing) Nothing
<*> nicHtmlField ("HTML")
(Just $ string "You can put rich text here")
<*> maybeEmailField ("An e-mail addres") Nothing
<*> maybeTextareaField "A text area" Nothing
<*> maybeFileField "Any file"
<*> maybePasswordField "Enter a password" Nothing
let (mhtml, mfile) = case res of
FormSuccess (_, _, _, _, _, _, _, x, _, _, y, _) -> (Just x, y)
_ -> (Nothing, Nothing)
let txt = case res of
FormSuccess (_, _, _, _, _, _, _, _, _, Just x, _, _) -> Just x
_ -> Nothing
defaultLayout $ do
addCassius [$cassius|
.tooltip
color: #666
font-style: italic
|]
addCassius [$cassius|
textarea.html
width: 300px
height: 150px
|]
addWidget [$hamlet|
$maybe formFailures.res failures
%ul.errors
$forall failures f
%li $f$
%form!method=post!enctype=$enctype$
$hidden$
%table
^form^
%tr
%td!colspan=2
%input!type=submit
$maybe mhtml html
$html$
$maybe txt t
$t$
$maybe mfile f
$show.f$
|]
setTitle $ string "Form"
main = basicHandler 3000 $ HW $ fileLookupDir "static" typeByExt
getAutoCompleteR :: Handler RepJson
getAutoCompleteR = do
term <- runFormGet' $ stringInput "term"
jsonToRepJson $ jsonList
[ jsonScalar $ term ++ "foo"
, jsonScalar $ term ++ "bar"
, jsonScalar $ term ++ "baz"
]
data Person = Person String Int
getCustomFormR = do
let customForm = GForm $ do
(a1, [b1], c1) <- deform $ stringInput "name"
(a2, [b2], c2) <- deform $ intInput "age"
let b = do
b1' <- extractBody b1
b2' <- extractBody b2
addHamlet [$hamlet|
%p This is a custom layout.
%h1 Name Follows!
%p ^b1'^
%p Age: ^b2'^
|]
return (Person <$> a1 <*> a2, b , c1 `mappend` c2)
(_, wform, enctype) <- runFormGet customForm
defaultLayout $ do
form <- extractBody wform
addHamlet [$hamlet|
%form
^form^
%div
%input!type=submit
|]

10
yesod.cabal
View File

@ -59,10 +59,6 @@ library
exposed-modules: Yesod
Yesod.Content
Yesod.Dispatch
Yesod.Form
Yesod.Form.Core
Yesod.Form.Jquery
Yesod.Form.Nic
Yesod.Hamlet
Yesod.Handler
Yesod.Json
@ -70,13 +66,9 @@ library
Yesod.Widget
Yesod.Yesod
Yesod.Helpers.AtomFeed
Yesod.Helpers.Crud
Yesod.Helpers.Sitemap
Yesod.Helpers.Static
other-modules: Yesod.Form.Class
Yesod.Internal
Yesod.Form.Fields
Yesod.Form.Profiles
other-modules: Yesod.Internal
ghc-options: -Wall
executable yesod